1;;;; Implementation of VICINITY and MODULES for Scheme 2;Copyright (C) 1991, 1992, 1993, 1994, 1997, 2002, 2003, 2005 Aubrey Jaffer 3; 4;Permission to copy this software, to modify it, to redistribute it, 5;to distribute modified versions, and to use it for any purpose is 6;granted, subject to the following restrictions and understandings. 7; 8;1. Any copy made of this software must include this copyright notice 9;in full. 10; 11;2. I have made no warranty or representation that the operation of 12;this software will be error-free, and I am under no obligation to 13;provide any services, by way of maintenance, update, or otherwise. 14; 15;3. In conjunction with products arising from the use of this 16;material, there shall be no use of my name in any advertising, 17;promotional, or sales literature without prior written consent in 18;each case. 19;@ 20(define *slib-version* "3b6") 21 22;;;; MODULES 23;@ 24(define *catalog* #f) 25(define *base-table-implementations* '()) 26;@ 27(define (slib:version path) 28 (let ((expr (and (file-exists? path) 29 (call-with-input-file path (lambda (port) (read port)))))) 30 (and (list? expr) (= 3 (length expr)) 31 (eq? (car expr) 'define) (eq? (cadr expr) '*slib-version*) 32 (string? (caddr expr)) (caddr expr)))) 33 34(define (catalog/require-version-match? slibcat) 35 (let* ((apair (assq '*slib-version* slibcat)) 36 (req (in-vicinity (library-vicinity) 37 (string-append "require" (scheme-file-suffix)))) 38 (reqvers (slib:version req))) 39 (cond ((not (file-exists? req)) 40 (slib:warn "can't find " req) #f) 41 ((not apair) #f) 42 ((not (equal? reqvers (cdr apair))) #f) 43 ((not (equal? reqvers *slib-version*)) 44 (slib:warn "The loaded " req " is stale.") 45 #t) 46 (else #t)))) 47 48(define (catalog:try-read vicinity name) 49 (or (and vicinity name 50 (let ((path (in-vicinity vicinity name))) 51 (and (file-exists? path) 52 (call-with-input-file path 53 (lambda (port) 54 (do ((expr (read port) (read port)) 55 (lst '() (cons expr lst))) 56 ((eof-object? expr) 57 (apply append lst)))))))) 58 '())) 59;@ 60(define (catalog:resolve vicinity catlist) 61 (define (res1 e) (if (string? e) (in-vicinity vicinity e) e)) 62 (define (resolve p) 63 (cond ((symbol? (cdr p)) p) 64 ((not (list? p)) (cons (car p) (res1 (cdr p)))) 65 ((null? (cddr p)) (cons (car p) (res1 (cadr p)))) 66 (else (map res1 p)))) 67 (map resolve catlist)) 68;@ 69(define (catalog:read vicinity cat) 70 (catalog:get #f) ; make sure *catalog* exists 71 (set! *catalog* 72 (append (catalog:resolve vicinity (catalog:try-read vicinity cat)) 73 *catalog*))) 74 75(define (catalog:get feature) 76 (if (not *catalog*) 77 (let ((slibcat (catalog:try-read (implementation-vicinity) "slibcat"))) 78 (cond ((not (catalog/require-version-match? slibcat)) 79 (slib:load-source (in-vicinity (library-vicinity) "mklibcat")) 80 (set! slibcat 81 (catalog:try-read (implementation-vicinity) "slibcat")))) 82 (cond (slibcat 83 (set! *catalog* ((slib:eval 84 (cadr (or (assq 'catalog:filter slibcat) 85 '(#f identity)))) 86 slibcat)))) 87 (and (home-vicinity) 88 (set! *catalog* 89 (append (catalog:try-read (home-vicinity) "homecat") 90 *catalog*))) 91 (set! *catalog* 92 (append (catalog:try-read (user-vicinity) "usercat") *catalog*)))) 93 (and feature *catalog* (cdr (or (assq feature *catalog*) '(#f . #f))))) 94;@ 95(define (slib:in-catalog? feature) 96 (let ((path (catalog:get feature))) 97 (if (symbol? path) (slib:in-catalog? path) path))) 98 99;@ 100(define (feature-eval expression provided?) 101 (define (bail expression) 102 (slib:error 'invalid 'feature 'expression expression)) 103 (define (feval expression) 104 (cond ((not expression) expression) 105 ((symbol? expression) (provided? expression)) 106 ((and (list? expression) (pair? expression)) 107 (case (car expression) 108 ((not) (case (length expression) 109 ((2) (not (feval (cadr expression)))) 110 (else (bail expression)))) 111 ((or) (case (length expression) 112 ((1) #f) 113 ;;((2) (feval (cadr expression))) 114 (else (or (feval (cadr expression)) 115 (feval (cons 'or (cddr expression))))))) 116 ((and) (case (length expression) 117 ((1) #t) 118 ;;((2) (feval (cadr expression))) 119 (else (and (feval (cadr expression)) 120 (feval (cons 'and (cddr expression))))))) 121 (else (bail expression)))) 122 (else (bail expression)))) 123 (feval expression)) 124;@ 125(define (slib:provided? expression) 126 (define feature-list (cons (scheme-implementation-type) 127 (cons (software-type) slib:features))) 128 (define (provided? expression) 129 (if (memq expression feature-list) #t 130 (and *catalog* 131 (let ((path (catalog:get expression))) 132 (cond ((symbol? path) (provided? path)) 133 (else #f)))))) 134 (feature-eval expression provided?)) 135;@ 136(define (slib:provide feature) 137 (if (not (memq feature slib:features)) 138 (set! slib:features (cons feature slib:features)))) 139;@ 140(define (slib:require feature) 141 (cond 142 ((not feature) (set! *catalog* #f)) 143 ((slib:provided? feature)) 144 (else 145 (let ((path (catalog:get feature))) 146 (cond ((not path) 147 (slib:error 'slib:require 'unsupported 'feature feature)) 148 ((symbol? path) (slib:provide feature) (slib:require path)) 149 ((string? path) ;simple name 150 (if (not (eq? 'new-catalog feature)) (slib:provide feature)) 151 (slib:load path)) 152 (else ;dispatched loads 153 (slib:require (car path)) 154 (if (not (eq? 'new-catalog feature)) (slib:provide feature)) 155 (apply (case (car path) 156 ((macro) macro:load) 157 ((syntactic-closures) synclo:load) 158 ((syntax-case) syncase:load) 159 ((macros-that-work) macwork:load) 160 ((macro-by-example) defmacro:load) 161 ((defmacro) defmacro:load) 162 ((source) slib:load-source) 163 ((compiled) slib:load-compiled) 164 ((aggregate) 165 (lambda feature (for-each slib:require feature))) 166 ((spectral-tristimulus-values) load-ciexyz) 167 ((color-names) 168 (lambda (filename) 169 (load-color-dictionary feature filename))) 170 (else (slib:error "unknown package loader" path))) 171 (if (list? path) (cdr path) (list (cdr path)))))))))) 172;@ 173(define (slib:require-if feature? feature) 174 (if (slib:provided? feature?) (slib:require feature))) 175 176;@ 177(define provide slib:provide) 178(define provided? slib:provided?) 179(define require slib:require) 180(define require-if slib:require-if) 181 182(let ((x (string->number "0.0"))) 183 (if (and x (inexact? x)) (slib:provide 'inexact))) 184(if (rational? (string->number "1/19")) (slib:provide 'rational)) 185(let ((x (string->number "0.01"))) 186 (if (and (real? x) (not (integer? x))) (slib:provide 'real))) 187(let ((z (string->number "0.01+i"))) 188 (if (and (complex? z) (not (real? z))) (slib:provide 'complex))) 189(let ((n (string->number "9999999999999999999999999999999"))) 190 (if (and n (exact? n)) (slib:provide 'bignum))) 191 192(cond 193 ((slib:provided? 'srfi-0) 194 (slib:provide 'srfi-59) 195 (slib:provide 'srfi-96) 196 (do ((idx 0 (+ 1 idx)) 197 (srfis (symbol->string 'srfi-))) 198 ((> idx 150)) 199 (let ((srfi (string->symbol (string-append srfis (number->string idx))))) 200 (if (slib:eval `(cond-expand (,srfi #t) (else #f))) 201 (slib:provide srfi)))))) 202 203(define (slib:pathnameize-load *old-load*) 204 (lambda (<pathname> . extra) 205 (with-load-pathname <pathname> 206 (lambda () 207 (apply *old-load* (cons <pathname> extra)))))) 208 209(set! slib:load-source 210 (slib:pathnameize-load slib:load-source)) 211(set! slib:load 212 (slib:pathnameize-load slib:load)) 213 214;@ 215(define (slib:eval-load <pathname> evl) 216 (if (not (file-exists? <pathname>)) 217 (set! <pathname> (string-append <pathname> (scheme-file-suffix)))) 218 (call-with-input-file <pathname> 219 (lambda (port) 220 (with-load-pathname <pathname> 221 (lambda () 222 (do ((o (read port) (read port))) 223 ((eof-object? o)) 224 (evl o))))))) 225 226(define (report:print . args) 227 (for-each (lambda (x) (write x) (display #\space)) args) 228 (newline)) 229;@ 230(define (slib:report . args) 231 (define rpt (lambda () (slib:report-version) (slib:report-locations #t))) 232 (cond ((null? args) 233 (slib:report-version) (slib:report-locations)) 234 ((not (string? (car args))) 235 (rpt)) 236 ((slib:provided? 'transcript) 237 (transcript-on (car args)) 238 (rpt) 239 (transcript-off)) 240 ((slib:provided? 'with-file) 241 (with-output-to-file (car args) rpt)) 242 (else (rpt)))) 243 244;@ 245(define (slib:report-version) 246 (report:print 247 'SLIB *slib-version* 'on (scheme-implementation-type) 248 (scheme-implementation-version) 'on (software-type))) 249 250(define slib:report-locations 251 (let ((lfeatures slib:features)) ; Capture load-time value 252 (lambda args 253 (define sit (scheme-implementation-type)) 254 (define siv (string->symbol (scheme-implementation-version))) 255 (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity)) 256 (report:print '(LIBRARY-VICINITY) 'is (library-vicinity)) 257 (report:print '(SCHEME-FILE-SUFFIX) 'is (scheme-file-suffix)) 258 (let* ((i (+ -1 5))) 259 (cond ((eq? (car lfeatures) (car slib:features))) 260 (else (report:print 'loaded 'SLIB:FEATURES ':) (display slib:tab))) 261 (for-each 262 (lambda (x) 263 (cond ((eq? (car lfeatures) x) 264 (if (not (eq? (car lfeatures) (car slib:features))) (newline)) 265 (report:print sit siv 'SLIB:FEATURES ':) 266 (display slib:tab) (set! i (+ -1 5))) 267 ((zero? i) (newline) (display slib:tab) (set! i (+ -1 5))) 268 ((not (= (+ -1 5) i)) (display #\space))) 269 (write x) (set! i (+ -1 i))) 270 slib:features)) 271 (newline) 272 (report:print sit siv '*CATALOG* ':) 273 (catalog:get #f) 274 (cond ((pair? args) 275 (for-each (lambda (x) (display slib:tab) (report:print x)) 276 *catalog*)) 277 (else (display slib:tab) (report:print (car *catalog*)) 278 (display slib:tab) (report:print '...))) 279 (newline)))) 280 281(let ((siv (scheme-implementation-version))) 282 (cond ((zero? (string-length siv))) 283 ((or (not (string? siv)) (char=? #\? (string-ref siv 0))) 284 (newline) 285 (slib:report-version) 286 (report:print 'edit (scheme-implementation-type) ".init" 287 'to 'set '(scheme-implementation-version) 'string) 288 (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity)) 289 (report:print 'type '(slib:report) 'for 'configuration) 290 (newline)))) 291