summaryrefslogtreecommitdiffstats
path: root/require.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /require.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'require.scm')
-rw-r--r--require.scm280
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"