aboutsummaryrefslogtreecommitdiffstats
path: root/scheme48.init
diff options
context:
space:
mode:
Diffstat (limited to 'scheme48.init')
-rw-r--r--scheme48.init91
1 files changed, 65 insertions, 26 deletions
diff --git a/scheme48.init b/scheme48.init
index 202c7bb..4c67a10 100644
--- a/scheme48.init
+++ b/scheme48.init
@@ -7,9 +7,36 @@
,load-package floatnums
,config
,load =scheme48/misc/packages.scm
+
+(define-structure slib:os-strings
+ (export os-string->string)
+ (open scheme
+ (subset environments
+ (*structure-ref environment-ref))
+ (subset handle (with-handler))
+ (subset package-commands-internal
+ (config-package)))
+ (begin
+ (define (identity x)
+ x)
+ (define (xstructure-ref structure-name export-name default)
+ (call-with-current-continuation
+ (lambda (k)
+ (with-handler
+ (lambda (condition decline)
+ (k default))
+ (lambda ()
+ (*structure-ref (environment-ref (config-package)
+ structure-name)
+ export-name))))))
+ (define os-string->string
+ (xstructure-ref 'os-strings 'os-string->string
+ identity))))
+
(define-structure slib-primitives
(export s48-char->integer
s48-use!
+ s48-os-string->string
s48-getenv s48-current-time s48-time-seconds
(s48-access-mode :syntax)
s48-accessible?
@@ -29,6 +56,9 @@
(subset package-commands-internal (config-package))
(subset package-mutation (package-open!))
;; primitives
+ (modify slib:os-strings
+ (prefix s48-)
+ (expose os-string->string))
(modify posix
(rename (current-time s48-current-time)
(time-seconds s48-time-seconds)
@@ -54,7 +84,8 @@
,user
,open slib-primitives
-(define getenv s48-getenv)
+(define (getenv name)
+ (s48-os-string->string (s48-getenv name)))
(define system s48-system)
;;; (software-type) should be set to the generic operating system type.
@@ -74,7 +105,13 @@
;;; the version of the scheme implementation loading this file.
(define scheme-implementation-version
(let ((version (getenv "S48_VERSION")))
- (lambda () version)))
+ (define vl (string-length version))
+ (do ((idx 0 (+ 1 idx)))
+ ((or (>= idx vl)
+ (not (or (char-numeric? (string-ref version idx))
+ (memv (string-ref version idx) '(#\. #\-)))))
+ (let ((nv (substring version 0 idx)))
+ (lambda () nv))))))
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxiliary files to your Scheme
@@ -139,8 +176,7 @@
;@
(define sub-vicinity
(case (software-type)
- ((vms) (lambda
- (vic name)
+ ((vms) (lambda (vic name)
(let ((l (string-length vic)))
(if (or (zero? (string-length vic))
(not (char=? #\] (string-ref vic (- l 1)))))
@@ -181,6 +217,7 @@
; here used for native modules
vicinity
srfi-59
+ srfi-96
;; Scheme report features
;; R5RS-compliant implementations should provide all 9 features.
@@ -224,7 +261,7 @@
;; Other common features
-;;; srfi ;srfi-0, COND-EXPAND finds all srfi-*
+;;; srfi-0 ;srfi-0, COND-EXPAND finds all srfi-*
;;; sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
@@ -336,7 +373,7 @@
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
-(define char-code-limit 256)
+(define char-code-limit 128)
(define integer->char s48-ascii->char)
(define char->integer
(let ((code0 (s48-char->integer (integer->char 0))))
@@ -355,13 +392,6 @@
(lambda (form)
(eval form (interaction-environment)))))
-;;; If your implementation provides R4RS macros:
-(define macro:eval slib:eval)
-(define (macro:load <pathname>)
- (if (not (file-exists? <pathname>))
- (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
- (load <pathname>))
-
(define *defmacros*
(list (cons 'defmacro
(lambda (name parms . body)
@@ -393,12 +423,6 @@
(string->symbol
(string-append "slib:G" (number->string *gensym-counter*))))))
-(define base:eval slib:eval)
-(define (defmacro:eval x) (base:eval (defmacro:expand* x)))
-
-(define defmacro:load macro:load)
-;; slib:eval-load definition moved to "require.scm"
-
(define (slib:warn . args)
;;(if (provided? 'trace) (print-call-stack cep))
(apply s48-warn args))
@@ -420,9 +444,9 @@
;;; Define these if your implementation's syntax can support them and if
;;; they are not already defined.
-(define (1+ n) (+ n 1))
-(define (-1+ n) (+ n -1))
-;(define 1- -1+)
+;;(define (1+ n) (+ n 1))
+;;(define (-1+ n) (+ n -1))
+;;(define 1- -1+)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exiting not supported.
@@ -448,6 +472,18 @@
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-source)
+;;; If your implementation provides R4RS macros:
+(define macro:eval slib:eval)
+(define macro:load slib:load-source)
+
+(define base:eval slib:eval)
+(define (defmacro:eval x) (slib:eval (defmacro:expand* x)))
+(define defmacro:load macro:load)
+
+;;; If your implementation provides syntax-case macros:
+;;(define syncase:eval slib:eval)
+;;(define syncase:load slib:load-source)
+
;;; Scheme48 complains that these are not defined (even though they
;;; won't be called until they are).
(define synclo:load #f)
@@ -475,8 +511,6 @@
;;; Needed to support defmacro
(require 'defmacroexpand)
-(define *args* '())
-(define (program-arguments) (cons "scheme48" *args*))
;@
(define (current-time)
@@ -515,7 +549,7 @@
,collect
,batch off
-,dump slib.image "(slib 3a5)"
+,dump slib.image "(slib 3b1)"
;;; Put Scheme48-specific code into catalog
(call-with-output-file (in-vicinity (implementation-vicinity) "implcat")
@@ -529,7 +563,12 @@
(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))
+ (append
+ '(1 2 5 6 7 8 9 11 13 14 16 17 23 25 26 27 28 31 34 35 36 37 42 45)
+ (if (string>=? (scheme-implementation-version) "1.4")
+ '(4 39 40 43 43 60 61 63 66 67 71 78)
+ '())
+ (if (string>=? (scheme-implementation-version) "1.5") '(19) '())))
(for-each
(lambda (f)
(define module