1 ;;;; slib.scm --- definitions needed to get SLIB to work with Guile
3 ;;;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 2.1 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (define-module (ice-9 slib)
20 :export (slib:load slib:load-source defmacro:load
21 implementation-vicinity library-vicinity home-vicinity
22 scheme-implementation-type scheme-implementation-version
23 output-port-width output-port-height array-indexes
26 require slib:error slib:exit slib:warn slib:eval
27 defmacro:eval logical:logand logical:logior logical:logxor
28 logical:lognot logical:ash logical:logcount logical:integer-length
29 logical:bit-extract logical:integer-expt logical:ipow-by-squaring
30 slib:eval-load slib:tab slib:form-feed difftime offset-time
32 :replace (delete-file open-file provide provided? system)
37 (define (eval-load <filename> evl)
38 (if (not (file-exists? <filename>))
39 (set! <filename> (string-append <filename> (scheme-file-suffix))))
40 (call-with-input-file <filename>
42 (let ((old-load-pathname *load-pathname*))
43 (set! *load-pathname* <filename>)
44 (do ((o (read port) (read port)))
47 (set! *load-pathname* old-load-pathname)))))
51 (define slib:exit quit)
52 (define slib:error error)
53 (define slib:warn warn)
54 (define slib:eval (lambda (x) (eval x slib-module)))
55 (define defmacro:eval (lambda (x) (eval x (interaction-environment))))
56 (define logical:logand logand)
57 (define logical:logior logior)
58 (define logical:logxor logxor)
59 (define logical:lognot lognot)
60 (define logical:ash ash)
61 (define logical:logcount logcount)
62 (define logical:integer-length integer-length)
63 (define logical:bit-extract bit-extract)
64 (define logical:integer-expt integer-expt)
65 (define slib:eval-load eval-load)
66 (define slib:tab #\tab)
67 (define slib:form-feed #\page)
69 (define slib-module (current-module))
71 (define (defined? symbol)
72 (module-defined? slib-module symbol))
74 ;;; *FEATURES* should be set to a list of symbols describing features
75 ;;; of this implementation. Suggestions for features are:
79 source ;can load scheme source files
80 ;(slib:load-source "filename")
81 ; compiled ;can load compiled files
82 ;(slib:load-compiled "filename")
84 ;; Scheme report features
86 ; rev5-report ;conforms to
87 eval ;R5RS two-argument eval
88 ; values ;R5RS multiple values
89 dynamic-wind ;R5RS dynamic-wind
90 ; macro ;R5RS high level macros
91 delay ;has DELAY and FORCE
92 multiarg-apply ;APPLY can take more than 2 args.
94 rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
95 ;LIST->STRING, STRING-COPY,
96 ;STRING-FILL!, LIST->VECTOR,
97 ;VECTOR->LIST, and VECTOR-FILL!
99 ; rev4-report ;conforms to
101 ; ieee-p1178 ;conforms to
103 ; rev3-report ;conforms to
105 rev2-procedures ;SUBSTRING-MOVE-LEFT!,
106 ;SUBSTRING-MOVE-RIGHT!,
108 ;STRING-NULL?, APPEND!, 1+,
109 ;-1+, <?, <=?, =?, >?, >=?
110 ; object-hash ;has OBJECT-HASH
112 multiarg/and- ;/ and - can take more than 2 args.
113 with-file ;has WITH-INPUT-FROM-FILE and
114 ;WITH-OUTPUT-FROM-FILE
115 ; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
116 ; ieee-floating-point ;conforms to IEEE Standard 754-1985
117 ;IEEE Standard for Binary
118 ;Floating-Point Arithmetic.
119 full-continuation ;can return multiple times
121 ;; Other common features
123 ; srfi ;srfi-0, COND-EXPAND finds all srfi-*
124 ; sicp ;runs code from Structure and
125 ;Interpretation of Computer
126 ;Programs by Abelson and Sussman.
127 defmacro ;has Common Lisp DEFMACRO
128 ; record ;has user defined data structures
129 string-port ;has CALL-WITH-INPUT-STRING and
130 ;CALL-WITH-OUTPUT-STRING
134 ; format ;Common-lisp output formatting
135 ; trace ;has macros: TRACE and UNTRACE
136 ; compiler ;has (COMPILER)
139 ;; core definitions compatible, plus `make-random-state' below
143 (if (defined? 'getenv)
147 (if (defined? 'current-time)
151 (if (defined? 'system)
155 (if (defined? 'char-ready?)
161 ;; The array module specified by slib 3a1 is not the same as what guile
162 ;; provides, so we must remove `array' from the features list.
164 ;; The main difference is `create-array' which is similar to
165 ;; `make-uniform-array', but the `Ac64' etc prototype procedures incorporate
166 ;; an initial fill element into the prototype.
168 ;; Believe the array-for-each module will need to be taken from slib when
169 ;; the array module is taken from there, since what the array module creates
170 ;; won't be understood by the guile functions. So remove `array-for-each'
171 ;; from the features list too.
173 ;; Also, slib 3a1 array-for-each specifies an `array-map' which is not in
174 ;; guile (but could be implemented quite easily).
176 ;; ENHANCE-ME: It'd be nice to implement what's necessary, since the guile
177 ;; functions should be more efficient than the implementation in slib.
179 ;; FIXME: Since the *features* variable is shared by slib and the guile
180 ;; core, removing these feature symbols has the unhappy effect of making it
181 ;; look like they aren't in the core either. Let's assume that arrays have
182 ;; been present unconditionally long enough that no guile-specific code will
183 ;; bother to test. An alternative would be to make a new separate
184 ;; *features* variable which the slib stuff operated on, leaving the core
185 ;; mechanism alone. That might be a good thing anyway.
187 (set! *features* (delq 'array *features*))
188 (set! *features* (delq 'array-for-each *features*))
190 ;; The random module in slib 3a1 provides a `random:chunk' which is used by
191 ;; the random-inexact module. Guile doesn't provide random:chunk so we must
192 ;; remove 'random from `*features*' to use the slib code.
194 ;; ENHANCE-ME: Maybe Guile could provide a `random:chunk', the rest of the
195 ;; random module is already the same as Guile.
197 ;; FIXME: As per the array bits above, *features* is shared by slib and the
198 ;; guile core, so removing 'random has the unhappy effect of making it look
199 ;; like this isn't in the core. Let's assume random numbers have been
200 ;; present unconditionally long enough that no guile-specific code will
203 (set! *features* (delq 'random *features*))
206 ;;; FIXME: Because uers want require to search the path, this uses
207 ;;; load-from-path, which probably isn't a hot idea. slib
208 ;;; doesn't expect this function to search a path, so I expect to get
209 ;;; bug reports at some point complaining that the wrong file gets
210 ;;; loaded when something accidentally appears in the path before
211 ;;; slib, etc. ad nauseum. However, the right fix seems to involve
212 ;;; changing catalog:get in slib/require.scm, and I don't expect
213 ;;; Aubrey will integrate such a change. So I'm just going to punt
214 ;;; for the time being.
215 (define (slib:load name)
216 (save-module-excursion
218 (set-current-module slib-module)
219 (let ((errinfo (catch 'system-error
221 (load-from-path name)
223 (lambda args args))))
228 (string-append name ".scm"))
231 (apply throw errinfo))))))
233 (define slib:load-source slib:load)
234 (define defmacro:load slib:load)
236 (define slib-parent-dir
237 (let* ((path (%search-load-path "slib/require.scm")))
239 (substring path 0 (- (string-length path) 17))
240 (error "Could not find slib/require.scm in " %load-path))))
242 (define (implementation-vicinity)
243 (string-append slib-parent-dir "/"))
244 (define (library-vicinity)
245 (string-append (implementation-vicinity) "slib/"))
246 (define home-vicinity
247 (let ((home-path (getenv "HOME")))
248 (lambda () home-path)))
249 (define (scheme-implementation-type) 'guile)
250 (define scheme-implementation-version version)
251 ;;; (scheme-implementation-home-page) should return a (string) URI
252 ;;; (Uniform Resource Identifier) for this scheme implementation's home
253 ;;; page; or false if there isn't one.
254 (define (scheme-implementation-home-page)
255 "http://www.gnu.org/software/guile/guile.html")
257 ;; legacy from r3rs, but slib says all implementations provide these
258 ;; ("Legacy" section of the "Miscellany" node in the manual)
260 (define-public nil #f)
262 ;; ENHANCE-ME: Could call ioctl TIOCGWINSZ to get the size of a tty (see
263 ;; "man 4 tty_ioctl" on a GNU/Linux system), on systems with that.
264 (define (output-port-width . arg) 80)
265 (define (output-port-height . arg) 24)
267 ;; slib 3a1 and up, straight from Template.scm
268 (define-public (call-with-open-ports . ports)
269 (define proc (car ports))
270 (cond ((procedure? proc) (set! ports (cdr ports)))
271 (else (set! ports (reverse ports))
272 (set! proc (car ports))
273 (set! ports (reverse (cdr ports)))))
274 (let ((ans (apply proc ports)))
275 (for-each close-port ports)
278 ;; slib (version 3a1) requires open-file accept a symbol r, rb, w or wb for
279 ;; MODES, so extend the guile core open-file accordingly.
281 ;; slib (version 3a1) also calls open-file with strings "rb" or "wb", not
282 ;; sure if that's intentional, but in any case this extension continues to
283 ;; accept strings to make that work.
285 (define-public (open-file filename modes)
287 (set! modes (symbol->string modes)))
288 ((@ (guile) open-file) filename modes))
290 ;; returning #t/#f instead of throwing an error for failure
291 (define-public (delete-file filename)
293 (lambda () ((@ (guile) delete-file) filename) #t)
296 ;; Nothing special to do for this, so straight from Template.scm. Maybe
297 ;; "sensible-browser" for a debian system would be worth trying too (and
298 ;; would be good on a tty).
299 (define-public (browse-url url)
300 (define (try cmd end) (zero? (system (string-append cmd url end))))
301 (or (try "netscape-remote -remote 'openURL(" ")'")
302 (try "netscape -remote 'openURL(" ")'")
303 (try "netscape '" "'&")
304 (try "netscape '" "'")))
307 (define (array-indexes ra)
308 (let ((ra0 (apply make-array '() (array-shape ra))))
309 (array-index-map! ra0 list)
314 (define (make-random-state . args)
315 (let ((seed (if (null? args) *random-state* (car args))))
316 (cond ((string? seed))
317 ((number? seed) (set! seed (number->string seed)))
319 (require 'object->string)
320 (set! seed (object->limited-string seed 50)))))
321 (seed->random-state seed)))
323 ;;; {rev2-procedures}
335 ;; If the program run is killed by a signal, the shell normally gives an
336 ;; exit code of 128+signum. If the shell itself is killed by a signal then
337 ;; we do the same 128+signum here.
339 ;; "stop-sig" shouldn't arise here, since system shouldn't be calling
340 ;; waitpid with WUNTRACED, but allow for it anyway, just in case.
342 (if (memq 'system *features*)
343 (define-public system
345 (let ((st ((@ (guile) system) str)))
346 (or (status:exit-val st)
347 (+ 128 (or (status:term-sig st)
348 (status:stop-sig st))))))))
354 (define offset-time +)
358 (procedure->memoizing-macro
360 (if (= (length env) 1)
361 `(define-public ,@(cdr exp))
362 `(define-private ,@(cdr exp))))))
364 ;;; Hack to make syncase macros work in the slib module
365 (if (nested-ref the-root-module '(app modules ice-9 syncase))
366 (set-object-property! (module-local-variable (current-module) 'define)
370 (define (software-type)
371 "Return a symbol describing the current platform's operating system.
372 This may be one of AIX, VMS, UNIX, COHERENT, WINDOWS, MS-DOS, OS/2,
373 THINKC, AMIGA, ATARIST, MACH, or ACORN.
375 Note that most varieties of Unix are considered to be simply \"UNIX\".
376 That is because when a program depends on features that are not present
377 on every operating system, it is usually better to test for the presence
378 or absence of that specific feature. The return value of
379 @code{software-type} should only be used for this purpose when there is
380 no other easy or unambiguous way of detecting such features."
383 (slib:load (in-vicinity (library-vicinity) "require.scm"))
385 (define require require:require)
387 ;; {Extensions to the require system so that the user can add new
388 ;; require modules easily.}
390 (define *vicinity-table*
392 (cons 'implementation (implementation-vicinity))
393 (cons 'library (library-vicinity))))
395 (define (install-require-vicinity name vicinity)
396 (let ((entry (assq name *vicinity-table*)))
398 (set-cdr! entry vicinity)
399 (set! *vicinity-table*
400 (acons name vicinity *vicinity-table*)))))
402 (define (install-require-module name vicinity-name file-name)
403 (if (not *catalog*) ;Fix which loads catalog in slib
404 (catalog:get 'random)) ;(doesn't load the feature 'random)
405 (let ((entry (assq name *catalog*))
406 (vicinity (cdr (assq vicinity-name *vicinity-table*))))
407 (let ((path-name (in-vicinity vicinity file-name)))
409 (set-cdr! entry path-name)
411 (acons name path-name *catalog*))))))
413 (define (make-exchanger obj)
414 (lambda (rep) (let ((old obj)) (set! obj rep) old)))