build: Fix race between installing `guild' and the `guile-tools' symlink.
[bpt/guile.git] / module / ice-9 / boot-9.scm
CommitLineData
87e00370 1;;; -*- mode: scheme; coding: utf-8; -*-
0f2d19dd 2
b3da54d1
LC
3;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4;;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
5;;;; Free Software Foundation, Inc.
20edfbbd 6;;;;
73be1d9e
MV
7;;;; This library is free software; you can redistribute it and/or
8;;;; modify it under the terms of the GNU Lesser General Public
9;;;; License as published by the Free Software Foundation; either
53befeb7 10;;;; version 3 of the License, or (at your option) any later version.
73be1d9e
MV
11;;;;
12;;;; This library is distributed in the hope that it will be useful,
0f2d19dd 13;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e
MV
14;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15;;;; Lesser General Public License for more details.
16;;;;
17;;;; You should have received a copy of the GNU Lesser General Public
18;;;; License along with this library; if not, write to the Free Software
92205699 19;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
a482f2cc 20;;;;
3d2ada2f 21
0f2d19dd
JB
22\f
23
20edfbbd
TTN
24;;; Commentary:
25
0f2d19dd
JB
26;;; This file is the first thing loaded into Guile. It adds many mundane
27;;; definitions and a few that are interesting.
28;;;
20edfbbd 29;;; The module system (hence the hierarchical namespace) are defined in this
0f2d19dd
JB
30;;; file.
31;;;
32
20edfbbd
TTN
33;;; Code:
34
0f2d19dd 35\f
9fb41cea 36
9c35c579
AW
37;; Before compiling, make sure any symbols are resolved in the (guile)
38;; module, the primary location of those symbols, rather than in
39;; (guile-user), the default module that we compile in.
40
41(eval-when (compile)
42 (set-current-module (resolve-module '(guile))))
43
416f26c7
AW
44\f
45
46;;; {Error handling}
47;;;
48
49;; Define delimited continuation operators, and implement catch and throw in
50;; terms of them.
51
d648f569
AW
52(define make-prompt-tag
53 (lambda* (#:optional (stem "prompt"))
54 (gensym stem)))
55
c6a32a2c
AW
56(define default-prompt-tag
57 ;; not sure if we should expose this to the user as a fluid
58 (let ((%default-prompt-tag (make-prompt-tag)))
59 (lambda ()
60 %default-prompt-tag)))
8fc43b12
AW
61
62(define (call-with-prompt tag thunk handler)
416f26c7 63 (@prompt tag (thunk) handler))
8fc43b12 64(define (abort-to-prompt tag . args)
416f26c7
AW
65 (@abort tag args))
66
67
416f26c7
AW
68;; Define catch and with-throw-handler, using some common helper routines and a
69;; shared fluid. Hide the helpers in a lexical contour.
70
37620f3f 71(define with-throw-handler #f)
416f26c7 72(let ()
416f26c7
AW
73 (define (default-exception-handler k . args)
74 (cond
75 ((eq? k 'quit)
76 (primitive-exit (cond
77 ((not (pair? args)) 0)
78 ((integer? (car args)) (car args))
79 ((not (car args)) 1)
80 (else 0))))
81 (else
82 (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
83 (primitive-exit 1))))
84
9447207f
AW
85 (define %running-exception-handlers (make-fluid '()))
86 (define %exception-handler (make-fluid default-exception-handler))
87
416f26c7 88 (define (default-throw-handler prompt-tag catch-k)
9447207f 89 (let ((prev (fluid-ref %exception-handler)))
416f26c7
AW
90 (lambda (thrown-k . args)
91 (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
8fc43b12 92 (apply abort-to-prompt prompt-tag thrown-k args)
416f26c7
AW
93 (apply prev thrown-k args)))))
94
95 (define (custom-throw-handler prompt-tag catch-k pre)
9447207f 96 (let ((prev (fluid-ref %exception-handler)))
416f26c7
AW
97 (lambda (thrown-k . args)
98 (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
9447207f 99 (let ((running (fluid-ref %running-exception-handlers)))
416f26c7
AW
100 (with-fluids ((%running-exception-handlers (cons pre running)))
101 (if (not (memq pre running))
102 (apply pre thrown-k args))
103 ;; fall through
104 (if prompt-tag
8fc43b12 105 (apply abort-to-prompt prompt-tag thrown-k args)
416f26c7
AW
106 (apply prev thrown-k args))))
107 (apply prev thrown-k args)))))
108
37620f3f
AW
109 (set! catch
110 (lambda* (k thunk handler #:optional pre-unwind-handler)
111 "Invoke @var{thunk} in the dynamic context of @var{handler} for
416f26c7
AW
112exceptions matching @var{key}. If thunk throws to the symbol
113@var{key}, then @var{handler} is invoked this way:
114@lisp
115 (handler key args ...)
116@end lisp
117
118@var{key} is a symbol or @code{#t}.
119
120@var{thunk} takes no arguments. If @var{thunk} returns
121normally, that is the return value of @code{catch}.
122
123Handler is invoked outside the scope of its own @code{catch}.
124If @var{handler} again throws to the same key, a new handler
125from further up the call chain is invoked.
126
127If the key is @code{#t}, then a throw to @emph{any} symbol will
128match this call to @code{catch}.
129
130If a @var{pre-unwind-handler} is given and @var{thunk} throws
131an exception that matches @var{key}, Guile calls the
132@var{pre-unwind-handler} before unwinding the dynamic state and
133invoking the main @var{handler}. @var{pre-unwind-handler} should
134be a procedure with the same signature as @var{handler}, that
135is @code{(lambda (key . args))}. It is typically used to save
136the stack at the point where the exception occurred, but can also
137query other parts of the dynamic state at that point, such as
138fluid values.
139
140A @var{pre-unwind-handler} can exit either normally or non-locally.
141If it exits normally, Guile unwinds the stack and dynamic context
142and then calls the normal (third argument) handler. If it exits
143non-locally, that exit determines the continuation."
37620f3f 144 (if (not (or (symbol? k) (eqv? k #t)))
222056dc 145 (scm-error 'wrong-type-arg "catch"
37620f3f
AW
146 "Wrong type argument in position ~a: ~a"
147 (list 1 k) (list k)))
148 (let ((tag (make-prompt-tag "catch")))
149 (call-with-prompt
150 tag
151 (lambda ()
152 (with-fluids
153 ((%exception-handler
154 (if pre-unwind-handler
155 (custom-throw-handler tag k pre-unwind-handler)
156 (default-throw-handler tag k))))
157 (thunk)))
158 (lambda (cont k . args)
159 (apply handler k args))))))
160
161 (set! with-throw-handler
162 (lambda (k thunk pre-unwind-handler)
163 "Add @var{handler} to the dynamic context as a throw handler
91a214eb 164for key @var{k}, then invoke @var{thunk}."
37620f3f 165 (if (not (or (symbol? k) (eqv? k #t)))
222056dc 166 (scm-error 'wrong-type-arg "with-throw-handler"
37620f3f
AW
167 "Wrong type argument in position ~a: ~a"
168 (list 1 k) (list k)))
169 (with-fluids ((%exception-handler
170 (custom-throw-handler #f k pre-unwind-handler)))
171 (thunk))))
172
173 (set! throw
174 (lambda (key . args)
175 "Invoke the catch form matching @var{key}, passing @var{args} to the
416f26c7
AW
176@var{handler}.
177
178@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
179
180If there is no handler at all, Guile prints an error and then exits."
37620f3f 181 (if (not (symbol? key))
9447207f 182 ((fluid-ref %exception-handler) 'wrong-type-arg "throw"
37620f3f 183 "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
9447207f 184 (apply (fluid-ref %exception-handler) key args)))))
416f26c7
AW
185
186
187\f
188
928258fb
AW
189;;; {R4RS compliance}
190;;;
191
192(primitive-load-path "ice-9/r4rs")
193
194\f
195
eb5d1f88
AW
196;;; {Simple Debugging Tools}
197;;;
198
199;; peek takes any number of arguments, writes them to the
200;; current ouput port, and returns the last argument.
201;; It is handy to wrap around an expression to look at
202;; a value each time is evaluated, e.g.:
203;;
9b5a0d84
AW
204;; (+ 10 (troublesome-fn))
205;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
eb5d1f88
AW
206;;
207
208(define (peek . stuff)
209 (newline)
210 (display ";;; ")
211 (write stuff)
212 (newline)
213 (car (last-pair stuff)))
214
215(define pk peek)
216
3972de76
AW
217;; Temporary definition; replaced later.
218(define current-warning-port current-error-port)
b7742c6b 219
eb5d1f88 220(define (warn . stuff)
2c27dd57 221 (with-output-to-port (current-warning-port)
eb5d1f88
AW
222 (lambda ()
223 (newline)
224 (display ";;; WARNING ")
225 (display stuff)
226 (newline)
227 (car (last-pair stuff)))))
228
229\f
230
21ed9efe 231;;; {Features}
3d2ada2f 232;;;
21ed9efe
MD
233
234(define (provide sym)
235 (if (not (memq sym *features*))
236 (set! *features* (cons sym *features*))))
237
3d2ada2f
DH
238;; Return #t iff FEATURE is available to this Guile interpreter. In SLIB,
239;; provided? also checks to see if the module is available. We should do that
240;; too, but don't.
241
50706e94
JB
242(define (provided? feature)
243 (and (memq feature *features*) #t))
244
4d248541
AW
245\f
246
9b3cc659
AW
247;;; {Structs}
248;;;
249
250(define (make-struct/no-tail vtable . args)
251 (apply make-struct vtable 0 args))
252
253\f
254
a2230b65
AW
255;;; Boot versions of `map' and `for-each', enough to get the expander
256;;; running.
257;;;
258(define map
259 (case-lambda
260 ((f l)
261 (let map1 ((l l))
262 (if (null? l)
263 '()
264 (cons (f (car l)) (map1 (cdr l))))))
265 ((f l1 l2)
266 (let map2 ((l1 l1) (l2 l2))
267 (if (null? l1)
268 '()
269 (cons (f (car l1) (car l2))
270 (map2 (cdr l1) (cdr l2))))))
271 ((f l1 . rest)
272 (let lp ((l1 l1) (rest rest))
273 (if (null? l1)
274 '()
275 (cons (apply f (car l1) (map car rest))
276 (lp (cdr l1) (map cdr rest))))))))
277
278(define for-each
279 (case-lambda
280 ((f l)
281 (let for-each1 ((l l))
282 (if (pair? l)
283 (begin
284 (f (car l))
285 (for-each1 (cdr l))))))
286 ((f l1 l2)
287 (let for-each2 ((l1 l1) (l2 l2))
288 (if (pair? l1)
289 (begin
290 (f (car l1) (car l2))
291 (for-each2 (cdr l1) (cdr l2))))))
292 ((f l1 . rest)
293 (let lp ((l1 l1) (rest rest))
294 (if (pair? l1)
295 (begin
296 (apply f (car l1) (map car rest))
297 (lp (cdr l1) (map cdr rest))))))))
298
4d248541
AW
299;;; {and-map and or-map}
300;;;
301;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
302;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
303;;;
304
305;; and-map f l
306;;
307;; Apply f to successive elements of l until exhaustion or f returns #f.
308;; If returning early, return #f. Otherwise, return the last value returned
309;; by f. If f has never been called because l is empty, return #t.
310;;
311(define (and-map f lst)
312 (let loop ((result #t)
9b5a0d84 313 (l lst))
4d248541 314 (and result
9b5a0d84
AW
315 (or (and (null? l)
316 result)
317 (loop (f (car l)) (cdr l))))))
4d248541
AW
318
319;; or-map f l
320;;
321;; Apply f to successive elements of l until exhaustion or while f returns #f.
322;; If returning early, return the return value of f.
323;;
324(define (or-map f lst)
325 (let loop ((result #f)
9b5a0d84 326 (l lst))
4d248541 327 (or result
9b5a0d84
AW
328 (and (not (null? l))
329 (loop (f (car l)) (cdr l))))))
4d248541
AW
330
331\f
332
3d2ada2f 333;; let format alias simple-format until the more complete version is loaded
52cfc69b 334
8641dd9e
GB
335(define format simple-format)
336
fdc6aebf
KR
337;; this is scheme wrapping the C code so the final pred call is a tail call,
338;; per SRFI-13 spec
a4c8a02e
AW
339(define string-any
340 (lambda* (char_pred s #:optional (start 0) (end (string-length s)))
fdc6aebf 341 (if (and (procedure? char_pred)
9b5a0d84
AW
342 (> end start)
343 (<= end (string-length s))) ;; let c-code handle range error
344 (or (string-any-c-code char_pred s start (1- end))
345 (char_pred (string-ref s (1- end))))
346 (string-any-c-code char_pred s start end))))
fdc6aebf
KR
347
348;; this is scheme wrapping the C code so the final pred call is a tail call,
349;; per SRFI-13 spec
a4c8a02e
AW
350(define string-every
351 (lambda* (char_pred s #:optional (start 0) (end (string-length s)))
fdc6aebf 352 (if (and (procedure? char_pred)
9b5a0d84
AW
353 (> end start)
354 (<= end (string-length s))) ;; let c-code handle range error
355 (and (string-every-c-code char_pred s start (1- end))
356 (char_pred (string-ref s (1- end))))
357 (string-every-c-code char_pred s start end))))
fdc6aebf 358
1b05b324
MV
359;; A variant of string-fill! that we keep for compatability
360;;
361(define (substring-fill! str start end fill)
362 (string-fill! str fill start end))
363
21ed9efe 364\f
79451588 365
12eae603
AW
366;; Define a minimal stub of the module API for psyntax, before modules
367;; have booted.
efa6f9d9 368(define (module-name x)
a26934a8 369 '(guile))
05a5e5d6
AW
370(define (module-add! module sym var)
371 (hashq-set! (%get-pre-modules-obarray) sym var))
3d5f3091
AW
372(define (module-define! module sym val)
373 (let ((v (hashq-ref (%get-pre-modules-obarray) sym)))
374 (if v
375 (variable-set! v val)
05a5e5d6 376 (module-add! (current-module) sym (make-variable val)))))
3d5f3091
AW
377(define (module-ref module sym)
378 (let ((v (module-variable module sym)))
379 (if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))
12eae603
AW
380(define (resolve-module . args)
381 #f)
3d5f3091 382
6a952e0e 383;; API provided by psyntax
e4721dde 384(define syntax-violation #f)
22225fc1
AW
385(define datum->syntax #f)
386(define syntax->datum #f)
750ae8b7 387(define syntax-source #f)
22225fc1
AW
388(define identifier? #f)
389(define generate-temporaries #f)
13182603 390(define bound-identifier=? #f)
13182603 391(define free-identifier=? #f)
5a0132b3 392
8a73a6d2 393;; $sc-dispatch is an implementation detail of psyntax. It is used by
6a952e0e 394;; expanded macros, to dispatch an input against a set of patterns.
5a0132b3
AW
395(define $sc-dispatch #f)
396
6a952e0e 397;; Load it up!
13182603 398(primitive-load-path "ice-9/psyntax-pp")
4f692ace
AW
399;; The binding for `macroexpand' has now been overridden, making psyntax the
400;; expander now.
79451588 401
a1a482e0
AW
402(define-syntax and
403 (syntax-rules ()
404 ((_) #t)
405 ((_ x) x)
406 ((_ x y ...) (if x (and y ...) #f))))
407
408(define-syntax or
409 (syntax-rules ()
410 ((_) #f)
411 ((_ x) x)
412 ((_ x y ...) (let ((t x)) (if t t (or y ...))))))
413
e7cf0457
MW
414(include-from-path "ice-9/quasisyntax")
415
9accf3d9
AW
416(define-syntax-rule (when test stmt stmt* ...)
417 (if test (begin stmt stmt* ...)))
418
419(define-syntax-rule (unless test stmt stmt* ...)
420 (if (not test) (begin stmt stmt* ...)))
421
a1a482e0 422(define-syntax cond
e7cf0457
MW
423 (lambda (whole-expr)
424 (define (fold f seed xs)
425 (let loop ((xs xs) (seed seed))
426 (if (null? xs) seed
427 (loop (cdr xs) (f (car xs) seed)))))
428 (define (reverse-map f xs)
429 (fold (lambda (x seed) (cons (f x) seed))
430 '() xs))
431 (syntax-case whole-expr ()
432 ((_ clause clauses ...)
433 #`(begin
434 #,@(fold (lambda (clause-builder tail)
435 (clause-builder tail))
436 #'()
437 (reverse-map
438 (lambda (clause)
439 (define* (bad-clause #:optional (msg "invalid clause"))
440 (syntax-violation 'cond msg whole-expr clause))
441 (syntax-case clause (=> else)
442 ((else e e* ...)
443 (lambda (tail)
444 (if (null? tail)
445 #'((begin e e* ...))
446 (bad-clause "else must be the last clause"))))
447 ((else . _) (bad-clause))
448 ((test => receiver)
449 (lambda (tail)
450 #`((let ((t test))
451 (if t
452 (receiver t)
453 #,@tail)))))
454 ((test => receiver ...)
455 (bad-clause "wrong number of receiver expressions"))
456 ((generator guard => receiver)
457 (lambda (tail)
458 #`((call-with-values (lambda () generator)
459 (lambda vals
460 (if (apply guard vals)
461 (apply receiver vals)
462 #,@tail))))))
463 ((generator guard => receiver ...)
464 (bad-clause "wrong number of receiver expressions"))
465 ((test)
466 (lambda (tail)
467 #`((let ((t test))
468 (if t t #,@tail)))))
469 ((test e e* ...)
470 (lambda (tail)
471 #`((if test
472 (begin e e* ...)
473 #,@tail))))
474 (_ (bad-clause))))
475 #'(clause clauses ...))))))))
a1a482e0
AW
476
477(define-syntax case
e7cf0457
MW
478 (lambda (whole-expr)
479 (define (fold f seed xs)
480 (let loop ((xs xs) (seed seed))
481 (if (null? xs) seed
482 (loop (cdr xs) (f (car xs) seed)))))
483 (define (fold2 f a b xs)
484 (let loop ((xs xs) (a a) (b b))
485 (if (null? xs) (values a b)
486 (call-with-values
487 (lambda () (f (car xs) a b))
488 (lambda (a b)
489 (loop (cdr xs) a b))))))
490 (define (reverse-map-with-seed f seed xs)
491 (fold2 (lambda (x ys seed)
492 (call-with-values
493 (lambda () (f x seed))
494 (lambda (y seed)
495 (values (cons y ys) seed))))
496 '() seed xs))
497 (syntax-case whole-expr ()
498 ((_ expr clause clauses ...)
499 (with-syntax ((key #'key))
500 #`(let ((key expr))
501 #,@(fold
502 (lambda (clause-builder tail)
503 (clause-builder tail))
504 #'()
505 (reverse-map-with-seed
506 (lambda (clause seen)
507 (define* (bad-clause #:optional (msg "invalid clause"))
508 (syntax-violation 'case msg whole-expr clause))
509 (syntax-case clause ()
510 ((test . rest)
511 (with-syntax
512 ((clause-expr
513 (syntax-case #'rest (=>)
514 ((=> receiver) #'(receiver key))
515 ((=> receiver ...)
516 (bad-clause
517 "wrong number of receiver expressions"))
518 ((e e* ...) #'(begin e e* ...))
519 (_ (bad-clause)))))
520 (syntax-case #'test (else)
521 ((datums ...)
522 (let ((seen
523 (fold
524 (lambda (datum seen)
525 (define (warn-datum type)
526 ((@ (system base message)
527 warning)
528 type
529 (append (source-properties datum)
530 (source-properties
531 (syntax->datum #'test)))
532 datum
533 (syntax->datum clause)
534 (syntax->datum whole-expr)))
535 (if (memv datum seen)
536 (warn-datum 'duplicate-case-datum))
537 (if (or (pair? datum)
538 (array? datum)
539 (generalized-vector? datum))
540 (warn-datum 'bad-case-datum))
541 (cons datum seen))
542 seen
543 (map syntax->datum #'(datums ...)))))
544 (values (lambda (tail)
545 #`((if (memv key '(datums ...))
546 clause-expr
547 #,@tail)))
548 seen)))
549 (else (values (lambda (tail)
550 (if (null? tail)
551 #'(clause-expr)
552 (bad-clause
553 "else must be the last clause")))
554 seen))
555 (_ (bad-clause)))))
556 (_ (bad-clause))))
557 '() #'(clause clauses ...)))))))))
a1a482e0
AW
558
559(define-syntax do
560 (syntax-rules ()
561 ((do ((var init step ...) ...)
562 (test expr ...)
563 command ...)
564 (letrec
565 ((loop
566 (lambda (var ...)
567 (if test
568 (begin
569 (if #f #f)
570 expr ...)
571 (begin
572 command
573 ...
574 (loop (do "step" var step ...)
575 ...))))))
576 (loop init ...)))
577 ((do "step" x)
578 x)
579 ((do "step" x y)
580 y)))
581
0c65f52c
AW
582(define-syntax-rule (delay exp)
583 (make-promise (lambda () exp)))
79451588 584
41147ee7
AW
585(define-syntax current-source-location
586 (lambda (x)
587 (syntax-case x ()
588 ((_)
589 (with-syntax ((s (datum->syntax x (syntax-source x))))
590 #''s)))))
591
925172cf
AW
592;; We provide this accessor out of convenience. current-line and
593;; current-column aren't so interesting, because they distort what they
594;; are measuring; better to use syntax-source from a macro.
595;;
596(define-syntax current-filename
597 (lambda (x)
598 "A macro that expands to the current filename: the filename that
599the (current-filename) form appears in. Expands to #f if this
600information is unavailable."
21ad60a1
AW
601 (false-if-exception
602 (canonicalize-path (assq-ref (syntax-source x) 'filename)))))
925172cf 603
0c65f52c
AW
604(define-syntax-rule (define-once sym val)
605 (define sym
606 (if (module-locally-bound? (current-module) 'sym) sym val)))
41147ee7 607
a2230b65
AW
608;;; The real versions of `map' and `for-each', with cycle detection, and
609;;; that use reverse! instead of recursion in the case of `map'.
610;;;
611(define map
612 (case-lambda
613 ((f l)
614 (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
615 (if (pair? hare)
616 (if move?
617 (if (eq? tortoise hare)
618 (scm-error 'wrong-type-arg "map" "Circular list: ~S"
619 (list l) #f)
620 (map1 (cdr hare) (cdr tortoise) #f
621 (cons (f (car hare)) out)))
622 (map1 (cdr hare) tortoise #t
623 (cons (f (car hare)) out)))
624 (if (null? hare)
625 (reverse! out)
626 (scm-error 'wrong-type-arg "map" "Not a list: ~S"
627 (list l) #f)))))
628
629 ((f l1 l2)
630 (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
631 (cond
632 ((pair? h1)
633 (cond
634 ((not (pair? h2))
635 (scm-error 'wrong-type-arg "map"
636 (if (list? h2)
637 "List of wrong length: ~S"
638 "Not a list: ~S")
639 (list l2) #f))
640 ((not move?)
641 (map2 (cdr h1) (cdr h2) t1 t2 #t
642 (cons (f (car h1) (car h2)) out)))
643 ((eq? t1 h1)
644 (scm-error 'wrong-type-arg "map" "Circular list: ~S"
645 (list l1) #f))
646 ((eq? t2 h2)
647 (scm-error 'wrong-type-arg "map" "Circular list: ~S"
648 (list l2) #f))
649 (else
650 (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
651 (cons (f (car h1) (car h2)) out)))))
652
653 ((and (null? h1) (null? h2))
654 (reverse! out))
655
656 ((null? h1)
657 (scm-error 'wrong-type-arg "map"
658 (if (list? h2)
659 "List of wrong length: ~S"
660 "Not a list: ~S")
661 (list l2) #f))
662 (else
663 (scm-error 'wrong-type-arg "map"
664 "Not a list: ~S"
665 (list l1) #f)))))
666
667 ((f l1 . rest)
668 (let ((len (length l1)))
669 (let mapn ((rest rest))
670 (or (null? rest)
671 (if (= (length (car rest)) len)
672 (mapn (cdr rest))
673 (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
674 (list (car rest)) #f)))))
675 (let mapn ((l1 l1) (rest rest) (out '()))
676 (if (null? l1)
677 (reverse! out)
678 (mapn (cdr l1) (map cdr rest)
679 (cons (apply f (car l1) (map car rest)) out)))))))
680
681(define map-in-order map)
682
683(define for-each
684 (case-lambda
685 ((f l)
686 (let for-each1 ((hare l) (tortoise l) (move? #f))
687 (if (pair? hare)
688 (if move?
689 (if (eq? tortoise hare)
690 (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
691 (list l) #f)
692 (begin
693 (f (car hare))
694 (for-each1 (cdr hare) (cdr tortoise) #f)))
695 (begin
696 (f (car hare))
697 (for-each1 (cdr hare) tortoise #t)))
698
699 (if (not (null? hare))
700 (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
701 (list l) #f)))))
702
703 ((f l1 l2)
704 (let for-each2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f))
705 (cond
706 ((and (pair? h1) (pair? h2))
707 (cond
708 ((not move?)
709 (f (car h1) (car h2))
710 (for-each2 (cdr h1) (cdr h2) t1 t2 #t))
711 ((eq? t1 h1)
712 (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
713 (list l1) #f))
714 ((eq? t2 h2)
715 (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
716 (list l2) #f))
717 (else
718 (f (car h1) (car h2))
719 (for-each2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f))))
720
721 ((if (null? h1)
722 (or (null? h2) (pair? h2))
723 (and (pair? h1) (null? h2)))
724 (if #f #f))
725
726 ((list? h1)
727 (scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
728 (list h2) #f))
729 (else
730 (scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
731 (list h1) #f)))))
732
733 ((f l1 . rest)
734 (let ((len (length l1)))
735 (let for-eachn ((rest rest))
736 (or (null? rest)
737 (if (= (length (car rest)) len)
738 (for-eachn (cdr rest))
739 (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
740 (list (car rest)) #f)))))
741
742 (let for-eachn ((l1 l1) (rest rest))
743 (if (pair? l1)
744 (begin
745 (apply f (car l1) (map car rest))
746 (for-eachn (cdr l1) (map cdr rest))))))))
747
748
79451588 749\f
48fdec21 750
40b91dc8
AW
751;;;
752;;; Extensible exception printing.
753;;;
754
755(define set-exception-printer! #f)
e8df456a
AW
756;; There is already a definition of print-exception from backtrace.c
757;; that we will override.
40b91dc8
AW
758
759(let ((exception-printers '()))
760 (define (print-location frame port)
761 (let ((source (and=> frame frame-source)))
762 ;; source := (addr . (filename . (line . column)))
763 (if source
764 (let ((filename (or (cadr source) "<unnamed port>"))
765 (line (caddr source))
766 (col (cdddr source)))
153c4a4a 767 (format port "~a:~a:~a: " filename (1+ line) col))
40b91dc8
AW
768 (format port "ERROR: "))))
769
770 (set! set-exception-printer!
771 (lambda (key proc)
772 (set! exception-printers (acons key proc exception-printers))))
773
774 (set! print-exception
775 (lambda (port frame key args)
776 (define (default-printer)
777 (format port "Throw to key `~a' with args `~s'." key args))
778
779 (if frame
780 (let ((proc (frame-procedure frame)))
781 (print-location frame port)
782 (format port "In procedure ~a:\n"
da874e54
AW
783 (or (false-if-exception (procedure-name proc))
784 proc))))
40b91dc8
AW
785
786 (print-location frame port)
787 (catch #t
788 (lambda ()
789 (let ((printer (assq-ref exception-printers key)))
790 (if printer
791 (printer port key args default-printer)
792 (default-printer))))
793 (lambda (k . args)
794 (format port "Error while printing exception.")))
795 (newline port)
796 (force-output port))))
797
798;;;
799;;; Printers for those keys thrown by Guile.
800;;;
801(let ()
802 (define (scm-error-printer port key args default-printer)
803 ;; Abuse case-lambda as a pattern matcher, given that we don't have
804 ;; ice-9 match at this point.
805 (apply (case-lambda
806 ((subr msg args . rest)
807 (if subr
808 (format port "In procedure ~a: " subr))
4e33a132 809 (apply format port msg (or args '())))
40b91dc8
AW
810 (_ (default-printer)))
811 args))
812
813 (define (syntax-error-printer port key args default-printer)
814 (apply (case-lambda
dc20f5a8 815 ((who what where form subform . extra)
40b91dc8
AW
816 (format port "Syntax error:\n")
817 (if where
818 (let ((file (or (assq-ref where 'filename) "unknown file"))
819 (line (and=> (assq-ref where 'line) 1+))
820 (col (assq-ref where 'column)))
821 (format port "~a:~a:~a: " file line col))
822 (format port "unknown location: "))
823 (if who
824 (format port "~a: " who))
825 (format port "~a" what)
826 (if subform
827 (format port " in subform ~s of ~s" subform form)
828 (if form
829 (format port " in form ~s" form))))
830 (_ (default-printer)))
831 args))
832
e7b2efd5
LC
833 (define (getaddrinfo-error-printer port key args default-printer)
834 (format port "In procedure getaddrinfo: ~a" (gai-strerror (car args))))
835
40b91dc8
AW
836 (set-exception-printer! 'goops-error scm-error-printer)
837 (set-exception-printer! 'host-not-found scm-error-printer)
838 (set-exception-printer! 'keyword-argument-error scm-error-printer)
839 (set-exception-printer! 'misc-error scm-error-printer)
840 (set-exception-printer! 'no-data scm-error-printer)
841 (set-exception-printer! 'no-recovery scm-error-printer)
842 (set-exception-printer! 'null-pointer-error scm-error-printer)
843 (set-exception-printer! 'out-of-range scm-error-printer)
844 (set-exception-printer! 'program-error scm-error-printer)
845 (set-exception-printer! 'read-error scm-error-printer)
846 (set-exception-printer! 'regular-expression-syntax scm-error-printer)
847 (set-exception-printer! 'signal scm-error-printer)
848 (set-exception-printer! 'stack-overflow scm-error-printer)
849 (set-exception-printer! 'system-error scm-error-printer)
850 (set-exception-printer! 'try-again scm-error-printer)
851 (set-exception-printer! 'unbound-variable scm-error-printer)
852 (set-exception-printer! 'wrong-number-of-args scm-error-printer)
853 (set-exception-printer! 'wrong-type-arg scm-error-printer)
854
e7b2efd5
LC
855 (set-exception-printer! 'syntax-error syntax-error-printer)
856
857 (set-exception-printer! 'getaddrinfo-error getaddrinfo-error-printer))
40b91dc8
AW
858
859
860\f
861
3d2ada2f
DH
862;;; {Defmacros}
863;;;
3d2ada2f 864
13182603
AW
865(define-syntax define-macro
866 (lambda (x)
97ce9dbf 867 "Define a defmacro."
13182603 868 (syntax-case x ()
97ce9dbf 869 ((_ (macro . args) doc body1 body ...)
a927454d
AW
870 (string? (syntax->datum #'doc))
871 #'(define-macro macro doc (lambda args body1 body ...)))
97ce9dbf 872 ((_ (macro . args) body ...)
a927454d 873 #'(define-macro macro #f (lambda args body ...)))
97ce9dbf 874 ((_ macro doc transformer)
a927454d
AW
875 (or (string? (syntax->datum #'doc))
876 (not (syntax->datum #'doc)))
877 #'(define-syntax macro
878 (lambda (y)
879 doc
a5e95abe
AW
880 #((macro-type . defmacro)
881 (defmacro-args args))
a927454d
AW
882 (syntax-case y ()
883 ((_ . args)
884 (let ((v (syntax->datum #'args)))
885 (datum->syntax y (apply transformer v)))))))))))
13182603
AW
886
887(define-syntax defmacro
888 (lambda (x)
97ce9dbf 889 "Define a defmacro, with the old lispy defun syntax."
13182603 890 (syntax-case x ()
97ce9dbf 891 ((_ macro args doc body1 body ...)
a927454d
AW
892 (string? (syntax->datum #'doc))
893 #'(define-macro macro doc (lambda args body1 body ...)))
97ce9dbf 894 ((_ macro args body ...)
a927454d 895 #'(define-macro macro #f (lambda args body ...))))))
3d2ada2f
DH
896
897(provide 'defmacro)
48fdec21
MV
898
899\f
900
3d2ada2f
DH
901;;; {Deprecation}
902;;;
3d2ada2f 903
ec0f307e
AW
904(define-syntax begin-deprecated
905 (lambda (x)
906 (syntax-case x ()
907 ((_ form form* ...)
908 (if (include-deprecated-features)
909 #'(begin form form* ...)
910 #'(begin))))))
0f2d19dd
JB
911
912\f
3d2ada2f 913
79451588 914;;; {Trivial Functions}
0f2d19dd 915;;;
79451588 916
6b08d75b 917(define (identity x) x)
18f06db9
LC
918
919(define (compose proc . rest)
920 "Compose PROC with the procedures in REST, such that the last one in
921REST is applied first and PROC last, and return the resulting procedure.
922The given procedures must have compatible arity."
923 (if (null? rest)
924 proc
925 (let ((g (apply compose rest)))
926 (lambda args
927 (call-with-values (lambda () (apply g args)) proc)))))
928
929(define (negate proc)
930 "Return a procedure with the same arity as PROC that returns the `not'
931of PROC's result."
932 (lambda args
933 (not (apply proc args))))
934
935(define (const value)
936 "Return a procedure that accepts any number of arguments and returns
937VALUE."
938 (lambda _
939 value))
940
132e5fac 941(define (and=> value procedure) (and value (procedure value)))
e8ed460e 942(define call/cc call-with-current-continuation)
79451588 943
0c65f52c
AW
944(define-syntax-rule (false-if-exception expr)
945 (catch #t
946 (lambda () expr)
947 (lambda (k . args) #f)))
3d2ada2f
DH
948
949\f
950
951;;; {General Properties}
952;;;
953
02b582ce
AW
954;; Properties are a lispy way to associate random info with random objects.
955;; Traditionally properties are implemented as an alist or a plist actually
956;; pertaining to the object in question.
957;;
958;; These "object properties" have the advantage that they can be associated with
959;; any object, even if the object has no plist. Object properties are good when
960;; you are extending pre-existing objects in unexpected ways. They also present
961;; a pleasing, uniform procedure-with-setter interface. But if you have a data
962;; type that always has properties, it's often still best to store those
963;; properties within the object itself.
3d2ada2f
DH
964
965(define (make-object-property)
0c65f52c
AW
966 (define-syntax-rule (with-mutex lock exp)
967 (dynamic-wind (lambda () (lock-mutex lock))
968 (lambda () exp)
969 (lambda () (unlock-mutex lock))))
79488112
AW
970 (let ((prop (make-weak-key-hash-table))
971 (lock (make-mutex)))
3d2ada2f 972 (make-procedure-with-setter
79488112
AW
973 (lambda (obj) (with-mutex lock (hashq-ref prop obj)))
974 (lambda (obj val) (with-mutex lock (hashq-set! prop obj val))))))
975
3d2ada2f 976
0f2d19dd 977\f
6b08d75b 978
0f2d19dd
JB
979;;; {Symbol Properties}
980;;;
981
02b582ce
AW
982;;; Symbol properties are something you see in old Lisp code. In most current
983;;; Guile code, symbols are not used as a data structure -- they are used as
984;;; keys into other data structures.
985
0f2d19dd
JB
986(define (symbol-property sym prop)
987 (let ((pair (assoc prop (symbol-pref sym))))
988 (and pair (cdr pair))))
989
990(define (set-symbol-property! sym prop val)
991 (let ((pair (assoc prop (symbol-pref sym))))
992 (if pair
9b5a0d84
AW
993 (set-cdr! pair val)
994 (symbol-pset! sym (acons prop val (symbol-pref sym))))))
0f2d19dd
JB
995
996(define (symbol-property-remove! sym prop)
997 (let ((pair (assoc prop (symbol-pref sym))))
998 (if pair
9b5a0d84 999 (symbol-pset! sym (delq! pair (symbol-pref sym))))))
0f2d19dd
JB
1000
1001\f
1e531c3a 1002
0f2d19dd
JB
1003;;; {Arrays}
1004;;;
1005
2042e178
MV
1006(define (array-shape a)
1007 (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
1008 (array-dimensions a)))
0f2d19dd
JB
1009
1010\f
3d2ada2f 1011
0f2d19dd
JB
1012;;; {Keywords}
1013;;;
1014
010b159f
AW
1015;;; It's much better if you can use lambda* / define*, of course.
1016
0f2d19dd
JB
1017(define (kw-arg-ref args kw)
1018 (let ((rem (member kw args)))
1019 (and rem (pair? (cdr rem)) (cadr rem))))
1020
1021\f
fa7e9274 1022
9f9aa47b 1023;;; {Structs}
3d2ada2f 1024;;;
fa7e9274
MV
1025
1026(define (struct-layout s)
9f9aa47b 1027 (struct-ref (struct-vtable s) vtable-index-layout))
fa7e9274
MV
1028
1029\f
d7faeb2e 1030
0f2d19dd
JB
1031;;; {Records}
1032;;;
1033
fa7e9274
MV
1034;; Printing records: by default, records are printed as
1035;;
1036;; #<type-name field1: val1 field2: val2 ...>
1037;;
1038;; You can change that by giving a custom printing function to
1039;; MAKE-RECORD-TYPE (after the list of field symbols). This function
1040;; will be called like
1041;;
1042;; (<printer> object port)
1043;;
1044;; It should print OBJECT to PORT.
1045
cf8f1a90 1046(define (inherit-print-state old-port new-port)
8a30733e
MD
1047 (if (get-print-state old-port)
1048 (port-with-print-state new-port (get-print-state old-port))
cf8f1a90
MV
1049 new-port))
1050
e31f22eb 1051;; 0: type-name, 1: fields, 2: constructor
20edfbbd 1052(define record-type-vtable
581bd72a
AW
1053 (let ((s (make-vtable (string-append standard-vtable-fields "prprpw")
1054 (lambda (s p)
1055 (display "#<record-type " p)
1056 (display (record-type-name s) p)
1057 (display ">" p)))))
1058 (set-struct-vtable-name! s 'record-type)
1059 s))
0f2d19dd
JB
1060
1061(define (record-type? obj)
1062 (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
1063
b2669c41 1064(define* (make-record-type type-name fields #:optional printer)
31ac29b6 1065 ;; Pre-generate constructors for nfields < 20.
e31f22eb
AW
1066 (define-syntax make-constructor
1067 (lambda (x)
1068 (define *max-static-argument-count* 20)
1069 (define (make-formals n)
1070 (let lp ((i 0))
1071 (if (< i n)
1072 (cons (datum->syntax
1073 x
1074 (string->symbol
1075 (string (integer->char (+ (char->integer #\a) i)))))
1076 (lp (1+ i)))
1077 '())))
1078 (syntax-case x ()
1079 ((_ rtd exp) (not (identifier? #'exp))
1080 #'(let ((n exp))
1081 (make-constructor rtd n)))
1082 ((_ rtd nfields)
1083 #`(case nfields
1084 #,@(let lp ((n 0))
1085 (if (< n *max-static-argument-count*)
1086 (cons (with-syntax (((formal ...) (make-formals n))
1087 (n n))
1088 #'((n)
1089 (lambda (formal ...)
1090 (make-struct rtd 0 formal ...))))
1091 (lp (1+ n)))
1092 '()))
1093 (else
1094 (lambda args
1095 (if (= (length args) nfields)
1096 (apply make-struct rtd 0 args)
1097 (scm-error 'wrong-number-of-args
1098 (format #f "make-~a" type-name)
1099 "Wrong number of arguments" '() #f)))))))))
1100
51797cec
AW
1101 (define (default-record-printer s p)
1102 (display "#<" p)
1103 (display (record-type-name (record-type-descriptor s)) p)
1104 (let loop ((fields (record-type-fields (record-type-descriptor s)))
1105 (off 0))
1106 (cond
1107 ((not (null? fields))
1108 (display " " p)
1109 (display (car fields) p)
1110 (display ": " p)
1111 (display (struct-ref s off) p)
1112 (loop (cdr fields) (+ 1 off)))))
1113 (display ">" p))
1114
e31f22eb
AW
1115 (let ((rtd (make-struct record-type-vtable 0
1116 (make-struct-layout
1117 (apply string-append
1118 (map (lambda (f) "pw") fields)))
b2669c41 1119 (or printer default-record-printer)
e31f22eb
AW
1120 type-name
1121 (copy-tree fields))))
1122 (struct-set! rtd (+ vtable-offset-user 2)
1123 (make-constructor rtd (length fields)))
51797cec
AW
1124 ;; Temporary solution: Associate a name to the record type descriptor
1125 ;; so that the object system can create a wrapper class for it.
e31f22eb
AW
1126 (set-struct-vtable-name! rtd (if (symbol? type-name)
1127 type-name
1128 (string->symbol type-name)))
1129 rtd))
0f2d19dd
JB
1130
1131(define (record-type-name obj)
1132 (if (record-type? obj)
9f9aa47b 1133 (struct-ref obj vtable-offset-user)
0f2d19dd
JB
1134 (error 'not-a-record-type obj)))
1135
1136(define (record-type-fields obj)
1137 (if (record-type? obj)
9f9aa47b 1138 (struct-ref obj (+ 1 vtable-offset-user))
0f2d19dd
JB
1139 (error 'not-a-record-type obj)))
1140
d44a0d12
AW
1141(define* (record-constructor rtd #:optional field-names)
1142 (if (not field-names)
e31f22eb 1143 (struct-ref rtd (+ 2 vtable-offset-user))
d44a0d12
AW
1144 (primitive-eval
1145 `(lambda ,field-names
1146 (make-struct ',rtd 0 ,@(map (lambda (f)
1147 (if (memq f field-names)
1148 f
1149 #f))
1150 (record-type-fields rtd)))))))
3bf27608 1151
0f2d19dd
JB
1152(define (record-predicate rtd)
1153 (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
1154
3ba9acb1 1155(define (%record-type-error rtd obj) ;; private helper
afc4ccd4
KR
1156 (or (eq? rtd (record-type-descriptor obj))
1157 (scm-error 'wrong-type-arg "%record-type-check"
9b5a0d84
AW
1158 "Wrong type record (want `~S'): ~S"
1159 (list (record-type-name rtd) obj)
1160 #f)))
afc4ccd4 1161
0f2d19dd 1162(define (record-accessor rtd field-name)
3bf27608 1163 (let ((pos (list-index (record-type-fields rtd) field-name)))
0f2d19dd 1164 (if (not pos)
9b5a0d84 1165 (error 'no-such-field field-name))
3bf27608
AW
1166 (lambda (obj)
1167 (if (eq? (struct-vtable obj) rtd)
1168 (struct-ref obj pos)
1169 (%record-type-error rtd obj)))))
0f2d19dd
JB
1170
1171(define (record-modifier rtd field-name)
3bf27608 1172 (let ((pos (list-index (record-type-fields rtd) field-name)))
0f2d19dd 1173 (if (not pos)
9b5a0d84 1174 (error 'no-such-field field-name))
3bf27608
AW
1175 (lambda (obj val)
1176 (if (eq? (struct-vtable obj) rtd)
1177 (struct-set! obj pos val)
1178 (%record-type-error rtd obj)))))
0f2d19dd
JB
1179
1180(define (record? obj)
1181 (and (struct? obj) (record-type? (struct-vtable obj))))
1182
1183(define (record-type-descriptor obj)
1184 (if (struct? obj)
1185 (struct-vtable obj)
1186 (error 'not-a-record obj)))
1187
21ed9efe
MD
1188(provide 'record)
1189
0f2d19dd 1190\f
3d2ada2f 1191
0f2d19dd
JB
1192;;; {Booleans}
1193;;;
1194
1195(define (->bool x) (not (not x)))
1196
1197\f
3d2ada2f 1198
0f2d19dd
JB
1199;;; {Symbols}
1200;;;
1201
1202(define (symbol-append . args)
06f0414c 1203 (string->symbol (apply string-append (map symbol->string args))))
0f2d19dd
JB
1204
1205(define (list->symbol . args)
1206 (string->symbol (apply list->string args)))
1207
1208(define (symbol . args)
1209 (string->symbol (apply string args)))
1210
0f2d19dd 1211\f
3d2ada2f 1212
0f2d19dd
JB
1213;;; {Lists}
1214;;;
1215
1216(define (list-index l k)
1217 (let loop ((n 0)
9b5a0d84 1218 (l l))
0f2d19dd 1219 (and (not (null? l))
9b5a0d84
AW
1220 (if (eq? (car l) k)
1221 n
1222 (loop (+ n 1) (cdr l))))))
0f2d19dd 1223
1729d8ff 1224\f
3d2ada2f 1225
073167ef
LC
1226;; Load `posix.scm' even when not (provided? 'posix) so that we get the
1227;; `stat' accessors.
1228(primitive-load-path "ice-9/posix")
6fa8995c 1229
52cfc69b 1230(if (provided? 'socket)
1e6ebf54 1231 (primitive-load-path "ice-9/networking"))
3afb28ce 1232
f3197274 1233;; For reference, Emacs file-exists-p uses stat in this same way.
6fa8995c 1234(define file-exists?
52cfc69b 1235 (if (provided? 'posix)
6fa8995c 1236 (lambda (str)
9b5a0d84 1237 (->bool (stat str #f)))
6fa8995c 1238 (lambda (str)
9b5a0d84
AW
1239 (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
1240 (lambda args #f))))
1241 (if port (begin (close-port port) #t)
1242 #f)))))
6fa8995c
GH
1243
1244(define file-is-directory?
52cfc69b 1245 (if (provided? 'posix)
6fa8995c 1246 (lambda (str)
9b5a0d84 1247 (eq? (stat:type (stat str)) 'directory))
6fa8995c 1248 (lambda (str)
9b5a0d84
AW
1249 (let ((port (catch 'system-error
1250 (lambda () (open-file (string-append str "/.")
1251 OPEN_READ))
1252 (lambda args #f))))
1253 (if port (begin (close-port port) #t)
1254 #f)))))
0f2d19dd 1255
019ac1c9
MV
1256(define (system-error-errno args)
1257 (if (eq? (car args) 'system-error)
1258 (car (list-ref args 4))
1259 #f))
1260
0f2d19dd 1261\f
3d2ada2f 1262
0f2d19dd
JB
1263;;; {Error Handling}
1264;;;
1265
4eeaf67c
AW
1266(define error
1267 (case-lambda
1268 (()
4eeaf67c
AW
1269 (scm-error 'misc-error #f "?" #f #f))
1270 ((message . args)
4eeaf67c
AW
1271 (let ((msg (string-join (cons "~A" (make-list (length args) "~S")))))
1272 (scm-error 'misc-error #f msg (cons message args) #f)))))
be2d2c70 1273
0f2d19dd 1274\f
bce074ee 1275
b38507c1
AW
1276;;; {Time Structures}
1277;;;
1278
708bf0f3
GH
1279(define (tm:sec obj) (vector-ref obj 0))
1280(define (tm:min obj) (vector-ref obj 1))
1281(define (tm:hour obj) (vector-ref obj 2))
1282(define (tm:mday obj) (vector-ref obj 3))
1283(define (tm:mon obj) (vector-ref obj 4))
1284(define (tm:year obj) (vector-ref obj 5))
1285(define (tm:wday obj) (vector-ref obj 6))
1286(define (tm:yday obj) (vector-ref obj 7))
1287(define (tm:isdst obj) (vector-ref obj 8))
1288(define (tm:gmtoff obj) (vector-ref obj 9))
1289(define (tm:zone obj) (vector-ref obj 10))
1290
1291(define (set-tm:sec obj val) (vector-set! obj 0 val))
1292(define (set-tm:min obj val) (vector-set! obj 1 val))
1293(define (set-tm:hour obj val) (vector-set! obj 2 val))
1294(define (set-tm:mday obj val) (vector-set! obj 3 val))
1295(define (set-tm:mon obj val) (vector-set! obj 4 val))
1296(define (set-tm:year obj val) (vector-set! obj 5 val))
1297(define (set-tm:wday obj val) (vector-set! obj 6 val))
1298(define (set-tm:yday obj val) (vector-set! obj 7 val))
1299(define (set-tm:isdst obj val) (vector-set! obj 8 val))
1300(define (set-tm:gmtoff obj val) (vector-set! obj 9 val))
1301(define (set-tm:zone obj val) (vector-set! obj 10 val))
1302
6afcd3b2
GH
1303(define (tms:clock obj) (vector-ref obj 0))
1304(define (tms:utime obj) (vector-ref obj 1))
1305(define (tms:stime obj) (vector-ref obj 2))
1306(define (tms:cutime obj) (vector-ref obj 3))
1307(define (tms:cstime obj) (vector-ref obj 4))
1308
b38507c1
AW
1309\f
1310
1311;;; {File Descriptors and Ports}
1312;;;
1313
1334c61a 1314(define file-position ftell)
52c9a338
AW
1315(define* (file-set-position port offset #:optional (whence SEEK_SET))
1316 (seek port offset whence))
8b13c6b3 1317
e38303a2
GH
1318(define (move->fdes fd/port fd)
1319 (cond ((integer? fd/port)
9b5a0d84
AW
1320 (dup->fdes fd/port fd)
1321 (close fd/port)
1322 fd)
1323 (else
1324 (primitive-move->fdes fd/port fd)
1325 (set-port-revealed! fd/port 1)
1326 fd/port)))
8b13c6b3
GH
1327
1328(define (release-port-handle port)
1329 (let ((revealed (port-revealed port)))
1330 (if (> revealed 0)
9b5a0d84 1331 (set-port-revealed! port (- revealed 1)))))
0f2d19dd 1332
02851b26
AW
1333(define dup->port
1334 (case-lambda
1335 ((port/fd mode)
1336 (fdopen (dup->fdes port/fd) mode))
1337 ((port/fd mode new-fd)
1338 (let ((port (fdopen (dup->fdes port/fd new-fd) mode)))
1339 (set-port-revealed! port 1)
1340 port))))
1341
1342(define dup->inport
1343 (case-lambda
1344 ((port/fd)
1345 (dup->port port/fd "r"))
1346 ((port/fd new-fd)
1347 (dup->port port/fd "r" new-fd))))
1348
1349(define dup->outport
1350 (case-lambda
1351 ((port/fd)
1352 (dup->port port/fd "w"))
1353 ((port/fd new-fd)
1354 (dup->port port/fd "w" new-fd))))
1355
1356(define dup
1357 (case-lambda
1358 ((port/fd)
1359 (if (integer? port/fd)
1360 (dup->fdes port/fd)
1361 (dup->port port/fd (port-mode port/fd))))
1362 ((port/fd new-fd)
1363 (if (integer? port/fd)
1364 (dup->fdes port/fd new-fd)
1365 (dup->port port/fd (port-mode port/fd) new-fd)))))
e38303a2
GH
1366
1367(define (duplicate-port port modes)
1368 (dup->port port modes))
1369
1370(define (fdes->inport fdes)
1371 (let loop ((rest-ports (fdes->ports fdes)))
1372 (cond ((null? rest-ports)
9b5a0d84
AW
1373 (let ((result (fdopen fdes "r")))
1374 (set-port-revealed! result 1)
1375 result))
1376 ((input-port? (car rest-ports))
1377 (set-port-revealed! (car rest-ports)
1378 (+ (port-revealed (car rest-ports)) 1))
1379 (car rest-ports))
1380 (else
1381 (loop (cdr rest-ports))))))
e38303a2
GH
1382
1383(define (fdes->outport fdes)
1384 (let loop ((rest-ports (fdes->ports fdes)))
1385 (cond ((null? rest-ports)
9b5a0d84
AW
1386 (let ((result (fdopen fdes "w")))
1387 (set-port-revealed! result 1)
1388 result))
1389 ((output-port? (car rest-ports))
1390 (set-port-revealed! (car rest-ports)
1391 (+ (port-revealed (car rest-ports)) 1))
1392 (car rest-ports))
1393 (else
1394 (loop (cdr rest-ports))))))
e38303a2
GH
1395
1396(define (port->fdes port)
1397 (set-port-revealed! port (+ (port-revealed port) 1))
1398 (fileno port))
1399
956055a9
GH
1400(define (setenv name value)
1401 (if value
1402 (putenv (string-append name "=" value))
1403 (putenv name)))
1404
5c1254da
MV
1405(define (unsetenv name)
1406 "Remove the entry for NAME from the environment."
1407 (putenv name))
1408
0f2d19dd 1409\f
3d2ada2f 1410
0f2d19dd
JB
1411;;; {Load Paths}
1412;;;
1413
3cab8392
JB
1414(define (in-vicinity vicinity file)
1415 (let ((tail (let ((len (string-length vicinity)))
9b5a0d84
AW
1416 (if (zero? len)
1417 #f
1418 (string-ref vicinity (- len 1))))))
3cab8392 1419 (string-append vicinity
9b5a0d84
AW
1420 (if (or (not tail)
1421 (eq? tail #\/))
1422 ""
1423 "/")
1424 file)))
02ceadb8 1425
0f2d19dd 1426\f
3d2ada2f 1427
ef00e7f4 1428;;; {Help for scm_shell}
3d2ada2f 1429;;;
ef00e7f4
JB
1430;;; The argument-processing code used by Guile-based shells generates
1431;;; Scheme code based on the argument list. This page contains help
1432;;; functions for the code it generates.
3d2ada2f 1433;;;
ef00e7f4 1434
ef00e7f4
JB
1435(define (command-line) (program-arguments))
1436
5aa7fe69
JB
1437;; This is mostly for the internal use of the code generated by
1438;; scm_compile_shell_switches.
eef6519b 1439
ef00e7f4 1440(define (load-user-init)
1f08acd9 1441 (let* ((home (or (getenv "HOME")
9b5a0d84
AW
1442 (false-if-exception (passwd:dir (getpwuid (getuid))))
1443 "/")) ;; fallback for cygwin etc.
1444 (init-file (in-vicinity home ".guile")))
1f08acd9 1445 (if (file-exists? init-file)
9b5a0d84 1446 (primitive-load init-file))))
ef00e7f4
JB
1447
1448\f
3d2ada2f 1449
107139ea
AW
1450;;; {The interpreter stack}
1451;;;
1452
06dcb9df 1453;; %stacks defined in stacks.c
a6cd3555 1454(define (%start-stack tag thunk)
8fc43b12
AW
1455 (let ((prompt-tag (make-prompt-tag "start-stack")))
1456 (call-with-prompt
1457 prompt-tag
1458 (lambda ()
1459 (with-fluids ((%stacks (acons tag prompt-tag
1460 (or (fluid-ref %stacks) '()))))
1461 (thunk)))
1462 (lambda (k . args)
52738540 1463 (%start-stack tag (lambda () (apply k args)))))))
0c65f52c
AW
1464
1465(define-syntax-rule (start-stack tag exp)
1466 (%start-stack tag (lambda () exp)))
107139ea
AW
1467
1468\f
1469
a06181a2 1470;;; {Loading by paths}
3d2ada2f 1471;;;
a06181a2
JB
1472
1473;;; Load a Scheme source file named NAME, searching for it in the
1474;;; directories listed in %load-path, and applying each of the file
1475;;; name extensions listed in %load-extensions.
1476(define (load-from-path name)
1477 (start-stack 'load-stack
9b5a0d84 1478 (primitive-load-path name)))
0f2d19dd 1479
925172cf
AW
1480(define-syntax-rule (add-to-load-path elt)
1481 "Add ELT to Guile's load path, at compile-time and at run-time."
21ad60a1
AW
1482 (eval-when (compile load eval)
1483 (set! %load-path (cons elt %load-path))))
925172cf 1484
85e95b47
AW
1485(define %load-verbosely #f)
1486(define (assert-load-verbosity v) (set! %load-verbosely v))
1487
1488(define (%load-announce file)
1489 (if %load-verbosely
2c27dd57 1490 (with-output-to-port (current-warning-port)
9b5a0d84
AW
1491 (lambda ()
1492 (display ";;; ")
1493 (display "loading ")
1494 (display file)
1495 (newline)
1496 (force-output)))))
85e95b47
AW
1497
1498(set! %load-hook %load-announce)
1499
0f2d19dd 1500\f
3d2ada2f 1501
0f2d19dd
JB
1502;;; {Reader Extensions}
1503;;;
0f2d19dd
JB
1504;;; Reader code for various "#c" forms.
1505;;;
1506
9447207f 1507(define read-eval? (make-fluid #f))
600c9584
RB
1508(read-hash-extend #\.
1509 (lambda (c port)
1510 (if (fluid-ref read-eval?)
1511 (eval (read port) (interaction-environment))
1512 (error
71335c0d 1513 "#. read expansion found and read-eval? is #f."))))
75a97b92 1514
0f2d19dd 1515\f
3d2ada2f 1516
0f2d19dd
JB
1517;;; {Low Level Modules}
1518;;;
1519;;; These are the low level data structures for modules.
1520;;;
37f5dfe5
DH
1521;;; Every module object is of the type 'module-type', which is a record
1522;;; consisting of the following members:
1523;;;
2de74cb5 1524;;; - eval-closure: A deprecated field, to be removed in Guile 2.2.
37f5dfe5
DH
1525;;;
1526;;; - obarray: a hash table that maps symbols to variable objects. In this
1527;;; hash table, the definitions are found that are local to the module (that
1528;;; is, not imported from other modules). When looking up bindings in the
1529;;; module, this hash table is searched first.
1530;;;
1531;;; - binder: either #f or a function taking a module and a symbol argument.
1532;;; If it is a function it is called after the obarray has been
1533;;; unsuccessfully searched for a binding. It then can provide bindings
1534;;; that would otherwise not be found locally in the module.
1535;;;
1536;;; - uses: a list of modules from which non-local bindings can be inherited.
1537;;; These modules are the third place queried for bindings after the obarray
1538;;; has been unsuccessfully searched and the binder function did not deliver
1539;;; a result either.
1540;;;
1541;;; - transformer: either #f or a function taking a scheme expression as
1542;;; delivered by read. If it is a function, it will be called to perform
1543;;; syntax transformations (e. g. makro expansion) on the given scheme
1544;;; expression. The output of the transformer function will then be passed
1545;;; to Guile's internal memoizer. This means that the output must be valid
1546;;; scheme code. The only exception is, that the output may make use of the
1547;;; syntax extensions provided to identify the modules that a binding
1548;;; belongs to.
1549;;;
1550;;; - name: the name of the module. This is used for all kinds of printing
1551;;; outputs. In certain places the module name also serves as a way of
1552;;; identification. When adding a module to the uses list of another
1553;;; module, it is made sure that the new uses list will not contain two
1554;;; modules of the same name.
1555;;;
1556;;; - kind: classification of the kind of module. The value is (currently?)
1557;;; only used for printing. It has no influence on how a module is treated.
1558;;; Currently the following values are used when setting the module kind:
1559;;; 'module, 'directory, 'interface, 'custom-interface. If no explicit kind
1560;;; is set, it defaults to 'module.
1561;;;
608860a5
LC
1562;;; - duplicates-handlers: a list of procedures that get called to make a
1563;;; choice between two duplicate bindings when name clashes occur. See the
1564;;; `duplicate-handlers' global variable below.
37f5dfe5 1565;;;
608860a5
LC
1566;;; - observers: a list of procedures that get called when the module is
1567;;; modified.
37f5dfe5 1568;;;
608860a5
LC
1569;;; - weak-observers: a weak-key hash table of procedures that get called
1570;;; when the module is modified. See `module-observe-weak' for details.
37f5dfe5
DH
1571;;;
1572;;; In addition, the module may (must?) contain a binding for
608860a5
LC
1573;;; `%module-public-interface'. This variable should be bound to a module
1574;;; representing the exported interface of a module. See the
1575;;; `module-public-interface' and `module-export!' procedures.
37f5dfe5 1576;;;
0f2d19dd
JB
1577;;; !!! warning: The interface to lazy binder procedures is going
1578;;; to be changed in an incompatible way to permit all the basic
1579;;; module ops to be virtualized.
1580;;;
1581;;; (make-module size use-list lazy-binding-proc) => module
1582;;; module-{obarray,uses,binder}[|-set!]
1583;;; (module? obj) => [#t|#f]
1584;;; (module-locally-bound? module symbol) => [#t|#f]
1585;;; (module-bound? module symbol) => [#t|#f]
1586;;; (module-symbol-locally-interned? module symbol) => [#t|#f]
1587;;; (module-symbol-interned? module symbol) => [#t|#f]
1588;;; (module-local-variable module symbol) => [#<variable ...> | #f]
1589;;; (module-variable module symbol) => [#<variable ...> | #f]
1590;;; (module-symbol-binding module symbol opt-value)
9b5a0d84 1591;;; => [ <obj> | opt-value | an error occurs ]
0f2d19dd
JB
1592;;; (module-make-local-var! module symbol) => #<variable...>
1593;;; (module-add! module symbol var) => unspecified
1594;;; (module-remove! module symbol) => unspecified
1595;;; (module-for-each proc module) => unspecified
1596;;; (make-scm-module) => module ; a lazy copy of the symhash module
1597;;; (set-current-module module) => unspecified
1598;;; (current-module) => #<module...>
1599;;;
1600;;;
1601
1602\f
3d2ada2f 1603
44cf1f0f 1604;;; {Printing Modules}
3d2ada2f
DH
1605;;;
1606
44cf1f0f 1607;; This is how modules are printed. You can re-define it.
31ac29b6 1608(define (%print-module mod port)
0f2d19dd
JB
1609 (display "#<" port)
1610 (display (or (module-kind mod) "module") port)
dc1eed52
AW
1611 (display " " port)
1612 (display (module-name mod) port)
0f2d19dd
JB
1613 (display " " port)
1614 (display (number->string (object-address mod) 16) port)
1615 (display ">" port))
1616
31ac29b6
AW
1617(letrec-syntax
1618 ;; Locally extend the syntax to allow record accessors to be defined at
1619 ;; compile-time. Cache the rtd locally to the constructor, the getters and
1620 ;; the setters, in order to allow for redefinition of the record type; not
1621 ;; relevant in the case of modules, but perhaps if we make this public, it
1622 ;; could matter.
1623
1624 ((define-record-type
1625 (lambda (x)
1626 (define (make-id scope . fragments)
1627 (datum->syntax #'scope
1628 (apply symbol-append
1629 (map (lambda (x)
1630 (if (symbol? x) x (syntax->datum x)))
1631 fragments))))
1632
1633 (define (getter rtd type-name field slot)
1634 #`(define #,(make-id rtd type-name '- field)
1635 (let ((rtd #,rtd))
1636 (lambda (#,type-name)
1637 (if (eq? (struct-vtable #,type-name) rtd)
1638 (struct-ref #,type-name #,slot)
1639 (%record-type-error rtd #,type-name))))))
1640
1641 (define (setter rtd type-name field slot)
1642 #`(define #,(make-id rtd 'set- type-name '- field '!)
1643 (let ((rtd #,rtd))
1644 (lambda (#,type-name val)
1645 (if (eq? (struct-vtable #,type-name) rtd)
1646 (struct-set! #,type-name #,slot val)
1647 (%record-type-error rtd #,type-name))))))
1648
1649 (define (accessors rtd type-name fields n exp)
1650 (syntax-case fields ()
1651 (() exp)
1652 (((field #:no-accessors) field* ...) (identifier? #'field)
1653 (accessors rtd type-name #'(field* ...) (1+ n)
1654 exp))
1655 (((field #:no-setter) field* ...) (identifier? #'field)
1656 (accessors rtd type-name #'(field* ...) (1+ n)
1657 #`(begin #,exp
1658 #,(getter rtd type-name #'field n))))
1659 (((field #:no-getter) field* ...) (identifier? #'field)
1660 (accessors rtd type-name #'(field* ...) (1+ n)
1661 #`(begin #,exp
1662 #,(setter rtd type-name #'field n))))
1663 ((field field* ...) (identifier? #'field)
1664 (accessors rtd type-name #'(field* ...) (1+ n)
1665 #`(begin #,exp
1666 #,(getter rtd type-name #'field n)
1667 #,(setter rtd type-name #'field n))))))
1668
1669 (define (predicate rtd type-name fields exp)
1670 (accessors
1671 rtd type-name fields 0
1672 #`(begin
1673 #,exp
1674 (define (#,(make-id rtd type-name '?) obj)
1675 (and (struct? obj) (eq? (struct-vtable obj) #,rtd))))))
1676
1677 (define (field-list fields)
1678 (syntax-case fields ()
1679 (() '())
1680 (((f . opts) . rest) (identifier? #'f)
1681 (cons #'f (field-list #'rest)))
1682 ((f . rest) (identifier? #'f)
1683 (cons #'f (field-list #'rest)))))
1684
1685 (define (constructor rtd type-name fields exp)
1686 (let ((ctor (make-id rtd type-name '-constructor))
1687 (args (field-list fields)))
1688 (predicate rtd type-name fields
1689 #`(begin #,exp
1690 (define #,ctor
1691 (let ((rtd #,rtd))
1692 (lambda #,args
1693 (make-struct rtd 0 #,@args))))
1694 (struct-set! #,rtd (+ vtable-offset-user 2)
1695 #,ctor)))))
1696
1697 (define (type type-name printer fields)
1698 (define (make-layout)
1699 (let lp ((fields fields) (slots '()))
1700 (syntax-case fields ()
1701 (() (datum->syntax #'here
1702 (make-struct-layout
1703 (apply string-append slots))))
1704 ((_ . rest) (lp #'rest (cons "pw" slots))))))
1705
1706 (let ((rtd (make-id type-name type-name '-type)))
1707 (constructor rtd type-name fields
1708 #`(begin
1709 (define #,rtd
1710 (make-struct record-type-vtable 0
1711 '#,(make-layout)
1712 #,printer
1713 '#,type-name
1714 '#,(field-list fields)))
1715 (set-struct-vtable-name! #,rtd '#,type-name)))))
1716
1717 (syntax-case x ()
1718 ((_ type-name printer (field ...))
1719 (type #'type-name #'printer #'(field ...)))))))
1720
1721 ;; module-type
1722 ;;
1723 ;; A module is characterized by an obarray in which local symbols
1724 ;; are interned, a list of modules, "uses", from which non-local
1725 ;; bindings can be inherited, and an optional lazy-binder which
1726 ;; is a (CLOSURE module symbol) which, as a last resort, can provide
1727 ;; bindings that would otherwise not be found locally in the module.
1728 ;;
1729 ;; NOTE: If you change the set of fields or their order, you also need to
1730 ;; change the constants in libguile/modules.h.
1731 ;;
31ac29b6
AW
1732 ;; NOTE: The getter `module-transfomer' is defined libguile/modules.c.
1733 ;; NOTE: The getter `module-name' is defined later, due to boot reasons.
4e48b495 1734 ;; NOTE: The getter `module-public-interface' is used in libguile/modules.c.
31ac29b6
AW
1735 ;;
1736 (define-record-type module
1737 (lambda (obj port) (%print-module obj port))
1738 (obarray
1739 uses
1740 binder
1741 eval-closure
1742 (transformer #:no-getter)
1743 (name #:no-getter)
1744 kind
1745 duplicates-handlers
1746 (import-obarray #:no-setter)
1747 observers
1748 (weak-observers #:no-setter)
f905381d 1749 version
81fc66cf 1750 submodules
4e48b495 1751 submodule-binder
78f79f18
AW
1752 public-interface
1753 filename)))
31ac29b6 1754
0f2d19dd 1755
8b718458 1756;; make-module &opt size uses binder
0f2d19dd 1757;;
8b718458
JB
1758;; Create a new module, perhaps with a particular size of obarray,
1759;; initial uses list, or binding procedure.
0f2d19dd 1760;;
e9729cbb
AW
1761(define* (make-module #:optional (size 31) (uses '()) (binder #f))
1762 (define %default-import-size
1763 ;; Typical number of imported bindings actually used by a module.
1764 600)
1765
1766 (if (not (integer? size))
1767 (error "Illegal size to make-module." size))
1768 (if (not (and (list? uses)
1769 (and-map module? uses)))
1770 (error "Incorrect use list." uses))
1771 (if (and binder (not (procedure? binder)))
1772 (error
1773 "Lazy-binder expected to be a procedure or #f." binder))
1774
2de74cb5
AW
1775 (module-constructor (make-hash-table size)
1776 uses binder #f macroexpand
1777 #f #f #f
1778 (make-hash-table %default-import-size)
1779 '()
1780 (make-weak-key-hash-table 31) #f
1781 (make-hash-table 7) #f #f #f))
0f2d19dd 1782
8b718458 1783
0f2d19dd 1784\f
3d2ada2f 1785
1777c18b
MD
1786;;; {Observer protocol}
1787;;;
1788
1789(define (module-observe module proc)
1790 (set-module-observers! module (cons proc (module-observers module)))
1791 (cons module proc))
1792
723ae5b3 1793(define* (module-observe-weak module observer-id #:optional (proc observer-id))
608860a5
LC
1794 ;; Register PROC as an observer of MODULE under name OBSERVER-ID (which can
1795 ;; be any Scheme object). PROC is invoked and passed MODULE any time
1796 ;; MODULE is modified. PROC gets unregistered when OBSERVER-ID gets GC'd
1797 ;; (thus, it is never unregistered if OBSERVER-ID is an immediate value,
1798 ;; for instance).
1799
1800 ;; The two-argument version is kept for backward compatibility: when called
1801 ;; with two arguments, the observer gets unregistered when closure PROC
1802 ;; gets GC'd (making it impossible to use an anonymous lambda for PROC).
723ae5b3 1803 (hashq-set! (module-weak-observers module) observer-id proc))
1777c18b
MD
1804
1805(define (module-unobserve token)
1806 (let ((module (car token))
9b5a0d84 1807 (id (cdr token)))
1777c18b 1808 (if (integer? id)
9b5a0d84
AW
1809 (hash-remove! (module-weak-observers module) id)
1810 (set-module-observers! module (delq1! id (module-observers module)))))
1777c18b
MD
1811 *unspecified*)
1812
d57da08b 1813(define module-defer-observers #f)
03d6cddc 1814(define module-defer-observers-mutex (make-mutex 'recursive))
d57da08b
MD
1815(define module-defer-observers-table (make-hash-table))
1816
1a961d7e 1817(define (module-modified m)
d57da08b
MD
1818 (if module-defer-observers
1819 (hash-set! module-defer-observers-table m #t)
1820 (module-call-observers m)))
1821
1822;;; This function can be used to delay calls to observers so that they
1823;;; can be called once only in the face of massive updating of modules.
1824;;;
1825(define (call-with-deferred-observers thunk)
1826 (dynamic-wind
1827 (lambda ()
9b5a0d84
AW
1828 (lock-mutex module-defer-observers-mutex)
1829 (set! module-defer-observers #t))
d57da08b
MD
1830 thunk
1831 (lambda ()
9b5a0d84
AW
1832 (set! module-defer-observers #f)
1833 (hash-for-each (lambda (m dummy)
1834 (module-call-observers m))
1835 module-defer-observers-table)
1836 (hash-clear! module-defer-observers-table)
1837 (unlock-mutex module-defer-observers-mutex))))
d57da08b
MD
1838
1839(define (module-call-observers m)
1777c18b 1840 (for-each (lambda (proc) (proc m)) (module-observers m))
608860a5
LC
1841
1842 ;; We assume that weak observers don't (un)register themselves as they are
1843 ;; called since this would preclude proper iteration over the hash table
1844 ;; elements.
1845 (hash-for-each (lambda (id proc) (proc m)) (module-weak-observers m)))
1777c18b
MD
1846
1847\f
3d2ada2f 1848
0f2d19dd
JB
1849;;; {Module Searching in General}
1850;;;
1851;;; We sometimes want to look for properties of a symbol
1852;;; just within the obarray of one module. If the property
1853;;; holds, then it is said to hold ``locally'' as in, ``The symbol
1854;;; DISPLAY is locally rebound in the module `safe-guile'.''
1855;;;
1856;;;
1857;;; Other times, we want to test for a symbol property in the obarray
1858;;; of M and, if it is not found there, try each of the modules in the
1859;;; uses list of M. This is the normal way of testing for some
1860;;; property, so we state these properties without qualification as
1861;;; in: ``The symbol 'fnord is interned in module M because it is
1862;;; interned locally in module M2 which is a member of the uses list
1863;;; of M.''
1864;;;
1865
1866;; module-search fn m
20edfbbd 1867;;
0f2d19dd
JB
1868;; return the first non-#f result of FN applied to M and then to
1869;; the modules in the uses of m, and so on recursively. If all applications
1870;; return #f, then so does this function.
1871;;
1872(define (module-search fn m v)
1873 (define (loop pos)
1874 (and (pair? pos)
9b5a0d84
AW
1875 (or (module-search fn (car pos) v)
1876 (loop (cdr pos)))))
0f2d19dd
JB
1877 (or (fn m v)
1878 (loop (module-uses m))))
1879
1880
1881;;; {Is a symbol bound in a module?}
1882;;;
1883;;; Symbol S in Module M is bound if S is interned in M and if the binding
1884;;; of S in M has been set to some well-defined value.
1885;;;
1886
1887;; module-locally-bound? module symbol
1888;;
1889;; Is a symbol bound (interned and defined) locally in a given module?
1890;;
1891(define (module-locally-bound? m v)
1892 (let ((var (module-local-variable m v)))
1893 (and var
9b5a0d84 1894 (variable-bound? var))))
0f2d19dd
JB
1895
1896;; module-bound? module symbol
1897;;
1898;; Is a symbol bound (interned and defined) anywhere in a given module
1899;; or its uses?
1900;;
1901(define (module-bound? m v)
f176c584
AW
1902 (let ((var (module-variable m v)))
1903 (and var
9b5a0d84 1904 (variable-bound? var))))
0f2d19dd
JB
1905
1906;;; {Is a symbol interned in a module?}
1907;;;
20edfbbd 1908;;; Symbol S in Module M is interned if S occurs in
0f2d19dd
JB
1909;;; of S in M has been set to some well-defined value.
1910;;;
1911;;; It is possible to intern a symbol in a module without providing
1912;;; an initial binding for the corresponding variable. This is done
1913;;; with:
1914;;; (module-add! module symbol (make-undefined-variable))
1915;;;
1916;;; In that case, the symbol is interned in the module, but not
1917;;; bound there. The unbound symbol shadows any binding for that
1918;;; symbol that might otherwise be inherited from a member of the uses list.
1919;;;
1920
1921(define (module-obarray-get-handle ob key)
1922 ((if (symbol? key) hashq-get-handle hash-get-handle) ob key))
1923
1924(define (module-obarray-ref ob key)
1925 ((if (symbol? key) hashq-ref hash-ref) ob key))
1926
1927(define (module-obarray-set! ob key val)
1928 ((if (symbol? key) hashq-set! hash-set!) ob key val))
1929
1930(define (module-obarray-remove! ob key)
1931 ((if (symbol? key) hashq-remove! hash-remove!) ob key))
1932
1933;; module-symbol-locally-interned? module symbol
20edfbbd 1934;;
0f2d19dd
JB
1935;; is a symbol interned (not neccessarily defined) locally in a given module
1936;; or its uses? Interned symbols shadow inherited bindings even if
1937;; they are not themselves bound to a defined value.
1938;;
1939(define (module-symbol-locally-interned? m v)
1940 (not (not (module-obarray-get-handle (module-obarray m) v))))
1941
1942;; module-symbol-interned? module symbol
20edfbbd 1943;;
0f2d19dd
JB
1944;; is a symbol interned (not neccessarily defined) anywhere in a given module
1945;; or its uses? Interned symbols shadow inherited bindings even if
1946;; they are not themselves bound to a defined value.
1947;;
1948(define (module-symbol-interned? m v)
1949 (module-search module-symbol-locally-interned? m v))
1950
1951
1952;;; {Mapping modules x symbols --> variables}
1953;;;
1954
1955;; module-local-variable module symbol
1956;; return the local variable associated with a MODULE and SYMBOL.
1957;;
1958;;; This function is very important. It is the only function that can
1959;;; return a variable from a module other than the mutators that store
1960;;; new variables in modules. Therefore, this function is the location
1961;;; of the "lazy binder" hack.
1962;;;
1963;;; If symbol is defined in MODULE, and if the definition binds symbol
1964;;; to a variable, return that variable object.
1965;;;
1966;;; If the symbols is not found at first, but the module has a lazy binder,
1967;;; then try the binder.
1968;;;
1969;;; If the symbol is not found at all, return #f.
1970;;;
608860a5
LC
1971;;; (This is now written in C, see `modules.c'.)
1972;;;
0f2d19dd
JB
1973
1974;;; {Mapping modules x symbols --> bindings}
1975;;;
1976;;; These are similar to the mapping to variables, except that the
1977;;; variable is dereferenced.
1978;;;
1979
1980;; module-symbol-binding module symbol opt-value
20edfbbd 1981;;
0f2d19dd
JB
1982;; return the binding of a variable specified by name within
1983;; a given module, signalling an error if the variable is unbound.
1984;; If the OPT-VALUE is passed, then instead of signalling an error,
1985;; return OPT-VALUE.
1986;;
1987(define (module-symbol-local-binding m v . opt-val)
1988 (let ((var (module-local-variable m v)))
7b07e5ef 1989 (if (and var (variable-bound? var))
9b5a0d84
AW
1990 (variable-ref var)
1991 (if (not (null? opt-val))
1992 (car opt-val)
1993 (error "Locally unbound variable." v)))))
0f2d19dd
JB
1994
1995;; module-symbol-binding module symbol opt-value
20edfbbd 1996;;
0f2d19dd
JB
1997;; return the binding of a variable specified by name within
1998;; a given module, signalling an error if the variable is unbound.
1999;; If the OPT-VALUE is passed, then instead of signalling an error,
2000;; return OPT-VALUE.
2001;;
2002(define (module-symbol-binding m v . opt-val)
2003 (let ((var (module-variable m v)))
7b07e5ef 2004 (if (and var (variable-bound? var))
9b5a0d84
AW
2005 (variable-ref var)
2006 (if (not (null? opt-val))
2007 (car opt-val)
2008 (error "Unbound variable." v)))))
0f2d19dd
JB
2009
2010
2011\f
3d2ada2f 2012
0f2d19dd
JB
2013;;; {Adding Variables to Modules}
2014;;;
0f2d19dd
JB
2015
2016;; module-make-local-var! module symbol
20edfbbd 2017;;
0f2d19dd
JB
2018;; ensure a variable for V in the local namespace of M.
2019;; If no variable was already there, then create a new and uninitialzied
2020;; variable.
2021;;
d57da08b
MD
2022;; This function is used in modules.c.
2023;;
0f2d19dd
JB
2024(define (module-make-local-var! m v)
2025 (or (let ((b (module-obarray-ref (module-obarray m) v)))
9b5a0d84
AW
2026 (and (variable? b)
2027 (begin
2028 ;; Mark as modified since this function is called when
2029 ;; the standard eval closure defines a binding
2030 (module-modified m)
2031 b)))
0c5f718b 2032
608860a5
LC
2033 ;; Create a new local variable.
2034 (let ((local-var (make-undefined-variable)))
2035 (module-add! m v local-var)
2036 local-var)))
0f2d19dd 2037
89d06712 2038;; module-ensure-local-variable! module symbol
9540368e 2039;;
89d06712
MV
2040;; Ensure that there is a local variable in MODULE for SYMBOL. If
2041;; there is no binding for SYMBOL, create a new uninitialized
2042;; variable. Return the local variable.
9540368e 2043;;
89d06712
MV
2044(define (module-ensure-local-variable! module symbol)
2045 (or (module-local-variable module symbol)
9540368e 2046 (let ((var (make-undefined-variable)))
9b5a0d84
AW
2047 (module-add! module symbol var)
2048 var)))
9540368e 2049
0f2d19dd 2050;; module-add! module symbol var
20edfbbd 2051;;
0f2d19dd
JB
2052;; ensure a particular variable for V in the local namespace of M.
2053;;
2054(define (module-add! m v var)
2055 (if (not (variable? var))
2056 (error "Bad variable to module-add!" var))
1777c18b 2057 (module-obarray-set! (module-obarray m) v var)
1a961d7e 2058 (module-modified m))
0f2d19dd 2059
20edfbbd
TTN
2060;; module-remove!
2061;;
0f2d19dd
JB
2062;; make sure that a symbol is undefined in the local namespace of M.
2063;;
2064(define (module-remove! m v)
c35738c1 2065 (module-obarray-remove! (module-obarray m) v)
1a961d7e 2066 (module-modified m))
0f2d19dd
JB
2067
2068(define (module-clear! m)
c35738c1 2069 (hash-clear! (module-obarray m))
1a961d7e 2070 (module-modified m))
0f2d19dd
JB
2071
2072;; MODULE-FOR-EACH -- exported
20edfbbd 2073;;
0f2d19dd
JB
2074;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
2075;;
2076(define (module-for-each proc module)
c35738c1 2077 (hash-for-each proc (module-obarray module)))
0f2d19dd
JB
2078
2079(define (module-map proc module)
711a9fd7 2080 (hash-map->list proc (module-obarray module)))
c35738c1 2081
0f27ab8a
AW
2082;; Submodules
2083;;
2084;; Modules exist in a separate namespace from values, because you generally do
2085;; not want the name of a submodule, which you might not even use, to collide
2086;; with local variables that happen to be named the same as the submodule.
2087;;
2088(define (module-ref-submodule module name)
81fc66cf
AW
2089 (or (hashq-ref (module-submodules module) name)
2090 (and (module-submodule-binder module)
2091 ((module-submodule-binder module) module name))))
0f27ab8a
AW
2092
2093(define (module-define-submodule! module name submodule)
f6a5308b 2094 (hashq-set! (module-submodules module) name submodule))
0f27ab8a 2095
dcb68c09
AW
2096;; It used to be, however, that module names were also present in the
2097;; value namespace. When we enable deprecated code, we preserve this
2098;; legacy behavior.
2099;;
2100;; These shims are defined here instead of in deprecated.scm because we
2101;; need their definitions before loading other modules.
2102;;
2103(begin-deprecated
2104 (define (module-ref-submodule module name)
2105 (or (hashq-ref (module-submodules module) name)
2106 (and (module-submodule-binder module)
2107 ((module-submodule-binder module) module name))
2108 (let ((var (module-local-variable module name)))
2109 (and var (variable-bound? var) (module? (variable-ref var))
2110 (begin
2111 (warn "module" module "not in submodules table")
2112 (variable-ref var))))))
2113
2114 (define (module-define-submodule! module name submodule)
2115 (let ((var (module-local-variable module name)))
2116 (if (and var
2117 (or (not (variable-bound? var))
2118 (not (module? (variable-ref var)))))
2119 (warn "defining module" module ": not overriding local definition" var)
2120 (module-define! module name submodule)))
2121 (hashq-set! (module-submodules module) name submodule)))
2122
0f2d19dd
JB
2123\f
2124
0f2d19dd
JB
2125;;; {Module-based Loading}
2126;;;
2127
2128(define (save-module-excursion thunk)
2129 (let ((inner-module (current-module))
9b5a0d84 2130 (outer-module #f))
0f2d19dd 2131 (dynamic-wind (lambda ()
9b5a0d84
AW
2132 (set! outer-module (current-module))
2133 (set-current-module inner-module)
2134 (set! inner-module #f))
2135 thunk
2136 (lambda ()
2137 (set! inner-module (current-module))
2138 (set-current-module outer-module)
2139 (set! outer-module #f)))))
0f2d19dd 2140
0f2d19dd 2141\f
3d2ada2f 2142
44cf1f0f 2143;;; {MODULE-REF -- exported}
3d2ada2f
DH
2144;;;
2145
0f2d19dd
JB
2146;; Returns the value of a variable called NAME in MODULE or any of its
2147;; used modules. If there is no such variable, then if the optional third
2148;; argument DEFAULT is present, it is returned; otherwise an error is signaled.
20edfbbd 2149;;
0f2d19dd
JB
2150(define (module-ref module name . rest)
2151 (let ((variable (module-variable module name)))
2152 (if (and variable (variable-bound? variable))
9b5a0d84
AW
2153 (variable-ref variable)
2154 (if (null? rest)
2155 (error "No variable named" name 'in module)
2156 (car rest) ; default value
2157 ))))
0f2d19dd
JB
2158
2159;; MODULE-SET! -- exported
2160;;
2161;; Sets the variable called NAME in MODULE (or in a module that MODULE uses)
2162;; to VALUE; if there is no such variable, an error is signaled.
20edfbbd 2163;;
0f2d19dd
JB
2164(define (module-set! module name value)
2165 (let ((variable (module-variable module name)))
2166 (if variable
9b5a0d84
AW
2167 (variable-set! variable value)
2168 (error "No variable named" name 'in module))))
0f2d19dd
JB
2169
2170;; MODULE-DEFINE! -- exported
2171;;
2172;; Sets the variable called NAME in MODULE to VALUE; if there is no such
2173;; variable, it is added first.
20edfbbd 2174;;
0f2d19dd
JB
2175(define (module-define! module name value)
2176 (let ((variable (module-local-variable module name)))
2177 (if variable
9b5a0d84
AW
2178 (begin
2179 (variable-set! variable value)
2180 (module-modified module))
2181 (let ((variable (make-variable value)))
2182 (module-add! module name variable)))))
0f2d19dd 2183
ed218d98
MV
2184;; MODULE-DEFINED? -- exported
2185;;
2186;; Return #t iff NAME is defined in MODULE (or in a module that MODULE
2187;; uses)
2188;;
2189(define (module-defined? module name)
2190 (let ((variable (module-variable module name)))
2191 (and variable (variable-bound? variable))))
2192
0f2d19dd
JB
2193;; MODULE-USE! module interface
2194;;
2195;; Add INTERFACE to the list of interfaces used by MODULE.
20edfbbd 2196;;
0f2d19dd 2197(define (module-use! module interface)
b1907902
AW
2198 (if (not (or (eq? module interface)
2199 (memq interface (module-uses module))))
608860a5
LC
2200 (begin
2201 ;; Newly used modules must be appended rather than consed, so that
2202 ;; `module-variable' traverses the use list starting from the first
2203 ;; used module.
51c0fd80
AR
2204 (set-module-uses! module (append (module-uses module)
2205 (list interface)))
8f44138a 2206 (hash-clear! (module-import-obarray module))
608860a5 2207 (module-modified module))))
0f2d19dd 2208
7b07e5ef
MD
2209;; MODULE-USE-INTERFACES! module interfaces
2210;;
8d795c83
AW
2211;; Same as MODULE-USE!, but only notifies module observers after all
2212;; interfaces are added to the inports list.
7b07e5ef
MD
2213;;
2214(define (module-use-interfaces! module interfaces)
8d795c83
AW
2215 (let* ((cur (module-uses module))
2216 (new (let lp ((in interfaces) (out '()))
2217 (if (null? in)
2218 (reverse out)
2219 (lp (cdr in)
2220 (let ((iface (car in)))
2221 (if (or (memq iface cur) (memq iface out))
2222 out
2223 (cons iface out))))))))
2224 (set-module-uses! module (append cur new))
4181e920
AW
2225 (hash-clear! (module-import-obarray module))
2226 (module-modified module)))
7b07e5ef 2227
0f2d19dd 2228\f
3d2ada2f 2229
0f2d19dd
JB
2230;;; {Recursive Namespaces}
2231;;;
0f2d19dd 2232;;; A hierarchical namespace emerges if we consider some module to be
b910c4ac 2233;;; root, and submodules of that module to be nested namespaces.
0f2d19dd 2234;;;
b910c4ac 2235;;; The routines here manage variable names in hierarchical namespace.
0f2d19dd
JB
2236;;; Each variable name is a list of elements, looked up in successively nested
2237;;; modules.
2238;;;
9b5a0d84 2239;;; (nested-ref some-root-module '(foo bar baz))
b910c4ac
AW
2240;;; => <value of a variable named baz in the submodule bar of
2241;;; the submodule foo of some-root-module>
0f2d19dd
JB
2242;;;
2243;;;
2244;;; There are:
2245;;;
9b5a0d84
AW
2246;;; ;; a-root is a module
2247;;; ;; name is a list of symbols
0f2d19dd 2248;;;
9b5a0d84
AW
2249;;; nested-ref a-root name
2250;;; nested-set! a-root name val
2251;;; nested-define! a-root name val
2252;;; nested-remove! a-root name
0f2d19dd 2253;;;
b910c4ac
AW
2254;;; These functions manipulate values in namespaces. For referencing the
2255;;; namespaces themselves, use the following:
0f2d19dd 2256;;;
b910c4ac
AW
2257;;; nested-ref-module a-root name
2258;;; nested-define-module! a-root name mod
2259;;;
2260;;; (current-module) is a natural choice for a root so for convenience there are
0f2d19dd
JB
2261;;; also:
2262;;;
b910c4ac
AW
2263;;; local-ref name == nested-ref (current-module) name
2264;;; local-set! name val == nested-set! (current-module) name val
2265;;; local-define name val == nested-define! (current-module) name val
2266;;; local-remove name == nested-remove! (current-module) name
2267;;; local-ref-module name == nested-ref-module (current-module) name
2268;;; local-define-module! name m == nested-define-module! (current-module) name m
0f2d19dd
JB
2269;;;
2270
2271
0dd5491c 2272(define (nested-ref root names)
b910c4ac
AW
2273 (if (null? names)
2274 root
2275 (let loop ((cur root)
2276 (head (car names))
2277 (tail (cdr names)))
2278 (if (null? tail)
2279 (module-ref cur head #f)
2280 (let ((cur (module-ref-submodule cur head)))
2281 (and cur
2282 (loop cur (car tail) (cdr tail))))))))
0f2d19dd 2283
0dd5491c 2284(define (nested-set! root names val)
0f2d19dd 2285 (let loop ((cur root)
b910c4ac
AW
2286 (head (car names))
2287 (tail (cdr names)))
2288 (if (null? tail)
2289 (module-set! cur head val)
2290 (let ((cur (module-ref-submodule cur head)))
2291 (if (not cur)
2292 (error "failed to resolve module" names)
2293 (loop cur (car tail) (cdr tail)))))))
0f2d19dd 2294
0dd5491c 2295(define (nested-define! root names val)
0f2d19dd 2296 (let loop ((cur root)
b910c4ac
AW
2297 (head (car names))
2298 (tail (cdr names)))
2299 (if (null? tail)
2300 (module-define! cur head val)
2301 (let ((cur (module-ref-submodule cur head)))
2302 (if (not cur)
2303 (error "failed to resolve module" names)
2304 (loop cur (car tail) (cdr tail)))))))
0f2d19dd 2305
0dd5491c 2306(define (nested-remove! root names)
0f2d19dd 2307 (let loop ((cur root)
b910c4ac
AW
2308 (head (car names))
2309 (tail (cdr names)))
2310 (if (null? tail)
2311 (module-remove! cur head)
2312 (let ((cur (module-ref-submodule cur head)))
2313 (if (not cur)
2314 (error "failed to resolve module" names)
2315 (loop cur (car tail) (cdr tail)))))))
2316
2317
2318(define (nested-ref-module root names)
2319 (let loop ((cur root)
2320 (names names))
2321 (if (null? names)
2322 cur
2323 (let ((cur (module-ref-submodule cur (car names))))
2324 (and cur
2325 (loop cur (cdr names)))))))
2326
2327(define (nested-define-module! root names module)
2328 (if (null? names)
2329 (error "can't redefine root module" root module)
2330 (let loop ((cur root)
2331 (head (car names))
2332 (tail (cdr names)))
2333 (if (null? tail)
2334 (module-define-submodule! cur head module)
2335 (let ((cur (or (module-ref-submodule cur head)
2336 (let ((m (make-module 31)))
2337 (set-module-kind! m 'directory)
2338 (set-module-name! m (append (module-name cur)
2339 (list head)))
2340 (module-define-submodule! cur head m)
2341 m))))
2342 (loop cur (car tail) (cdr tail)))))))
2343
0f2d19dd 2344
1623ca68
AW
2345(define (local-ref names)
2346 (nested-ref (current-module) names))
2347
2348(define (local-set! names val)
2349 (nested-set! (current-module) names val))
2350
2351(define (local-define names val)
2352 (nested-define! (current-module) names val))
2353
2354(define (local-remove names)
2355 (nested-remove! (current-module) names))
2356
2357(define (local-ref-module names)
2358 (nested-ref-module (current-module) names))
2359
2360(define (local-define-module names mod)
2361 (nested-define-module! (current-module) names mod))
b910c4ac 2362
0f2d19dd
JB
2363
2364
2365\f
3d2ada2f 2366
cb67c838 2367;;; {The (guile) module}
0f2d19dd 2368;;;
cb67c838
AW
2369;;; The standard module, which has the core Guile bindings. Also called the
2370;;; "root module", as it is imported by many other modules, but it is not
2371;;; necessarily the root of anything; and indeed, the module named '() might be
2372;;; better thought of as a root.
0f2d19dd 2373;;;
bbd1d133 2374
76aea207
AW
2375;; The root module uses the pre-modules-obarray as its obarray. This
2376;; special obarray accumulates all bindings that have been established
2377;; before the module system is fully booted.
2378;;
2379;; (The obarray continues to be used by code that has been closed over
2380;; before the module system has been booted.)
2381;;
2382(define the-root-module
2383 (let ((m (make-module 0)))
2384 (set-module-obarray! m (%get-pre-modules-obarray))
2385 (set-module-name! m '(guile))
76aea207
AW
2386 m))
2387
2388;; The root interface is a module that uses the same obarray as the
2389;; root module. It does not allow new definitions, tho.
2390;;
2391(define the-scm-module
2392 (let ((m (make-module 0)))
2393 (set-module-obarray! m (%get-pre-modules-obarray))
76aea207
AW
2394 (set-module-name! m '(guile))
2395 (set-module-kind! m 'interface)
7354a105
LC
2396
2397 ;; In Guile 1.8 and earlier M was its own public interface.
2398 (set-module-public-interface! m m)
2399
76aea207
AW
2400 m))
2401
2402(set-module-public-interface! the-root-module the-scm-module)
bbd1d133
AW
2403
2404\f
2405
2406;; Now that we have a root module, even though modules aren't fully booted,
2407;; expand the definition of resolve-module.
2408;;
2409(define (resolve-module name . args)
2410 (if (equal? name '(guile))
2411 the-root-module
2412 (error "unexpected module to resolve during module boot" name)))
2413
2414;; Cheat. These bindings are needed by modules.c, but we don't want
2415;; to move their real definition here because that would be unnatural.
2416;;
57ced5b9 2417(define define-module* #f)
bbd1d133
AW
2418(define process-use-modules #f)
2419(define module-export! #f)
2420(define default-duplicate-binding-procedures #f)
2421
2422;; This boots the module system. All bindings needed by modules.c
2423;; must have been defined by now.
296ff5e7 2424;;
bbd1d133
AW
2425(set-current-module the-root-module)
2426
2427
2428\f
2429
2430;; Now that modules are booted, give module-name its final definition.
2431;;
2432(define module-name
2433 (let ((accessor (record-accessor module-type 'name)))
2434 (lambda (mod)
2435 (or (accessor mod)
2436 (let ((name (list (gensym))))
cb67c838
AW
2437 ;; Name MOD and bind it in the module root so that it's visible to
2438 ;; `resolve-module'. This is important as `psyntax' stores module
2439 ;; names and relies on being able to `resolve-module' them.
bbd1d133 2440 (set-module-name! mod name)
9e0bfdba 2441 (nested-define-module! (resolve-module '() #f) name mod)
bbd1d133
AW
2442 (accessor mod))))))
2443
296ff5e7 2444(define (make-modules-in module name)
9e0bfdba
AW
2445 (or (nested-ref-module module name)
2446 (let ((m (make-module 31)))
2447 (set-module-kind! m 'directory)
2448 (set-module-name! m (append (module-name module) name))
2449 (nested-define-module! module name m)
2450 m)))
0f2d19dd 2451
296ff5e7
MV
2452(define (beautify-user-module! module)
2453 (let ((interface (module-public-interface module)))
2454 (if (or (not interface)
9b5a0d84
AW
2455 (eq? interface module))
2456 (let ((interface (make-module 31)))
2457 (set-module-name! interface (module-name module))
dca14012 2458 (set-module-version! interface (module-version module))
9b5a0d84
AW
2459 (set-module-kind! interface 'interface)
2460 (set-module-public-interface! module interface))))
296ff5e7 2461 (if (and (not (memq the-scm-module (module-uses module)))
9b5a0d84 2462 (not (eq? module the-root-module)))
608860a5
LC
2463 ;; Import the default set of bindings (from the SCM module) in MODULE.
2464 (module-use! module the-scm-module)))
432558b9 2465
dca14012 2466(define (version-matches? version-ref target)
dca14012
JG
2467 (define (sub-versions-match? v-refs t)
2468 (define (sub-version-matches? v-ref t)
befd1df9
AW
2469 (let ((matches? (lambda (v) (sub-version-matches? v t))))
2470 (cond
2471 ((number? v-ref) (eqv? v-ref t))
2472 ((list? v-ref)
2473 (case (car v-ref)
2474 ((>=) (>= t (cadr v-ref)))
2475 ((<=) (<= t (cadr v-ref)))
2476 ((and) (and-map matches? (cdr v-ref)))
2477 ((or) (or-map matches? (cdr v-ref)))
2478 ((not) (not (matches? (cadr v-ref))))
2479 (else (error "Invalid sub-version reference" v-ref))))
2480 (else (error "Invalid sub-version reference" v-ref)))))
dca14012
JG
2481 (or (null? v-refs)
2482 (and (not (null? t))
2483 (sub-version-matches? (car v-refs) (car t))
2484 (sub-versions-match? (cdr v-refs) (cdr t)))))
befd1df9
AW
2485
2486 (let ((matches? (lambda (v) (version-matches? v target))))
2487 (or (null? version-ref)
2488 (case (car version-ref)
2489 ((and) (and-map matches? (cdr version-ref)))
2490 ((or) (or-map matches? (cdr version-ref)))
2491 ((not) (not (matches? (cadr version-ref))))
2492 (else (sub-versions-match? version-ref target))))))
dca14012 2493
f95f82f8
AW
2494(define (make-fresh-user-module)
2495 (let ((m (make-module)))
2496 (beautify-user-module! m)
2497 m))
2498
1f60d9d2
MD
2499;; NOTE: This binding is used in libguile/modules.c.
2500;;
53f84bc8 2501(define resolve-module
cb67c838
AW
2502 (let ((root (make-module)))
2503 (set-module-name! root '())
2504 ;; Define the-root-module as '(guile).
d58ccc66 2505 (module-define-submodule! root 'guile the-root-module)
cb67c838 2506
7e314766 2507 (lambda* (name #:optional (autoload #t) (version #f) #:key (ensure #t))
6b7d701e 2508 (let ((already (nested-ref-module root name)))
cb67c838 2509 (cond
d58ccc66 2510 ((and already
cb67c838
AW
2511 (or (not autoload) (module-public-interface already)))
2512 ;; A hit, a palpable hit.
e44d2e4d 2513 (if (and version
cb67c838
AW
2514 (not (version-matches? version (module-version already))))
2515 (error "incompatible module version already loaded" name))
2516 already)
2517 (autoload
2518 ;; Try to autoload the module, and recurse.
2519 (try-load-module name version)
7e314766 2520 (resolve-module name #f #:ensure ensure))
cb67c838 2521 (else
51b22dbb 2522 ;; No module found (or if one was, it had no public interface), and
7e314766
AW
2523 ;; we're not autoloading. Make an empty module if #:ensure is true.
2524 (or already
2525 (and ensure
2526 (make-modules-in root name)))))))))
cb67c838 2527
296ff5e7 2528
dca14012
JG
2529(define (try-load-module name version)
2530 (try-module-autoload name version))
0f2d19dd 2531
c9b16cee 2532(define (reload-module m)
cdab9fc6 2533 "Revisit the source file corresponding to the module @var{m}."
c9b16cee
AW
2534 (let ((f (module-filename m)))
2535 (if f
2536 (save-module-excursion
2537 (lambda ()
2538 ;; Re-set the initial environment, as in try-module-autoload.
2539 (set-current-module (make-fresh-user-module))
2540 (primitive-load-path f)
2541 m))
2542 ;; Though we could guess, we *should* know it.
2543 (error "unknown file name for module" m))))
2544
90847923
MD
2545(define (purify-module! module)
2546 "Removes bindings in MODULE which are inherited from the (guile) module."
2547 (let ((use-list (module-uses module)))
2548 (if (and (pair? use-list)
9b5a0d84
AW
2549 (eq? (car (last-pair use-list)) the-scm-module))
2550 (set-module-uses! module (reverse (cdr (reverse use-list)))))))
90847923 2551
4eecfeb7 2552;; Return a module that is an interface to the module designated by
532cf805
MV
2553;; NAME.
2554;;
c614a00b 2555;; `resolve-interface' takes four keyword arguments:
532cf805
MV
2556;;
2557;; #:select SELECTION
2558;;
2559;; SELECTION is a list of binding-specs to be imported; A binding-spec
2560;; is either a symbol or a pair of symbols (ORIG . SEEN), where ORIG
2561;; is the name in the used module and SEEN is the name in the using
2562;; module. Note that SEEN is also passed through RENAMER, below. The
2563;; default is to select all bindings. If you specify no selection but
4eecfeb7 2564;; a renamer, only the bindings that already exist in the used module
532cf805
MV
2565;; are made available in the interface. Bindings that are added later
2566;; are not picked up.
2567;;
c614a00b 2568;; #:hide BINDINGS
532cf805 2569;;
c614a00b 2570;; BINDINGS is a list of bindings which should not be imported.
f595ccfe
MD
2571;;
2572;; #:prefix PREFIX
2573;;
2574;; PREFIX is a symbol that will be appended to each exported name.
2575;; The default is to not perform any renaming.
532cf805 2576;;
c614a00b
MD
2577;; #:renamer RENAMER
2578;;
2579;; RENAMER is a procedure that takes a symbol and returns its new
2580;; name. The default is not perform any renaming.
2581;;
532cf805
MV
2582;; Signal "no code for module" error if module name is not resolvable
2583;; or its public interface is not available. Signal "no binding"
2584;; error if selected binding does not exist in the used module.
2585;;
36d58fc3
AW
2586(define* (resolve-interface name #:key
2587 (select #f)
2588 (hide '())
2589 (prefix #f)
2590 (renamer (if prefix
2591 (symbol-prefix-proc prefix)
2592 identity))
2593 version)
47aabe86 2594 (let* ((module (resolve-module name #t version #:ensure #f))
b622dec7
TTN
2595 (public-i (and module (module-public-interface module))))
2596 (and (or (not module) (not public-i))
2597 (error "no code for module" name))
c614a00b 2598 (if (and (not select) (null? hide) (eq? renamer identity))
b622dec7 2599 public-i
532cf805 2600 (let ((selection (or select (module-map (lambda (sym var) sym)
9b5a0d84 2601 public-i)))
b622dec7 2602 (custom-i (make-module 31)))
c614a00b 2603 (set-module-kind! custom-i 'custom-interface)
9b5a0d84
AW
2604 (set-module-name! custom-i name)
2605 ;; XXX - should use a lazy binder so that changes to the
2606 ;; used module are picked up automatically.
2607 (for-each (lambda (bspec)
2608 (let* ((direct? (symbol? bspec))
2609 (orig (if direct? bspec (car bspec)))
2610 (seen (if direct? bspec (cdr bspec)))
2611 (var (or (module-local-variable public-i orig)
2612 (module-local-variable module orig)
2613 (error
2614 ;; fixme: format manually for now
2615 (simple-format
2616 #f "no binding `~A' in module ~A"
2617 orig name)))))
2618 (if (memq orig hide)
2619 (set! hide (delq! orig hide))
2620 (module-add! custom-i
2621 (renamer seen)
2622 var))))
2623 selection)
2624 ;; Check that we are not hiding bindings which don't exist
2625 (for-each (lambda (binding)
2626 (if (not (module-local-variable public-i binding))
2627 (error
2628 (simple-format
2629 #f "no binding `~A' to hide in module ~A"
2630 binding name))))
2631 hide)
b622dec7 2632 custom-i))))
fb1b76f4
TTN
2633
2634(define (symbol-prefix-proc prefix)
2635 (lambda (symbol)
2636 (symbol-append prefix symbol)))
0f2d19dd 2637
57ced5b9
AW
2638;; This function is called from "modules.c". If you change it, be
2639;; sure to update "modules.c" as well.
2640
f7f62d3a
AW
2641(define* (define-module* name
2642 #:key filename pure version (duplicates '())
2643 (imports '()) (exports '()) (replacements '())
2644 (re-exports '()) (autoloads '()) transformer)
2645 (define (list-of pred l)
2646 (or (null? l)
2647 (and (pair? l) (pred (car l)) (list-of pred (cdr l)))))
2648 (define (valid-export? x)
2649 (or (symbol? x) (and (pair? x) (symbol? (car x)) (symbol? (cdr x)))))
2650 (define (valid-autoload? x)
2651 (and (pair? x) (list-of symbol? (car x)) (list-of symbol? (cdr x))))
2652
2653 (define (resolve-imports imports)
2654 (define (resolve-import import-spec)
2655 (if (list? import-spec)
2656 (apply resolve-interface import-spec)
2657 (error "unexpected use-module specification" import-spec)))
2658 (let lp ((imports imports) (out '()))
2659 (cond
2660 ((null? imports) (reverse! out))
2661 ((pair? imports)
2662 (lp (cdr imports)
2663 (cons (resolve-import (car imports)) out)))
2664 (else (error "unexpected tail of imports list" imports)))))
2665
2666 ;; We could add a #:no-check arg, set by the define-module macro, if
2667 ;; these checks are taking too much time.
2668 ;;
2669 (let ((module (resolve-module name #f)))
2670 (beautify-user-module! module)
2671 (if filename
2672 (set-module-filename! module filename))
2673 (if pure
2674 (purify-module! module))
2675 (if version
2676 (begin
2677 (if (not (list-of integer? version))
2678 (error "expected list of integers for version"))
2679 (set-module-version! module version)
2680 (set-module-version! (module-public-interface module) version)))
f7f62d3a
AW
2681 (let ((imports (resolve-imports imports)))
2682 (call-with-deferred-observers
2683 (lambda ()
2684 (if (pair? imports)
2685 (module-use-interfaces! module imports))
2686 (if (list-of valid-export? exports)
2687 (if (pair? exports)
2688 (module-export! module exports))
2689 (error "expected exports to be a list of symbols or symbol pairs"))
2690 (if (list-of valid-export? replacements)
2691 (if (pair? replacements)
2692 (module-replace! module replacements))
2693 (error "expected replacements to be a list of symbols or symbol pairs"))
2694 (if (list-of valid-export? re-exports)
2695 (if (pair? re-exports)
2696 (module-re-export! module re-exports))
2697 (error "expected re-exports to be a list of symbols or symbol pairs"))
2698 ;; FIXME
2699 (if (not (null? autoloads))
6b1c5d9d
AW
2700 (apply module-autoload! module autoloads))
2701 ;; Wait until modules have been loaded to resolve duplicates
2702 ;; handlers.
2703 (if (pair? duplicates)
2704 (let ((handlers (lookup-duplicates-handlers duplicates)))
2705 (set-module-duplicates-handlers! module handlers))))))
f7f62d3a
AW
2706
2707 (if transformer
2708 (if (and (pair? transformer) (list-of symbol? transformer))
2709 (let ((iface (resolve-interface transformer))
2710 (sym (car (last-pair transformer))))
2711 (set-module-transformer! module (module-ref iface sym)))
2712 (error "expected transformer to be a module name" transformer)))
2713
2714 (run-hook module-defined-hook module)
2715 module))
2716
db853761
NJ
2717;; `module-defined-hook' is a hook that is run whenever a new module
2718;; is defined. Its members are called with one argument, the new
2719;; module.
2720(define module-defined-hook (make-hook 1))
2721
3d2ada2f
DH
2722\f
2723
71225060 2724;;; {Autoload}
3d2ada2f 2725;;;
71225060
MD
2726
2727(define (make-autoload-interface module name bindings)
2728 (let ((b (lambda (a sym definep)
9b5a0d84
AW
2729 (and (memq sym bindings)
2730 (let ((i (module-public-interface (resolve-module name))))
2731 (if (not i)
2732 (error "missing interface for module" name))
2733 (let ((autoload (memq a (module-uses module))))
2734 ;; Replace autoload-interface with actual interface if
2735 ;; that has not happened yet.
2736 (if (pair? autoload)
2737 (set-car! autoload i)))
2738 (module-local-variable i sym))))))
608860a5 2739 (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
f905381d 2740 (make-hash-table 0) '() (make-weak-value-hash-table 31) #f
78f79f18 2741 (make-hash-table 0) #f #f #f)))
608860a5
LC
2742
2743(define (module-autoload! module . args)
2744 "Have @var{module} automatically load the module named @var{name} when one
2745of the symbols listed in @var{bindings} is looked up. @var{args} should be a
2746list of module-name/binding-list pairs, e.g., as in @code{(module-autoload!
2747module '(ice-9 q) '(make-q q-length))}."
2748 (let loop ((args args))
2749 (cond ((null? args)
2750 #t)
2751 ((null? (cdr args))
2752 (error "invalid name+binding autoload list" args))
2753 (else
2754 (let ((name (car args))
2755 (bindings (cadr args)))
2756 (module-use! module (make-autoload-interface module
2757 name bindings))
2758 (loop (cddr args)))))))
2759
71225060 2760
0f2d19dd 2761\f
3d2ada2f 2762
44cf1f0f 2763;;; {Autoloading modules}
3d2ada2f 2764;;;
0f2d19dd
JB
2765
2766(define autoloads-in-progress '())
2767
482a28f9
MV
2768;; This function is called from "modules.c". If you change it, be
2769;; sure to update "modules.c" as well.
2770
d9113d47 2771(define* (try-module-autoload module-name #:optional version)
0f2d19dd 2772 (let* ((reverse-name (reverse module-name))
9b5a0d84
AW
2773 (name (symbol->string (car reverse-name)))
2774 (dir-hint-module-name (reverse (cdr reverse-name)))
2775 (dir-hint (apply string-append
2776 (map (lambda (elt)
2777 (string-append (symbol->string elt) "/"))
2778 dir-hint-module-name))))
0209ca9a 2779 (resolve-module dir-hint-module-name #f)
0f2d19dd 2780 (and (not (autoload-done-or-in-progress? dir-hint name))
9b5a0d84
AW
2781 (let ((didit #f))
2782 (dynamic-wind
2783 (lambda () (autoload-in-progress! dir-hint name))
2784 (lambda ()
eddd16d7
AW
2785 (with-fluids ((current-reader #f))
2786 (save-module-excursion
2787 (lambda ()
39392995
AW
2788 ;; The initial environment when loading a module is a fresh
2789 ;; user module.
2790 (set-current-module (make-fresh-user-module))
e44d2e4d
AW
2791 ;; Here we could allow some other search strategy (other than
2792 ;; primitive-load-path), for example using versions encoded
2793 ;; into the file system -- but then we would have to figure
6f06e8d3 2794 ;; out how to locate the compiled file, do auto-compilation,
e44d2e4d
AW
2795 ;; etc. Punt for now, and don't use versions when locating
2796 ;; the file.
2797 (primitive-load-path (in-vicinity dir-hint name) #f)
eddd16d7 2798 (set! didit #t)))))
9b5a0d84
AW
2799 (lambda () (set-autoloaded! dir-hint name didit)))
2800 didit))))
0f2d19dd 2801
71225060 2802\f
3d2ada2f
DH
2803
2804;;; {Dynamic linking of modules}
2805;;;
d0cbd20c 2806
0f2d19dd
JB
2807(define autoloads-done '((guile . guile)))
2808
2809(define (autoload-done-or-in-progress? p m)
2810 (let ((n (cons p m)))
2811 (->bool (or (member n autoloads-done)
9b5a0d84 2812 (member n autoloads-in-progress)))))
0f2d19dd
JB
2813
2814(define (autoload-done! p m)
2815 (let ((n (cons p m)))
2816 (set! autoloads-in-progress
9b5a0d84 2817 (delete! n autoloads-in-progress))
0f2d19dd 2818 (or (member n autoloads-done)
9b5a0d84 2819 (set! autoloads-done (cons n autoloads-done)))))
0f2d19dd
JB
2820
2821(define (autoload-in-progress! p m)
2822 (let ((n (cons p m)))
2823 (set! autoloads-done
9b5a0d84 2824 (delete! n autoloads-done))
0f2d19dd
JB
2825 (set! autoloads-in-progress (cons n autoloads-in-progress))))
2826
2827(define (set-autoloaded! p m done?)
2828 (if done?
2829 (autoload-done! p m)
2830 (let ((n (cons p m)))
9b5a0d84
AW
2831 (set! autoloads-done (delete! n autoloads-done))
2832 (set! autoloads-in-progress (delete! n autoloads-in-progress)))))
0f2d19dd 2833
0f2d19dd
JB
2834\f
2835
83b38198 2836;;; {Run-time options}
3d2ada2f 2837;;;
83b38198 2838
122f296d
AW
2839(define-syntax define-option-interface
2840 (syntax-rules ()
2841 ((_ (interface (options enable disable) (option-set!)))
2842 (begin
2843 (define options
2844 (case-lambda
2845 (() (interface))
2846 ((arg)
2847 (if (list? arg)
2848 (begin (interface arg) (interface))
2849 (for-each
2850 (lambda (option)
2851 (apply (lambda (name value documentation)
2852 (display name)
2853 (if (< (string-length (symbol->string name)) 8)
2854 (display #\tab))
2855 (display #\tab)
2856 (display value)
2857 (display #\tab)
2858 (display documentation)
2859 (newline))
2860 option))
2861 (interface #t))))))
2862 (define (enable . flags)
2863 (interface (append flags (interface)))
2864 (interface))
2865 (define (disable . flags)
2866 (let ((options (interface)))
2867 (for-each (lambda (flag) (set! options (delq! flag options)))
2868 flags)
2869 (interface options)
2870 (interface)))
0c65f52c
AW
2871 (define-syntax-rule (option-set! opt val)
2872 (eval-when (eval load compile expand)
2873 (options (append (options) (list 'opt val)))))))))
e9bab9df 2874
e9bab9df
DH
2875(define-option-interface
2876 (debug-options-interface
2877 (debug-options debug-enable debug-disable)
2878 (debug-set!)))
2879
e9bab9df
DH
2880(define-option-interface
2881 (read-options-interface
2882 (read-options read-enable read-disable)
2883 (read-set!)))
2884
2885(define-option-interface
2886 (print-options-interface
2887 (print-options print-enable print-disable)
2888 (print-set!)))
83b38198
MD
2889
2890\f
2891
410e83c0
AW
2892;;; {The Unspecified Value}
2893;;;
2894;;; Currently Guile represents unspecified values via one particular value,
2895;;; which may be obtained by evaluating (if #f #f). It would be nice in the
2896;;; future if we could replace this with a return of 0 values, though.
9346b857 2897;;;
410e83c0
AW
2898
2899(define-syntax *unspecified*
2900 (identifier-syntax (if #f #f)))
2901
2902(define (unspecified? v) (eq? v *unspecified*))
2903
2904
2905\f
2906
90de5c4c
AW
2907;;; {Parameters}
2908;;;
2909
2910(define <parameter>
2911 ;; Three fields: the procedure itself, the fluid, and the converter.
2912 (make-struct <applicable-struct-vtable> 0 'pwprpr))
2913(set-struct-vtable-name! <parameter> '<parameter>)
2914
2915(define* (make-parameter init #:optional (conv (lambda (x) x)))
2916 (let ((fluid (make-fluid (conv init))))
2917 (make-struct <parameter> 0
2918 (case-lambda
2919 (() (fluid-ref fluid))
13dd74c8
AW
2920 ((x) (let ((prev (fluid-ref fluid)))
2921 (fluid-set! fluid (conv x))
2922 prev)))
90de5c4c
AW
2923 fluid conv)))
2924
2925(define (parameter? x)
2926 (and (struct? x) (eq? (struct-vtable x) <parameter>)))
2927
2928(define (parameter-fluid p)
2929 (if (parameter? p)
2930 (struct-ref p 1)
2931 (scm-error 'wrong-type-arg "parameter-fluid"
2932 "Not a parameter: ~S" (list p) #f)))
2933
2934(define (parameter-converter p)
2935 (if (parameter? p)
2936 (struct-ref p 2)
2937 (scm-error 'wrong-type-arg "parameter-fluid"
2938 "Not a parameter: ~S" (list p) #f)))
2939
2940(define-syntax parameterize
2941 (lambda (x)
2942 (syntax-case x ()
2943 ((_ ((param value) ...) body body* ...)
2944 (with-syntax (((p ...) (generate-temporaries #'(param ...))))
2945 #'(let ((p param) ...)
2946 (if (not (parameter? p))
2947 (scm-error 'wrong-type-arg "parameterize"
2948 "Not a parameter: ~S" (list p) #f))
2949 ...
2950 (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
2951 ...)
2952 body body* ...)))))))
2953
2954\f
9670f238
AW
2955;;;
2956;;; Current ports as parameters.
2957;;;
2958
2959(let ((fluid->parameter
2960 (lambda (fluid conv)
2961 (make-struct <parameter> 0
2962 (case-lambda
2963 (() (fluid-ref fluid))
2964 ((x) (let ((prev (fluid-ref fluid)))
2965 (fluid-set! fluid (conv x))
2966 prev)))
2967 fluid conv))))
2968 (define-syntax-rule (port-parameterize! binding fluid predicate msg)
2969 (begin
2970 (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
2971 (lambda (x)
2972 (if (predicate x) x
2973 (error msg x)))))
2974 (module-remove! (current-module) 'fluid)))
2975
2976 (port-parameterize! current-input-port %current-input-port-fluid
2977 input-port? "expected an input port")
2978 (port-parameterize! current-output-port %current-output-port-fluid
2979 output-port? "expected an output port")
2980 (port-parameterize! current-error-port %current-error-port-fluid
2981 output-port? "expected an output port"))
2982
2983
2984\f
3972de76
AW
2985;;;
2986;;; Warnings.
2987;;;
2988
2989(define current-warning-port
2990 (make-parameter (current-error-port)
2991 (lambda (x)
2992 (if (output-port? x)
2993 x
2994 (error "expected an output port" x)))))
2995
2996
2997\f
90de5c4c 2998
0f2d19dd
JB
2999;;; {Running Repls}
3000;;;
3001
9447207f 3002(define *repl-stack* (make-fluid '()))
1fdd5bec 3003
9346b857
AW
3004;; Programs can call `batch-mode?' to see if they are running as part of a
3005;; script or if they are running interactively. REPL implementations ensure that
3006;; `batch-mode?' returns #f during their extent.
3007;;
1fdd5bec 3008(define (batch-mode?)
9447207f 3009 (null? (fluid-ref *repl-stack*)))
1fdd5bec 3010
9346b857 3011;; Programs can re-enter batch mode, for example after a fork, by calling
0feb833d
AW
3012;; `ensure-batch-mode!'. It's not a great interface, though; it would be better
3013;; to abort to the outermost prompt, and call a thunk there.
1fdd5bec 3014;;
9346b857 3015(define (ensure-batch-mode!)
9d2136ba 3016 (set! batch-mode? (lambda () #t)))
4bbbcd5c 3017
0f2d19dd
JB
3018(define (quit . args)
3019 (apply throw 'quit args))
3020
7950df7c
GH
3021(define exit quit)
3022
0f2d19dd
JB
3023(define (gc-run-time)
3024 (cdr (assq 'gc-time-taken (gc-stats))))
3025
8942e7a1
AW
3026(define abort-hook (make-hook))
3027(define before-error-hook (make-hook))
3028(define after-error-hook (make-hook))
3029(define before-backtrace-hook (make-hook))
3030(define after-backtrace-hook (make-hook))
3031
3e3cec45
MD
3032(define before-read-hook (make-hook))
3033(define after-read-hook (make-hook))
870777d7
KN
3034(define before-eval-hook (make-hook 1))
3035(define after-eval-hook (make-hook 1))
3036(define before-print-hook (make-hook 1))
3037(define after-print-hook (make-hook 1))
1c6cd8e8 3038
c592de96
AW
3039;;; This hook is run at the very end of an interactive session.
3040;;;
3041(define exit-hook (make-hook))
3042
dc5c2038
MD
3043;;; The default repl-reader function. We may override this if we've
3044;;; the readline library.
3045(define repl-reader
17ee350c 3046 (lambda* (prompt #:optional (reader (fluid-ref current-reader)))
0becb8f3 3047 (if (not (char-ready?))
dceb7829
AW
3048 (begin
3049 (display (if (string? prompt) prompt (prompt)))
3050 ;; An interesting situation. The printer resets the column to
3051 ;; 0 by printing a newline, but we then advance it by printing
3052 ;; the prompt. However the port-column of the output port
3053 ;; does not typically correspond with the actual column on the
b3da54d1 3054 ;; screen, because the input is echoed back! Since the
dceb7829
AW
3055 ;; input is line-buffered and thus ends with a newline, the
3056 ;; output will really start on column zero. So, here we zero
3057 ;; it out. See bug 9664.
3058 ;;
3059 ;; Note that for similar reasons, the output-line will not
3060 ;; reflect the actual line on the screen. But given the
3061 ;; possibility of multiline input, the fix is not as
3062 ;; straightforward, so we don't bother.
3063 ;;
3064 ;; Also note that the readline implementation papers over
3065 ;; these concerns, because it's readline itself printing the
3066 ;; prompt, and not Guile.
3067 (set-port-column! (current-output-port) 0)))
dc5c2038 3068 (force-output)
04efd24d 3069 (run-hook before-read-hook)
17ee350c 3070 ((or reader read) (current-input-port))))
dc5c2038 3071
0f2d19dd 3072
0f2d19dd 3073\f
3d2ada2f 3074
44cf1f0f 3075;;; {IOTA functions: generating lists of numbers}
3d2ada2f 3076;;;
0f2d19dd 3077
e69cd299
MD
3078(define (iota n)
3079 (let loop ((count (1- n)) (result '()))
3080 (if (< count 0) result
3081 (loop (1- count) (cons count result)))))
0f2d19dd
JB
3082
3083\f
3d2ada2f 3084
773abfbb
KR
3085;;; {While}
3086;;;
3087;;; with `continue' and `break'.
3088;;;
3089
10e69149
AW
3090;; The inliner will remove the prompts at compile-time if it finds that
3091;; `continue' or `break' are not used.
3092;;
3093(define-syntax while
3094 (lambda (x)
3095 (syntax-case x ()
3096 ((while cond body ...)
3097 #`(let ((break-tag (make-prompt-tag "break"))
3098 (continue-tag (make-prompt-tag "continue")))
3099 (call-with-prompt
3100 break-tag
3101 (lambda ()
3102 (define-syntax #,(datum->syntax #'while 'break)
3103 (lambda (x)
3104 (syntax-case x ()
91956a94
AW
3105 ((_ arg (... ...))
3106 #'(abort-to-prompt break-tag arg (... ...)))
10e69149 3107 (_
91956a94
AW
3108 #'(lambda args
3109 (apply abort-to-prompt break-tag args))))))
10e69149
AW
3110 (let lp ()
3111 (call-with-prompt
3112 continue-tag
3113 (lambda ()
3114 (define-syntax #,(datum->syntax #'while 'continue)
3115 (lambda (x)
3116 (syntax-case x ()
3117 ((_)
3118 #'(abort-to-prompt continue-tag))
3119 ((_ . args)
3120 (syntax-violation 'continue "too many arguments" x))
3121 (_
ddf134cf
MW
3122 #'(lambda ()
3123 (abort-to-prompt continue-tag))))))
91956a94 3124 (do () ((not cond) #f) body ...))
10e69149 3125 (lambda (k) (lp)))))
91956a94
AW
3126 (lambda (k . args)
3127 (if (null? args)
3128 #t
3129 (apply values args)))))))))
5578a53f 3130
773abfbb 3131
0f2d19dd 3132\f
3d2ada2f 3133
0f2d19dd
JB
3134;;; {Module System Macros}
3135;;;
3136
532cf805
MV
3137;; Return a list of expressions that evaluate to the appropriate
3138;; arguments for resolve-interface according to SPEC.
3139
1fdd5bec
AW
3140(eval-when (compile)
3141 (if (memq 'prefix (read-options))
3142 (error "boot-9 must be compiled with #:kw, not :kw")))
1a1a10d3 3143
532cf805
MV
3144(define (keyword-like-symbol->keyword sym)
3145 (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
3146
074e036e
AW
3147(define-syntax define-module
3148 (lambda (x)
3149 (define (keyword-like? stx)
3150 (let ((dat (syntax->datum stx)))
3151 (and (symbol? dat)
3152 (eqv? (string-ref (symbol->string dat) 0) #\:))))
3153 (define (->keyword sym)
3154 (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
3155
cd8c3519 3156 (define (parse-iface args)
074e036e
AW
3157 (let loop ((in args) (out '()))
3158 (syntax-case in ()
3159 (() (reverse! out))
3160 ;; The user wanted #:foo, but wrote :foo. Fix it.
3161 ((sym . in) (keyword-like? #'sym)
3162 (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
3163 ((kw . in) (not (keyword? (syntax->datum #'kw)))
3164 (syntax-violation 'define-module "expected keyword arg" x #'kw))
3165 ((#:renamer renamer . in)
cd8c3519 3166 (loop #'in (cons* #',renamer #:renamer out)))
074e036e 3167 ((kw val . in)
cd8c3519 3168 (loop #'in (cons* #'val #'kw out))))))
074e036e 3169
cd8c3519 3170 (define (parse args imp exp rex rep aut)
074e036e
AW
3171 ;; Just quote everything except #:use-module and #:use-syntax. We
3172 ;; need to know about all arguments regardless since we want to turn
3173 ;; symbols that look like keywords into real keywords, and the
3174 ;; keyword args in a define-module form are not regular
3175 ;; (i.e. no-backtrace doesn't take a value).
cd8c3519
AW
3176 (syntax-case args ()
3177 (()
3178 (let ((imp (if (null? imp) '() #`(#:imports `#,imp)))
3179 (exp (if (null? exp) '() #`(#:exports '#,exp)))
3180 (rex (if (null? rex) '() #`(#:re-exports '#,rex)))
3181 (rep (if (null? rep) '() #`(#:replacements '#,rep)))
3182 (aut (if (null? aut) '() #`(#:autoloads '#,aut))))
3183 #`(#,@imp #,@exp #,@rex #,@rep #,@aut)))
3184 ;; The user wanted #:foo, but wrote :foo. Fix it.
3185 ((sym . args) (keyword-like? #'sym)
3186 (parse #`(#,(->keyword (syntax->datum #'sym)) . args)
3187 imp exp rex rep aut))
3188 ((kw . args) (not (keyword? (syntax->datum #'kw)))
3189 (syntax-violation 'define-module "expected keyword arg" x #'kw))
3190 ((#:no-backtrace . args)
3191 ;; Ignore this one.
3192 (parse #'args imp exp rex rep aut))
3193 ((#:pure . args)
3194 #`(#:pure #t . #,(parse #'args imp exp rex rep aut)))
3195 ((kw)
3196 (syntax-violation 'define-module "keyword arg without value" x #'kw))
3197 ((#:version (v ...) . args)
3198 #`(#:version '(v ...) . #,(parse #'args imp exp rex rep aut)))
3199 ((#:duplicates (d ...) . args)
3200 #`(#:duplicates '(d ...) . #,(parse #'args imp exp rex rep aut)))
3201 ((#:filename f . args)
3202 #`(#:filename 'f . #,(parse #'args imp exp rex rep aut)))
3203 ((#:use-module (name name* ...) . args)
3204 (and (and-map symbol? (syntax->datum #'(name name* ...))))
ad4bd7c2 3205 (parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut))
cd8c3519
AW
3206 ((#:use-syntax (name name* ...) . args)
3207 (and (and-map symbol? (syntax->datum #'(name name* ...))))
3208 #`(#:transformer '(name name* ...)
ad4bd7c2 3209 . #,(parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut)))
cd8c3519
AW
3210 ((#:use-module ((name name* ...) arg ...) . args)
3211 (and (and-map symbol? (syntax->datum #'(name name* ...))))
3212 (parse #'args
ad4bd7c2 3213 #`(#,@imp ((name name* ...) #,@(parse-iface #'(arg ...))))
cd8c3519
AW
3214 exp rex rep aut))
3215 ((#:export (ex ...) . args)
3216 (parse #'args imp #`(#,@exp ex ...) rex rep aut))
3217 ((#:export-syntax (ex ...) . args)
3218 (parse #'args imp #`(#,@exp ex ...) rex rep aut))
3219 ((#:re-export (re ...) . args)
3220 (parse #'args imp exp #`(#,@rex re ...) rep aut))
3221 ((#:re-export-syntax (re ...) . args)
3222 (parse #'args imp exp #`(#,@rex re ...) rep aut))
3223 ((#:replace (r ...) . args)
3224 (parse #'args imp exp rex #`(#,@rep r ...) aut))
3225 ((#:replace-syntax (r ...) . args)
3226 (parse #'args imp exp rex #`(#,@rep r ...) aut))
3227 ((#:autoload name bindings . args)
3228 (parse #'args imp exp rex rep #`(#,@aut name bindings)))
3229 ((kw val . args)
3230 (syntax-violation 'define-module "unknown keyword or bad argument"
3231 #'kw #'val))))
074e036e
AW
3232
3233 (syntax-case x ()
3234 ((_ (name name* ...) arg ...)
cd8c3519
AW
3235 (and-map symbol? (syntax->datum #'(name name* ...)))
3236 (with-syntax (((quoted-arg ...)
3237 (parse #'(arg ...) '() '() '() '() '()))
c415fe08
AW
3238 ;; Ideally the filename is either a string or #f;
3239 ;; this hack is to work around a case in which
3240 ;; port-filename returns a symbol (`socket') for
3241 ;; sockets.
3242 (filename (let ((f (assq-ref (or (syntax-source x) '())
3243 'filename)))
3244 (and (string? f) f))))
d9b1c71a 3245 #'(eval-when (eval load compile expand)
cd8c3519
AW
3246 (let ((m (define-module* '(name name* ...)
3247 #:filename filename quoted-arg ...)))
074e036e
AW
3248 (set-current-module m)
3249 m)))))))
0f2d19dd 3250
532cf805
MV
3251;; The guts of the use-modules macro. Add the interfaces of the named
3252;; modules to the use-list of the current module, in order.
3253
482a28f9
MV
3254;; This function is called by "modules.c". If you change it, be sure
3255;; to change scm_c_use_module as well.
3256
532cf805 3257(define (process-use-modules module-interface-args)
d57da08b 3258 (let ((interfaces (map (lambda (mif-args)
9b5a0d84
AW
3259 (or (apply resolve-interface mif-args)
3260 (error "no such module" mif-args)))
3261 module-interface-args)))
d57da08b
MD
3262 (call-with-deferred-observers
3263 (lambda ()
3264 (module-use-interfaces! (current-module) interfaces)))))
89da9036 3265
4e3328ce
AW
3266(define-syntax use-modules
3267 (lambda (x)
3268 (define (keyword-like? stx)
3269 (let ((dat (syntax->datum stx)))
3270 (and (symbol? dat)
3271 (eqv? (string-ref (symbol->string dat) 0) #\:))))
3272 (define (->keyword sym)
3273 (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
3274
3275 (define (quotify-iface args)
3276 (let loop ((in args) (out '()))
3277 (syntax-case in ()
3278 (() (reverse! out))
3279 ;; The user wanted #:foo, but wrote :foo. Fix it.
3280 ((sym . in) (keyword-like? #'sym)
3281 (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
3282 ((kw . in) (not (keyword? (syntax->datum #'kw)))
3283 (syntax-violation 'define-module "expected keyword arg" x #'kw))
3284 ((#:renamer renamer . in)
3285 (loop #'in (cons* #'renamer #:renamer out)))
3286 ((kw val . in)
3287 (loop #'in (cons* #''val #'kw out))))))
3288
3289 (define (quotify specs)
3290 (let lp ((in specs) (out '()))
3291 (syntax-case in ()
3292 (() (reverse out))
3293 (((name name* ...) . in)
3294 (and-map symbol? (syntax->datum #'(name name* ...)))
3295 (lp #'in (cons #''((name name* ...)) out)))
3296 ((((name name* ...) arg ...) . in)
3297 (and-map symbol? (syntax->datum #'(name name* ...)))
3298 (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...))))
3299 (lp #'in (cons #`(list '(name name* ...) quoted-arg ...)
3300 out)))))))
3301
3302 (syntax-case x ()
3303 ((_ spec ...)
3304 (with-syntax (((quoted-args ...) (quotify #'(spec ...))))
520caaeb 3305 #'(eval-when (eval load compile expand)
4e3328ce
AW
3306 (process-use-modules (list quoted-args ...))
3307 *unspecified*))))))
3308
0c65f52c
AW
3309(define-syntax-rule (use-syntax spec ...)
3310 (begin
3311 (eval-when (eval load compile expand)
3312 (issue-deprecation-warning
3313 "`use-syntax' is deprecated. Please contact guile-devel for more info."))
3314 (use-modules spec ...)))
0f2d19dd 3315
b1e4c7cc
JG
3316(include-from-path "ice-9/r6rs-libraries")
3317
0c65f52c
AW
3318(define-syntax-rule (define-private foo bar)
3319 (define foo bar))
13182603
AW
3320
3321(define-syntax define-public
3322 (syntax-rules ()
3323 ((_ (name . args) . body)
3324 (define-public name (lambda args . body)))
3325 ((_ name val)
3326 (begin
3327 (define name val)
3328 (export name)))))
3329
0c65f52c
AW
3330(define-syntax-rule (defmacro-public name args body ...)
3331 (begin
3332 (defmacro name args body ...)
3333 (export-syntax name)))
0f2d19dd 3334
87e00370 3335;; And now for the most important macro.
0c65f52c
AW
3336(define-syntax-rule (λ formals body ...)
3337 (lambda formals body ...))
87e00370
LC
3338
3339\f
89d06712 3340;; Export a local variable
482a28f9
MV
3341
3342;; This function is called from "modules.c". If you change it, be
3343;; sure to update "modules.c" as well.
3344
90847923
MD
3345(define (module-export! m names)
3346 (let ((public-i (module-public-interface m)))
3347 (for-each (lambda (name)
78c22f5e
JG
3348 (let* ((internal-name (if (pair? name) (car name) name))
3349 (external-name (if (pair? name) (cdr name) name))
3350 (var (module-ensure-local-variable! m internal-name)))
3351 (module-add! public-i external-name var)))
9b5a0d84 3352 names)))
89d06712 3353
f595ccfe
MD
3354(define (module-replace! m names)
3355 (let ((public-i (module-public-interface m)))
3356 (for-each (lambda (name)
78c22f5e
JG
3357 (let* ((internal-name (if (pair? name) (car name) name))
3358 (external-name (if (pair? name) (cdr name) name))
3359 (var (module-ensure-local-variable! m internal-name)))
eceee4ef
AW
3360 ;; FIXME: use a bit on variables instead of object
3361 ;; properties.
9b5a0d84 3362 (set-object-property! var 'replace #t)
78c22f5e 3363 (module-add! public-i external-name var)))
9b5a0d84 3364 names)))
f595ccfe 3365
d2b7b761
AW
3366;; Export all local variables from a module
3367;;
3368(define (module-export-all! mod)
3369 (define (fresh-interface!)
3370 (let ((iface (make-module)))
3371 (set-module-name! iface (module-name mod))
e5602ce7 3372 (set-module-version! iface (module-version mod))
d2b7b761
AW
3373 (set-module-kind! iface 'interface)
3374 (set-module-public-interface! mod iface)
3375 iface))
3376 (let ((iface (or (module-public-interface mod)
3377 (fresh-interface!))))
3378 (set-module-obarray! iface (module-obarray mod))))
3379
89d06712
MV
3380;; Re-export a imported variable
3381;;
3382(define (module-re-export! m names)
3383 (let ((public-i (module-public-interface m)))
3384 (for-each (lambda (name)
78c22f5e
JG
3385 (let* ((internal-name (if (pair? name) (car name) name))
3386 (external-name (if (pair? name) (cdr name) name))
3387 (var (module-variable m internal-name)))
9b5a0d84 3388 (cond ((not var)
78c22f5e
JG
3389 (error "Undefined variable:" internal-name))
3390 ((eq? var (module-local-variable m internal-name))
3391 (error "re-exporting local variable:" internal-name))
9b5a0d84 3392 (else
78c22f5e 3393 (module-add! public-i external-name var)))))
9b5a0d84 3394 names)))
90847923 3395
0c65f52c
AW
3396(define-syntax-rule (export name ...)
3397 (eval-when (eval load compile expand)
3398 (call-with-deferred-observers
3399 (lambda ()
3400 (module-export! (current-module) '(name ...))))))
a0cc0a01 3401
0c65f52c
AW
3402(define-syntax-rule (re-export name ...)
3403 (eval-when (eval load compile expand)
3404 (call-with-deferred-observers
3405 (lambda ()
3406 (module-re-export! (current-module) '(name ...))))))
89d06712 3407
0c65f52c
AW
3408(define-syntax-rule (export! name ...)
3409 (eval-when (eval load compile expand)
3410 (call-with-deferred-observers
3411 (lambda ()
3412 (module-replace! (current-module) '(name ...))))))
1052739b 3413
0c65f52c
AW
3414(define-syntax-rule (export-syntax name ...)
3415 (export name ...))
a0cc0a01 3416
0c65f52c
AW
3417(define-syntax-rule (re-export-syntax name ...)
3418 (re-export name ...))
a0cc0a01 3419
3de80ed5
AW
3420\f
3421
f595ccfe
MD
3422;;; {Parameters}
3423;;;
3424
e9729cbb 3425(define* (make-mutable-parameter init #:optional (converter identity))
9447207f 3426 (let ((fluid (make-fluid (converter init))))
e9729cbb
AW
3427 (case-lambda
3428 (() (fluid-ref fluid))
3429 ((val) (fluid-set! fluid (converter val))))))
3430
f595ccfe
MD
3431
3432\f
3d2ada2f 3433
7b07e5ef
MD
3434;;; {Handling of duplicate imported bindings}
3435;;;
3436
3437;; Duplicate handlers take the following arguments:
3438;;
3439;; module importing module
9b5a0d84
AW
3440;; name conflicting name
3441;; int1 old interface where name occurs
3442;; val1 value of binding in old interface
3443;; int2 new interface where name occurs
3444;; val2 value of binding in new interface
3445;; var previous resolution or #f
3446;; val value of previous resolution
7b07e5ef
MD
3447;;
3448;; A duplicate handler can take three alternative actions:
3449;;
3450;; 1. return #f => leave responsibility to next handler
3451;; 2. exit with an error
3452;; 3. return a variable resolving the conflict
3453;;
3454
3455(define duplicate-handlers
3456 (let ((m (make-module 7)))
f595ccfe
MD
3457
3458 (define (check module name int1 val1 int2 val2 var val)
3459 (scm-error 'misc-error
9b5a0d84
AW
3460 #f
3461 "~A: `~A' imported from both ~A and ~A"
3462 (list (module-name module)
3463 name
3464 (module-name int1)
3465 (module-name int2))
3466 #f))
f595ccfe 3467
65bed4aa 3468 (define (warn module name int1 val1 int2 val2 var val)
2c27dd57 3469 (format (current-warning-port)
9b5a0d84
AW
3470 "WARNING: ~A: `~A' imported from both ~A and ~A\n"
3471 (module-name module)
3472 name
3473 (module-name int1)
3474 (module-name int2))
65bed4aa 3475 #f)
f595ccfe
MD
3476
3477 (define (replace module name int1 val1 int2 val2 var val)
3478 (let ((old (or (and var (object-property var 'replace) var)
9b5a0d84
AW
3479 (module-variable int1 name)))
3480 (new (module-variable int2 name)))
3481 (if (object-property old 'replace)
3482 (and (or (eq? old new)
3483 (not (object-property new 'replace)))
3484 old)
3485 (and (object-property new 'replace)
3486 new))))
f595ccfe 3487
65bed4aa
MD
3488 (define (warn-override-core module name int1 val1 int2 val2 var val)
3489 (and (eq? int1 the-scm-module)
9b5a0d84 3490 (begin
2c27dd57 3491 (format (current-warning-port)
9b5a0d84
AW
3492 "WARNING: ~A: imported module ~A overrides core binding `~A'\n"
3493 (module-name module)
3494 (module-name int2)
3495 name)
3496 (module-local-variable int2 name))))
f595ccfe 3497
65bed4aa
MD
3498 (define (first module name int1 val1 int2 val2 var val)
3499 (or var (module-local-variable int1 name)))
f595ccfe 3500
65bed4aa
MD
3501 (define (last module name int1 val1 int2 val2 var val)
3502 (module-local-variable int2 name))
f595ccfe 3503
65bed4aa
MD
3504 (define (noop module name int1 val1 int2 val2 var val)
3505 #f)
3506
7b07e5ef
MD
3507 (set-module-name! m 'duplicate-handlers)
3508 (set-module-kind! m 'interface)
f595ccfe
MD
3509 (module-define! m 'check check)
3510 (module-define! m 'warn warn)
3511 (module-define! m 'replace replace)
3512 (module-define! m 'warn-override-core warn-override-core)
3513 (module-define! m 'first first)
3514 (module-define! m 'last last)
65bed4aa
MD
3515 (module-define! m 'merge-generics noop)
3516 (module-define! m 'merge-accessors noop)
7b07e5ef
MD
3517 m))
3518
f595ccfe 3519(define (lookup-duplicates-handlers handler-names)
109c2c9f
MD
3520 (and handler-names
3521 (map (lambda (handler-name)
9b5a0d84
AW
3522 (or (module-symbol-local-binding
3523 duplicate-handlers handler-name #f)
3524 (error "invalid duplicate handler name:"
3525 handler-name)))
3526 (if (list? handler-names)
3527 handler-names
3528 (list handler-names)))))
f595ccfe 3529
70a459e3
MD
3530(define default-duplicate-binding-procedures
3531 (make-mutable-parameter #f))
3532
3533(define default-duplicate-binding-handler
6496a663 3534 (make-mutable-parameter '(replace warn-override-core warn last)
9b5a0d84
AW
3535 (lambda (handler-names)
3536 (default-duplicate-binding-procedures
3537 (lookup-duplicates-handlers handler-names))
3538 handler-names)))
f595ccfe 3539
7b07e5ef 3540\f
7f24bc58 3541
c50775e2
AW
3542;;; {`load'.}
3543;;;
3544;;; Load is tricky when combined with relative paths, compilation, and
b3da54d1 3545;;; the file system. If a path is relative, what is it relative to? The
c50775e2
AW
3546;;; path of the source file at the time it was compiled? The path of
3547;;; the compiled file? What if both or either were installed? And how
3548;;; do you get that information? Tricky, I say.
3549;;;
3550;;; To get around all of this, we're going to do something nasty, and
3551;;; turn `load' into a macro. That way it can know the path of the
3552;;; source file with respect to which it was invoked, so it can resolve
3553;;; relative paths with respect to the original source path.
3554;;;
3555;;; There is an exception, and that is that if the source file was in
3556;;; the load path when it was compiled, instead of looking up against
3557;;; the absolute source location, we load-from-path against the relative
3558;;; source location.
3559;;;
3560
5a79300f
LC
3561(define %auto-compilation-options
3562 ;; Default `compile-file' option when auto-compiling.
f86f748d 3563 '(#:warnings (unbound-variable arity-mismatch format)))
5a79300f 3564
c50775e2 3565(define* (load-in-vicinity dir path #:optional reader)
6934d9e7
AW
3566 (define (canonical->suffix canon)
3567 (cond
3568 ((string-prefix? "/" canon) canon)
3569 ((and (> (string-length canon) 2)
3570 (eqv? (string-ref canon 1) #\:))
3571 ;; Paths like C:... transform to /C...
3572 (string-append "/" (substring canon 0 1) (substring canon 2)))
3573 (else canon)))
3574
c50775e2
AW
3575 ;; Returns the .go file corresponding to `name'. Does not search load
3576 ;; paths, only the fallback path. If the .go file is missing or out of
6f06e8d3 3577 ;; date, and auto-compilation is enabled, will try auto-compilation, just
c50775e2 3578 ;; as primitive-load-path does internally. primitive-load is
6f06e8d3 3579 ;; unaffected. Returns #f if auto-compilation failed or was disabled.
c50775e2
AW
3580 ;;
3581 ;; NB: Unless we need to compile the file, this function should not cause
3582 ;; (system base compile) to be loaded up. For that reason compiled-file-name
3583 ;; partially duplicates functionality from (system base compile).
3584 ;;
3585 (define (compiled-file-name canon-path)
6934d9e7
AW
3586 ;; FIXME: would probably be better just to append SHA1(canon-path)
3587 ;; to the %compile-fallback-path, to avoid deep directory stats.
c50775e2
AW
3588 (and %compile-fallback-path
3589 (string-append
3590 %compile-fallback-path
6934d9e7 3591 (canonical->suffix canon-path)
c50775e2
AW
3592 (cond ((or (null? %load-compiled-extensions)
3593 (string-null? (car %load-compiled-extensions)))
3594 (warn "invalid %load-compiled-extensions"
3595 %load-compiled-extensions)
3596 ".go")
3597 (else (car %load-compiled-extensions))))))
3598
3599 (define (fresh-compiled-file-name name go-path)
3600 (catch #t
3601 (lambda ()
3602 (let* ((scmstat (stat name))
1e56cff2
AW
3603 (gostat (and (not %fresh-auto-compile)
3604 (stat go-path #f))))
c50775e2
AW
3605 (if (and gostat
3606 (or (> (stat:mtime gostat) (stat:mtime scmstat))
3607 (and (= (stat:mtime gostat) (stat:mtime scmstat))
3608 (>= (stat:mtimensec gostat)
3609 (stat:mtimensec scmstat)))))
3610 go-path
3611 (begin
3612 (if gostat
2c27dd57 3613 (format (current-warning-port)
c50775e2
AW
3614 ";;; note: source file ~a\n;;; newer than compiled ~a\n"
3615 name go-path))
3616 (cond
6f06e8d3
AW
3617 (%load-should-auto-compile
3618 (%warn-auto-compilation-enabled)
2c27dd57 3619 (format (current-warning-port) ";;; compiling ~a\n" name)
5a79300f
LC
3620 (let ((cfn
3621 ((module-ref
c50775e2
AW
3622 (resolve-interface '(system base compile))
3623 'compile-file)
3624 name
5a79300f 3625 #:opts %auto-compilation-options
c50775e2 3626 #:env (current-module))))
2c27dd57 3627 (format (current-warning-port) ";;; compiled ~a\n" cfn)
c50775e2
AW
3628 cfn))
3629 (else #f))))))
3630 (lambda (k . args)
2c27dd57 3631 (format (current-warning-port)
669ea4eb
AW
3632 ";;; WARNING: compilation of ~a failed:\n" name)
3633 (for-each (lambda (s)
3634 (if (not (string-null? s))
2c27dd57 3635 (format (current-warning-port) ";;; ~a\n" s)))
669ea4eb
AW
3636 (string-split
3637 (call-with-output-string
3638 (lambda (port) (print-exception port #f k args)))
3639 #\newline))
c50775e2
AW
3640 #f)))
3641
3642 (define (absolute-path? path)
3643 (string-prefix? "/" path))
3644
3645 (define (load-absolute abs-path)
3646 (let ((cfn (let ((canon (false-if-exception (canonicalize-path abs-path))))
3647 (and canon
3648 (let ((go-path (compiled-file-name canon)))
3649 (and go-path
3650 (fresh-compiled-file-name abs-path go-path)))))))
3651 (if cfn
dcada7d8
AW
3652 (begin
3653 (if %load-hook
3654 (%load-hook abs-path))
3655 (load-compiled cfn))
c50775e2
AW
3656 (start-stack 'load-stack
3657 (primitive-load abs-path)))))
3658
3659 (save-module-excursion
3660 (lambda ()
3661 (with-fluids ((current-reader reader)
3662 (%file-port-name-canonicalization 'relative))
3663 (cond
3664 ((or (absolute-path? path))
3665 (load-absolute path))
3666 ((absolute-path? dir)
3667 (load-absolute (in-vicinity dir path)))
3668 (else
3669 (load-from-path (in-vicinity dir path))))))))
3670
3671(define-syntax load
3672 (make-variable-transformer
3673 (lambda (x)
3674 (let* ((src (syntax-source x))
3675 (file (and src (assq-ref src 'filename)))
3676 (dir (and (string? file) (dirname file))))
3677 (syntax-case x ()
3678 ((_ arg ...)
3679 #`(load-in-vicinity #,(or dir #'(getcwd)) arg ...))
3680 (id
3681 (identifier? #'id)
3682 #`(lambda args
3683 (apply load-in-vicinity #,(or dir #'(getcwd)) args))))))))
3684
3685\f
3686
7f24bc58
MG
3687;;; {`cond-expand' for SRFI-0 support.}
3688;;;
3689;;; This syntactic form expands into different commands or
3690;;; definitions, depending on the features provided by the Scheme
3691;;; implementation.
3692;;;
3693;;; Syntax:
3694;;;
3695;;; <cond-expand>
3696;;; --> (cond-expand <cond-expand-clause>+)
3697;;; | (cond-expand <cond-expand-clause>* (else <command-or-definition>))
3698;;; <cond-expand-clause>
3699;;; --> (<feature-requirement> <command-or-definition>*)
3700;;; <feature-requirement>
3701;;; --> <feature-identifier>
3702;;; | (and <feature-requirement>*)
3703;;; | (or <feature-requirement>*)
3704;;; | (not <feature-requirement>)
3705;;; <feature-identifier>
3706;;; --> <a symbol which is the name or alias of a SRFI>
3707;;;
3708;;; Additionally, this implementation provides the
3709;;; <feature-identifier>s `guile' and `r5rs', so that programs can
3710;;; determine the implementation type and the supported standard.
3711;;;
3712;;; Currently, the following feature identifiers are supported:
3713;;;
08b609aa 3714;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
7f24bc58
MG
3715;;;
3716;;; Remember to update the features list when adding more SRFIs.
3d2ada2f 3717;;;
7f24bc58 3718
b9b8f9da 3719(define %cond-expand-features
f41be016 3720 ;; Adjust the above comment when changing this.
018733ff 3721 '(guile
60c8ad9e 3722 guile-2
018733ff
KR
3723 r5rs
3724 srfi-0 ;; cond-expand itself
85acb35f 3725 srfi-4 ;; homogenous numeric vectors
018733ff 3726 srfi-6 ;; open-input-string etc, in the guile core
4a276c08
MV
3727 srfi-13 ;; string library
3728 srfi-14 ;; character sets
9670f238
AW
3729 srfi-23 ;; `error` procedure
3730 srfi-39 ;; parameterize
344d68d5 3731 srfi-55 ;; require-extension
08b609aa 3732 srfi-61 ;; general cond clause
018733ff 3733 ))
1d00af09 3734
b9b8f9da
MG
3735;; This table maps module public interfaces to the list of features.
3736;;
3737(define %cond-expand-table (make-hash-table 31))
3738
3739;; Add one or more features to the `cond-expand' feature list of the
3740;; module `module'.
3741;;
3742(define (cond-expand-provide module features)
3743 (let ((mod (module-public-interface module)))
3744 (and mod
9b5a0d84
AW
3745 (hashq-set! %cond-expand-table mod
3746 (append (hashq-ref %cond-expand-table mod '())
3747 features)))))
b9b8f9da 3748
1fdd5bec
AW
3749(define-syntax cond-expand
3750 (lambda (x)
3751 (define (module-has-feature? mod sym)
3752 (or-map (lambda (mod)
3753 (memq sym (hashq-ref %cond-expand-table mod '())))
3754 (module-uses mod)))
3755
3756 (define (condition-matches? condition)
3757 (syntax-case condition (and or not)
3758 ((and c ...)
3759 (and-map condition-matches? #'(c ...)))
3760 ((or c ...)
3761 (or-map condition-matches? #'(c ...)))
3762 ((not c)
3763 (if (condition-matches? #'c) #f #t))
3764 (c
3765 (identifier? #'c)
3766 (let ((sym (syntax->datum #'c)))
3767 (if (memq sym %cond-expand-features)
3768 #t
3769 (module-has-feature? (current-module) sym))))))
3770
3771 (define (match clauses alternate)
3772 (syntax-case clauses ()
3773 (((condition form ...) . rest)
3774 (if (condition-matches? #'condition)
3775 #'(begin form ...)
3776 (match #'rest alternate)))
3777 (() (alternate))))
3778
3779 (syntax-case x (else)
3780 ((_ clause ... (else form ...))
3781 (match #'(clause ...)
3782 (lambda ()
3783 #'(begin form ...))))
3784 ((_ clause ...)
3785 (match #'(clause ...)
3786 (lambda ()
3787 (syntax-violation 'cond-expand "unfulfilled cond-expand" x)))))))
0f2d19dd 3788
f41be016
MG
3789;; This procedure gets called from the startup code with a list of
3790;; numbers, which are the numbers of the SRFIs to be loaded on startup.
3791;;
3792(define (use-srfis srfis)
9a18d8d4
KR
3793 (process-use-modules
3794 (map (lambda (num)
9b5a0d84
AW
3795 (list (list 'srfi (string->symbol
3796 (string-append "srfi-" (number->string num))))))
3797 srfis)))
f8a502cb 3798
0f2d19dd 3799\f
9d774814 3800
344d68d5
RB
3801;;; srfi-55: require-extension
3802;;;
3803
6669cd81
AW
3804(define-syntax require-extension
3805 (lambda (x)
3806 (syntax-case x (srfi)
3807 ((_ (srfi n ...))
3808 (and-map integer? (syntax->datum #'(n ...)))
3809 (with-syntax
3810 (((srfi-n ...)
3811 (map (lambda (n)
3812 (datum->syntax x (symbol-append 'srfi- n)))
3813 (map string->symbol
3814 (map number->string (syntax->datum #'(n ...)))))))
3815 #'(use-modules (srfi srfi-n) ...)))
3816 ((_ (type arg ...))
3817 (identifier? #'type)
3818 (syntax-violation 'require-extension "Not a recognized extension type"
3819 x)))))
344d68d5
RB
3820
3821\f
165b10dd
AR
3822;;; Defining transparently inlinable procedures
3823;;;
3824
3825(define-syntax define-inlinable
3826 ;; Define a macro and a procedure such that direct calls are inlined, via
3827 ;; the macro expansion, whereas references in non-call contexts refer to
3828 ;; the procedure. Inspired by the `define-integrable' macro by Dybvig et al.
3829 (lambda (x)
3830 ;; Use a space in the prefix to avoid potential -Wunused-toplevel
3831 ;; warning
3832 (define prefix (string->symbol "% "))
3833 (define (make-procedure-name name)
3834 (datum->syntax name
3835 (symbol-append prefix (syntax->datum name)
3836 '-procedure)))
3837
3838 (syntax-case x ()
3839 ((_ (name formals ...) body ...)
3840 (identifier? #'name)
3841 (with-syntax ((proc-name (make-procedure-name #'name))
3842 ((args ...) (generate-temporaries #'(formals ...))))
3843 #`(begin
3844 (define (proc-name formals ...)
449bf60b 3845 (syntax-parameterize ((name (identifier-syntax proc-name)))
2844ab85 3846 body ...))
449bf60b 3847 (define-syntax-parameter name
165b10dd
AR
3848 (lambda (x)
3849 (syntax-case x ()
3850 ((_ args ...)
449bf60b 3851 #'((syntax-parameterize ((name (identifier-syntax proc-name)))
2844ab85
AW
3852 (lambda (formals ...)
3853 body ...))
165b10dd
AR
3854 args ...))
3855 (_
3856 (identifier? x)
3857 #'proc-name))))))))))
3858
3859\f
344d68d5 3860
755457ec
MD
3861(define using-readline?
3862 (let ((using-readline? (make-fluid)))
3863 (make-procedure-with-setter
3864 (lambda () (fluid-ref using-readline?))
3865 (lambda (v) (fluid-set! using-readline? v)))))
3866
4d31f0da 3867\f
3d2ada2f
DH
3868
3869;;; {Deprecated stuff}
3870;;;
3871
3d2ada2f 3872(begin-deprecated
0ea72faa 3873 (module-use! the-scm-module (resolve-interface '(ice-9 deprecated))))
3d2ada2f
DH
3874
3875\f
3876
68fcf711
AW
3877;;; SRFI-4 in the default environment. FIXME: we should figure out how
3878;;; to deprecate this.
3d2ada2f 3879;;;
6eb396fe 3880
a2689737
AW
3881;; FIXME:
3882(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
3883
68fcf711
AW
3884\f
3885
3886;;; A few identifiers that need to be defined in this file are really
3887;;; internal implementation details. We shove them off into internal
3888;;; modules, removing them from the (guile) module.
3889;;;
3890
3891(define-module (system syntax))
3892
3893(let ()
3894 (define (steal-bindings! from to ids)
3895 (for-each
3896 (lambda (sym)
3897 (let ((v (module-local-variable from sym)))
3898 (module-remove! from sym)
3899 (module-add! to sym v)))
3900 ids)
3901 (module-export! to ids))
3902
3903 (steal-bindings! the-root-module (resolve-module '(system syntax))
3904 '(syntax-local-binding
3905 syntax-module
f9685f43
AW
3906 syntax-locally-bound-identifiers
3907 syntax-session-id)))
68fcf711
AW
3908
3909
3910\f
3911
3912;;; Place the user in the guile-user module.
3913;;;
3914
7cf64a0a 3915;; Set filename to #f to prevent reload.
68623e8e 3916(define-module (guile-user)
7cf64a0a
AW
3917 #:autoload (system base compile) (compile compile-file)
3918 #:filename #f)
6d36532c 3919
7385dc12
LC
3920;; Remain in the `(guile)' module at compilation-time so that the
3921;; `-Wunused-toplevel' warning works as expected.
3922(eval-when (compile) (set-current-module the-root-module))
3923
20edfbbd 3924;;; boot-9.scm ends here