Import Upstream version 2c0upstream/2c0

1 files changed, 175 insertions, 0 deletions

diff --git a/mklibcat.scm b/mklibcat.scm
new file mode 100644
index 0000000..050a3ba
--- /dev/null
+++ b/mklibcat.scm
@@ -0,0 +1,175 @@
+;"mklibcat.scm" Build catalog for SLIB
+;Copyright (C) 1997 Aubrey Jaffer
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;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
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;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)
+
+    (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")))
+      (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		macro	.	"fluidlet")
+	     (alist			.	"alist")
+	     (hash			.	"hash")
+	     (sierpinski		.	"sierpinski")
+	     (soundex			.	"soundex")
+	     (hash-table		.	"hashtab")
+	     (logical			.	"logical")
+	     (random			.	"random")
+	     (random-inexact		.	"randinex")
+	     (modular			.	"modular")
+	     (primes			.	"primes")
+	     (factor			.	"factor")
+	     (charplot			.	"charplot")
+	     (sort			.	"sort")
+	     (tsort			.	topological-sort)
+	     (topological-sort		.	"tsort")
+	     (common-list-functions	.	"comlist")
+	     (tree			.	"tree")
+	     (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			.	macros-that-work)
+	     (yasos		macro	.	"yasos")
+	     (oop			.	yasos)
+	     (collect		macro	.	"collect")
+	     (struct	defmacro	.	"struct")
+	     (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")
+	     (alist-table		.	"alistab")
+	     (parameters		.	"paramlst")
+	     (read-command		.	"comparse")
+	     (batch			.	"batch")
+	     (make-crc			.	"makcrc")
+	     (wt-tree			.	"wttree")
+	     (string-search		.	"strsrch")
+	     (root			.	"root")
+	     (precedence-parse		.	"prec")
+	     (parse			.	precedence-parse)
+	     (commutative-ring		.	"cring")
+	     (self-set			.	"selfset")
+	     (determinant		.	"determ")
+	     (byte			.	"byte")
+	     (tzfile			.	"tzfile")
+	     (new-catalog		.	"mklibcat")
+	     ))))
+    (display " " op)
+
+    (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)
+
+    (let ((mkimpcat (in-vicinity (implementation-vicinity) "mkimpcat")))
+      (cond ((not (file-exists? mkimpcat))
+	     (set! mkimpcat (string-append mkimpcat (scheme-file-suffix)))))
+      (cond ((file-exists? mkimpcat)
+	     (slib:load-source mkimpcat))))
+
+    (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"))
+    ))
+
+(set! *catalog* #f)