;"mklibcat.scm" Build catalog for SLIB
;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
;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 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.
;
;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")))
	(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")
	   (peano-fill				"peanosfc")
	   (soundex				"soundex")
	   (hash-table				"hashtab")
	   (logical				"logical")
	   (random				"random")
	   (random-inexact			"randinex")
	   (modular				"modular")
	   (factor				"factor")
	   (primes				factor)
	   (limit				"limit")
	   (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")

	   (printf				"printf")
	   (scanf		defmacro	"scanf")
	   (stdio-ports				"stdio")
	   (stdio		aggregate scanf printf stdio-ports)

	   (break		defmacro	"break")
	   (trace		defmacro	"trace")
	   (debugf				"debug")
	   (debug		aggregate trace break debugf)

	   (delay				promise)
	   (promise		macro		"promise")

	   (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")
	   (array-interpolate			"linterp")
	   (repl				"repl")
	   (process				"process")
	   (chapter-order			"chap")
	   (posix-time				"psxtime")
	   (common-lisp-time			"cltime")
	   (time-core				"timecore")
	   (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")
	   (nbs-iscc		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")
	   (and-let*				srfi-2)
	   (srfi-2		defmacro	"srfi-2")
	   (receive				srfi-8)
	   (srfi-8		macro		"srfi-8")
	   (define-record-type			srfi-9)
	   (srfi-9		macro		"srfi-9")
	   (srfi-47				array)
	   (srfi-63				array)
	   (srfi-60				logical)
	   (guarded-cond-clause			srfi-61)
	   (srfi-61		macro		"srfi-61")
	   (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))