Import Upstream version 3a1upstream/3a1

1 files changed, 222 insertions, 179 deletions

diff --git a/mklibcat.scm b/mklibcat.scm
index 5b7d211..e6a0321 100644
--- a/mklibcat.scm
+++ b/mklibcat.scm
@@ -1,5 +1,5 @@
 ;"mklibcat.scm" Build catalog for SLIB
-;Copyright (C) 1997 Aubrey Jaffer
+;Copyright (C) 1997, 1998, 1999, 2000, 2001, 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.
 ;
@@ -17,185 +17,228 @@
 ;promotional, or sales literature without prior written consent in
 ;each case.
 
-(call-with-output-file (in-vicinity (implementation-vicinity) "slibcat")
-  (lambda (op)
-    (display ";\"slibcat\" SLIB catalog for " op)
-    (display (scheme-implementation-type) op)
-    (display (scheme-implementation-version) op)
-    (display ".        -*-scheme-*-" op) (newline op)
-    (display ";" op) (newline op)
-    (display "; DO NOT EDIT THIS FILE -- it is automagically generated" op)
-    (newline op) (newline op)
+(let ((catpath (in-vicinity (implementation-vicinity) "slibcat")))
+  (and (file-exists? catpath) (delete-file catpath))
+  (call-with-output-file catpath
+    (lambda (op)
+      (define (display* . args)
+	(for-each (lambda (arg) (display arg op)) args)
+	(newline op))
+      (define (write* asp)
+	(display " " op) (write asp op) (newline op))
+      (display* ";\"slibcat\" SLIB catalog for "
+		(scheme-implementation-type) (scheme-implementation-version)
+		".        -*-scheme-*-")
+      (display* ";")
+      (display* "; DO NOT EDIT THIS FILE -- it is automagically generated")
+      (display*)
 
-    (display "(" op) (newline op)
-    (for-each
-     (lambda (asp) (display " " op) (write asp op) (newline op))
-     (append
-      (list (cons 'schelog
-		  (in-vicinity (sub-vicinity (library-vicinity) "schelog")
-			       "schelog"))
-	    (cons 'portable-scheme-debugger
-		  (in-vicinity (sub-vicinity (library-vicinity) "psd")
-			       "psd-slib"))
-	    (cons 'jfilter
-		  (in-vicinity (sub-vicinity (library-vicinity) "jfilter")
-			       "jfilter")))
-      (map (lambda (p)
-	     (if (symbol? (cdr p)) p
-		 (cons
-		  (car p)
-		  (if (pair? (cdr p))
-		      (cons
-		       (cadr p)
-		       (in-vicinity (library-vicinity) (cddr p)))
-		      (in-vicinity (library-vicinity) (cdr p))))))
-	   '(
-	     (rev4-optional-procedures	.	"sc4opt")
-	     (rev2-procedures		.	"sc2")
-	     (multiarg/and-		.	"mularg")
-	     (multiarg-apply		.	"mulapply")
-	     (rationalize		.	"ratize")
-	     (transcript		.	"trnscrpt")
-	     (with-file			.	"withfile")
-	     (dynamic-wind		.	"dynwind")
-	     (dynamic			.	"dynamic")
-	     (fluid-let		defmacro	.	"fluidlet")
-	     (alist			.	"alist")
-	     (hash			.	"hash")
-	     (sierpinski		.	"sierpinski")
-	     (soundex			.	"soundex")
-	     (hash-table		.	"hashtab")
-	     (logical			.	"logical")
-	     (random			.	"random")
-	     (random-inexact		.	"randinex")
-	     (modular			.	"modular")
-	     (factor			.	"factor")
-	     (primes			.	factor)
-	     (charplot			.	"charplot")
-	     (sort			.	"sort")
-	     (tsort			.	topological-sort)
-	     (topological-sort		.	"tsort")
-	     (common-list-functions	.	"comlist")
-	     (tree			.	"tree")
-	     (coerce			.	"coerce")
-	     (format			.	"format")
-	     (generic-write		.	"genwrite")
-	     (pretty-print		.	"pp")
-	     (pprint-file		.	"ppfile")
-	     (object->string		.	"obj2str")
-	     (string-case		.	"strcase")
-	     (stdio			.	"stdio")
-	     (printf			.	"printf")
-	     (scanf			.	"scanf")
-	     (line-i/o			.	"lineio")
-	     (string-port		.	"strport")
-	     (getopt			.	"getopt")
-	     (debug			.	"debug")
-	     (qp			.	"qp")
-	     (break	defmacro	.	"break")
-	     (trace	defmacro	.	"trace")
-	     (eval			.	"eval")
-	     (record			.	"record")
-	     (promise			.	"promise")
-	     (synchk			.	"synchk")
-	     (defmacroexpand		.	"defmacex")
-	     (macro-by-example	defmacro	.	"mbe")
-	     (syntax-case		.	"scainit")
-	     (syntactic-closures	.	"scmacro")
-	     (macros-that-work		.	"macwork")
-	     (macro			.	macro-by-example)
-	     (object			.	"object")
-	     (yasos		macro	.	"yasyn")
-	     (oop			.	yasos)
-	     (collect		macro	.	"collect")
-	     (structure	syntax-case	.	"structure")
-	     (values			.	"values")
-	     (queue			.	"queue")
-	     (priority-queue		.	"priorque")
-	     (array			.	"array")
-	     (array-for-each		.	"arraymap")
-	     (repl			.	"repl")
-	     (process			.	"process")
-	     (chapter-order		.	"chap")
-	     (posix-time		.	"psxtime")
-	     (common-lisp-time		.	"cltime")
-	     (time-zone			.	"timezone")
-	     (relational-database	.	"rdms")
-	     (database-utilities	.	"dbutil")
-	     (database-browse		.	"dbrowse")
-	     (html-form			.	"htmlform")
-	     (alist-table		.	"alistab")
-	     (parameters		.	"paramlst")
-	     (getopt-parameters		.	"getparam")
-	     (read-command		.	"comparse")
-	     (batch			.	"batch")
-	     (glob			.	"glob")
-	     (filename			.	glob)
-	     (make-crc			.	"makcrc")
-	     (fft			.	"fft")
-	     (wt-tree			.	"wttree")
-	     (string-search		.	"strsrch")
-	     (root			.	"root")
-	     (minimize			.	"minimize")
-	     (precedence-parse		.	"prec")
-	     (parse			.	precedence-parse)
-	     (commutative-ring		.	"cring")
-	     (self-set			.	"selfset")
-	     (determinant		.	"determ")
-	     (byte			.	"byte")
-	     (tzfile			.	"tzfile")
-	     (schmooz			.	"schmooz")
-	     (net-clients		.	"nclients")
-	     (db->html			.	"db2html")
-	     (http			.	"http-cgi")
-	     (cgi			.	http)
-	     (uri			.	"uri")
-	     (uniform-resource-identifier .	uri)
-	     (pnm			.	"pnm")
-	     (metric-units		.	"simetrix")
-	     (diff			.	"differ")
-	     (srfi-0			.	srfi)
-	     (srfi	defmacro	.	"srfi")
-	     (srfi-1			.	"srfi-1")
-	     (new-catalog		.	"mklibcat")
-	     ))))
-    (display " " op)
+      (display* "(")
+      (for-each
+       write*
+       (append
+	(list (cons 'schelog
+		    (in-vicinity (sub-vicinity (library-vicinity) "schelog")
+				 "schelog"))
+	      (cons 'portable-scheme-debugger
+		    (in-vicinity (sub-vicinity (library-vicinity) "psd")
+				 "psd-slib"))
+	      (cons 'jfilter
+		    (in-vicinity (sub-vicinity (library-vicinity) "jfilter")
+				 "jfilter")))
+	(catalog:resolve
+	 (library-vicinity)
+	 '(
+	   ;; null is the start of SLIB associations.
+	   (null				"null")
+	   (aggregate				"null")
+	   (r2rs	aggregate	rev3-procedures	rev2-procedures)
+	   (r3rs	aggregate	rev3-procedures)
+	   (r4rs	aggregate	rev4-optional-procedures)
+	   (r5rs	aggregate	values	macro	eval)
+	   (rev4-optional-procedures		"sc4opt")
+	   (rev3-procedures			"null")
+	   (rev2-procedures			"sc2")
+	   (multiarg/and-			"mularg")
+	   (multiarg-apply			"mulapply")
+	   (rationalize				"ratize")
+	   (transcript				"trnscrpt")
+	   (with-file				"withfile")
+	   (dynamic-wind			"dynwind")
+	   (dynamic				"dynamic")
+	   (fluid-let		defmacro	"fluidlet")
+	   (alist				"alist")
+	   (hash				"hash")
+	   (sierpinski				"sierpinski")
+	   (hilbert-fill			"phil-spc")
+	   (soundex				"soundex")
+	   (hash-table				"hashtab")
+	   (logical				"logical")
+	   (random				"random")
+	   (random-inexact			"randinex")
+	   (modular				"modular")
+	   (factor				"factor")
+	   (primes				factor)
+	   (eps-graph				"grapheps")
+	   (charplot				"charplot")
+	   (sort				"sort")
+	   (tsort				topological-sort)
+	   (topological-sort			"tsort")
+	   (common-list-functions		"comlist")
+	   (tree				"tree")
+	   (coerce				"coerce")
+	   ;;(format				"format")
+	   (generic-write			"genwrite")
+	   (pretty-print			"pp")
+	   (pprint-file				"ppfile")
+	   (object->string			"obj2str")
+	   (string-case				"strcase")
+	   (line-i/o				"lineio")
+	   (string-port				"strport")
+	   (getopt				"getopt")
+	   (qp					"qp")
+	   (eval				"eval")
+	   (record				"record")
+	   (synchk				"synchk")
+	   (defmacroexpand			"defmacex")
 
-    (let* ((req (in-vicinity (library-vicinity)
-			     (string-append "require" (scheme-file-suffix)))))
-      (write (cons '*SLIB-VERSION* (or (require:version req) *SLIB-VERSION*))
-	     op))
-    (newline op)
-    (display ")" op) (newline op)
+	   (printf				"printf")
+	   (scanf		defmacro	"scanf")
+	   (stdio-ports				"stdio")
+	   (stdio		aggregate scanf printf stdio-ports)
 
-    (let ((load-if-exists
-	   (lambda (path)
-	     (cond ((not (file-exists? path))
-		    (set! path (string-append path (scheme-file-suffix)))))
-	     (cond ((file-exists? path)
-		    (slib:load-source path))))))
-      ;;(load-if-exists (in-vicinity (implementation-vicinity) "mksitcat"))
-      (load-if-exists (in-vicinity (implementation-vicinity) "mkimpcat")))
+	   (break		defmacro	"break")
+	   (trace		defmacro	"trace")
+	   (debugf				"debug")
+	   (debug		aggregate trace break debugf)
 
-    (let ((catcat
-	   (lambda (vicinity name specificity)
-	     (let ((path (in-vicinity vicinity name)))
-	       (and (file-exists? path)
-		    (call-with-input-file path
-		      (lambda (ip)
-			(newline op)
-			(display "; " op)
-			(write path op)
-			(display " SLIB " op)
-			(display specificity op)
-			(display "-specific catalog additions" op)
-			(newline op) (newline op)
-			(do ((c (read-char ip) (read-char ip)))
-			    ((eof-object? c))
-			  (write-char c op)))))))))
-      (catcat (library-vicinity) "sitecat" "site")
-      (catcat (implementation-vicinity) "implcat" "implementation")
-      (catcat (implementation-vicinity) "sitecat" "site"))
-    ))
+	   (delay				promise)
+	   (promise		macro		"promise")
 
-(set! *catalog* #f)
+	   (macro-by-example	defmacro	"mbe")
+
+	   (syntax-case				"scainit")
+	   (syntactic-closures			"scmacro")
+	   (macros-that-work			"macwork")
+	   (macro				macro-by-example)
+	   (object				"object")
+	   (yasos		macro		"yasyn")
+	   (oop					yasos)
+	   (collect				"collectx")
+	   (structure		syntax-case	"structure")
+	   (values				"values")
+	   (queue				"queue")
+	   (priority-queue			"priorque")
+	   (array				"array")
+	   (subarray				"subarray")
+	   (array-for-each			"arraymap")
+	   (repl				"repl")
+	   (process				"process")
+	   (chapter-order			"chap")
+	   (posix-time				"psxtime")
+	   (common-lisp-time			"cltime")
+	   (time-zone		defmacro	"timezone")
+	   (relational-database			"rdms")
+	   (databases				"dbutil")
+	   (database-utilities			databases)
+	   (database-commands			"dbcom")
+	   (database-browse			"dbrowse")
+	   (database-interpolate		"dbinterp")
+	   (within-database	macro		"dbsyn")
+	   (html-form				"htmlform")
+	   (alist-table				"alistab")
+	   (parameters				"paramlst")
+	   (getopt-parameters			"getparam")
+	   (read-command			"comparse")
+	   (batch				"batch")
+	   (glob				"glob")
+	   (filename				glob)
+	   (crc					"crc")
+	   (fft					"fft")
+	   (wt-tree				"wttree")
+	   (string-search			"strsrch")
+	   (root				"root")
+	   (minimize				"minimize")
+	   (precedence-parse	defmacro	"prec")
+	   (parse				precedence-parse)
+	   (commutative-ring			"cring")
+	   (self-set				"selfset")
+	   (determinant				"determ")
+	   (byte				"byte")
+	   (byte-number				"bytenumb")
+	   (tzfile				"tzfile")
+	   (schmooz				"schmooz")
+	   (transact		defmacro	"transact")
+	   (net-clients				transact)
+	   (db->html				"db2html")
+	   (http		defmacro	"http-cgi")
+	   (cgi					http)
+	   (uri			defmacro	"uri")
+	   (uniform-resource-identifier		uri)
+	   (pnm					"pnm")
+	   (metric-units			"simetrix")
+	   (diff				"differ")
+	   (solid				"solid")
+	   (vrml97				solid)
+	   (vrml				vrml97)
+	   (color		defmacro	"color")
+	   (color-space				"colorspc")
+	   (cie					color-space)
+	   (color-names				"colornam")
+	   (color-database	defmacro	"mkclrnam")
+	   (resene		color-names	"clrnamdb.scm")
+	   (saturate		color-names	"clrnamdb.scm")
+	   (daylight				"daylight")
+	   (matfile				"matfile")
+	   (mat-file				matfile)
+	   (spectral-tristimulus-values		color-space)
+	   (cie1964 spectral-tristimulus-values "cie1964.xyz")
+	   (cie1931 spectral-tristimulus-values "cie1931.xyz")
+	   (ciexyz				cie1931)
+	   (cvs			defmacro	"cvs")
+	   (html-for-each	defmacro	"html4each")
+	   (directory				"dirs")
+	   (ncbi-dna		defmacro	"ncbi-dna")
+	   (manifest				"manifest")
+	   (top-refs				"top-refs")
+	   (vet					"vet")
+	   (srfi-0				srfi)
+	   (srfi		defmacro	"srfi")
+	   (srfi-1				"srfi-1")
+	   (srfi-2		defmacro	"srfi-2")
+	   (srfi-8		macro		"srfi-8")
+	   (srfi-9		macro		"srfi-9")
+	   (new-catalog				"mklibcat")
+	   ))))
+      (let* ((req (in-vicinity (library-vicinity)
+			       (string-append "require" (scheme-file-suffix)))))
+	(write* (cons '*SLIB-VERSION* (or (slib:version req) *SLIB-VERSION*))))
+      (display* ")")
+
+      (let ((load-if-exists
+	     (lambda (path)
+	       (cond ((not (file-exists? path))
+		      (set! path (string-append path (scheme-file-suffix)))))
+	       (cond ((file-exists? path)
+		      (slib:load-source path))))))
+	;;(load-if-exists (in-vicinity (implementation-vicinity) "mksitcat"))
+	(load-if-exists (in-vicinity (implementation-vicinity) "mkimpcat")))
+
+      (let ((catcat
+	     (lambda (vicinity name specificity)
+	       (let ((path (in-vicinity vicinity name)))
+		 (and (file-exists? path)
+		      (call-with-input-file path
+			(lambda (ip)
+			  (display*)
+			  (display* "; " "\"" path "\"" " SLIB "
+				    specificity "-specific catalog additions")
+			  (display*)
+			  (do ((c (read-char ip) (read-char ip)))
+			      ((eof-object? c))
+			    (write-char c op)))))))))
+	(catcat (library-vicinity) "sitecat" "site")
+	(catcat (implementation-vicinity) "implcat" "implementation")
+	(catcat (implementation-vicinity) "sitecat" "site"))
+      ))
+  (set! *catalog* #f))