summaryrefslogtreecommitdiffstats
path: root/scheme48.init
diff options
context:
space:
mode:
Diffstat (limited to 'scheme48.init')
-rw-r--r--scheme48.init118
1 files changed, 79 insertions, 39 deletions
diff --git a/scheme48.init b/scheme48.init
index 0a91cf9..c7e91af 100644
--- a/scheme48.init
+++ b/scheme48.init
@@ -8,26 +8,33 @@
,config
,load =scheme48/misc/packages.scm
(define-structure slib-primitives
- (export s48-modulo s48-atan s48-char->integer
+ (export s48-char->integer
+ s48-use!
s48-getenv s48-current-time s48-time-seconds
+ (s48-access-mode :syntax)
+ s48-accessible?
s48-system
s48-current-error-port
s48-force-output
s48-with-handler
s48-ascii->char
s48-error s48-warn
- s48-make-string-input-port
- s48-make-string-output-port
- s48-string-output-port-output
s48-exit)
(open (modify scheme
- (rename (modulo s48-modulo) (atan s48-atan)
- (char->integer s48-char->integer)))
- ; primitives
+ (rename (char->integer s48-char->integer)))
+ ;; for `s48-use!' procedure
+ (subset ensures-loaded (ensure-loaded))
+ (subset environments (environment-ref))
+ (subset package-commands-internal (config-package))
+ (subset package-mutation (package-open!))
+ ;; primitives
(modify posix
(rename (current-time s48-current-time)
(time-seconds s48-time-seconds)
(lookup-environment-variable s48-getenv)))
+ (modify posix-files
+ (prefix s48-)
+ (expose access-mode accessible?))
(modify c-system-function (rename (system s48-system)))
(modify i/o
(rename (current-error-port s48-current-error-port)
@@ -35,15 +42,14 @@
(modify handle (rename (with-handler s48-with-handler)))
(modify ascii (rename (ascii->char s48-ascii->char)))
(modify signals (rename (error s48-error) (warn s48-warn)))
- (modify root-scheduler (rename (scheme-exit-now s48-exit)))
- (modify extended-ports
- (rename (make-string-input-port
- s48-make-string-input-port)
- (make-string-output-port
- s48-make-string-output-port)
- (string-output-port-output
- s48-string-output-port-output))))
- (begin #t))
+ (modify root-scheduler (rename (scheme-exit-now s48-exit))))
+ (begin
+ ;; Here used to import builtin SRFI modules.
+ (define (s48-use! struct-name)
+ (let ((struc (environment-ref (config-package) struct-name)))
+ (ensure-loaded struc)
+ (package-open! (interaction-environment) (lambda () struc))))
+ ))
,user
,open slib-primitives
@@ -164,14 +170,14 @@
thunk
(lambda () (exchange old)))))))
-;;@ *FEATURES* is a list of symbols naming the (SLIB) features
+;;@ SLIB:FEATURES is a list of symbols naming the (SLIB) features
;;; initially supported by this implementation.
-(define *features*
+(define slib:features
'(
source ;can load scheme source files
;(SLIB:LOAD-SOURCE "filename")
-;;; compiled ;can load compiled files
- ;(SLIB:LOAD-COMPILED "filename")
+ compiled ;can load compiled files
+ ; here used for native modules
vicinity
srfi-59
@@ -223,7 +229,7 @@
;Programs by Abelson and Sussman.
defmacro ;has Common Lisp DEFMACRO
;;; record ;has user defined data structures
- string-port ;has CALL-WITH-INPUT-STRING and
+;;; string-port ;has CALL-WITH-INPUT-STRING and
;CALL-WITH-OUTPUT-STRING
;;; sort
;;; pretty-print
@@ -259,14 +265,7 @@
;;; (FILE-EXISTS? <string>)
(define (file-exists? f)
- (call-with-current-continuation
- (lambda (k)
- (s48-with-handler
- (lambda (condition decline)
- (k #f))
- (lambda ()
- (close-input-port (open-input-file f))
- #t)))))
+ (s48-accessible? f (s48-access-mode exists)))
;;; (DELETE-FILE <string>)
(define (delete-file file-name)
@@ -432,7 +431,8 @@
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
-(define slib:load-compiled load)
+;;; See creation of "implcat" file at end of this file.
+(define slib:load-compiled s48-use!)
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-source)
@@ -468,14 +468,6 @@
(define (program-arguments) (cons "scheme48" *args*))
;@
-(define (call-with-output-string proc)
- (let ((port (s48-make-string-output-port)))
- (proc port)
- (s48-string-output-port-output port)))
-(define (call-with-input-string string proc)
- (proc (s48-make-string-input-port string)))
-
-;@
(define (current-time)
(s48-time-seconds (s48-current-time)))
(define (difftime caltime1 caltime0)
@@ -483,9 +475,57 @@
(define (offset-time caltime offset)
(+ caltime offset))
+;;; Scheme48-specific code
+,push
+,config
+
+;; 'record
+
+(define-interface slib-record-interface
+ (export record-modifier record-accessor record-constructor
+ record-predicate make-record-type))
+
+(define-structure slib-record slib-record-interface
+ (open scheme record-types)
+ (files ((=scheme48 slib) record)))
+
+;; 'string-port
+
+(define-interface slib-string-port-interface
+ (export call-with-output-string call-with-input-string))
+
+(define-structure slib-string-port slib-string-port-interface
+ (open scheme extended-ports)
+ (files ((=scheme48 slib) strport)))
+,pop
+
+;;; Write slib.image
(require #f)
,collect
,batch off
-,dump slib.image "(slib 3a3)"
+,dump slib.image "(slib 3a4)"
+
+;;; Put Scheme48-specific code into catalog
+(call-with-output-file (in-vicinity (implementation-vicinity) "implcat")
+ (lambda (op)
+ (define (display* . args)
+ (for-each (lambda (arg) (display arg op)) args)
+ (newline op))
+ (display* "(")
+ (for-each
+ (lambda (idx)
+ (define srfi
+ (string->symbol (string-append "srfi-" (number->string idx))))
+ (display* " " (list srfi 'compiled srfi)))
+ '(1 2 5 6 7 8 9 11 13 14 16 17 23 25 26 27 28 31 34 35 36 37 42 45))
+ (for-each
+ (lambda (f)
+ (define module
+ (string->symbol (string-append "slib-" (symbol->string f))))
+ (display* " " (list f 'compiled module)))
+ '(record string-port))
+ (display* ")")))
+(require 'new-catalog)
+
,exit