summaryrefslogtreecommitdiffstats
path: root/require.scm
diff options
context:
space:
mode:
Diffstat (limited to 'require.scm')
-rw-r--r--require.scm235
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)))