Import Upstream version 3a1upstream/3a1

1 files changed, 152 insertions, 128 deletions

diff --git a/require.scm b/require.scm
index e5d919d..a11cbf5 100644
--- a/require.scm
+++ b/require.scm
@@ -1,5 +1,5 @@
 ;;;; Implementation of VICINITY and MODULES for Scheme
-;Copyright (C) 1991, 1992, 1993, 1994, 1997 Aubrey Jaffer
+;Copyright (C) 1991, 1992, 1993, 1994, 1997, 2002, 2003 Aubrey Jaffer
 ;
 ;Permission to copy this software, to modify it, to redistribute it,
 ;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
 ;1.  Any copy made of this software must include this copyright notice
 ;in full.
 ;
-;2.  I have made no warrantee or representation that the operation of
+;2.  I have made no warranty or representation that the operation of
 ;this software will be error-free, and I am under no obligation to
 ;provide any services, by way of maintenance, update, or otherwise.
 ;
@@ -16,21 +16,16 @@
 ;material, there shall be no use of my name in any advertising,
 ;promotional, or sales literature without prior written consent in
 ;each case.
-
-(define *SLIB-VERSION* "2d2")
-
-;;; Standardize msdos -> ms-dos.
-(define software-type
-  (cond ((eq? 'msdos (software-type))
-	 (lambda () 'ms-dos))
-	(else software-type)))
-
+;@
+(define *SLIB-VERSION* "3a1")
+;@
 (define (user-vicinity)
   (case (software-type)
     ((VMS)	"[.]")
     (else	"")))
-
+;@
 (define *load-pathname* #f)
+;@
 (define vicinity:suffix?
   (let ((suffi
 	 (case (software-type)
@@ -38,18 +33,21 @@
 	   ((MACOS THINKC)			'(#\:))
 	   ((MS-DOS WINDOWS ATARIST OS/2)	'(#\\ #\/))
 	   ((NOSVE)				'(#\: #\.))
-	   ((UNIX COHERENT)			'(#\/))
+	   ((UNIX COHERENT PLAN9)		'(#\/))
 	   ((VMS)				'(#\: #\])))))
-    (lambda (chr) (memv chr suffi))))
+    (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*
-      (let loop ((i (- (string-length *load-pathname*) 1)))
-	(cond ((negative? i) "")
-	      ((vicinity:suffix? (string-ref *load-pathname* i))
-	       (substring *load-pathname* 0 (+ i 1)))
-	      (else (loop (- i 1)))))
+      (pathname->vicinity *load-pathname*)
       (slib:error 'program-vicinity " called; use slib:load to load")))
-
+;@
 (define sub-vicinity
   (case (software-type)
     ((VMS) (lambda
@@ -65,10 +63,10 @@
 		   ((NOSVE) ".")
 		   ((MACOS THINKC) ":")
 		   ((MS-DOS WINDOWS ATARIST OS/2) "\\")
-		   ((UNIX COHERENT AMIGA) "/"))))
+		   ((UNIX COHERENT PLAN9 AMIGA) "/"))))
 	    (lambda (vic name)
 	      (string-append vic name *vicinity-suffix*))))))
-
+;@
 (define (make-vicinity <pathname>) <pathname>)
 
 (define (slib:pathnameize-load *old-load*)
@@ -76,7 +74,6 @@
     (let ((old-load-pathname *load-pathname*))
       (set! *load-pathname* <pathname>)
       (apply *old-load* (cons <pathname> extra))
-      (require:provide <pathname>)
       (set! *load-pathname* old-load-pathname))))
 
 (set! slib:load-source
@@ -85,11 +82,11 @@
       (slib:pathnameize-load slib:load))
 
 ;;;; MODULES
-
+;@
 (define *catalog* #f)
-(define *modules* '())
-
-(define (require:version path)
+(define *base-table-implementations* '())
+;@
+(define (slib:version path)
   (let ((expr (and (file-exists? path)
 		   (call-with-input-file path (lambda (port) (read port))))))
     (and (list? expr) (= 3 (length expr))
@@ -100,7 +97,7 @@
   (let* ((apair (assq '*SLIB-VERSION* slibcat))
 	 (req (in-vicinity (library-vicinity)
 			   (string-append "require" (scheme-file-suffix))))
-	 (reqvers (require:version req)))
+	 (reqvers (slib:version req)))
     (cond ((not (file-exists? req))
 	   (slib:warn "can't find " req) #f)
 	  ((not apair) #f)
@@ -121,6 +118,21 @@
 			  ((eof-object? expr)
 			   (apply append lst))))))))
       '()))
+;@
+(define (catalog:resolve vicinity catlist)
+  (define (res1 e) (if (string? e) (in-vicinity vicinity e) e))
+  (define (resolve p)
+    (cond ((symbol? (cdr p)) p)
+	  ((not (list? p)) (cons (car p) (res1 (cdr p))))
+	  ((null? (cddr p)) (cons (car p) (res1 (cadr p))))
+	  (else (map res1 p))))
+  (map resolve catlist))
+;@
+(define (catalog:read vicinity cat)
+  (catalog:get #f)			; make sure *catalog* exists
+  (set! *catalog*
+	(append (catalog:resolve vicinity (catalog:try-read vicinity cat))
+		*catalog*)))
 
 (define (catalog:get feature)
   (if (not *catalog*)
@@ -139,124 +151,136 @@
 	(set! *catalog*
 	      (append (catalog:try-read (user-vicinity) "usercat") *catalog*))))
   (and feature *catalog* (cdr (or (assq feature *catalog*) '(#f . #f)))))
+;@
+(define (slib:in-catalog? feature)
+  (let ((path (catalog:get feature)))
+    (if (symbol? path) (slib:in-catalog? path) path)))
 
-(define (require:provided? feature)
-  (if (symbol? feature)
-      (if (memq feature *features*) #t
-	  (and *catalog*
-	       (let ((path (catalog:get feature)))
-		 (cond ((symbol? path) (require:provided? path))
-		       ((member (if (pair? path) (cdr path) path) *modules*)
-			#t)
-		       (else #f)))))
-      (and (member feature *modules*) #t)))
-
-(define (require:feature->path feature)
-  (and (symbol? feature)
-       (let ((path (catalog:get feature)))
-	 (if (symbol? path) (require:feature->path path) path))))
-
-(define (require:require feature)
-  (or (require:provided? feature)
-      (let ((path (catalog:get feature)))
-	(cond ((and (not path) (string? feature) (file-exists? feature))
-	       (set! path feature)))
-	(cond ((not feature) (set! *catalog* #f))
-	      ((not path)
-	       (slib:error ";required feature not supported: " feature))
-	      ((symbol? path) (require:require path) (require:provide feature))
-	      ((not (pair? path))	;simple name
-	       (slib:load path)
-	       (and (not (eq? 'new-catalog feature)) (require:provide feature)))
-	      (else			;special loads
-	       (require:require (car path))
-	       (apply (case (car path)
-			((macro) macro:load)
-			((syntactic-closures) synclo:load)
-			((syntax-case) syncase:load)
-			((macros-that-work) macwork:load)
-			((macro-by-example) defmacro:load)
-			((defmacro) defmacro:load)
-			((source) slib:load-source)
-			((compiled) slib:load-compiled)
-			(else (slib:error "unknown package loader" path)))
-		      (if (list? path) (cdr path) (list (cdr path))))
-	       (require:provide feature))))))
-
-(define (require:provide feature)
-  (if (symbol? feature)
-      (if (not (memq feature *features*))
-	  (set! *features* (cons feature *features*)))
-      (if (not (member feature *modules*))
-	  (set! *modules* (cons feature *modules*)))))
-
-(require:provide 'vicinity)
+;@
+(define (feature-eval expression provided?)
+  (define (bail expression)
+    (slib:error 'invalid 'feature 'expression expression))
+  (define (feval expression)
+    (cond ((not expression) expression)
+	  ((symbol? expression) (provided? expression))
+	  ((and (list? expression) (pair? expression))
+	   (case (car expression)
+	     ((not) (case (length expression)
+		      ((2) (not (feval (cadr expression))))
+		      (else (bail expression))))
+	     ((or)  (case (length expression)
+		      ((1) #f)
+		      ;;((2) (feval (cadr expression)))
+		      (else (or (feval (cadr expression))
+				(feval (cons 'or (cddr expression)))))))
+	     ((and) (case (length expression)
+		      ((1) #t)
+		      ;;((2) (feval (cadr expression)))
+		      (else (and (feval (cadr expression))
+				 (feval (cons 'and (cddr expression)))))))
+	     (else (bail expression))))
+	  (else (bail expression))))
+  (feval expression))
+;@
+(define (provided? expression)
+  (define feature-list (cons (software-type) *features*))
+  (define (provided? expression)
+    (if (memq expression feature-list) #t
+	(and *catalog*
+	     (let ((path (catalog:get expression)))
+	       (cond ((symbol? path) (provided? path))
+		     (else #f))))))
+  (feature-eval expression provided?))
+;@
+(define (require feature)
+  (cond
+   ((not feature) (set! *catalog* #f))
+   ((slib:provided? feature))
+   (else
+    (let ((path (catalog:get feature)))
+      (cond ((not path)
+	     (slib:error 'slib:require 'unsupported 'feature feature))
+	    ((symbol? path) (slib:provide feature) (slib:require path))
+	    ((string? path)		;simple name
+	     (and (not (eq? 'new-catalog feature)) (slib:provide feature))
+	     (slib:load path))
+	    (else			;dispatched loads
+	     (slib:provide feature)
+	     (slib:require (car path))
+	     (apply (case (car path)
+		      ((macro) macro:load)
+		      ((syntactic-closures) synclo:load)
+		      ((syntax-case) syncase:load)
+		      ((macros-that-work) macwork:load)
+		      ((macro-by-example) defmacro:load)
+		      ((defmacro) defmacro:load)
+		      ((source) slib:load-source)
+		      ((compiled) slib:load-compiled)
+		      ((aggregate)
+		       (lambda feature (for-each slib:require feature)))
+		      ((spectral-tristimulus-values) load-ciexyz)
+		      ((color-names)
+		       (lambda (filename)
+			 (load-color-dictionary feature filename)))
+		      (else (slib:error "unknown package loader" path)))
+		    (if (list? path) (cdr path) (list (cdr path))))))))))
+;@
+(define (require-if feature? feature)
+  (if (slib:provided? feature?) (slib:require feature)))
+;@
+(define (provide feature)
+  (if (not (memq feature *features*))
+      (set! *features* (cons feature *features*))))
 
-(define provide require:provide)
-(define provided? require:provided?)
-(define require require:require)
+;@
+(define slib:provide provide)
+(define slib:provided? provided?)
+(define slib:require require)
+(define slib:require-if require-if)
+;;; Legacy
+(define require:provide provide)
+(define require:provided? provided?)
+(define require:require require)
 
+(slib:provide 'vicinity)
 (if (and (string->number "0.0") (inexact? (string->number "0.0")))
-    (require:provide 'inexact))
-(if (rational? (string->number "1/19")) (require:provide 'rational))
-(if (real? (string->number "0.0")) (require:provide 'real))
-(if (complex? (string->number "1+i")) (require:provide 'complex))
+    (slib:provide 'inexact))
+(if (rational? (string->number "1/19")) (slib:provide 'rational))
+(if (real? (string->number "0.0")) (slib:provide 'real))
+(if (complex? (string->number "1+i")) (slib:provide 'complex))
 (let ((n (string->number "9999999999999999999999999999999")))
-  (if (and n (exact? n)) (require:provide 'bignum)))
+  (if (and n (exact? n)) (slib:provide 'bignum)))
 
 (cond
- ((provided? 'srfi)
-  (cond-expand (srfi-0 (provide 'srfi-0)) (else #f))
-  (cond-expand (srfi-1 (provide 'srfi-1)) (else #f))
-  (cond-expand (srfi-2 (provide 'srfi-2)) (else #f))
-  (cond-expand (srfi-3 (provide 'srfi-3)) (else #f))
-  (cond-expand (srfi-4 (provide 'srfi-4)) (else #f))
-  (cond-expand (srfi-5 (provide 'srfi-5)) (else #f))
-  (cond-expand (srfi-6 (provide 'srfi-6)) (else #f))
-  (cond-expand (srfi-7 (provide 'srfi-7)) (else #f))
-  (cond-expand (srfi-8 (provide 'srfi-8)) (else #f))
-  (cond-expand (srfi-9 (provide 'srfi-9)) (else #f))
-  (cond-expand (srfi-10 (provide 'srfi-10)) (else #f))
-  (cond-expand (srfi-11 (provide 'srfi-11)) (else #f))
-  (cond-expand (srfi-12 (provide 'srfi-12)) (else #f))
-  (cond-expand (srfi-13 (provide 'srfi-13)) (else #f))
-  (cond-expand (srfi-14 (provide 'srfi-14)) (else #f))
-  (cond-expand (srfi-15 (provide 'srfi-15)) (else #f))
-  (cond-expand (srfi-16 (provide 'srfi-16)) (else #f))
-  (cond-expand (srfi-17 (provide 'srfi-17)) (else #f))
-  (cond-expand (srfi-18 (provide 'srfi-18)) (else #f))
-  (cond-expand (srfi-19 (provide 'srfi-19)) (else #f))
-  (cond-expand (srfi-20 (provide 'srfi-20)) (else #f))
-  (cond-expand (srfi-21 (provide 'srfi-21)) (else #f))
-  (cond-expand (srfi-22 (provide 'srfi-22)) (else #f))
-  (cond-expand (srfi-23 (provide 'srfi-23)) (else #f))
-  (cond-expand (srfi-24 (provide 'srfi-24)) (else #f))
-  (cond-expand (srfi-25 (provide 'srfi-25)) (else #f))
-  (cond-expand (srfi-26 (provide 'srfi-26)) (else #f))
-  (cond-expand (srfi-27 (provide 'srfi-27)) (else #f))
-  (cond-expand (srfi-28 (provide 'srfi-28)) (else #f))
-  (cond-expand (srfi-29 (provide 'srfi-29)) (else #f))
-  (cond-expand (srfi-30 (provide 'srfi-30)) (else #f))))
+ ((slib:provided? 'srfi)
+  (do ((idx 0 (+ 1 idx))
+       (srfis (symbol->string 'srfi-)))
+      ((> idx 100))
+    (let ((srfi (string->symbol (string-append srfis (number->string idx)))))
+      (if (slib:eval `(cond-expand (,srfi #t) (else #f)))
+	  (slib:provide srfi))))))
 
 (define report:print
   (lambda args
     (for-each (lambda (x) (write x) (display #\ )) args)
     (newline)))
 
+;@
 (define slib:report
   (let ((slib:report (lambda () (slib:report-version) (slib:report-locations))))
     (lambda args
       (cond ((null? args) (slib:report))
 	    ((not (string? (car args)))
 	     (slib:report-version) (slib:report-locations #t))
-	    ((require:provided? 'transcript)
+	    ((slib:provided? 'transcript)
 	     (transcript-on (car args))
 	     (slib:report)
 	     (transcript-off))
-	    ((require:provided? 'with-file)
+	    ((slib:provided? 'with-file)
 	     (with-output-to-file (car args) slib:report))
 	    (else (slib:report))))))
 
+;@
 (define slib:report-version
   (lambda ()
     (report:print
@@ -266,13 +290,13 @@
 (define slib:report-locations
   (let ((features *features*))
     (lambda args
+      (define sit (scheme-implementation-type))
+      (define siv (string->symbol (scheme-implementation-version)))
       (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity))
       (report:print '(LIBRARY-VICINITY) 'is (library-vicinity))
       (report:print '(SCHEME-FILE-SUFFIX) 'is (scheme-file-suffix))
       (cond (*load-pathname*
 	     (report:print '*LOAD-PATHNAME* 'is *load-pathname*)))
-      (cond ((not (null? *modules*))
-	     (report:print 'Loaded '*MODULES* 'are: *modules*)))
       (let* ((i (+ -1 5)))
 	(cond ((eq? (car features) (car *features*)))
 	      (else (report:print 'loaded '*FEATURES* ':) (display slib:tab)))
@@ -280,14 +304,14 @@
 	 (lambda (x)
 	   (cond ((eq? (car features) x)
 		  (if (not (eq? (car features) (car *features*))) (newline))
-		  (report:print 'Implementation '*FEATURES* ':)
+		  (report:print sit siv '*FEATURES* ':)
 		  (display slib:tab) (set! i (+ -1 5)))
 		 ((zero? i) (newline) (display slib:tab) (set! i (+ -1 5)))
 		 ((not (= (+ -1 5) i)) (display #\ )))
 	   (write x) (set! i (+ -1 i)))
 	 *features*))
       (newline)
-      (report:print 'Implementation '*CATALOG* ':)
+      (report:print sit siv '*CATALOG* ':)
       (catalog:get #f)
       (cond ((pair? args)
 	     (for-each (lambda (x) (display slib:tab) (report:print x))
@@ -296,9 +320,9 @@
 		  (display slib:tab) (report:print '...)))
       (newline))))
 
-(let ((sit (scheme-implementation-version)))
-  (cond ((zero? (string-length sit)))
-	((or (not (string? sit)) (char=? #\? (string-ref sit 0)))
+(let ((siv (scheme-implementation-version)))
+  (cond ((zero? (string-length siv)))
+	((or (not (string? siv)) (char=? #\? (string-ref siv 0)))
 	 (newline)
 	 (slib:report-version)
 	 (report:print 'edit (scheme-implementation-type) ".init"