From 4684239efa63dc1b2c1cbe37ef7d3062029f5532 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:40 -0800 Subject: Import Upstream version 3b1 --- scheme48.init | 91 ++++++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 65 insertions(+), 26 deletions(-) (limited to 'scheme48.init') 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 ) - (if (not (file-exists? )) - (set! (string-append (scheme-file-suffix)))) - (load )) - (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 -- cgit v1.2.3