;"mklibcat.scm" Build catalog for SLIB
;Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002 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
;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.

(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* "(")
      (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")))
	(map (lambda (p)
	       (if (or (symbol? (cdr p))
		       (and (pair? (cdr p)) (eqv? 'aggregate (cadr p))))
		   p
		   (cons
		    (car p)
		    (if (pair? (cdr p))
			(cons
			 (cadr p)
			 (in-vicinity (library-vicinity) (cddr p)))
			(in-vicinity (library-vicinity) (cdr p))))))
	     '(
	       (r2rs	aggregate	rev3-procedures	rev2-procedures)
	       (r3rs	aggregate	rev3-procedures)
	       (r4rs	aggregate	rev4-optional-procedures)
	       (r5rs	aggregate	values	macro	eval)
	       (null			.	"null")
	       (aggregate		.	"null")
	       (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")
	       (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")
	       (subarray		.	"subarray")
	       (array-for-each		.	"arraymap")
	       (repl			.	"repl")
	       (process			.	"process")
	       (chapter-order		.	"chap")
	       (posix-time		.	"psxtime")
	       (common-lisp-time	.	"cltime")
	       (time-zone		.	"timezone")
	       (relational-database	.	"rdms")
	       (databases		.	"dbutil")
	       (database-utilities	.	databases)
	       (database-commands	.	"dbcom")
	       (database-browse		.	"dbrowse")
	       (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	.	"prec")
	       (parse			.	precedence-parse)
	       (commutative-ring	.	"cring")
	       (self-set		.	"selfset")
	       (determinant		.	"determ")
	       (byte			.	"byte")
	       (tzfile			.	"tzfile")
	       (schmooz			.	"schmooz")
	       (transact		.	"transact")
	       (net-clients		.	transact)
	       (db->html		.	"db2html")
	       (http			.	"http-cgi")
	       (cgi			.	http)
	       (uri			.	"uri")
	       (uniform-resource-identifier .	uri)
	       (pnm			.	"pnm")
	       (metric-units		.	"simetrix")
	       (diff			.	"differ")
	       (solid			.	"solid")
	       (vrml97			.	solid)
	       (vrml			.	vrml97)
	       (color			.	"color")
	       (color-space		.	"colorspc")
	       (cie			.	color-space)
	       (color-names		.	"colornam")
	       (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			.	"cvs")
	       (html-for-each		.	"html4each")
	       (directory		.	"dirs")
	       (srfi-0			.	srfi)
	       (srfi	defmacro	.	"srfi")
	       (srfi-1			.	"srfi-1")
	       (new-catalog		.	"mklibcat")
	       ))))
      (let* ((req (in-vicinity (library-vicinity)
			       (string-append "require" (scheme-file-suffix)))))
	(write* (cons '*SLIB-VERSION* (or (require: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))