1 files changed, 54 insertions, 0 deletions
diff --git a/mkpltcat.scm b/mkpltcat.scm
new file mode 100644
index 0000000..80d4414
--- /dev/null
+++ b/mkpltcat.scm
@@ -0,0 +1,54 @@
+;;;; "mkimpcat.scm" Build mzscheme-specific catalog for SLIB.
+;;; This code is in the public domain.
+;;; Author: Aubrey Jaffer.
+
+(let ((catname "implcat"))
+  (define ivcatname (in-vicinity (implementation-vicinity) catname))
+  (if (file-exists? ivcatname) (delete-file ivcatname))
+  (call-with-output-file ivcatname
+    (lambda (op)
+      (define (display* . args)
+	(for-each (lambda (arg) (display arg op)) args)
+	(newline op))
+      (define (add-alias from to)
+	(display " " op)
+	(write (cons from to) op)
+	(newline op))
+      (define (add-srfi feature)
+	(let ((str (symbol->string feature)))
+	  (define len (string-length str))
+	  (cond ((not (and (> len 5)
+			   (string-ci= "srfi-" (substring str 0 5))))
+		 (error 'add-srfi 'bad 'srfi 'name feature)))))
+
+      (display* ";\"" catname "\" Implementation-specific SLIB catalog for "
+		(scheme-implementation-type) (scheme-implementation-version)
+		".  -*-scheme-*-")
+      (display* ";")
+      (display* ";			DO NOT EDIT THIS FILE")
+      (display* "; it is automagically generated by \""
+		(current-load-relative-directory)
+		"mkimpcat.scm"
+		"\"")
+      (display*)
+
+      ;;; Output association lists to file "implcat"
+      (display* "(")
+      (do ((kdx 0 (+ 1 kdx)))
+	  ((>= kdx 150))
+	(let ((kstr (number->string kdx)))
+	  (cond ((file-exists?
+		  (build-path (collection-path "srfi")
+			      (string-append kstr ".ss")))
+		 (display " " op)
+		 (write `(,(string->symbol (string-append "srfi-" kstr))
+			  compiled
+			  (lib ,(string-append kstr ".ss") "srfi"))
+			op)
+		 (newline op)))))
+
+      (if (string>? (version) "370")
+	  (add-alias 'array 'srfi-63))
+      (add-alias 'logical 'srfi-60)
+      (display* ")")
+      )))