diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
commit | 8ffbc2df0fde83082610149d24e594c1cd879f4a (patch) | |
tree | a2be9aad5101c5e450ad141d15c514bc9c2a2963 /require.scm | |
download | slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip |
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'require.scm')
-rw-r--r-- | require.scm | 348 |
1 files changed, 348 insertions, 0 deletions
diff --git a/require.scm b/require.scm new file mode 100644 index 0000000..d1ebe9a --- /dev/null +++ b/require.scm @@ -0,0 +1,348 @@ +;;;; Implementation of VICINITY and MODULES for Scheme +;Copyright (C) 1991, 1992, 1993, 1994 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 +;understandings. +; +;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 +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;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* "2a6") + +;;; Standardize msdos -> ms-dos. +(define software-type + (cond ((eq? 'msdos (software-type)) + (lambda () 'ms-dos)) + (else software-type))) + +(define (user-vicinity) + (case (software-type) + ((VMS) "[.]") + (else ""))) + +(define program-vicinity + (let ((*vicinity-suffix* + (case (software-type) + ((AMIGA) '(#\: #\/)) + ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) + ((MACOS THINKC) '(#\:)) + ((NOSVE) '(#\: #\.)) + ((UNIX COHERENT) '(#\/)) + ((VMS) '(#\: #\]))))) + (lambda () + (let loop ((i (- (string-length *load-pathname*) 1))) + (cond ((negative? i) "") + ((memv (string-ref *load-pathname* i) *vicinity-suffix*) + (substring *load-pathname* 0 (+ i 1))) + (else (loop (- i 1)))))))) + +(define sub-vicinity + (case (software-type) + ((VMS) + (lambda + (vic name) + (let ((l (string-length vic))) + (if (or (zero? (string-length vic)) + (not (char=? #\] (string-ref vic (- l 1))))) + (string-append vic "[" name "]") + (string-append (substring vic 0 (- l 1)) + "." name "]"))))) + (else + (let ((*vicinity-suffix* + (case (software-type) + ((NOSVE) ".") + ((UNIX COHERENT AMIGA) "/") + ((MACOS THINKC) ":") + ((MS-DOS WINDOWS ATARIST OS/2) "\\")))) + (lambda (vic name) + (string-append vic name *vicinity-suffix*)))))) + +(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*)) + (set! *load-pathname* <pathname>) + (apply *old-load* (cons <pathname> extra)) + (require:provide <pathname>) + (set! *load-pathname* old-load-pathname)))) + +(set! slib:load-source + (slib:pathnameize-load slib:load-source)) +(set! slib:load + (slib:pathnameize-load slib:load)) + +;;;; MODULES + +(define *modules* '()) + +(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)) + ((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)) + +(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) + (slib:error ";required feature not supported: " feature)) + ((not (pair? path)) ;simple name + (slib:load path) + (require:provide feature)) + (else ;special loads + (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)) + (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 provide require:provide) +(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)) +(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 +)) + +(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) + (transcript-on (car args)) + (slib:report) + (transcript-off)) + ((require:provided? 'with-file) + (with-output-to-file (car args) slib:report)) + (else (slib:report)))))) + +(define slib:report-version + (lambda () + (report:print + 'SLIB *SLIB-VERSION* 'on (scheme-implementation-type) + (scheme-implementation-version) 'on (software-type)))) + +(define slib:report-locations + (let ((features *features*) (catalog *catalog*)) + (lambda args + (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))) + (for-each + (lambda (x) + (cond ((eq? (car features) x) + (if (not (eq? (car features) (car *features*))) (newline)) + (report:print 'Implementation '*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) + (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 '...)))) + (newline)))) + +(let ((sit (scheme-implementation-version))) + (cond ((zero? (string-length sit))) + ((or (not (string? sit)) (char=? #\? (string-ref sit 0))) + (newline) + (slib:report-version) + (report:print 'edit (scheme-implementation-type) ".init" + 'to 'set '(scheme-implementation-version) 'string) + (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity)) + (report:print 'type '(slib:report) 'for 'configuration) + (newline)))) |