Commit | Line | Data |
---|---|---|
0f2d19dd JB |
1 | ;;; installed-scm-file |
2 | (define-module #/ice-9/slib) | |
3 | ||
4 | \f | |
5 | ||
6 | (define (eval-load <filename> evl) | |
7 | (if (not (file-exists? <filename>)) | |
8 | (set! <filename> (string-append <filename> (scheme-file-suffix)))) | |
9 | (call-with-input-file <filename> | |
10 | (lambda (port) | |
11 | (let ((old-load-pathname *load-pathname*)) | |
12 | (set! *load-pathname* <filename>) | |
75a97b92 | 13 | (do ((o (read port) (read port))) |
0f2d19dd JB |
14 | ((eof-object? o)) |
15 | (evl o)) | |
16 | (set! *load-pathname* old-load-pathname))))) | |
17 | ||
18 | \f | |
19 | ||
20 | (define slib:exit quit) | |
21 | (define slib:error error) | |
22 | (define slib:eval eval) | |
23 | (define defmacro:eval eval) | |
24 | (define logical:logand logand) | |
25 | (define logical:logior logior) | |
26 | (define logical:logxor logxor) | |
27 | (define logical:lognot lognot) | |
28 | (define logical:ash ash) | |
29 | (define logical:logcount logcount) | |
30 | (define logical:integer-length integer-length) | |
31 | (define logical:bit-extract bit-extract) | |
32 | (define logical:integer-expt integer-expt) | |
33 | (define logical:ipow-by-squaring ipow-by-squaring) | |
34 | (define slib:eval-load eval-load) | |
35 | (define slib:tab #\tab) | |
36 | (define slib:form-feed #\page) | |
37 | ||
ed218d98 MV |
38 | (define slib-module (current-module)) |
39 | ||
40 | (define (defined? symbol) | |
41 | (module-defined? slib-module symbol)) | |
42 | ||
0f2d19dd JB |
43 | (define slib:features |
44 | (append '(source | |
45 | eval | |
46 | abort | |
47 | alist | |
48 | defmacro | |
49 | delay | |
50 | dynamic-wind | |
51 | full-continuation | |
52 | hash | |
53 | hash-table | |
54 | line-i/o | |
55 | logical | |
56 | multiarg/and- | |
57 | multiarg-apply | |
58 | promise | |
59 | rev2-procedures | |
60 | rev4-optional-procedures | |
61 | string-port | |
62 | with-file) | |
63 | ||
b1818df3 | 64 | (if (defined? 'getenv) |
0f2d19dd JB |
65 | '(getenv) |
66 | '()) | |
67 | ||
b1818df3 | 68 | (if (defined? 'current-time) |
0f2d19dd JB |
69 | '(current-time) |
70 | '()) | |
71 | ||
b1818df3 | 72 | (if (defined? 'system) |
0f2d19dd JB |
73 | '(system) |
74 | '()) | |
75 | ||
b1818df3 | 76 | (if (defined? 'array?) |
0f2d19dd JB |
77 | '(array) |
78 | '()) | |
79 | ||
b1818df3 | 80 | (if (defined? 'char-ready?) |
0f2d19dd JB |
81 | '(char-ready?) |
82 | '()) | |
83 | ||
b1818df3 | 84 | (if (defined? 'array-for-each) |
0f2d19dd JB |
85 | '(array-for-each) |
86 | '()) | |
87 | ||
88 | (if (and (string->number "0.0") (inexact? (string->number "0.0"))) | |
89 | '(inexact) | |
90 | '()) | |
91 | ||
92 | (if (rational? (string->number "1/19")) | |
93 | '(rational) | |
94 | '()) | |
95 | ||
96 | (if (real? (string->number "0.0")) | |
97 | '(real) | |
98 | ()) | |
99 | ||
100 | (if (complex? (string->number "1+i")) | |
101 | '(complex) | |
102 | '()) | |
103 | ||
104 | (let ((n (string->number "9999999999999999999999999999999"))) | |
105 | (if (and n (exact? n)) | |
106 | '(bignum) | |
107 | '())))) | |
108 | ||
109 | ||
0f2d19dd JB |
110 | (define (slib:load name) |
111 | (save-module-excursion | |
112 | (lambda () | |
113 | (set-current-module slib-module) | |
c51bfd81 MD |
114 | (let* ((errinfo (catch 'system-error |
115 | (lambda () | |
116 | (basic-load name) | |
117 | #f) | |
118 | (lambda args args))) | |
119 | (errinfo (and errinfo | |
120 | (catch 'system-error | |
121 | (lambda () | |
122 | (basic-load (string-append name ".scm")) | |
123 | #f) | |
124 | (lambda args args))))) | |
125 | (if errinfo | |
126 | (apply throw errinfo)))))) | |
0f2d19dd JB |
127 | |
128 | (define slib:load-source slib:load) | |
129 | (define defmacro:load slib:load) | |
130 | ||
c51bfd81 MD |
131 | (define slib-parent-dir |
132 | (let* ((path (%search-load-path "slib/require.scm"))) | |
00f06035 GH |
133 | (if path |
134 | (make-shared-substring path 0 (- (string-length path) 17)) | |
135 | (error "Could not find slib/require.scm in " %load-path)))) | |
c51bfd81 MD |
136 | |
137 | (define-public (implementation-vicinity) | |
138 | (string-append slib-parent-dir "/")) | |
139 | (define (library-vicinity) | |
140 | (string-append (implementation-vicinity) "slib/")) | |
0f2d19dd JB |
141 | (define (scheme-implementation-type) 'guile) |
142 | (define (scheme-implementation-version) "") | |
143 | ||
144 | (define (output-port-width . arg) 80) | |
145 | (define (output-port-height . arg) 24) | |
146 | ||
0f2d19dd JB |
147 | ;;; {Time} |
148 | ;;; | |
149 | ||
150 | (define difftime -) | |
151 | (define offset-time +) | |
152 | ||
153 | \f | |
154 | (define %system-define define) | |
155 | ||
156 | (define define | |
157 | (procedure->memoizing-macro | |
158 | (lambda (exp env) | |
159 | (if (= (length env) 1) | |
160 | `(define-public ,@(cdr exp)) | |
161 | `(%system-define ,@(cdr exp)))))) | |
162 | ||
163 | (define (software-type) 'UNIX) | |
164 | ||
c51bfd81 | 165 | (slib:load (in-vicinity (library-vicinity) "require.scm")) |
0f2d19dd JB |
166 | |
167 | (define-public require require:require) | |
c51bfd81 MD |
168 | |
169 | ;; {Extensions to the require system so that the user can add new | |
170 | ;; require modules easily.} | |
171 | ||
172 | (define *vicinity-table* | |
173 | (list | |
174 | (cons 'implementation (implementation-vicinity)) | |
175 | (cons 'library (library-vicinity)))) | |
176 | ||
177 | (define (install-require-vicinity name vicinity) | |
178 | (let ((entry (assq name *vicinity-table*))) | |
179 | (if entry | |
180 | (set-cdr! entry vicinity) | |
181 | (set! *vicinity-table* | |
182 | (acons name vicinity *vicinity-table*))))) | |
183 | ||
184 | (define (install-require-module name vicinity-name file-name) | |
185 | (let ((entry (assq name *catalog*)) | |
186 | (vicinity (cdr (assq vicinity-name *vicinity-table*)))) | |
187 | (let ((path-name (in-vicinity vicinity file-name))) | |
188 | (if entry | |
189 | (set-cdr! entry path-name) | |
190 | (set! *catalog* | |
191 | (acons name path-name *catalog*)))))) |