diff options
Diffstat (limited to 'require.scm')
| -rw-r--r-- | require.scm | 235 |
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))) |