Import Debian changes 2c0-3debian/2c0-3

slib (2c0-3) unstable; urgency=low

  * New maintainer.
  * slibconfig script to automatically configure guile.
  * Fix type in description, closes: Bug#18996

slib (2c0-2) unstable; urgency=low

  * Minor fix for debian/rules targets

slib (2c0-1) unstable; urgency=low

  * New upstream source
  * New maintainer

1 files changed, 79 insertions, 156 deletions

diff --git a/require.scm b/require.scm
index d1ebe9a..5b02ff6 100644
--- a/require.scm
+++ b/require.scm
@@ -1,5 +1,5 @@
 ;;;; Implementation of VICINITY and MODULES for Scheme
-;Copyright (C) 1991, 1992, 1993, 1994 Aubrey Jaffer
+;Copyright (C) 1991, 1992, 1993, 1994, 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
@@ -17,7 +17,7 @@
 ;promotional, or sales literature without prior written consent in
 ;each case.
 
-(define *SLIB-VERSION* "2a6")
+(define *SLIB-VERSION* "2c0")
 
 ;;; Standardize msdos -> ms-dos.
 (define software-type
@@ -30,6 +30,7 @@
     ((VMS)	"[.]")
     (else	"")))
 
+(define *load-pathname* #f)
 (define program-vicinity
   (let ((*vicinity-suffix*
 	 (case (software-type)
@@ -69,114 +70,6 @@
 
 (define (make-vicinity <pathname>) <pathname>)
 
-(define *catalog*
-  (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")
-     (format-inexact		.	"formatfl")
-     (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)
-     (object			.	"object")
-     (record-object		.	"recobj")
-     (yasos		macro	.	"yasyn")
-     (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		.	"time")
-     (common-lisp-time		.	"cltime")
-     (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")
-     )))
-
-(set! *catalog*
-      (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")))
-	      *catalog*))
-
-(define *load-pathname* #f)
-
 (define (slib:pathnameize-load *old-load*)
   (lambda (<pathname> . extra)
     (let ((old-load-pathname *load-pathname*))
@@ -192,38 +85,88 @@
 
 ;;;; MODULES
 
+(define *catalog* #f)
 (define *modules* '())
 
+(define (require:version path)
+  (let ((expr (and (file-exists? path)
+		   (call-with-input-file path (lambda (port) (read port))))))
+    (and (list? expr) (= 3 (length expr))
+	 (eq? (car expr) 'define) (eq? (cadr expr) '*SLIB-VERSION*)
+	 (string? (caddr expr)) (caddr expr))))
+
+(define (catalog/require-version-match? slibcat)
+  (let* ((apair (assq '*SLIB-VERSION* slibcat))
+	 (req (in-vicinity (library-vicinity)
+			   (string-append "require" (scheme-file-suffix))))
+	 (reqvers (require:version req)))
+    (cond ((not (file-exists? req))
+	   (slib:warn "can't find " req) #f)
+	  ((not apair) #f)
+	  ((not (equal? reqvers (cdr apair))) #f)
+	  ((not (equal? reqvers *SLIB-VERSION*))
+	   (slib:warn "The loaded " req " is stale.")
+	   #t)
+	  (else #t))))
+
+(define (catalog:try-read vicinity name)
+  (or (and vicinity name
+	   (let ((path (in-vicinity vicinity name)))
+	     (and (file-exists? path)
+		  (call-with-input-file path
+		    (lambda (port)
+		      (do ((expr (read port) (read port))
+			   (lst '() (cons expr lst)))
+			  ((eof-object? expr)
+			   (apply append lst))))))))
+      '()))
+
+(define (catalog:get feature)
+  (if (not *catalog*)
+      (let ((slibcat (catalog:try-read (implementation-vicinity) "slibcat")))
+	(cond ((not (catalog/require-version-match? slibcat))
+	       (slib:load (in-vicinity (library-vicinity) "mklibcat"))
+	       (set! slibcat
+		     (catalog:try-read (implementation-vicinity) "slibcat"))))
+	(cond (slibcat
+	       (set! *catalog* ((slib:eval
+				 (cadr (or (assq 'catalog:filter slibcat)
+					   '(#f identity))))
+				slibcat))))
+	(set! *catalog*
+	      (append (catalog:try-read (home-vicinity) "homecat") *catalog*))
+	(set! *catalog*
+	      (append (catalog:try-read (user-vicinity) "usercat") *catalog*))))
+  (and feature *catalog* (cdr (or (assq feature *catalog*) '(#f . #f)))))
+
 (define (require:provided? feature)
   (if (symbol? feature)
       (if (memq feature *features*) #t
-	  (let ((path (cdr (or (assq feature *catalog*) '(#f . #f)))))
-	    (cond ((symbol? path) (provided? path))
+	  (let ((path (catalog:get feature)))
+	    (cond ((symbol? path) (require:provided? path))
 		  ((member (if (pair? path) (cdr path) path) *modules*)
 		   #t)
 		  (else #f))))
       (and (member feature *modules*) #t)))
 
 (define (require:feature->path feature)
-  (if (symbol? feature)
-      (let ((path (cdr (or (assq feature *catalog*) '(#f . #f)))))
-	(if (symbol? path) (require:feature->path path) path))
-      feature))
+  (and (symbol? feature)
+       (let ((path (catalog:get feature)))
+	 (if (symbol? path) (require:feature->path path) path))))
 
 (define (require:require feature)
   (or (require:provided? feature)
       (let ((path (require:feature->path feature)))
 	(cond ((and (not path) (string? feature) (file-exists? feature))
 	       (set! path feature)))
-	(cond ((not path)
-	       ;;(newline) (display ";required feature not supported: ")
-	       ;;(display feature) (newline)
+	(cond ((not feature) (set! *catalog* #f))
+	      ((not path)
 	       (slib:error ";required feature not supported: " feature))
 	      ((not (pair? path))	;simple name
 	       (slib:load path)
-	       (require:provide feature))
+	       (and (not (eq? 'new-catalog feature)) (require:provide feature)))
 	      (else			;special loads
-	       (require (car path))
+	       (require:require (car path))
 	       (apply (case (car path)
 			((macro) macro:load)
 			((syntactic-closures) synclo:load)
@@ -232,7 +175,8 @@
 			((macro-by-example) defmacro:load)
 			((defmacro) defmacro:load)
 			((source) slib:load-source)
-			((compiled) slib:load-compiled))
+			((compiled) slib:load-compiled)
+			(else (slib:error "unknown package loader" path)))
 		      (if (list? path) (cdr path) (list (cdr path))))
 	       (require:provide feature))))))
 
@@ -249,24 +193,13 @@
 (define provided? require:provided?)
 (define require require:require)
 
-;;; Supported by all implementations
-(provide 'eval)
-(provide 'defmacro)
-
 (if (and (string->number "0.0") (inexact? (string->number "0.0")))
-    (provide 'inexact))
-(if (rational? (string->number "1/19")) (provide 'rational))
-(if (real? (string->number "0.0")) (provide 'real))
-(if (complex? (string->number "1+i")) (provide 'complex))
+    (require:provide 'inexact))
+(if (rational? (string->number "1/19")) (require:provide 'rational))
+(if (real? (string->number "0.0")) (require:provide 'real))
+(if (complex? (string->number "1+i")) (require:provide 'complex))
 (let ((n (string->number "9999999999999999999999999999999")))
-  (if (and n (exact? n)) (provide 'bignum)))
-
-(define current-time
-  (if (provided? 'current-time) current-time
-      (let ((c 0))
-	(lambda () (set! c (+ c 1)) c))))
-(define difftime (if (provided? 'current-time) difftime -))
-(define offset-time (if (provided? 'current-time) offset-time +))
+  (if (and n (exact? n)) (require:provide 'bignum)))
 
 (define report:print
   (lambda args
@@ -294,7 +227,7 @@
      (scheme-implementation-version) 'on (software-type))))
 
 (define slib:report-locations
-  (let ((features *features*) (catalog *catalog*))
+  (let ((features *features*))
     (lambda args
       (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity))
       (report:print '(LIBRARY-VICINITY) 'is (library-vicinity))
@@ -317,23 +250,13 @@
 	   (write x) (set! i (+ -1 i)))
 	 *features*))
       (newline)
-      (let* ((i #t))
-	(cond ((not (eq? (car catalog) (car *catalog*)))
-	       (report:print 'Additional '*CATALOG* ':)))
-	(cond ((or (pair? args) (not (eq? (car catalog) (car *catalog*))))
-	       (for-each
-		(lambda (x)
-		  (cond ((eq? (car catalog) x)
-			 (report:print 'Implementation '*CATALOG* ':)
-			 (set! i (pair? args))
-			 (cond (i)
-			       (else (display slib:tab) (report:print x)
-				     (display slib:tab) (report:print '...)))))
-		  (cond (i (display slib:tab) (report:print x))))
-		*catalog*))
-	      (else (report:print 'Implementation '*CATALOG* ':)
-		    (display slib:tab) (report:print (car *catalog*))
-		    (display slib:tab) (report:print '...))))
+      (report:print 'Implementation '*CATALOG* ':)
+      (catalog:get #f)
+      (cond ((pair? args)
+	     (for-each (lambda (x) (display slib:tab) (report:print x))
+		       *catalog*))
+	    (else (display slib:tab) (report:print (car *catalog*))
+		  (display slib:tab) (report:print '...)))
       (newline))))
 
 (let ((sit (scheme-implementation-version)))