Import Upstream version 3a2upstream/3a2

1 files changed, 179 insertions, 115 deletions

diff --git a/bigloo.init b/bigloo.init
index 9ded1a4..af34546 100644
--- a/bigloo.init
+++ b/bigloo.init
@@ -3,23 +3,25 @@
 ;;;
 ;;; This code is in the public domain.
 
+;;@ (software-type) should be set to the generic operating system type.
+;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
 (define (software-type) 'UNIX)
 
-;;; (scheme-implementation-type) should return the name of the scheme
+;;@ (scheme-implementation-type) should return the name of the scheme
 ;;; implementation loading this file.
 (define (scheme-implementation-type) 'Bigloo)
 
-;;; (scheme-implementation-home-page) should return a (string) URI
+;;@ (scheme-implementation-home-page) should return a (string) URI
 ;;; (Uniform Resource Identifier) for this scheme implementation's home
 ;;; page; or false if there isn't one.
 (define (scheme-implementation-home-page)
   "http://www-sop.inria.fr/mimosa/fp/Bigloo/")
 
-;;; (scheme-implementation-version) should return a string describing
+;;@ (scheme-implementation-version) should return a string describing
 ;;; the version the scheme implementation loading this file.
 (define (scheme-implementation-version) *bigloo-version*)
 
-;;; (implementation-vicinity) should be defined to be the pathname of
+;;@ (implementation-vicinity) should be defined to be the pathname of
 ;;; the directory where any auxillary files to your Scheme
 ;;; implementation reside.
 (define (implementation-vicinity)
@@ -28,7 +30,7 @@
     ((MS-DOS) "C:\\scheme\\")
     (else "")))
 
-;;; (library-vicinity) should be defined to be the pathname of the
+;;@ (library-vicinity) should be defined to be the pathname of the
 ;;; directory where files of Scheme library functions reside.
 (define library-vicinity
   (let ((library-path
@@ -47,7 +49,7 @@
 	    (else "")))))
     (lambda () library-path)))
 
-;;; (home-vicinity) should return the vicinity of the user's HOME
+;;@ (home-vicinity) should return the vicinity of the user's HOME
 ;;; directory, the directory which typically contains files which
 ;;; customize a computer environment for a user.
 (define (home-vicinity)
@@ -59,32 +61,106 @@
 		home
 		(string-append home "/")))
 	   (else home)))))
+;@
+(define in-vicinity string-append)
+;@
+(define (user-vicinity)
+  (case (software-type)
+    ((VMS)	"[.]")
+    (else	"")))
 
-;;; *FEATURES* should be set to a list of symbols describing features
-;;; of this implementation.  See Template.scm for the list of feature
-;;; names.
+(define *load-pathname* #f)
+;@
+(define vicinity:suffix?
+  (let ((suffi
+	 (case (software-type)
+	   ((AMIGA)				'(#\: #\/))
+	   ((MACOS THINKC)			'(#\:))
+	   ((MS-DOS WINDOWS ATARIST OS/2)	'(#\\ #\/))
+	   ((NOSVE)				'(#\: #\.))
+	   ((UNIX COHERENT PLAN9)		'(#\/))
+	   ((VMS)				'(#\: #\]))
+	   (else
+	    (slib:warn "require.scm" 'unknown 'software-type (software-type))
+	    "/"))))
+    (lambda (chr) (and (memv chr suffi) #t))))
+;@
+(define (pathname->vicinity pathname)
+  (let loop ((i (- (string-length pathname) 1)))
+    (cond ((negative? i) "")
+	  ((vicinity:suffix? (string-ref pathname i))
+	   (substring pathname 0 (+ i 1)))
+	  (else (loop (- i 1))))))
+(define (program-vicinity)
+  (if *load-pathname*
+      (pathname->vicinity *load-pathname*)
+      (slib:error 'program-vicinity " called; use slib:load to load")))
+;@
+(define sub-vicinity
+  (case (software-type)
+    ((VMS) (lambda
+	       (vic name)
+	     (let ((l (string-length vic)))
+	       (if (or (zero? (string-length vic))
+		       (not (char=? #\] (string-ref vic (- l 1)))))
+		   (string-append vic "[" name "]")
+		   (string-append (substring vic 0 (- l 1))
+				  "." name "]")))))
+    (else (let ((*vicinity-suffix*
+		 (case (software-type)
+		   ((NOSVE) ".")
+		   ((MACOS THINKC) ":")
+		   ((MS-DOS WINDOWS ATARIST OS/2) "\\")
+		   ((UNIX COHERENT PLAN9 AMIGA) "/"))))
+	    (lambda (vic name)
+	      (string-append vic name *vicinity-suffix*))))))
+;@
+(define (make-vicinity <pathname>) <pathname>)
+;@
+(define with-load-pathname
+  (let ((exchange
+	 (lambda (new)
+	   (let ((old *load-pathname*))
+	     (set! *load-pathname* new)
+	     old))))
+    (lambda (path thunk)
+      (let* ((old (exchange path))
+	     (val (thunk)))
+	(exchange old)
+	val))))
+
+;;@ *FEATURES* is a list of symbols naming the (SLIB) features
+;;; initially supported by this implementation.
 (define *features*
       '(
 	source				;can load scheme source files
-					;(slib:load-source "filename")
-;	compiled			;can load compiled files
-					;(slib:load-compiled "filename")
+					;(SLIB:LOAD-SOURCE "filename")
+;;;	compiled			;can load compiled files
+					;(SLIB:LOAD-COMPILED "filename")
+	vicinity
+	srfi-59
 
 		       ;; Scheme report features
+   ;; R5RS-compliant implementations should provide all 9 features.
 
-;	r5rs				;conforms to
+;;;	r5rs				;conforms to
 	eval				;R5RS two-argument eval
-;	values				;R5RS multiple values
-;	dynamic-wind			;R5RS dynamic-wind
-;	macro				;R5RS high level macros
+;;;	values				;R5RS multiple values
+;;;	dynamic-wind			;R5RS dynamic-wind
+;;;	macro				;R5RS high level macros
 	delay				;has DELAY and FORCE
 	multiarg-apply			;APPLY can take more than 2 args.
-;	char-ready?
+;;;	char-ready?
+	rev4-optional-procedures	;LIST-TAIL, STRING-COPY,
+					;STRING-FILL!, and VECTOR-FILL!
+
+      ;; These four features are optional in both R4RS and R5RS
+
+	multiarg/and-			;/ and - can take more than 2 args.
 	rationalize
-	rev4-optional-procedures	;LIST-TAIL, STRING->LIST,
-					;LIST->STRING, STRING-COPY,
-					;STRING-FILL!, LIST->VECTOR,
-					;VECTOR->LIST, and VECTOR-FILL!
+	transcript			;TRANSCRIPT-ON and TRANSCRIPT-OFF
+	with-file			;has WITH-INPUT-FROM-FILE and
+					;WITH-OUTPUT-TO-FILE
 
 	r4rs				;conforms to
 
@@ -92,43 +168,39 @@
 
 	r3rs				;conforms to
 
-;	rev2-procedures			;SUBSTRING-MOVE-LEFT!,
+;;;	rev2-procedures			;SUBSTRING-MOVE-LEFT!,
 					;SUBSTRING-MOVE-RIGHT!,
 					;SUBSTRING-FILL!,
 					;STRING-NULL?, APPEND!, 1+,
 					;-1+, <?, <=?, =?, >?, >=?
 	object-hash			;has OBJECT-HASH
 
-	multiarg/and-			;/ and - can take more than 2 args.
-	with-file			;has WITH-INPUT-FROM-FILE and
-					;WITH-OUTPUT-TO-FILE
-	transcript			;TRANSCRIPT-ON and TRANSCRIPT-OFF
+;;	full-continuation		;not without the -call/cc switch
 	ieee-floating-point		;conforms to IEEE Standard 754-1985
 					;IEEE Standard for Binary
 					;Floating-Point Arithmetic.
-;;	full-continuation		;not without the -call/cc switch
 
 			;; Other common features
 
 	srfi				;srfi-0, COND-EXPAND finds all srfi-*
-;	sicp				;runs code from Structure and
+;;;	sicp				;runs code from Structure and
 					;Interpretation of Computer
 					;Programs by Abelson and Sussman.
 	defmacro			;has Common Lisp DEFMACRO
-;	record				;has user defined data structures
+;;;	record				;has user defined data structures
 	string-port			;has CALL-WITH-INPUT-STRING and
 					;CALL-WITH-OUTPUT-STRING
-;	sort
+;;;	sort
 	pretty-print
 	object->string
-;	format				;Common-lisp output formatting
-;	trace				;has macros: TRACE and UNTRACE
-;	compiler			;has (COMPILER)
-;	ed				;(ED) is editor
+;;;	format				;Common-lisp output formatting
+;;;	trace				;has macros: TRACE and UNTRACE
+;;;	compiler			;has (COMPILER)
+;;;	ed				;(ED) is editor
 	system				;posix (system <string>)
 	getenv				;posix (getenv <string>)
-;	program-arguments		;returns list of strings (argv)
-;	current-time			;returns time in seconds since 1/1/1970
+;;;	program-arguments		;returns list of strings (argv)
+;;;	current-time			;returns time in seconds since 1/1/1970
 
 		  ;; Implementation Specific features
 
@@ -140,13 +212,13 @@
 
 (define (object->string x) (obj->string x))
 
-;;; (OUTPUT-PORT-WIDTH <port>)
+;;@ (OUTPUT-PORT-WIDTH <port>)
 (define (output-port-width . arg) 79)
 
-;;; (OUTPUT-PORT-HEIGHT <port>)
+;;@ (OUTPUT-PORT-HEIGHT <port>)
 (define (output-port-height . arg) 24)
 
-;;; (TMPNAM) makes a temporary file name.
+;;@ (TMPNAM) makes a temporary file name.
 (define tmpnam
   (let ((cntr 100))
     (lambda ()
@@ -154,55 +226,23 @@
       (let ((tmp (string-append "slib_" (number->string cntr))))
 	(if (file-exists? tmp) (tmpnam) tmp)))))
 
-;;; FORCE-OUTPUT flushes any pending output on optional arg output port
+;;@ FORCE-OUTPUT flushes any pending output on optional arg output port
 ;;; use this definition if your system doesn't have such a procedure.
 (define (force-output . args)
   (flush-output-port (if (pair? args) (car args) (current-output-port))))
 
-;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
+;;@ CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
 ;;; port versions of CALL-WITH-*PUT-FILE.
 (define (call-with-output-string f)
   (let ((outsp (open-output-string)))
     (f outsp)
     (close-output-port outsp)))
-
 (define (call-with-input-string s f)
   (let* ((insp (open-input-string s))
 	 (res (f insp)))
     (close-input-port insp)
     res))
 
-(define (make-exchanger obj)
-  (lambda (rep) (let ((old obj)) (set! obj rep) old)))
-(define (open-file filename modes)
-  (case modes
-    ((r rb) (open-input-file filename))
-    ((w wb) (open-output-file filename))
-    (else (slib:error 'open-file 'mode? modes))))
-;;(define (port? obj) (or (input-port? port) (output-port? port)))
-(define (call-with-open-ports . ports)
-  (define proc (car ports))
-  (cond ((procedure? proc) (set! ports (cdr ports)))
-	(else (set! ports (reverse ports))
-	      (set! proc (car ports))
-	      (set! ports (reverse (cdr ports)))))
-  (let ((ans (apply proc ports)))
-    (for-each close-port ports)
-    ans))
-(define (close-port port)
-  (cond ((input-port? port)
-	 (close-input-port port)
-	 (if (output-port? port) (close-output-port port)))
-	((output-port? port) (close-output-port port))
-	(else (slib:error 'close-port 'port? port))))
-
-(define (browse-url url)
-  (define (try cmd end) (zero? (system (string-append cmd url end))))
-  (or (try "netscape-remote -remote 'openURL(" ")'")
-      (try "netscape -remote 'openURL(" ")'")
-      (try "netscape '" "'&")
-      (try "netscape '" "'")))
-
 ;;; "rationalize" adjunct procedures.
 (define (find-ratio x e)
   (let ((rat (rationalize x e)))
@@ -210,40 +250,42 @@
 (define (find-ratio-between x y)
   (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
 
-;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
+;;@ CHAR-CODE-LIMIT is one greater than the largest integer which can
 ;;; be returned by CHAR->INTEGER.
 (define char-code-limit 256)
 
-;;; MOST-POSITIVE-FIXNUM is used in modular.scm
+;;@ MOST-POSITIVE-FIXNUM is used in modular.scm
 (define most-positive-fixnum 536870911)
 
-;;; Return argument
+;;@ Return argument
 (define (identity x) x)
 
-;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
+;;@ SLIB:EVAL is single argument eval using the top-level (user) environment.
 (define slib:eval eval)
 
+;;; If your implementation provides R4RS macros:
+;(define macro:eval slib:eval)
+;(define macro:load load)
+
 (define-macro (defmacro name . forms)
   `(define-macro (,name . ,(car forms)) ,@(cdr forms)))
-
+;@
 (define (defmacro? m) (get-eval-expander m))
+;@
 (define (macroexpand-1 body) (expand-once body))
+;@
 (define (macroexpand body) (expand body))
-
+;@
 (define (gentemp) (gensym))
+;@
+(define defmacro:eval slib:eval)
 
-(define (slib:eval-load <pathname> evl)
-  (if (not (file-exists? <pathname>))
-      (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
-  (call-with-input-file <pathname>
-    (lambda (port)
-      (let ((old-load-pathname *load-pathname*))
-	(set! *load-pathname* <pathname>)
-	(do ((o (read port) (read port)))
-	    ((eof-object? o))
-	  (evl o))
-	(set! *load-pathname* old-load-pathname)))))
+;;(define (defmacro:expand* x)
+;;  (require 'defmacroexpand) (apply defmacro:expand* x '()))
 
+;; slib:eval-load definition moved to "require.scm"
+
+;@
 (define slib:warn
   (lambda args
     (let ((cep (current-error-port)))
@@ -251,13 +293,43 @@
       (display "Warn: " cep)
       (for-each (lambda (x) (display #\  cep) (write x cep)) args))))
 
-
-;;; define an error procedure for the library
+;;@ define an error procedure for the library
 (define (slib:error . args)
   (if (provided? 'trace) (print-call-stack (current-error-port)))
   (error 'slib:error "" args))
+;@
+(define (make-exchanger obj)
+  (lambda (rep) (let ((old obj)) (set! obj rep) old)))
+(define (open-file filename modes)
+  (case modes
+    ((r rb) (open-input-file filename))
+    ((w wb) (open-output-file filename))
+    (else (slib:error 'open-file 'mode? modes))))
+;;(define (port? obj) (or (input-port? port) (output-port? port)))
+(define (call-with-open-ports . ports)
+  (define proc (car ports))
+  (cond ((procedure? proc) (set! ports (cdr ports)))
+	(else (set! ports (reverse ports))
+	      (set! proc (car ports))
+	      (set! ports (reverse (cdr ports)))))
+  (let ((ans (apply proc ports)))
+    (for-each close-port ports)
+    ans))
+(define (close-port port)
+  (cond ((input-port? port)
+	 (close-input-port port)
+	 (if (output-port? port) (close-output-port port)))
+	((output-port? port) (close-output-port port))
+	(else (slib:error 'close-port 'port? port))))
+;@
+(define (browse-url url)
+  (define (try cmd end) (zero? (system (string-append cmd url end))))
+  (or (try "netscape-remote -remote 'openURL(" ")'")
+      (try "netscape -remote 'openURL(" ")'")
+      (try "netscape '" "'&")
+      (try "netscape '" "'")))
 
-;; define these as appropriate for your system.
+;;@ define these as appropriate for your system.
 (define slib:tab (integer->char 9))
 (define slib:form-feed (integer->char 12))
 
@@ -270,47 +342,39 @@
        (define ,maker-name ,name))
     ))
 
-
-;;(define force force)
-
-;;; Define these if your implementation's syntax can support it and if
+;;@ Define these if your implementation's syntax can support it and if
 ;;; they are not already defined.
-
 (define (1+ n) (+ n 1))
 (define (-1+ n) (+ n -1))
 (define 1- -1+)
 
-(define in-vicinity string-append)
-
-;;; Define SLIB:EXIT to be the implementation procedure to exit or
-;;; return if exitting not supported.
+;;@ Define SLIB:EXIT to be the implementation procedure to exit or
+;;; return if exiting not supported.
 (define slib:exit (lambda args (exit 0)))
 
-;;; Here for backward compatability
+;;@ Here for backward compatability
 (define scheme-file-suffix
   (let ((suffix (case (software-type)
 		  ((NOSVE) "_scm")
 		  (else ".scm"))))
     (lambda () suffix)))
 
-;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
+;;@ (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
 ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
 (define (slib:load-source f) (loadq (string-append f (scheme-file-suffix))))
 
-;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
+;;@ (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 loadq)
 
-;;; At this point SLIB:LOAD must be able to load SLIB files.
-(define slib:load slib:load-source)
-
-(define defmacro:eval slib:eval)
-(define defmacro:load slib:load)
-
-;;; If your implementation provides R4RS macros:
-;(define macro:eval slib:eval)
-;(define macro:load load)
+;;@ At this point SLIB:LOAD must be able to load SLIB files.
+(define (slib:load file)
+  (define file.scm (string-append file (scheme-file-suffix)))
+  (if (file-exists? file.scm)
+      (slib:load-source file.scm)
+      (slib:load-compiled file)))
+;@
+(define defmacro:load slib:load-source)
 
 (slib:load (in-vicinity (library-vicinity) "require"))
-; eof