Commit | Line | Data |
---|---|---|
9ddacf86 KN |
1 | ;;; "vscm.init" Configuration of *features* for VSCM -*-scheme-*- |
2 | ;;; Author: Aubrey Jaffer | |
3 | ;;; | |
4 | ;;; This code is in the public domain. | |
5 | ||
6 | ;;; From: Matthias Blume <blume@cs.Princeton.EDU> | |
7 | ;;; Date: Tue, 1 Mar 1994 11:42:31 -0500 | |
8 | ;;; Disclaimer: The code below is only a quick hack. If I find some | |
9 | ;;; time to spare I might get around to make some more things work. | |
10 | ||
11 | ;;; You have to provide ``vscm.init'' as an explicit command line | |
12 | ;;; argument. Since this is not very nice I would recommend the | |
13 | ;;; following installation procedure: | |
14 | ||
15 | ;1. run scheme | |
16 | ;2. (load "vscm.init") | |
17 | ;3. (slib:dump "dumpfile") | |
18 | ;3. mv dumpfile place-where-vscm-standard-bootfile-resides, e.g. | |
19 | ; mv dumpfile /usr/local/vscm/lib/scheme-boot | |
20 | ; (In this case vscm should have been compiled with flag | |
21 | ; -DDEFAULT_BOOTFILE='"/usr/local/vscm/lib/scheme-boot"'. See | |
22 | ; Makefile (definition of DDP) for details.) | |
23 | ||
24 | (define (slib:dump dump-to-file) | |
25 | (let ((args (dump dump-to-file))) | |
26 | (if args | |
27 | (begin | |
28 | (display "[SLIB available]") | |
29 | (newline) | |
30 | (((mcm) 'toplevel) args)) | |
31 | (quit)))) | |
32 | ||
33 | ;;; Caveat: While playing with this code I discovered a nasty bug. | |
34 | ;;; (Something is wrong with my ``restore'' code -- it seems to break | |
35 | ;;; on 64 bit machines (not always, though).) It works on MIPS, etc. | |
36 | ||
37 | ;;; (software-type) should be set to the generic operating system type. | |
38 | ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. | |
39 | ||
40 | (define (software-type) 'UNIX) | |
41 | ||
42 | ;;; (scheme-implementation-type) should return the name of the scheme | |
43 | ;;; implementation loading this file. | |
44 | ||
45 | (define (scheme-implementation-type) 'Vscm) | |
46 | ||
47 | ;;; (scheme-implementation-home-page) should return a (string) URI | |
48 | ;;; (Uniform Resource Identifier) for this scheme implementation's home | |
49 | ;;; page; or false if there isn't one. | |
50 | ||
51 | (define (scheme-implementation-home-page) | |
52 | "http://www.cs.princeton.edu/~blume/vscm/vscm.html") | |
53 | ||
54 | ;;; (scheme-implementation-version) should return a string describing the | |
55 | ;;; version the scheme implementation loading this file. | |
56 | ||
57 | (define (scheme-implementation-version) "?") | |
58 | ||
59 | ;;; (implementation-vicinity) should be defined to be the pathname of | |
60 | ;;; the directory where any auxillary files to your Scheme | |
61 | ;;; implementation reside. | |
62 | ||
63 | (define (implementation-vicinity) | |
64 | (case (software-type) | |
65 | ((UNIX) "/usr/local/src/scheme/") | |
66 | ((VMS) "scheme$src:") | |
67 | ((MS-DOS) "C:\\scheme\\"))) | |
68 | ||
69 | ;;; (library-vicinity) should be defined to be the pathname of the | |
70 | ;;; directory where files of Scheme library functions reside. | |
71 | ||
72 | (define library-vicinity | |
73 | (let ((library-path | |
74 | (or (getenv "SCHEME_LIBRARY_PATH") | |
75 | ;; Uses this path if SCHEME_LIBRARY_PATH is not set. | |
76 | (case (software-type) | |
77 | ((UNIX) "/usr/local/lib/slib/") | |
78 | ((VMS) "lib$scheme:") | |
79 | ((MS-DOS) "C:\\SLIB\\") | |
80 | (else ""))))) | |
81 | (lambda () library-path))) | |
82 | ||
83 | ;;; (home-vicinity) should return the vicinity of the user's HOME | |
84 | ;;; directory, the directory which typically contains files which | |
85 | ;;; customize a computer environment for a user. | |
86 | ||
87 | (define home-vicinity | |
88 | (let ((home-path (getenv "HOME"))) | |
89 | (lambda () home-path))) | |
90 | ||
91 | ;;; *FEATURES* should be set to a list of symbols describing features | |
92 | ;;; of this implementation. Suggestions for features are: | |
93 | ||
94 | (define *features* | |
95 | '( | |
96 | source ;can load scheme source files | |
97 | ;(slib:load-source "filename") | |
98 | ; compiled ;can load compiled files | |
99 | ;(slib:load-compiled "filename") | |
100 | rev4-report ;conforms to | |
101 | ; rev3-report ;conforms to | |
102 | ieee-p1178 ;conforms to | |
103 | ; sicp ;runs code from Structure and | |
104 | ;Interpretation of Computer | |
105 | ;Programs by Abelson and Sussman. | |
106 | rev4-optional-procedures ;LIST-TAIL, STRING->LIST, | |
107 | ;LIST->STRING, STRING-COPY, | |
108 | ;STRING-FILL!, LIST->VECTOR, | |
109 | ;VECTOR->LIST, and VECTOR-FILL! | |
110 | rev3-procedures ;LAST-PAIR, T, and NIL | |
111 | ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, | |
112 | ;SUBSTRING-MOVE-RIGHT!, | |
113 | ;SUBSTRING-FILL!, | |
114 | ;STRING-NULL?, APPEND!, 1+, | |
115 | ;-1+, <?, <=?, =?, >?, >=? | |
116 | multiarg/and- ;/ and - can take more than 2 args. | |
117 | multiarg-apply ;APPLY can take more than 2 args. | |
118 | rationalize | |
119 | delay ;has DELAY and FORCE | |
120 | with-file ;has WITH-INPUT-FROM-FILE and | |
121 | ;WITH-OUTPUT-FROM-FILE | |
122 | string-port ;has CALL-WITH-INPUT-STRING and | |
123 | ;CALL-WITH-OUTPUT-STRING | |
124 | ; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF | |
125 | ; char-ready? | |
126 | ; macro ;has R4RS high level macros | |
127 | defmacro ;has Common Lisp DEFMACRO | |
128 | ; eval ;proposed 2-argument eval | |
129 | ; record ;has user defined data structures | |
130 | values ;proposed multiple values | |
131 | ; dynamic-wind ;proposed dynamic-wind | |
132 | ieee-floating-point ;conforms to | |
133 | full-continuation ;can return multiple times | |
134 | ; object-hash ;has OBJECT-HASH | |
135 | ||
136 | ; sort | |
137 | ; queue ;queues | |
138 | ; pretty-print | |
139 | object->string | |
140 | ; format | |
141 | ; trace ;has macros: TRACE and UNTRACE | |
142 | ; compiler ;has (COMPILER) | |
143 | ; ed ;(ED) is editor | |
144 | system ;posix (system <string>) | |
145 | getenv ;posix (getenv <string>) | |
146 | program-arguments ;returns list of strings (argv) | |
147 | ; Xwindows ;X support | |
148 | ; curses ;screen management package | |
149 | ; termcap ;terminal description package | |
150 | ; terminfo ;sysV terminal description | |
151 | )) | |
152 | ||
153 | ;;; (OBJECT->STRING obj) -- analogous to WRITE | |
154 | (define object->string string-write) | |
155 | ||
156 | ;;; (PROGRAM-ARGUMENTS) | |
157 | ;;; | |
158 | (define (program-arguments) command-line-arguments) | |
159 | ||
160 | ;;; (OUTPUT-PORT-WIDTH <port>) | |
161 | (define (output-port-width . arg) 79) | |
162 | ||
163 | ;;; (CURRENT-ERROR-PORT) | |
164 | (define (current-error-port) | |
165 | (standard-port 2)) | |
166 | ||
167 | ;;; (TMPNAM) makes a temporary file name. | |
168 | (define tmpnam (let ((cntr 100)) | |
169 | (lambda () (set! cntr (+ 1 cntr)) | |
170 | (string-append "slib_" (number->string cntr))))) | |
171 | ||
172 | ;;; (FILE-EXISTS? <string>) | |
173 | (define (file-exists? f) | |
174 | (system (string-append "test -f " f))) | |
175 | ||
176 | ;;; (DELETE-FILE <string>) | |
177 | (define (delete-file f) | |
178 | (remove-file f)) | |
179 | ||
180 | ;;; FORCE-OUTPUT flushes any pending output on optional arg output port | |
181 | (define force-output flush) | |
182 | ||
183 | ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string | |
184 | ;;; port versions of CALL-WITH-*PUT-FILE. | |
185 | ||
186 | (define (call-with-output-string proc) | |
187 | (let ((outsp (open-output-string))) | |
188 | (proc outsp) | |
189 | (close-output-port outsp))) | |
190 | ||
191 | (define (call-with-input-string string proc) | |
192 | (let* ((insp (open-input-string string)) | |
193 | (res (proc insp))) | |
194 | (close-input-port insp) | |
195 | res)) | |
196 | ||
197 | ;;; Implementation of string ports using generic ports | |
198 | (define (open-input-string s) | |
199 | ||
200 | (let ((l (string-length s)) | |
201 | (eof (call-with-values (lambda () (string-read "")) (lambda (x y) x)))) | |
202 | ||
203 | (define (read) | |
204 | (call-with-values | |
205 | (lambda () | |
206 | (string-read s)) | |
207 | (lambda (obj res) | |
208 | (set! s res) | |
209 | (set! l (string-length res)) | |
210 | obj))) | |
211 | ||
212 | (define (read-char) | |
213 | (if (zero? l) | |
214 | eof | |
215 | (let ((c (string-ref s 0))) | |
216 | (set! s (substring s 1 l)) | |
217 | (set! l (- l 1)) | |
218 | c))) | |
219 | ||
220 | (define (peek-char) | |
221 | (if (zero? l) eof (string-ref s 0))) | |
222 | ||
223 | (define (char-ready?) #t) | |
224 | ||
225 | (define (close) s) | |
226 | ||
227 | (open-input-generic read read-char peek-char char-ready? close))) | |
228 | ||
229 | (define (open-output-string) | |
230 | ||
231 | (let ((s "")) | |
232 | ||
233 | (define (write x) | |
234 | (set! s (string-append s (string-write x))) | |
235 | x) | |
236 | ||
237 | (define (display x) | |
238 | (set! s (string-append s (string-display x))) | |
239 | x) | |
240 | ||
241 | (define (write-char x) | |
242 | (set! s (string-append s (string x))) | |
243 | x) | |
244 | ||
245 | (define (newline) | |
246 | (set! s (string-append s "\n")) | |
247 | #f) | |
248 | ||
249 | (define (flush) #f) | |
250 | ||
251 | (define (close) s) | |
252 | ||
253 | (open-output-generic write display write-char newline flush close))) | |
254 | ||
255 | ;;; "rationalize" adjunct procedures. | |
256 | (define (find-ratio x e) | |
257 | (let ((rat (rationalize x e))) | |
258 | (list (numerator rat) (denominator rat)))) | |
259 | (define (find-ratio-between x y) | |
260 | (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) | |
261 | ||
262 | ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can | |
263 | ;;; be returned by CHAR->INTEGER. | |
264 | (define char-code-limit 256) | |
265 | ||
266 | ;;; MOST-POSITIVE-FIXNUM is used in modular.scm | |
267 | (define most-positive-fixnum #x0fffffff) | |
268 | ||
269 | ;;; Return argument | |
270 | (define (identity x) x) | |
271 | ||
272 | ;;; SLIB:EVAL is single argument eval using the top-level (user) environment. | |
273 | (define slib:eval eval) | |
274 | ||
275 | ;;; If your implementation provides R4RS macros: | |
276 | (define macro:eval slib:eval) | |
277 | (define macro:load load) | |
278 | ||
279 | (define *defmacros* | |
280 | (list (cons 'defmacro | |
281 | (lambda (name parms . body) | |
282 | `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) | |
283 | *defmacros*)))))) | |
284 | (define (defmacro? m) (and (assq m *defmacros*) #t)) | |
285 | ||
286 | (define (macroexpand-1 e) | |
287 | (if (pair? e) (let ((a (car e))) | |
288 | (cond ((symbol? a) (set! a (assq a *defmacros*)) | |
289 | (if a (apply (cdr a) (cdr e)) e)) | |
290 | (else e))) | |
291 | e)) | |
292 | ||
293 | (define (macroexpand e) | |
294 | (if (pair? e) (let ((a (car e))) | |
295 | (cond ((symbol? a) | |
296 | (set! a (assq a *defmacros*)) | |
297 | (if a (macroexpand (apply (cdr a) (cdr e))) e)) | |
298 | (else e))) | |
299 | e)) | |
300 | ||
301 | (define gentemp | |
302 | (let ((*gensym-counter* -1)) | |
303 | (lambda () | |
304 | (set! *gensym-counter* (+ *gensym-counter* 1)) | |
305 | (string->symbol | |
306 | (string-append "slib:G" (number->string *gensym-counter*)))))) | |
307 | ||
308 | (define base:eval slib:eval) | |
309 | (define (defmacro:eval x) (base:eval (defmacro:expand* x))) | |
310 | (define (defmacro:expand* x) | |
311 | (require 'defmacroexpand) (apply defmacro:expand* x '())) | |
312 | ||
313 | (define (defmacro:load <pathname>) | |
314 | (slib:eval-load <pathname> defmacro:eval)) | |
315 | ||
316 | (define (slib:eval-load <pathname> evl) | |
317 | (if (not (file-exists? <pathname>)) | |
318 | (set! <pathname> (string-append <pathname> (scheme-file-suffix)))) | |
319 | (call-with-input-file <pathname> | |
320 | (lambda (port) | |
321 | (let ((old-load-pathname *load-pathname*)) | |
322 | (set! *load-pathname* <pathname>) | |
323 | (do ((o (read port) (read port))) | |
324 | ((eof-object? o)) | |
325 | (evl o)) | |
326 | (set! *load-pathname* old-load-pathname))))) | |
327 | ||
328 | (define slib:warn | |
329 | (lambda args | |
330 | (let ((cep (current-error-port))) | |
331 | (if (provided? 'trace) (print-call-stack cep)) | |
332 | (display "Warn: " cep) | |
333 | (for-each (lambda (x) (display x cep)) args)))) | |
334 | ||
335 | ;;; define an error procedure for the library | |
336 | (define (slib:error . argl) | |
337 | (if (provided? 'trace) (print-call-stack (current-error-port))) | |
338 | (error argl)) | |
339 | ||
340 | ;;; define these as appropriate for your system. | |
341 | (define slib:tab #\Tab) | |
342 | (define slib:form-feed #\d12) | |
343 | ||
344 | ;;; Support for older versions of Scheme. Not enough code for its own file. | |
345 | (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) | |
346 | (define t #t) | |
347 | (define nil #f) | |
348 | ||
349 | ;;; Define these if your implementation's syntax can support it and if | |
350 | ;;; they are not already defined. | |
351 | ||
352 | (define (1+ n) (+ n 1)) | |
353 | (define (-1+ n) (+ n -1)) | |
354 | (define 1- -1+) | |
355 | ||
356 | (define in-vicinity string-append) | |
357 | ||
358 | ;;; Define SLIB:EXIT to be the implementation procedure to exit or | |
359 | ;;; return if exitting not supported. | |
360 | (define slib:exit | |
361 | (lambda args | |
362 | (cond ((null? args) (quit)) | |
363 | ((eqv? #t (car args)) (quit)) | |
364 | ((eqv? #f (car args)) (quit 1)) | |
365 | (else (quit (car args)))))) | |
366 | ||
367 | ;;; Here for backward compatability | |
368 | (define scheme-file-suffix | |
369 | (let ((suffix (case (software-type) | |
370 | ((NOSVE) "_scm") | |
371 | (else ".scm")))) | |
372 | (lambda () suffix))) | |
373 | ||
374 | ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever | |
375 | ;;; suffix all the module files in SLIB have. See feature 'SOURCE. | |
376 | ||
377 | (define (slib:load-source f) (load (string-append f (scheme-file-suffix)))) | |
378 | ||
379 | ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced | |
380 | ;;; by compiling "foo.scm" if this implementation can compile files. | |
381 | ;;; See feature 'COMPILED. | |
382 | ||
383 | (define slib:load-compiled load) | |
384 | ||
385 | ;;; At this point SLIB:LOAD must be able to load SLIB files. | |
386 | ||
387 | (define slib:load slib:load-source) | |
388 | ||
389 | (slib:load (in-vicinity (library-vicinity) "require")) |