diff options
Diffstat (limited to 'scheme48.init')
| -rw-r--r-- | scheme48.init | 118 |
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 |