Import Upstream version 3a4upstream/3a4

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