Commit | Line | Data |
---|---|---|
7ebe6c76 JB |
1 | ;;;; slib.scm --- definitions needed to get SLIB to work with Guile |
2 | ;;;; | |
a482f2cc MV |
3 | ;;;; Copyright (C) 1997, 1998, 2000 Free Software Foundation, Inc. |
4 | ;;;; | |
5 | ;;;; This file is part of GUILE. | |
6 | ;;;; | |
7 | ;;;; GUILE is free software; you can redistribute it and/or modify it | |
8 | ;;;; under the terms of the GNU General Public License as published by | |
9 | ;;;; the Free Software Foundation; either version 2, or (at your | |
10 | ;;;; option) any later version. | |
11 | ;;;; | |
12 | ;;;; GUILE is distributed in the hope that it will be useful, but | |
13 | ;;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
15 | ;;;; General Public License for more details. | |
16 | ;;;; | |
17 | ;;;; You should have received a copy of the GNU General Public License | |
18 | ;;;; along with GUILE; see the file COPYING. If not, write to the | |
19 | ;;;; Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
20 | ;;;; Boston, MA 02111-1307 USA | |
21 | ;;;; | |
22 | ;;;; As a special exception, the Free Software Foundation gives permission | |
23 | ;;;; for additional uses of the text contained in its release of GUILE. | |
24 | ;;;; | |
25 | ;;;; The exception is that, if you link the GUILE library with other files | |
26 | ;;;; to produce an executable, this does not by itself cause the | |
27 | ;;;; resulting executable to be covered by the GNU General Public License. | |
28 | ;;;; Your use of that executable is in no way restricted on account of | |
29 | ;;;; linking the GUILE library code into it. | |
30 | ;;;; | |
31 | ;;;; This exception does not however invalidate any other reasons why | |
32 | ;;;; the executable file might be covered by the GNU General Public License. | |
33 | ;;;; | |
34 | ;;;; This exception applies only to the code released by the | |
35 | ;;;; Free Software Foundation under the name GUILE. If you copy | |
36 | ;;;; code from other Free Software Foundation releases into a copy of | |
37 | ;;;; GUILE, as the General Public License permits, the exception does | |
38 | ;;;; not apply to the code that you add in this way. To avoid misleading | |
39 | ;;;; anyone as to the status of such modified files, you must delete | |
40 | ;;;; this exception notice from them. | |
41 | ;;;; | |
42 | ;;;; If you write modifications of your own for GUILE, it is your choice | |
43 | ;;;; whether to permit this exception to apply to your modifications. | |
44 | ;;;; If you do not wish that, delete this exception notice. | |
7ebe6c76 | 45 | ;;;; |
3267d4a1 MD |
46 | (define-module (ice-9 slib) |
47 | :no-backtrace) | |
0f2d19dd JB |
48 | |
49 | \f | |
50 | ||
51 | (define (eval-load <filename> evl) | |
52 | (if (not (file-exists? <filename>)) | |
53 | (set! <filename> (string-append <filename> (scheme-file-suffix)))) | |
54 | (call-with-input-file <filename> | |
55 | (lambda (port) | |
56 | (let ((old-load-pathname *load-pathname*)) | |
57 | (set! *load-pathname* <filename>) | |
75a97b92 | 58 | (do ((o (read port) (read port))) |
0f2d19dd JB |
59 | ((eof-object? o)) |
60 | (evl o)) | |
61 | (set! *load-pathname* old-load-pathname))))) | |
62 | ||
63 | \f | |
64 | ||
65 | (define slib:exit quit) | |
66 | (define slib:error error) | |
7ed9feb0 | 67 | (define slib:warn warn) |
21c2a33a MD |
68 | (define slib:eval (lambda (x) (eval x slib-module))) |
69 | (define defmacro:eval (lambda (x) (eval x (interaction-environment)))) | |
0f2d19dd JB |
70 | (define logical:logand logand) |
71 | (define logical:logior logior) | |
72 | (define logical:logxor logxor) | |
73 | (define logical:lognot lognot) | |
74 | (define logical:ash ash) | |
75 | (define logical:logcount logcount) | |
76 | (define logical:integer-length integer-length) | |
77 | (define logical:bit-extract bit-extract) | |
78 | (define logical:integer-expt integer-expt) | |
79 | (define logical:ipow-by-squaring ipow-by-squaring) | |
80 | (define slib:eval-load eval-load) | |
81 | (define slib:tab #\tab) | |
82 | (define slib:form-feed #\page) | |
83 | ||
ed218d98 MV |
84 | (define slib-module (current-module)) |
85 | ||
86 | (define (defined? symbol) | |
87 | (module-defined? slib-module symbol)) | |
88 | ||
0f2d19dd JB |
89 | (define slib:features |
90 | (append '(source | |
91 | eval | |
92 | abort | |
93 | alist | |
94 | defmacro | |
95 | delay | |
96 | dynamic-wind | |
97 | full-continuation | |
98 | hash | |
99 | hash-table | |
100 | line-i/o | |
101 | logical | |
102 | multiarg/and- | |
103 | multiarg-apply | |
104 | promise | |
105 | rev2-procedures | |
106 | rev4-optional-procedures | |
107 | string-port | |
108 | with-file) | |
109 | ||
b1818df3 | 110 | (if (defined? 'getenv) |
0f2d19dd JB |
111 | '(getenv) |
112 | '()) | |
113 | ||
b1818df3 | 114 | (if (defined? 'current-time) |
0f2d19dd JB |
115 | '(current-time) |
116 | '()) | |
117 | ||
b1818df3 | 118 | (if (defined? 'system) |
0f2d19dd JB |
119 | '(system) |
120 | '()) | |
121 | ||
b1818df3 | 122 | (if (defined? 'array?) |
0f2d19dd JB |
123 | '(array) |
124 | '()) | |
125 | ||
b1818df3 | 126 | (if (defined? 'char-ready?) |
0f2d19dd JB |
127 | '(char-ready?) |
128 | '()) | |
129 | ||
b1818df3 | 130 | (if (defined? 'array-for-each) |
0f2d19dd JB |
131 | '(array-for-each) |
132 | '()) | |
133 | ||
134 | (if (and (string->number "0.0") (inexact? (string->number "0.0"))) | |
135 | '(inexact) | |
136 | '()) | |
137 | ||
138 | (if (rational? (string->number "1/19")) | |
139 | '(rational) | |
140 | '()) | |
141 | ||
142 | (if (real? (string->number "0.0")) | |
143 | '(real) | |
144 | ()) | |
145 | ||
146 | (if (complex? (string->number "1+i")) | |
147 | '(complex) | |
148 | '()) | |
149 | ||
150 | (let ((n (string->number "9999999999999999999999999999999"))) | |
151 | (if (and n (exact? n)) | |
152 | '(bignum) | |
153 | '())))) | |
154 | ||
155 | ||
9b345f6c | 156 | ;;; FIXME: Because uers want require to search the path, this uses |
096d5f90 | 157 | ;;; load-from-path, which probably isn't a hot idea. slib |
9b345f6c JB |
158 | ;;; doesn't expect this function to search a path, so I expect to get |
159 | ;;; bug reports at some point complaining that the wrong file gets | |
160 | ;;; loaded when something accidentally appears in the path before | |
161 | ;;; slib, etc. ad nauseum. However, the right fix seems to involve | |
162 | ;;; changing catalog:get in slib/require.scm, and I don't expect | |
163 | ;;; Aubrey will integrate such a change. So I'm just going to punt | |
164 | ;;; for the time being. | |
534a0099 | 165 | (define-public (slib:load name) |
0f2d19dd JB |
166 | (save-module-excursion |
167 | (lambda () | |
168 | (set-current-module slib-module) | |
d1005e3c MD |
169 | (let ((errinfo (catch 'system-error |
170 | (lambda () | |
171 | (load-from-path name) | |
172 | #f) | |
173 | (lambda args args)))) | |
174 | (if (and errinfo | |
175 | (catch 'system-error | |
176 | (lambda () | |
177 | (load-from-path | |
178 | (string-append name ".scm")) | |
179 | #f) | |
180 | (lambda args args))) | |
c51bfd81 | 181 | (apply throw errinfo)))))) |
0f2d19dd JB |
182 | |
183 | (define slib:load-source slib:load) | |
184 | (define defmacro:load slib:load) | |
185 | ||
c51bfd81 MD |
186 | (define slib-parent-dir |
187 | (let* ((path (%search-load-path "slib/require.scm"))) | |
00f06035 | 188 | (if path |
4e15fee8 | 189 | (substring path 0 (- (string-length path) 17)) |
00f06035 | 190 | (error "Could not find slib/require.scm in " %load-path)))) |
c51bfd81 MD |
191 | |
192 | (define-public (implementation-vicinity) | |
193 | (string-append slib-parent-dir "/")) | |
f353a9e2 | 194 | (define-public (library-vicinity) |
c51bfd81 | 195 | (string-append (implementation-vicinity) "slib/")) |
f353a9e2 | 196 | (define-public home-vicinity |
ad76c8d9 TP |
197 | (let ((home-path (getenv "HOME"))) |
198 | (lambda () home-path))) | |
f353a9e2 GH |
199 | (define-public (scheme-implementation-type) 'guile) |
200 | (define-public (scheme-implementation-version) "") | |
0f2d19dd JB |
201 | |
202 | (define (output-port-width . arg) 80) | |
203 | (define (output-port-height . arg) 24) | |
841d28d7 | 204 | (define (identity x) x) |
4b0d6055 | 205 | |
6001fe82 MD |
206 | ;;; {Random numbers} |
207 | ;;; | |
208 | (define-public (make-random-state . args) | |
209 | (let ((seed (if (null? args) *random-state* (car args)))) | |
210 | (cond ((string? seed)) | |
211 | ((number? seed) (set! seed (number->string seed))) | |
212 | (else (let () | |
213 | (require 'object->string) | |
214 | (set! seed (object->limited-string seed 50))))) | |
215 | (seed->random-state seed))) | |
216 | ||
0f2d19dd JB |
217 | ;;; {Time} |
218 | ;;; | |
219 | ||
220 | (define difftime -) | |
221 | (define offset-time +) | |
222 | ||
223 | \f | |
224 | (define %system-define define) | |
225 | ||
226 | (define define | |
227 | (procedure->memoizing-macro | |
228 | (lambda (exp env) | |
229 | (if (= (length env) 1) | |
230 | `(define-public ,@(cdr exp)) | |
231 | `(%system-define ,@(cdr exp)))))) | |
232 | ||
7a0ff2f8 MD |
233 | ;;; Hack to make syncase macros work in the slib module |
234 | (if (nested-ref the-root-module '(app modules ice-9 syncase)) | |
235 | (set-object-property! (module-local-variable (current-module) 'define) | |
236 | '*sc-expander* | |
237 | '(define))) | |
238 | ||
26ec032d | 239 | (define (software-type) |
ea4bcd7b GB |
240 | "Return a symbol describing the current platform's operating system. |
241 | This may be one of AIX, VMS, UNIX, COHERENT, WINDOWS, MS-DOS, OS/2, | |
242 | THINKC, AMIGA, ATARIST, MACH, or ACORN. | |
243 | ||
244 | Note that most varieties of Unix are considered to be simply \"UNIX\". | |
245 | That is because when a program depends on features that are not present | |
246 | on every operating system, it is usually better to test for the presence | |
247 | or absence of that specific feature. The return value of | |
248 | @code{software-type} should only be used for this purpose when there is | |
249 | no other easy or unambiguous way of detecting such features." | |
250 | 'UNIX) | |
0f2d19dd | 251 | |
c51bfd81 | 252 | (slib:load (in-vicinity (library-vicinity) "require.scm")) |
0f2d19dd JB |
253 | |
254 | (define-public require require:require) | |
c51bfd81 MD |
255 | |
256 | ;; {Extensions to the require system so that the user can add new | |
257 | ;; require modules easily.} | |
258 | ||
259 | (define *vicinity-table* | |
260 | (list | |
261 | (cons 'implementation (implementation-vicinity)) | |
262 | (cons 'library (library-vicinity)))) | |
263 | ||
264 | (define (install-require-vicinity name vicinity) | |
265 | (let ((entry (assq name *vicinity-table*))) | |
266 | (if entry | |
267 | (set-cdr! entry vicinity) | |
268 | (set! *vicinity-table* | |
269 | (acons name vicinity *vicinity-table*))))) | |
270 | ||
271 | (define (install-require-module name vicinity-name file-name) | |
12ed431d MD |
272 | (if (not *catalog*) ;Fix which loads catalog in slib |
273 | (catalog:get 'random)) ;(doesn't load the feature 'random) | |
c51bfd81 MD |
274 | (let ((entry (assq name *catalog*)) |
275 | (vicinity (cdr (assq vicinity-name *vicinity-table*)))) | |
276 | (let ((path-name (in-vicinity vicinity file-name))) | |
277 | (if entry | |
278 | (set-cdr! entry path-name) | |
279 | (set! *catalog* | |
280 | (acons name path-name *catalog*)))))) |