diff options
Diffstat (limited to 'require.scm')
| -rw-r--r-- | require.scm | 280 |
1 files changed, 152 insertions, 128 deletions
diff --git a/require.scm b/require.scm index e5d919d..a11cbf5 100644 --- a/require.scm +++ b/require.scm @@ -1,5 +1,5 @@ ;;;; Implementation of VICINITY and MODULES for Scheme -;Copyright (C) 1991, 1992, 1993, 1994, 1997 Aubrey Jaffer +;Copyright (C) 1991, 1992, 1993, 1994, 1997, 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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -16,21 +16,16 @@ ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. - -(define *SLIB-VERSION* "2d2") - -;;; Standardize msdos -> ms-dos. -(define software-type - (cond ((eq? 'msdos (software-type)) - (lambda () 'ms-dos)) - (else software-type))) - +;@ +(define *SLIB-VERSION* "3a1") +;@ (define (user-vicinity) (case (software-type) ((VMS) "[.]") (else ""))) - +;@ (define *load-pathname* #f) +;@ (define vicinity:suffix? (let ((suffi (case (software-type) @@ -38,18 +33,21 @@ ((MACOS THINKC) '(#\:)) ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) ((NOSVE) '(#\: #\.)) - ((UNIX COHERENT) '(#\/)) + ((UNIX COHERENT PLAN9) '(#\/)) ((VMS) '(#\: #\]))))) - (lambda (chr) (memv chr suffi)))) + (lambda (chr) (and (memv chr suffi) #t)))) +;@ +(define (pathname->vicinity pathname) + (let loop ((i (- (string-length pathname) 1))) + (cond ((negative? i) "") + ((vicinity:suffix? (string-ref pathname i)) + (substring pathname 0 (+ i 1))) + (else (loop (- i 1)))))) (define (program-vicinity) (if *load-pathname* - (let loop ((i (- (string-length *load-pathname*) 1))) - (cond ((negative? i) "") - ((vicinity:suffix? (string-ref *load-pathname* i)) - (substring *load-pathname* 0 (+ i 1))) - (else (loop (- i 1))))) + (pathname->vicinity *load-pathname*) (slib:error 'program-vicinity " called; use slib:load to load"))) - +;@ (define sub-vicinity (case (software-type) ((VMS) (lambda @@ -65,10 +63,10 @@ ((NOSVE) ".") ((MACOS THINKC) ":") ((MS-DOS WINDOWS ATARIST OS/2) "\\") - ((UNIX COHERENT AMIGA) "/")))) + ((UNIX COHERENT PLAN9 AMIGA) "/")))) (lambda (vic name) (string-append vic name *vicinity-suffix*)))))) - +;@ (define (make-vicinity <pathname>) <pathname>) (define (slib:pathnameize-load *old-load*) @@ -76,7 +74,6 @@ (let ((old-load-pathname *load-pathname*)) (set! *load-pathname* <pathname>) (apply *old-load* (cons <pathname> extra)) - (require:provide <pathname>) (set! *load-pathname* old-load-pathname)))) (set! slib:load-source @@ -85,11 +82,11 @@ (slib:pathnameize-load slib:load)) ;;;; MODULES - +;@ (define *catalog* #f) -(define *modules* '()) - -(define (require:version path) +(define *base-table-implementations* '()) +;@ +(define (slib:version path) (let ((expr (and (file-exists? path) (call-with-input-file path (lambda (port) (read port)))))) (and (list? expr) (= 3 (length expr)) @@ -100,7 +97,7 @@ (let* ((apair (assq '*SLIB-VERSION* slibcat)) (req (in-vicinity (library-vicinity) (string-append "require" (scheme-file-suffix)))) - (reqvers (require:version req))) + (reqvers (slib:version req))) (cond ((not (file-exists? req)) (slib:warn "can't find " req) #f) ((not apair) #f) @@ -121,6 +118,21 @@ ((eof-object? expr) (apply append lst)))))))) '())) +;@ +(define (catalog:resolve vicinity catlist) + (define (res1 e) (if (string? e) (in-vicinity vicinity e) e)) + (define (resolve p) + (cond ((symbol? (cdr p)) p) + ((not (list? p)) (cons (car p) (res1 (cdr p)))) + ((null? (cddr p)) (cons (car p) (res1 (cadr p)))) + (else (map res1 p)))) + (map resolve catlist)) +;@ +(define (catalog:read vicinity cat) + (catalog:get #f) ; make sure *catalog* exists + (set! *catalog* + (append (catalog:resolve vicinity (catalog:try-read vicinity cat)) + *catalog*))) (define (catalog:get feature) (if (not *catalog*) @@ -139,124 +151,136 @@ (set! *catalog* (append (catalog:try-read (user-vicinity) "usercat") *catalog*)))) (and feature *catalog* (cdr (or (assq feature *catalog*) '(#f . #f))))) +;@ +(define (slib:in-catalog? feature) + (let ((path (catalog:get feature))) + (if (symbol? path) (slib:in-catalog? path) path))) -(define (require:provided? feature) - (if (symbol? feature) - (if (memq feature *features*) #t - (and *catalog* - (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) - (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 (catalog:get feature))) - (cond ((and (not path) (string? feature) (file-exists? feature)) - (set! path feature))) - (cond ((not feature) (set! *catalog* #f)) - ((not path) - (slib:error ";required feature not supported: " feature)) - ((symbol? path) (require:require path) (require:provide feature)) - ((not (pair? path)) ;simple name - (slib:load path) - (and (not (eq? 'new-catalog feature)) (require:provide feature))) - (else ;special loads - (require:require (car path)) - (apply (case (car path) - ((macro) macro:load) - ((syntactic-closures) synclo:load) - ((syntax-case) syncase:load) - ((macros-that-work) macwork:load) - ((macro-by-example) defmacro:load) - ((defmacro) defmacro:load) - ((source) slib:load-source) - ((compiled) slib:load-compiled) - (else (slib:error "unknown package loader" path))) - (if (list? path) (cdr path) (list (cdr path)))) - (require:provide feature)))))) - -(define (require:provide feature) - (if (symbol? feature) - (if (not (memq feature *features*)) - (set! *features* (cons feature *features*))) - (if (not (member feature *modules*)) - (set! *modules* (cons feature *modules*))))) - -(require:provide 'vicinity) +;@ +(define (feature-eval expression provided?) + (define (bail expression) + (slib:error 'invalid 'feature 'expression expression)) + (define (feval expression) + (cond ((not expression) expression) + ((symbol? expression) (provided? expression)) + ((and (list? expression) (pair? expression)) + (case (car expression) + ((not) (case (length expression) + ((2) (not (feval (cadr expression)))) + (else (bail expression)))) + ((or) (case (length expression) + ((1) #f) + ;;((2) (feval (cadr expression))) + (else (or (feval (cadr expression)) + (feval (cons 'or (cddr expression))))))) + ((and) (case (length expression) + ((1) #t) + ;;((2) (feval (cadr expression))) + (else (and (feval (cadr expression)) + (feval (cons 'and (cddr expression))))))) + (else (bail expression)))) + (else (bail expression)))) + (feval expression)) +;@ +(define (provided? expression) + (define feature-list (cons (software-type) *features*)) + (define (provided? expression) + (if (memq expression feature-list) #t + (and *catalog* + (let ((path (catalog:get expression))) + (cond ((symbol? path) (provided? path)) + (else #f)))))) + (feature-eval expression provided?)) +;@ +(define (require feature) + (cond + ((not feature) (set! *catalog* #f)) + ((slib:provided? feature)) + (else + (let ((path (catalog:get feature))) + (cond ((not path) + (slib:error 'slib:require 'unsupported 'feature feature)) + ((symbol? path) (slib:provide feature) (slib:require path)) + ((string? path) ;simple name + (and (not (eq? 'new-catalog feature)) (slib:provide feature)) + (slib:load path)) + (else ;dispatched loads + (slib:provide feature) + (slib:require (car path)) + (apply (case (car path) + ((macro) macro:load) + ((syntactic-closures) synclo:load) + ((syntax-case) syncase:load) + ((macros-that-work) macwork:load) + ((macro-by-example) defmacro:load) + ((defmacro) defmacro:load) + ((source) slib:load-source) + ((compiled) slib:load-compiled) + ((aggregate) + (lambda feature (for-each slib:require feature))) + ((spectral-tristimulus-values) load-ciexyz) + ((color-names) + (lambda (filename) + (load-color-dictionary feature filename))) + (else (slib:error "unknown package loader" path))) + (if (list? path) (cdr path) (list (cdr path)))))))))) +;@ +(define (require-if feature? feature) + (if (slib:provided? feature?) (slib:require feature))) +;@ +(define (provide feature) + (if (not (memq feature *features*)) + (set! *features* (cons feature *features*)))) -(define provide require:provide) -(define provided? require:provided?) -(define require require:require) +;@ +(define slib:provide provide) +(define slib:provided? provided?) +(define slib:require require) +(define slib:require-if require-if) +;;; Legacy +(define require:provide provide) +(define require:provided? provided?) +(define require:require require) +(slib:provide 'vicinity) (if (and (string->number "0.0") (inexact? (string->number "0.0"))) - (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)) + (slib:provide 'inexact)) +(if (rational? (string->number "1/19")) (slib:provide 'rational)) +(if (real? (string->number "0.0")) (slib:provide 'real)) +(if (complex? (string->number "1+i")) (slib:provide 'complex)) (let ((n (string->number "9999999999999999999999999999999"))) - (if (and n (exact? n)) (require:provide 'bignum))) + (if (and n (exact? n)) (slib:provide 'bignum))) (cond - ((provided? 'srfi) - (cond-expand (srfi-0 (provide 'srfi-0)) (else #f)) - (cond-expand (srfi-1 (provide 'srfi-1)) (else #f)) - (cond-expand (srfi-2 (provide 'srfi-2)) (else #f)) - (cond-expand (srfi-3 (provide 'srfi-3)) (else #f)) - (cond-expand (srfi-4 (provide 'srfi-4)) (else #f)) - (cond-expand (srfi-5 (provide 'srfi-5)) (else #f)) - (cond-expand (srfi-6 (provide 'srfi-6)) (else #f)) - (cond-expand (srfi-7 (provide 'srfi-7)) (else #f)) - (cond-expand (srfi-8 (provide 'srfi-8)) (else #f)) - (cond-expand (srfi-9 (provide 'srfi-9)) (else #f)) - (cond-expand (srfi-10 (provide 'srfi-10)) (else #f)) - (cond-expand (srfi-11 (provide 'srfi-11)) (else #f)) - (cond-expand (srfi-12 (provide 'srfi-12)) (else #f)) - (cond-expand (srfi-13 (provide 'srfi-13)) (else #f)) - (cond-expand (srfi-14 (provide 'srfi-14)) (else #f)) - (cond-expand (srfi-15 (provide 'srfi-15)) (else #f)) - (cond-expand (srfi-16 (provide 'srfi-16)) (else #f)) - (cond-expand (srfi-17 (provide 'srfi-17)) (else #f)) - (cond-expand (srfi-18 (provide 'srfi-18)) (else #f)) - (cond-expand (srfi-19 (provide 'srfi-19)) (else #f)) - (cond-expand (srfi-20 (provide 'srfi-20)) (else #f)) - (cond-expand (srfi-21 (provide 'srfi-21)) (else #f)) - (cond-expand (srfi-22 (provide 'srfi-22)) (else #f)) - (cond-expand (srfi-23 (provide 'srfi-23)) (else #f)) - (cond-expand (srfi-24 (provide 'srfi-24)) (else #f)) - (cond-expand (srfi-25 (provide 'srfi-25)) (else #f)) - (cond-expand (srfi-26 (provide 'srfi-26)) (else #f)) - (cond-expand (srfi-27 (provide 'srfi-27)) (else #f)) - (cond-expand (srfi-28 (provide 'srfi-28)) (else #f)) - (cond-expand (srfi-29 (provide 'srfi-29)) (else #f)) - (cond-expand (srfi-30 (provide 'srfi-30)) (else #f)))) + ((slib:provided? 'srfi) + (do ((idx 0 (+ 1 idx)) + (srfis (symbol->string 'srfi-))) + ((> idx 100)) + (let ((srfi (string->symbol (string-append srfis (number->string idx))))) + (if (slib:eval `(cond-expand (,srfi #t) (else #f))) + (slib:provide srfi)))))) (define report:print (lambda args (for-each (lambda (x) (write x) (display #\ )) args) (newline))) +;@ (define slib:report (let ((slib:report (lambda () (slib:report-version) (slib:report-locations)))) (lambda args (cond ((null? args) (slib:report)) ((not (string? (car args))) (slib:report-version) (slib:report-locations #t)) - ((require:provided? 'transcript) + ((slib:provided? 'transcript) (transcript-on (car args)) (slib:report) (transcript-off)) - ((require:provided? 'with-file) + ((slib:provided? 'with-file) (with-output-to-file (car args) slib:report)) (else (slib:report)))))) +;@ (define slib:report-version (lambda () (report:print @@ -266,13 +290,13 @@ (define slib:report-locations (let ((features *features*)) (lambda args + (define sit (scheme-implementation-type)) + (define siv (string->symbol (scheme-implementation-version))) (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity)) (report:print '(LIBRARY-VICINITY) 'is (library-vicinity)) (report:print '(SCHEME-FILE-SUFFIX) 'is (scheme-file-suffix)) (cond (*load-pathname* (report:print '*LOAD-PATHNAME* 'is *load-pathname*))) - (cond ((not (null? *modules*)) - (report:print 'Loaded '*MODULES* 'are: *modules*))) (let* ((i (+ -1 5))) (cond ((eq? (car features) (car *features*))) (else (report:print 'loaded '*FEATURES* ':) (display slib:tab))) @@ -280,14 +304,14 @@ (lambda (x) (cond ((eq? (car features) x) (if (not (eq? (car features) (car *features*))) (newline)) - (report:print 'Implementation '*FEATURES* ':) + (report:print sit siv '*FEATURES* ':) (display slib:tab) (set! i (+ -1 5))) ((zero? i) (newline) (display slib:tab) (set! i (+ -1 5))) ((not (= (+ -1 5) i)) (display #\ ))) (write x) (set! i (+ -1 i))) *features*)) (newline) - (report:print 'Implementation '*CATALOG* ':) + (report:print sit siv '*CATALOG* ':) (catalog:get #f) (cond ((pair? args) (for-each (lambda (x) (display slib:tab) (report:print x)) @@ -296,9 +320,9 @@ (display slib:tab) (report:print '...))) (newline)))) -(let ((sit (scheme-implementation-version))) - (cond ((zero? (string-length sit))) - ((or (not (string? sit)) (char=? #\? (string-ref sit 0))) +(let ((siv (scheme-implementation-version))) + (cond ((zero? (string-length siv))) + ((or (not (string? siv)) (char=? #\? (string-ref siv 0))) (newline) (slib:report-version) (report:print 'edit (scheme-implementation-type) ".init" |