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