(module-make-local-var!): When creating a new variable, initialize it
[bpt/guile.git] / ice-9 / boot-9.scm
1 ;;; installed-scm-file
2
3 ;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
4 ;;;; Free Software Foundation, Inc.
5 ;;;;
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 2.1 of the License, or (at your option) any later version.
10 ;;;;
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
15 ;;;;
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19 ;;;;
20
21 \f
22
23 ;;; Commentary:
24
25 ;;; This file is the first thing loaded into Guile. It adds many mundane
26 ;;; definitions and a few that are interesting.
27 ;;;
28 ;;; The module system (hence the hierarchical namespace) are defined in this
29 ;;; file.
30 ;;;
31
32 ;;; Code:
33
34 \f
35
36 ;;; {Features}
37 ;;;
38
39 (define (provide sym)
40 (if (not (memq sym *features*))
41 (set! *features* (cons sym *features*))))
42
43 ;; Return #t iff FEATURE is available to this Guile interpreter. In SLIB,
44 ;; provided? also checks to see if the module is available. We should do that
45 ;; too, but don't.
46
47 (define (provided? feature)
48 (and (memq feature *features*) #t))
49
50 ;; let format alias simple-format until the more complete version is loaded
51
52 (define format simple-format)
53
54 ;; this is scheme wrapping the C code so the final pred call is a tail call,
55 ;; per SRFI-13 spec
56 (define (string-any char_pred s . rest)
57 (let ((start (if (null? rest)
58 0 (car rest)))
59 (end (if (or (null? rest) (null? (cdr rest)))
60 (string-length s) (cadr rest))))
61 (if (and (procedure? char_pred)
62 (> end start)
63 (<= end (string-length s))) ;; let c-code handle range error
64 (or (string-any-c-code char_pred s start (1- end))
65 (char_pred (string-ref s (1- end))))
66 (string-any-c-code char_pred s start end))))
67
68 ;; this is scheme wrapping the C code so the final pred call is a tail call,
69 ;; per SRFI-13 spec
70 (define (string-every char_pred s . rest)
71 (let ((start (if (null? rest)
72 0 (car rest)))
73 (end (if (or (null? rest) (null? (cdr rest)))
74 (string-length s) (cadr rest))))
75 (if (and (procedure? char_pred)
76 (> end start)
77 (<= end (string-length s))) ;; let c-code handle range error
78 (and (string-every-c-code char_pred s start (1- end))
79 (char_pred (string-ref s (1- end))))
80 (string-every-c-code char_pred s start end))))
81
82 \f
83
84 ;;; {EVAL-CASE}
85 ;;;
86
87 ;; (eval-case ((situation*) forms)* (else forms)?)
88 ;;
89 ;; Evaluate certain code based on the situation that eval-case is used
90 ;; in. The only defined situation right now is `load-toplevel' which
91 ;; triggers for code evaluated at the top-level, for example from the
92 ;; REPL or when loading a file.
93
94 (define eval-case
95 (procedure->memoizing-macro
96 (lambda (exp env)
97 (define (toplevel-env? env)
98 (or (not (pair? env)) (not (pair? (car env)))))
99 (define (syntax)
100 (error "syntax error in eval-case"))
101 (let loop ((clauses (cdr exp)))
102 (cond
103 ((null? clauses)
104 #f)
105 ((not (list? (car clauses)))
106 (syntax))
107 ((eq? 'else (caar clauses))
108 (or (null? (cdr clauses))
109 (syntax))
110 (cons 'begin (cdar clauses)))
111 ((not (list? (caar clauses)))
112 (syntax))
113 ((and (toplevel-env? env)
114 (memq 'load-toplevel (caar clauses)))
115 (cons 'begin (cdar clauses)))
116 (else
117 (loop (cdr clauses))))))))
118
119 \f
120
121 ;;; {Defmacros}
122 ;;;
123 ;;; Depends on: features, eval-case
124 ;;;
125
126 (define macro-table (make-weak-key-hash-table 61))
127 (define xformer-table (make-weak-key-hash-table 61))
128
129 (define (defmacro? m) (hashq-ref macro-table m))
130 (define (assert-defmacro?! m) (hashq-set! macro-table m #t))
131 (define (defmacro-transformer m) (hashq-ref xformer-table m))
132 (define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))
133
134 (define defmacro:transformer
135 (lambda (f)
136 (let* ((xform (lambda (exp env)
137 (copy-tree (apply f (cdr exp)))))
138 (a (procedure->memoizing-macro xform)))
139 (assert-defmacro?! a)
140 (set-defmacro-transformer! a f)
141 a)))
142
143
144 (define defmacro
145 (let ((defmacro-transformer
146 (lambda (name parms . body)
147 (let ((transformer `(lambda ,parms ,@body)))
148 `(eval-case
149 ((load-toplevel)
150 (define ,name (defmacro:transformer ,transformer)))
151 (else
152 (error "defmacro can only be used at the top level")))))))
153 (defmacro:transformer defmacro-transformer)))
154
155 (define defmacro:syntax-transformer
156 (lambda (f)
157 (procedure->syntax
158 (lambda (exp env)
159 (copy-tree (apply f (cdr exp)))))))
160
161
162 ;; XXX - should the definition of the car really be looked up in the
163 ;; current module?
164
165 (define (macroexpand-1 e)
166 (cond
167 ((pair? e) (let* ((a (car e))
168 (val (and (symbol? a) (local-ref (list a)))))
169 (if (defmacro? val)
170 (apply (defmacro-transformer val) (cdr e))
171 e)))
172 (#t e)))
173
174 (define (macroexpand e)
175 (cond
176 ((pair? e) (let* ((a (car e))
177 (val (and (symbol? a) (local-ref (list a)))))
178 (if (defmacro? val)
179 (macroexpand (apply (defmacro-transformer val) (cdr e)))
180 e)))
181 (#t e)))
182
183 (provide 'defmacro)
184
185 \f
186
187 ;;; {Deprecation}
188 ;;;
189 ;;; Depends on: defmacro
190 ;;;
191
192 (defmacro begin-deprecated forms
193 (if (include-deprecated-features)
194 (cons begin forms)
195 #f))
196
197 \f
198
199 ;;; {R4RS compliance}
200 ;;;
201
202 (primitive-load-path "ice-9/r4rs.scm")
203
204 \f
205
206 ;;; {Simple Debugging Tools}
207 ;;;
208
209 ;; peek takes any number of arguments, writes them to the
210 ;; current ouput port, and returns the last argument.
211 ;; It is handy to wrap around an expression to look at
212 ;; a value each time is evaluated, e.g.:
213 ;;
214 ;; (+ 10 (troublesome-fn))
215 ;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
216 ;;
217
218 (define (peek . stuff)
219 (newline)
220 (display ";;; ")
221 (write stuff)
222 (newline)
223 (car (last-pair stuff)))
224
225 (define pk peek)
226
227 (define (warn . stuff)
228 (with-output-to-port (current-error-port)
229 (lambda ()
230 (newline)
231 (display ";;; WARNING ")
232 (display stuff)
233 (newline)
234 (car (last-pair stuff)))))
235
236 \f
237
238 ;;; {Trivial Functions}
239 ;;;
240
241 (define (identity x) x)
242 (define (1+ n) (+ n 1))
243 (define (1- n) (+ n -1))
244 (define (and=> value procedure) (and value (procedure value)))
245 (define call/cc call-with-current-continuation)
246
247 ;;; apply-to-args is functionally redundant with apply and, worse,
248 ;;; is less general than apply since it only takes two arguments.
249 ;;;
250 ;;; On the other hand, apply-to-args is a syntacticly convenient way to
251 ;;; perform binding in many circumstances when the "let" family of
252 ;;; of forms don't cut it. E.g.:
253 ;;;
254 ;;; (apply-to-args (return-3d-mouse-coords)
255 ;;; (lambda (x y z)
256 ;;; ...))
257 ;;;
258
259 (define (apply-to-args args fn) (apply fn args))
260
261 (defmacro false-if-exception (expr)
262 `(catch #t (lambda () ,expr)
263 (lambda args #f)))
264
265 \f
266
267 ;;; {General Properties}
268 ;;;
269
270 ;; This is a more modern interface to properties. It will replace all
271 ;; other property-like things eventually.
272
273 (define (make-object-property)
274 (let ((prop (primitive-make-property #f)))
275 (make-procedure-with-setter
276 (lambda (obj) (primitive-property-ref prop obj))
277 (lambda (obj val) (primitive-property-set! prop obj val)))))
278
279 \f
280
281 ;;; {Symbol Properties}
282 ;;;
283
284 (define (symbol-property sym prop)
285 (let ((pair (assoc prop (symbol-pref sym))))
286 (and pair (cdr pair))))
287
288 (define (set-symbol-property! sym prop val)
289 (let ((pair (assoc prop (symbol-pref sym))))
290 (if pair
291 (set-cdr! pair val)
292 (symbol-pset! sym (acons prop val (symbol-pref sym))))))
293
294 (define (symbol-property-remove! sym prop)
295 (let ((pair (assoc prop (symbol-pref sym))))
296 (if pair
297 (symbol-pset! sym (delq! pair (symbol-pref sym))))))
298
299 \f
300
301 ;;; {Arrays}
302 ;;;
303
304 (if (provided? 'array)
305 (primitive-load-path "ice-9/arrays.scm"))
306
307 \f
308
309 ;;; {Keywords}
310 ;;;
311
312 (define (kw-arg-ref args kw)
313 (let ((rem (member kw args)))
314 (and rem (pair? (cdr rem)) (cadr rem))))
315
316 \f
317
318 ;;; {Structs}
319 ;;;
320
321 (define (struct-layout s)
322 (struct-ref (struct-vtable s) vtable-index-layout))
323
324 \f
325
326 ;;; {Environments}
327 ;;;
328
329 (define the-environment
330 (procedure->syntax
331 (lambda (x e)
332 e)))
333
334 (define the-root-environment (the-environment))
335
336 (define (environment-module env)
337 (let ((closure (and (pair? env) (car (last-pair env)))))
338 (and closure (procedure-property closure 'module))))
339
340 \f
341
342 ;;; {Records}
343 ;;;
344
345 ;; Printing records: by default, records are printed as
346 ;;
347 ;; #<type-name field1: val1 field2: val2 ...>
348 ;;
349 ;; You can change that by giving a custom printing function to
350 ;; MAKE-RECORD-TYPE (after the list of field symbols). This function
351 ;; will be called like
352 ;;
353 ;; (<printer> object port)
354 ;;
355 ;; It should print OBJECT to PORT.
356
357 (define (inherit-print-state old-port new-port)
358 (if (get-print-state old-port)
359 (port-with-print-state new-port (get-print-state old-port))
360 new-port))
361
362 ;; 0: type-name, 1: fields
363 (define record-type-vtable
364 (make-vtable-vtable "prpr" 0
365 (lambda (s p)
366 (cond ((eq? s record-type-vtable)
367 (display "#<record-type-vtable>" p))
368 (else
369 (display "#<record-type " p)
370 (display (record-type-name s) p)
371 (display ">" p))))))
372
373 (define (record-type? obj)
374 (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
375
376 (define (make-record-type type-name fields . opt)
377 (let ((printer-fn (and (pair? opt) (car opt))))
378 (let ((struct (make-struct record-type-vtable 0
379 (make-struct-layout
380 (apply string-append
381 (map (lambda (f) "pw") fields)))
382 (or printer-fn
383 (lambda (s p)
384 (display "#<" p)
385 (display type-name p)
386 (let loop ((fields fields)
387 (off 0))
388 (cond
389 ((not (null? fields))
390 (display " " p)
391 (display (car fields) p)
392 (display ": " p)
393 (display (struct-ref s off) p)
394 (loop (cdr fields) (+ 1 off)))))
395 (display ">" p)))
396 type-name
397 (copy-tree fields))))
398 ;; Temporary solution: Associate a name to the record type descriptor
399 ;; so that the object system can create a wrapper class for it.
400 (set-struct-vtable-name! struct (if (symbol? type-name)
401 type-name
402 (string->symbol type-name)))
403 struct)))
404
405 (define (record-type-name obj)
406 (if (record-type? obj)
407 (struct-ref obj vtable-offset-user)
408 (error 'not-a-record-type obj)))
409
410 (define (record-type-fields obj)
411 (if (record-type? obj)
412 (struct-ref obj (+ 1 vtable-offset-user))
413 (error 'not-a-record-type obj)))
414
415 (define (record-constructor rtd . opt)
416 (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd))))
417 (local-eval `(lambda ,field-names
418 (make-struct ',rtd 0 ,@(map (lambda (f)
419 (if (memq f field-names)
420 f
421 #f))
422 (record-type-fields rtd))))
423 the-root-environment)))
424
425 (define (record-predicate rtd)
426 (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
427
428 (define (record-accessor rtd field-name)
429 (let* ((pos (list-index (record-type-fields rtd) field-name)))
430 (if (not pos)
431 (error 'no-such-field field-name))
432 (local-eval `(lambda (obj)
433 (and (eq? ',rtd (record-type-descriptor obj))
434 (struct-ref obj ,pos)))
435 the-root-environment)))
436
437 (define (record-modifier rtd field-name)
438 (let* ((pos (list-index (record-type-fields rtd) field-name)))
439 (if (not pos)
440 (error 'no-such-field field-name))
441 (local-eval `(lambda (obj val)
442 (and (eq? ',rtd (record-type-descriptor obj))
443 (struct-set! obj ,pos val)))
444 the-root-environment)))
445
446
447 (define (record? obj)
448 (and (struct? obj) (record-type? (struct-vtable obj))))
449
450 (define (record-type-descriptor obj)
451 (if (struct? obj)
452 (struct-vtable obj)
453 (error 'not-a-record obj)))
454
455 (provide 'record)
456
457 \f
458
459 ;;; {Booleans}
460 ;;;
461
462 (define (->bool x) (not (not x)))
463
464 \f
465
466 ;;; {Symbols}
467 ;;;
468
469 (define (symbol-append . args)
470 (string->symbol (apply string-append (map symbol->string args))))
471
472 (define (list->symbol . args)
473 (string->symbol (apply list->string args)))
474
475 (define (symbol . args)
476 (string->symbol (apply string args)))
477
478 \f
479
480 ;;; {Lists}
481 ;;;
482
483 (define (list-index l k)
484 (let loop ((n 0)
485 (l l))
486 (and (not (null? l))
487 (if (eq? (car l) k)
488 n
489 (loop (+ n 1) (cdr l))))))
490
491 (define (make-list n . init)
492 (if (pair? init) (set! init (car init)))
493 (let loop ((answer '())
494 (n n))
495 (if (<= n 0)
496 answer
497 (loop (cons init answer) (- n 1)))))
498
499 \f
500
501 ;;; {and-map and or-map}
502 ;;;
503 ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
504 ;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
505 ;;;
506
507 ;; and-map f l
508 ;;
509 ;; Apply f to successive elements of l until exhaustion or f returns #f.
510 ;; If returning early, return #f. Otherwise, return the last value returned
511 ;; by f. If f has never been called because l is empty, return #t.
512 ;;
513 (define (and-map f lst)
514 (let loop ((result #t)
515 (l lst))
516 (and result
517 (or (and (null? l)
518 result)
519 (loop (f (car l)) (cdr l))))))
520
521 ;; or-map f l
522 ;;
523 ;; Apply f to successive elements of l until exhaustion or while f returns #f.
524 ;; If returning early, return the return value of f.
525 ;;
526 (define (or-map f lst)
527 (let loop ((result #f)
528 (l lst))
529 (or result
530 (and (not (null? l))
531 (loop (f (car l)) (cdr l))))))
532
533 \f
534
535 (if (provided? 'posix)
536 (primitive-load-path "ice-9/posix.scm"))
537
538 (if (provided? 'socket)
539 (primitive-load-path "ice-9/networking.scm"))
540
541 ;; For reference, Emacs file-exists-p uses stat in this same way.
542 ;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in
543 ;; C where all that's needed is to inspect the return from stat().
544 (define file-exists?
545 (if (provided? 'posix)
546 (lambda (str)
547 (->bool (false-if-exception (stat str))))
548 (lambda (str)
549 (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
550 (lambda args #f))))
551 (if port (begin (close-port port) #t)
552 #f)))))
553
554 (define file-is-directory?
555 (if (provided? 'posix)
556 (lambda (str)
557 (eq? (stat:type (stat str)) 'directory))
558 (lambda (str)
559 (let ((port (catch 'system-error
560 (lambda () (open-file (string-append str "/.")
561 OPEN_READ))
562 (lambda args #f))))
563 (if port (begin (close-port port) #t)
564 #f)))))
565
566 (define (has-suffix? str suffix)
567 (let ((sufl (string-length suffix))
568 (sl (string-length str)))
569 (and (> sl sufl)
570 (string=? (substring str (- sl sufl) sl) suffix))))
571
572 (define (system-error-errno args)
573 (if (eq? (car args) 'system-error)
574 (car (list-ref args 4))
575 #f))
576
577 \f
578
579 ;;; {Error Handling}
580 ;;;
581
582 (define (error . args)
583 (save-stack)
584 (if (null? args)
585 (scm-error 'misc-error #f "?" #f #f)
586 (let loop ((msg "~A")
587 (rest (cdr args)))
588 (if (not (null? rest))
589 (loop (string-append msg " ~S")
590 (cdr rest))
591 (scm-error 'misc-error #f msg args #f)))))
592
593 ;; bad-throw is the hook that is called upon a throw to a an unhandled
594 ;; key (unless the throw has four arguments, in which case
595 ;; it's usually interpreted as an error throw.)
596 ;; If the key has a default handler (a throw-handler-default property),
597 ;; it is applied to the throw.
598 ;;
599 (define (bad-throw key . args)
600 (let ((default (symbol-property key 'throw-handler-default)))
601 (or (and default (apply default key args))
602 (apply error "unhandled-exception:" key args))))
603
604 \f
605
606 (define (tm:sec obj) (vector-ref obj 0))
607 (define (tm:min obj) (vector-ref obj 1))
608 (define (tm:hour obj) (vector-ref obj 2))
609 (define (tm:mday obj) (vector-ref obj 3))
610 (define (tm:mon obj) (vector-ref obj 4))
611 (define (tm:year obj) (vector-ref obj 5))
612 (define (tm:wday obj) (vector-ref obj 6))
613 (define (tm:yday obj) (vector-ref obj 7))
614 (define (tm:isdst obj) (vector-ref obj 8))
615 (define (tm:gmtoff obj) (vector-ref obj 9))
616 (define (tm:zone obj) (vector-ref obj 10))
617
618 (define (set-tm:sec obj val) (vector-set! obj 0 val))
619 (define (set-tm:min obj val) (vector-set! obj 1 val))
620 (define (set-tm:hour obj val) (vector-set! obj 2 val))
621 (define (set-tm:mday obj val) (vector-set! obj 3 val))
622 (define (set-tm:mon obj val) (vector-set! obj 4 val))
623 (define (set-tm:year obj val) (vector-set! obj 5 val))
624 (define (set-tm:wday obj val) (vector-set! obj 6 val))
625 (define (set-tm:yday obj val) (vector-set! obj 7 val))
626 (define (set-tm:isdst obj val) (vector-set! obj 8 val))
627 (define (set-tm:gmtoff obj val) (vector-set! obj 9 val))
628 (define (set-tm:zone obj val) (vector-set! obj 10 val))
629
630 (define (tms:clock obj) (vector-ref obj 0))
631 (define (tms:utime obj) (vector-ref obj 1))
632 (define (tms:stime obj) (vector-ref obj 2))
633 (define (tms:cutime obj) (vector-ref obj 3))
634 (define (tms:cstime obj) (vector-ref obj 4))
635
636 (define file-position ftell)
637 (define (file-set-position port offset . whence)
638 (let ((whence (if (eq? whence '()) SEEK_SET (car whence))))
639 (seek port offset whence)))
640
641 (define (move->fdes fd/port fd)
642 (cond ((integer? fd/port)
643 (dup->fdes fd/port fd)
644 (close fd/port)
645 fd)
646 (else
647 (primitive-move->fdes fd/port fd)
648 (set-port-revealed! fd/port 1)
649 fd/port)))
650
651 (define (release-port-handle port)
652 (let ((revealed (port-revealed port)))
653 (if (> revealed 0)
654 (set-port-revealed! port (- revealed 1)))))
655
656 (define (dup->port port/fd mode . maybe-fd)
657 (let ((port (fdopen (apply dup->fdes port/fd maybe-fd)
658 mode)))
659 (if (pair? maybe-fd)
660 (set-port-revealed! port 1))
661 port))
662
663 (define (dup->inport port/fd . maybe-fd)
664 (apply dup->port port/fd "r" maybe-fd))
665
666 (define (dup->outport port/fd . maybe-fd)
667 (apply dup->port port/fd "w" maybe-fd))
668
669 (define (dup port/fd . maybe-fd)
670 (if (integer? port/fd)
671 (apply dup->fdes port/fd maybe-fd)
672 (apply dup->port port/fd (port-mode port/fd) maybe-fd)))
673
674 (define (duplicate-port port modes)
675 (dup->port port modes))
676
677 (define (fdes->inport fdes)
678 (let loop ((rest-ports (fdes->ports fdes)))
679 (cond ((null? rest-ports)
680 (let ((result (fdopen fdes "r")))
681 (set-port-revealed! result 1)
682 result))
683 ((input-port? (car rest-ports))
684 (set-port-revealed! (car rest-ports)
685 (+ (port-revealed (car rest-ports)) 1))
686 (car rest-ports))
687 (else
688 (loop (cdr rest-ports))))))
689
690 (define (fdes->outport fdes)
691 (let loop ((rest-ports (fdes->ports fdes)))
692 (cond ((null? rest-ports)
693 (let ((result (fdopen fdes "w")))
694 (set-port-revealed! result 1)
695 result))
696 ((output-port? (car rest-ports))
697 (set-port-revealed! (car rest-ports)
698 (+ (port-revealed (car rest-ports)) 1))
699 (car rest-ports))
700 (else
701 (loop (cdr rest-ports))))))
702
703 (define (port->fdes port)
704 (set-port-revealed! port (+ (port-revealed port) 1))
705 (fileno port))
706
707 (define (setenv name value)
708 (if value
709 (putenv (string-append name "=" value))
710 (putenv name)))
711
712 (define (unsetenv name)
713 "Remove the entry for NAME from the environment."
714 (putenv name))
715
716 \f
717
718 ;;; {Load Paths}
719 ;;;
720
721 ;;; Here for backward compatability
722 ;;
723 (define scheme-file-suffix (lambda () ".scm"))
724
725 (define (in-vicinity vicinity file)
726 (let ((tail (let ((len (string-length vicinity)))
727 (if (zero? len)
728 #f
729 (string-ref vicinity (- len 1))))))
730 (string-append vicinity
731 (if (or (not tail)
732 (eq? tail #\/))
733 ""
734 "/")
735 file)))
736
737 \f
738
739 ;;; {Help for scm_shell}
740 ;;;
741 ;;; The argument-processing code used by Guile-based shells generates
742 ;;; Scheme code based on the argument list. This page contains help
743 ;;; functions for the code it generates.
744 ;;;
745
746 (define (command-line) (program-arguments))
747
748 ;; This is mostly for the internal use of the code generated by
749 ;; scm_compile_shell_switches.
750
751 (define (turn-on-debugging)
752 (debug-enable 'debug)
753 (debug-enable 'backtrace)
754 (read-enable 'positions))
755
756 (define (load-user-init)
757 (let* ((home (or (getenv "HOME")
758 (false-if-exception (passwd:dir (getpwuid (getuid))))
759 "/")) ;; fallback for cygwin etc.
760 (init-file (in-vicinity home ".guile")))
761 (if (file-exists? init-file)
762 (primitive-load init-file))))
763
764 \f
765
766 ;;; {Loading by paths}
767 ;;;
768
769 ;;; Load a Scheme source file named NAME, searching for it in the
770 ;;; directories listed in %load-path, and applying each of the file
771 ;;; name extensions listed in %load-extensions.
772 (define (load-from-path name)
773 (start-stack 'load-stack
774 (primitive-load-path name)))
775
776
777 \f
778
779 ;;; {Transcendental Functions}
780 ;;;
781 ;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
782 ;;; Written by Jerry D. Hedden, (C) FSF.
783 ;;; See the file `COPYING' for terms applying to this program.
784 ;;;
785
786 (define (exp z)
787 (if (real? z) ($exp z)
788 (make-polar ($exp (real-part z)) (imag-part z))))
789
790 (define (log z)
791 (if (and (real? z) (>= z 0))
792 ($log z)
793 (make-rectangular ($log (magnitude z)) (angle z))))
794
795 (define (sqrt z)
796 (if (real? z)
797 (if (negative? z) (make-rectangular 0 ($sqrt (- z)))
798 ($sqrt z))
799 (make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
800
801 (define expt
802 (let ((integer-expt integer-expt))
803 (lambda (z1 z2)
804 (cond ((and (exact? z2) (integer? z2))
805 (integer-expt z1 z2))
806 ((and (real? z2) (real? z1) (>= z1 0))
807 ($expt z1 z2))
808 (else
809 (exp (* z2 (log z1))))))))
810
811 (define (sinh z)
812 (if (real? z) ($sinh z)
813 (let ((x (real-part z)) (y (imag-part z)))
814 (make-rectangular (* ($sinh x) ($cos y))
815 (* ($cosh x) ($sin y))))))
816 (define (cosh z)
817 (if (real? z) ($cosh z)
818 (let ((x (real-part z)) (y (imag-part z)))
819 (make-rectangular (* ($cosh x) ($cos y))
820 (* ($sinh x) ($sin y))))))
821 (define (tanh z)
822 (if (real? z) ($tanh z)
823 (let* ((x (* 2 (real-part z)))
824 (y (* 2 (imag-part z)))
825 (w (+ ($cosh x) ($cos y))))
826 (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
827
828 (define (asinh z)
829 (if (real? z) ($asinh z)
830 (log (+ z (sqrt (+ (* z z) 1))))))
831
832 (define (acosh z)
833 (if (and (real? z) (>= z 1))
834 ($acosh z)
835 (log (+ z (sqrt (- (* z z) 1))))))
836
837 (define (atanh z)
838 (if (and (real? z) (> z -1) (< z 1))
839 ($atanh z)
840 (/ (log (/ (+ 1 z) (- 1 z))) 2)))
841
842 (define (sin z)
843 (if (real? z) ($sin z)
844 (let ((x (real-part z)) (y (imag-part z)))
845 (make-rectangular (* ($sin x) ($cosh y))
846 (* ($cos x) ($sinh y))))))
847 (define (cos z)
848 (if (real? z) ($cos z)
849 (let ((x (real-part z)) (y (imag-part z)))
850 (make-rectangular (* ($cos x) ($cosh y))
851 (- (* ($sin x) ($sinh y)))))))
852 (define (tan z)
853 (if (real? z) ($tan z)
854 (let* ((x (* 2 (real-part z)))
855 (y (* 2 (imag-part z)))
856 (w (+ ($cos x) ($cosh y))))
857 (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
858
859 (define (asin z)
860 (if (and (real? z) (>= z -1) (<= z 1))
861 ($asin z)
862 (* -i (asinh (* +i z)))))
863
864 (define (acos z)
865 (if (and (real? z) (>= z -1) (<= z 1))
866 ($acos z)
867 (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
868
869 (define (atan z . y)
870 (if (null? y)
871 (if (real? z) ($atan z)
872 (/ (log (/ (- +i z) (+ +i z))) +2i))
873 ($atan2 z (car y))))
874
875 (define (log10 arg)
876 (/ (log arg) (log 10)))
877
878 \f
879
880 ;;; {Reader Extensions}
881 ;;;
882 ;;; Reader code for various "#c" forms.
883 ;;;
884
885 (read-hash-extend #\' (lambda (c port)
886 (read port)))
887
888 (define read-eval? (make-fluid))
889 (fluid-set! read-eval? #f)
890 (read-hash-extend #\.
891 (lambda (c port)
892 (if (fluid-ref read-eval?)
893 (eval (read port) (interaction-environment))
894 (error
895 "#. read expansion found and read-eval? is #f."))))
896
897 \f
898
899 ;;; {Command Line Options}
900 ;;;
901
902 (define (get-option argv kw-opts kw-args return)
903 (cond
904 ((null? argv)
905 (return #f #f argv))
906
907 ((or (not (eq? #\- (string-ref (car argv) 0)))
908 (eq? (string-length (car argv)) 1))
909 (return 'normal-arg (car argv) (cdr argv)))
910
911 ((eq? #\- (string-ref (car argv) 1))
912 (let* ((kw-arg-pos (or (string-index (car argv) #\=)
913 (string-length (car argv))))
914 (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
915 (kw-opt? (member kw kw-opts))
916 (kw-arg? (member kw kw-args))
917 (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
918 (substring (car argv)
919 (+ kw-arg-pos 1)
920 (string-length (car argv))))
921 (and kw-arg?
922 (begin (set! argv (cdr argv)) (car argv))))))
923 (if (or kw-opt? kw-arg?)
924 (return kw arg (cdr argv))
925 (return 'usage-error kw (cdr argv)))))
926
927 (else
928 (let* ((char (substring (car argv) 1 2))
929 (kw (symbol->keyword char)))
930 (cond
931
932 ((member kw kw-opts)
933 (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
934 (new-argv (if (= 0 (string-length rest-car))
935 (cdr argv)
936 (cons (string-append "-" rest-car) (cdr argv)))))
937 (return kw #f new-argv)))
938
939 ((member kw kw-args)
940 (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
941 (arg (if (= 0 (string-length rest-car))
942 (cadr argv)
943 rest-car))
944 (new-argv (if (= 0 (string-length rest-car))
945 (cddr argv)
946 (cdr argv))))
947 (return kw arg new-argv)))
948
949 (else (return 'usage-error kw argv)))))))
950
951 (define (for-next-option proc argv kw-opts kw-args)
952 (let loop ((argv argv))
953 (get-option argv kw-opts kw-args
954 (lambda (opt opt-arg argv)
955 (and opt (proc opt opt-arg argv loop))))))
956
957 (define (display-usage-report kw-desc)
958 (for-each
959 (lambda (kw)
960 (or (eq? (car kw) #t)
961 (eq? (car kw) 'else)
962 (let* ((opt-desc kw)
963 (help (cadr opt-desc))
964 (opts (car opt-desc))
965 (opts-proper (if (string? (car opts)) (cdr opts) opts))
966 (arg-name (if (string? (car opts))
967 (string-append "<" (car opts) ">")
968 ""))
969 (left-part (string-append
970 (with-output-to-string
971 (lambda ()
972 (map (lambda (x) (display (keyword->symbol x)) (display " "))
973 opts-proper)))
974 arg-name))
975 (middle-part (if (and (< (string-length left-part) 30)
976 (< (string-length help) 40))
977 (make-string (- 30 (string-length left-part)) #\ )
978 "\n\t")))
979 (display left-part)
980 (display middle-part)
981 (display help)
982 (newline))))
983 kw-desc))
984
985
986
987 (define (transform-usage-lambda cases)
988 (let* ((raw-usage (delq! 'else (map car cases)))
989 (usage-sans-specials (map (lambda (x)
990 (or (and (not (list? x)) x)
991 (and (symbol? (car x)) #t)
992 (and (boolean? (car x)) #t)
993 x))
994 raw-usage))
995 (usage-desc (delq! #t usage-sans-specials))
996 (kw-desc (map car usage-desc))
997 (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
998 (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
999 (transmogrified-cases (map (lambda (case)
1000 (cons (let ((opts (car case)))
1001 (if (or (boolean? opts) (eq? 'else opts))
1002 opts
1003 (cond
1004 ((symbol? (car opts)) opts)
1005 ((boolean? (car opts)) opts)
1006 ((string? (caar opts)) (cdar opts))
1007 (else (car opts)))))
1008 (cdr case)))
1009 cases)))
1010 `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
1011 (lambda (%argv)
1012 (let %next-arg ((%argv %argv))
1013 (get-option %argv
1014 ',kw-opts
1015 ',kw-args
1016 (lambda (%opt %arg %new-argv)
1017 (case %opt
1018 ,@ transmogrified-cases))))))))
1019
1020
1021 \f
1022
1023 ;;; {Low Level Modules}
1024 ;;;
1025 ;;; These are the low level data structures for modules.
1026 ;;;
1027 ;;; Every module object is of the type 'module-type', which is a record
1028 ;;; consisting of the following members:
1029 ;;;
1030 ;;; - eval-closure: the function that defines for its module the strategy that
1031 ;;; shall be followed when looking up symbols in the module.
1032 ;;;
1033 ;;; An eval-closure is a function taking two arguments: the symbol to be
1034 ;;; looked up and a boolean value telling whether a binding for the symbol
1035 ;;; should be created if it does not exist yet. If the symbol lookup
1036 ;;; succeeded (either because an existing binding was found or because a new
1037 ;;; binding was created), a variable object representing the binding is
1038 ;;; returned. Otherwise, the value #f is returned. Note that the eval
1039 ;;; closure does not take the module to be searched as an argument: During
1040 ;;; construction of the eval-closure, the eval-closure has to store the
1041 ;;; module it belongs to in its environment. This means, that any
1042 ;;; eval-closure can belong to only one module.
1043 ;;;
1044 ;;; The eval-closure of a module can be defined arbitrarily. However, three
1045 ;;; special cases of eval-closures are to be distinguished: During startup
1046 ;;; the module system is not yet activated. In this phase, no modules are
1047 ;;; defined and all bindings are automatically stored by the system in the
1048 ;;; pre-modules-obarray. Since no eval-closures exist at this time, the
1049 ;;; functions which require an eval-closure as their argument need to be
1050 ;;; passed the value #f.
1051 ;;;
1052 ;;; The other two special cases of eval-closures are the
1053 ;;; standard-eval-closure and the standard-interface-eval-closure. Both
1054 ;;; behave equally for the case that no new binding is to be created. The
1055 ;;; difference between the two comes in, when the boolean argument to the
1056 ;;; eval-closure indicates that a new binding shall be created if it is not
1057 ;;; found.
1058 ;;;
1059 ;;; Given that no new binding shall be created, both standard eval-closures
1060 ;;; define the following standard strategy of searching bindings in the
1061 ;;; module: First, the module's obarray is searched for the symbol. Second,
1062 ;;; if no binding for the symbol was found in the module's obarray, the
1063 ;;; module's binder procedure is exececuted. If this procedure did not
1064 ;;; return a binding for the symbol, the modules referenced in the module's
1065 ;;; uses list are recursively searched for a binding of the symbol. If the
1066 ;;; binding can not be found in these modules also, the symbol lookup has
1067 ;;; failed.
1068 ;;;
1069 ;;; If a new binding shall be created, the standard-interface-eval-closure
1070 ;;; immediately returns indicating failure. That is, it does not even try
1071 ;;; to look up the symbol. In contrast, the standard-eval-closure would
1072 ;;; first search the obarray, and if no binding was found there, would
1073 ;;; create a new binding in the obarray, therefore not calling the binder
1074 ;;; procedure or searching the modules in the uses list.
1075 ;;;
1076 ;;; The explanation of the following members obarray, binder and uses
1077 ;;; assumes that the symbol lookup follows the strategy that is defined in
1078 ;;; the standard-eval-closure and the standard-interface-eval-closure.
1079 ;;;
1080 ;;; - obarray: a hash table that maps symbols to variable objects. In this
1081 ;;; hash table, the definitions are found that are local to the module (that
1082 ;;; is, not imported from other modules). When looking up bindings in the
1083 ;;; module, this hash table is searched first.
1084 ;;;
1085 ;;; - binder: either #f or a function taking a module and a symbol argument.
1086 ;;; If it is a function it is called after the obarray has been
1087 ;;; unsuccessfully searched for a binding. It then can provide bindings
1088 ;;; that would otherwise not be found locally in the module.
1089 ;;;
1090 ;;; - uses: a list of modules from which non-local bindings can be inherited.
1091 ;;; These modules are the third place queried for bindings after the obarray
1092 ;;; has been unsuccessfully searched and the binder function did not deliver
1093 ;;; a result either.
1094 ;;;
1095 ;;; - transformer: either #f or a function taking a scheme expression as
1096 ;;; delivered by read. If it is a function, it will be called to perform
1097 ;;; syntax transformations (e. g. makro expansion) on the given scheme
1098 ;;; expression. The output of the transformer function will then be passed
1099 ;;; to Guile's internal memoizer. This means that the output must be valid
1100 ;;; scheme code. The only exception is, that the output may make use of the
1101 ;;; syntax extensions provided to identify the modules that a binding
1102 ;;; belongs to.
1103 ;;;
1104 ;;; - name: the name of the module. This is used for all kinds of printing
1105 ;;; outputs. In certain places the module name also serves as a way of
1106 ;;; identification. When adding a module to the uses list of another
1107 ;;; module, it is made sure that the new uses list will not contain two
1108 ;;; modules of the same name.
1109 ;;;
1110 ;;; - kind: classification of the kind of module. The value is (currently?)
1111 ;;; only used for printing. It has no influence on how a module is treated.
1112 ;;; Currently the following values are used when setting the module kind:
1113 ;;; 'module, 'directory, 'interface, 'custom-interface. If no explicit kind
1114 ;;; is set, it defaults to 'module.
1115 ;;;
1116 ;;; - duplicates-handlers
1117 ;;;
1118 ;;; - duplicates-interface
1119 ;;;
1120 ;;; - observers
1121 ;;;
1122 ;;; - weak-observers
1123 ;;;
1124 ;;; - observer-id
1125 ;;;
1126 ;;; In addition, the module may (must?) contain a binding for
1127 ;;; %module-public-interface... More explanations here...
1128 ;;;
1129 ;;; !!! warning: The interface to lazy binder procedures is going
1130 ;;; to be changed in an incompatible way to permit all the basic
1131 ;;; module ops to be virtualized.
1132 ;;;
1133 ;;; (make-module size use-list lazy-binding-proc) => module
1134 ;;; module-{obarray,uses,binder}[|-set!]
1135 ;;; (module? obj) => [#t|#f]
1136 ;;; (module-locally-bound? module symbol) => [#t|#f]
1137 ;;; (module-bound? module symbol) => [#t|#f]
1138 ;;; (module-symbol-locally-interned? module symbol) => [#t|#f]
1139 ;;; (module-symbol-interned? module symbol) => [#t|#f]
1140 ;;; (module-local-variable module symbol) => [#<variable ...> | #f]
1141 ;;; (module-variable module symbol) => [#<variable ...> | #f]
1142 ;;; (module-symbol-binding module symbol opt-value)
1143 ;;; => [ <obj> | opt-value | an error occurs ]
1144 ;;; (module-make-local-var! module symbol) => #<variable...>
1145 ;;; (module-add! module symbol var) => unspecified
1146 ;;; (module-remove! module symbol) => unspecified
1147 ;;; (module-for-each proc module) => unspecified
1148 ;;; (make-scm-module) => module ; a lazy copy of the symhash module
1149 ;;; (set-current-module module) => unspecified
1150 ;;; (current-module) => #<module...>
1151 ;;;
1152 ;;;
1153
1154 \f
1155
1156 ;;; {Printing Modules}
1157 ;;;
1158
1159 ;; This is how modules are printed. You can re-define it.
1160 ;; (Redefining is actually more complicated than simply redefining
1161 ;; %print-module because that would only change the binding and not
1162 ;; the value stored in the vtable that determines how record are
1163 ;; printed. Sigh.)
1164
1165 (define (%print-module mod port) ; unused args: depth length style table)
1166 (display "#<" port)
1167 (display (or (module-kind mod) "module") port)
1168 (let ((name (module-name mod)))
1169 (if name
1170 (begin
1171 (display " " port)
1172 (display name port))))
1173 (display " " port)
1174 (display (number->string (object-address mod) 16) port)
1175 (display ">" port))
1176
1177 ;; module-type
1178 ;;
1179 ;; A module is characterized by an obarray in which local symbols
1180 ;; are interned, a list of modules, "uses", from which non-local
1181 ;; bindings can be inherited, and an optional lazy-binder which
1182 ;; is a (CLOSURE module symbol) which, as a last resort, can provide
1183 ;; bindings that would otherwise not be found locally in the module.
1184 ;;
1185 ;; NOTE: If you change anything here, you also need to change
1186 ;; libguile/modules.h.
1187 ;;
1188 (define module-type
1189 (make-record-type 'module
1190 '(obarray uses binder eval-closure transformer name kind
1191 duplicates-handlers duplicates-interface
1192 observers weak-observers observer-id)
1193 %print-module))
1194
1195 ;; make-module &opt size uses binder
1196 ;;
1197 ;; Create a new module, perhaps with a particular size of obarray,
1198 ;; initial uses list, or binding procedure.
1199 ;;
1200 (define make-module
1201 (lambda args
1202
1203 (define (parse-arg index default)
1204 (if (> (length args) index)
1205 (list-ref args index)
1206 default))
1207
1208 (if (> (length args) 3)
1209 (error "Too many args to make-module." args))
1210
1211 (let ((size (parse-arg 0 31))
1212 (uses (parse-arg 1 '()))
1213 (binder (parse-arg 2 #f)))
1214
1215 (if (not (integer? size))
1216 (error "Illegal size to make-module." size))
1217 (if (not (and (list? uses)
1218 (and-map module? uses)))
1219 (error "Incorrect use list." uses))
1220 (if (and binder (not (procedure? binder)))
1221 (error
1222 "Lazy-binder expected to be a procedure or #f." binder))
1223
1224 (let ((module (module-constructor (make-hash-table size)
1225 uses binder #f #f #f #f #f #f
1226 '()
1227 (make-weak-value-hash-table 31)
1228 0)))
1229
1230 ;; We can't pass this as an argument to module-constructor,
1231 ;; because we need it to close over a pointer to the module
1232 ;; itself.
1233 (set-module-eval-closure! module (standard-eval-closure module))
1234
1235 module))))
1236
1237 (define module-constructor (record-constructor module-type))
1238 (define module-obarray (record-accessor module-type 'obarray))
1239 (define set-module-obarray! (record-modifier module-type 'obarray))
1240 (define module-uses (record-accessor module-type 'uses))
1241 (define set-module-uses! (record-modifier module-type 'uses))
1242 (define module-binder (record-accessor module-type 'binder))
1243 (define set-module-binder! (record-modifier module-type 'binder))
1244
1245 ;; NOTE: This binding is used in libguile/modules.c.
1246 (define module-eval-closure (record-accessor module-type 'eval-closure))
1247
1248 (define module-transformer (record-accessor module-type 'transformer))
1249 (define set-module-transformer! (record-modifier module-type 'transformer))
1250 (define module-name (record-accessor module-type 'name))
1251 (define set-module-name! (record-modifier module-type 'name))
1252 (define module-kind (record-accessor module-type 'kind))
1253 (define set-module-kind! (record-modifier module-type 'kind))
1254 (define module-duplicates-handlers
1255 (record-accessor module-type 'duplicates-handlers))
1256 (define set-module-duplicates-handlers!
1257 (record-modifier module-type 'duplicates-handlers))
1258 (define module-duplicates-interface
1259 (record-accessor module-type 'duplicates-interface))
1260 (define set-module-duplicates-interface!
1261 (record-modifier module-type 'duplicates-interface))
1262 (define module-observers (record-accessor module-type 'observers))
1263 (define set-module-observers! (record-modifier module-type 'observers))
1264 (define module-weak-observers (record-accessor module-type 'weak-observers))
1265 (define module-observer-id (record-accessor module-type 'observer-id))
1266 (define set-module-observer-id! (record-modifier module-type 'observer-id))
1267 (define module? (record-predicate module-type))
1268
1269 (define set-module-eval-closure!
1270 (let ((setter (record-modifier module-type 'eval-closure)))
1271 (lambda (module closure)
1272 (setter module closure)
1273 ;; Make it possible to lookup the module from the environment.
1274 ;; This implementation is correct since an eval closure can belong
1275 ;; to maximally one module.
1276 (set-procedure-property! closure 'module module))))
1277
1278 \f
1279
1280 ;;; {Observer protocol}
1281 ;;;
1282
1283 (define (module-observe module proc)
1284 (set-module-observers! module (cons proc (module-observers module)))
1285 (cons module proc))
1286
1287 (define (module-observe-weak module proc)
1288 (let ((id (module-observer-id module)))
1289 (hash-set! (module-weak-observers module) id proc)
1290 (set-module-observer-id! module (+ 1 id))
1291 (cons module id)))
1292
1293 (define (module-unobserve token)
1294 (let ((module (car token))
1295 (id (cdr token)))
1296 (if (integer? id)
1297 (hash-remove! (module-weak-observers module) id)
1298 (set-module-observers! module (delq1! id (module-observers module)))))
1299 *unspecified*)
1300
1301 (define module-defer-observers #f)
1302 (define module-defer-observers-mutex (make-mutex))
1303 (define module-defer-observers-table (make-hash-table))
1304
1305 (define (module-modified m)
1306 (if module-defer-observers
1307 (hash-set! module-defer-observers-table m #t)
1308 (module-call-observers m)))
1309
1310 ;;; This function can be used to delay calls to observers so that they
1311 ;;; can be called once only in the face of massive updating of modules.
1312 ;;;
1313 (define (call-with-deferred-observers thunk)
1314 (dynamic-wind
1315 (lambda ()
1316 (lock-mutex module-defer-observers-mutex)
1317 (set! module-defer-observers #t))
1318 thunk
1319 (lambda ()
1320 (set! module-defer-observers #f)
1321 (hash-for-each (lambda (m dummy)
1322 (module-call-observers m))
1323 module-defer-observers-table)
1324 (hash-clear! module-defer-observers-table)
1325 (unlock-mutex module-defer-observers-mutex))))
1326
1327 (define (module-call-observers m)
1328 (for-each (lambda (proc) (proc m)) (module-observers m))
1329 (hash-fold (lambda (id proc res) (proc m)) #f (module-weak-observers m)))
1330
1331 \f
1332
1333 ;;; {Module Searching in General}
1334 ;;;
1335 ;;; We sometimes want to look for properties of a symbol
1336 ;;; just within the obarray of one module. If the property
1337 ;;; holds, then it is said to hold ``locally'' as in, ``The symbol
1338 ;;; DISPLAY is locally rebound in the module `safe-guile'.''
1339 ;;;
1340 ;;;
1341 ;;; Other times, we want to test for a symbol property in the obarray
1342 ;;; of M and, if it is not found there, try each of the modules in the
1343 ;;; uses list of M. This is the normal way of testing for some
1344 ;;; property, so we state these properties without qualification as
1345 ;;; in: ``The symbol 'fnord is interned in module M because it is
1346 ;;; interned locally in module M2 which is a member of the uses list
1347 ;;; of M.''
1348 ;;;
1349
1350 ;; module-search fn m
1351 ;;
1352 ;; return the first non-#f result of FN applied to M and then to
1353 ;; the modules in the uses of m, and so on recursively. If all applications
1354 ;; return #f, then so does this function.
1355 ;;
1356 (define (module-search fn m v)
1357 (define (loop pos)
1358 (and (pair? pos)
1359 (or (module-search fn (car pos) v)
1360 (loop (cdr pos)))))
1361 (or (fn m v)
1362 (loop (module-uses m))))
1363
1364
1365 ;;; {Is a symbol bound in a module?}
1366 ;;;
1367 ;;; Symbol S in Module M is bound if S is interned in M and if the binding
1368 ;;; of S in M has been set to some well-defined value.
1369 ;;;
1370
1371 ;; module-locally-bound? module symbol
1372 ;;
1373 ;; Is a symbol bound (interned and defined) locally in a given module?
1374 ;;
1375 (define (module-locally-bound? m v)
1376 (let ((var (module-local-variable m v)))
1377 (and var
1378 (variable-bound? var))))
1379
1380 ;; module-bound? module symbol
1381 ;;
1382 ;; Is a symbol bound (interned and defined) anywhere in a given module
1383 ;; or its uses?
1384 ;;
1385 (define (module-bound? m v)
1386 (module-search module-locally-bound? m v))
1387
1388 ;;; {Is a symbol interned in a module?}
1389 ;;;
1390 ;;; Symbol S in Module M is interned if S occurs in
1391 ;;; of S in M has been set to some well-defined value.
1392 ;;;
1393 ;;; It is possible to intern a symbol in a module without providing
1394 ;;; an initial binding for the corresponding variable. This is done
1395 ;;; with:
1396 ;;; (module-add! module symbol (make-undefined-variable))
1397 ;;;
1398 ;;; In that case, the symbol is interned in the module, but not
1399 ;;; bound there. The unbound symbol shadows any binding for that
1400 ;;; symbol that might otherwise be inherited from a member of the uses list.
1401 ;;;
1402
1403 (define (module-obarray-get-handle ob key)
1404 ((if (symbol? key) hashq-get-handle hash-get-handle) ob key))
1405
1406 (define (module-obarray-ref ob key)
1407 ((if (symbol? key) hashq-ref hash-ref) ob key))
1408
1409 (define (module-obarray-set! ob key val)
1410 ((if (symbol? key) hashq-set! hash-set!) ob key val))
1411
1412 (define (module-obarray-remove! ob key)
1413 ((if (symbol? key) hashq-remove! hash-remove!) ob key))
1414
1415 ;; module-symbol-locally-interned? module symbol
1416 ;;
1417 ;; is a symbol interned (not neccessarily defined) locally in a given module
1418 ;; or its uses? Interned symbols shadow inherited bindings even if
1419 ;; they are not themselves bound to a defined value.
1420 ;;
1421 (define (module-symbol-locally-interned? m v)
1422 (not (not (module-obarray-get-handle (module-obarray m) v))))
1423
1424 ;; module-symbol-interned? module symbol
1425 ;;
1426 ;; is a symbol interned (not neccessarily defined) anywhere in a given module
1427 ;; or its uses? Interned symbols shadow inherited bindings even if
1428 ;; they are not themselves bound to a defined value.
1429 ;;
1430 (define (module-symbol-interned? m v)
1431 (module-search module-symbol-locally-interned? m v))
1432
1433
1434 ;;; {Mapping modules x symbols --> variables}
1435 ;;;
1436
1437 ;; module-local-variable module symbol
1438 ;; return the local variable associated with a MODULE and SYMBOL.
1439 ;;
1440 ;;; This function is very important. It is the only function that can
1441 ;;; return a variable from a module other than the mutators that store
1442 ;;; new variables in modules. Therefore, this function is the location
1443 ;;; of the "lazy binder" hack.
1444 ;;;
1445 ;;; If symbol is defined in MODULE, and if the definition binds symbol
1446 ;;; to a variable, return that variable object.
1447 ;;;
1448 ;;; If the symbols is not found at first, but the module has a lazy binder,
1449 ;;; then try the binder.
1450 ;;;
1451 ;;; If the symbol is not found at all, return #f.
1452 ;;;
1453 (define (module-local-variable m v)
1454 ; (caddr
1455 ; (list m v
1456 (let ((b (module-obarray-ref (module-obarray m) v)))
1457 (or (and (variable? b) b)
1458 (and (module-binder m)
1459 ((module-binder m) m v #f)))))
1460 ;))
1461
1462 ;; module-variable module symbol
1463 ;;
1464 ;; like module-local-variable, except search the uses in the
1465 ;; case V is not found in M.
1466 ;;
1467 ;; NOTE: This function is superseded with C code (see modules.c)
1468 ;;; when using the standard eval closure.
1469 ;;
1470 (define (module-variable m v)
1471 (module-search module-local-variable m v))
1472
1473
1474 ;;; {Mapping modules x symbols --> bindings}
1475 ;;;
1476 ;;; These are similar to the mapping to variables, except that the
1477 ;;; variable is dereferenced.
1478 ;;;
1479
1480 ;; module-symbol-binding module symbol opt-value
1481 ;;
1482 ;; return the binding of a variable specified by name within
1483 ;; a given module, signalling an error if the variable is unbound.
1484 ;; If the OPT-VALUE is passed, then instead of signalling an error,
1485 ;; return OPT-VALUE.
1486 ;;
1487 (define (module-symbol-local-binding m v . opt-val)
1488 (let ((var (module-local-variable m v)))
1489 (if (and var (variable-bound? var))
1490 (variable-ref var)
1491 (if (not (null? opt-val))
1492 (car opt-val)
1493 (error "Locally unbound variable." v)))))
1494
1495 ;; module-symbol-binding module symbol opt-value
1496 ;;
1497 ;; return the binding of a variable specified by name within
1498 ;; a given module, signalling an error if the variable is unbound.
1499 ;; If the OPT-VALUE is passed, then instead of signalling an error,
1500 ;; return OPT-VALUE.
1501 ;;
1502 (define (module-symbol-binding m v . opt-val)
1503 (let ((var (module-variable m v)))
1504 (if (and var (variable-bound? var))
1505 (variable-ref var)
1506 (if (not (null? opt-val))
1507 (car opt-val)
1508 (error "Unbound variable." v)))))
1509
1510
1511 \f
1512
1513 ;;; {Adding Variables to Modules}
1514 ;;;
1515
1516 ;; module-make-local-var! module symbol
1517 ;;
1518 ;; ensure a variable for V in the local namespace of M.
1519 ;; If no variable was already there, then create a new and uninitialzied
1520 ;; variable.
1521 ;;
1522 ;; This function is used in modules.c.
1523 ;;
1524 (define (module-make-local-var! m v)
1525 (or (let ((b (module-obarray-ref (module-obarray m) v)))
1526 (and (variable? b)
1527 (begin
1528 ;; Mark as modified since this function is called when
1529 ;; the standard eval closure defines a binding
1530 (module-modified m)
1531 b)))
1532
1533 ;; No local variable yet, so we need to create a new one. That
1534 ;; new variable is initialized with the old imported value of V,
1535 ;; if there is one.
1536 (let ((imported-var (module-variable m v))
1537 (local-var (or (and (module-binder m)
1538 ((module-binder m) m v #t))
1539 (begin
1540 (let ((answer (make-undefined-variable)))
1541 (module-add! m v answer)
1542 answer)))))
1543 (if (and imported-var (not (variable-bound? local-var)))
1544 (variable-set! local-var (variable-ref imported-var)))
1545 local-var)))
1546
1547 ;; module-ensure-local-variable! module symbol
1548 ;;
1549 ;; Ensure that there is a local variable in MODULE for SYMBOL. If
1550 ;; there is no binding for SYMBOL, create a new uninitialized
1551 ;; variable. Return the local variable.
1552 ;;
1553 (define (module-ensure-local-variable! module symbol)
1554 (or (module-local-variable module symbol)
1555 (let ((var (make-undefined-variable)))
1556 (module-add! module symbol var)
1557 var)))
1558
1559 ;; module-add! module symbol var
1560 ;;
1561 ;; ensure a particular variable for V in the local namespace of M.
1562 ;;
1563 (define (module-add! m v var)
1564 (if (not (variable? var))
1565 (error "Bad variable to module-add!" var))
1566 (module-obarray-set! (module-obarray m) v var)
1567 (module-modified m))
1568
1569 ;; module-remove!
1570 ;;
1571 ;; make sure that a symbol is undefined in the local namespace of M.
1572 ;;
1573 (define (module-remove! m v)
1574 (module-obarray-remove! (module-obarray m) v)
1575 (module-modified m))
1576
1577 (define (module-clear! m)
1578 (hash-clear! (module-obarray m))
1579 (module-modified m))
1580
1581 ;; MODULE-FOR-EACH -- exported
1582 ;;
1583 ;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
1584 ;;
1585 (define (module-for-each proc module)
1586 (hash-for-each proc (module-obarray module)))
1587
1588 (define (module-map proc module)
1589 (hash-map->list proc (module-obarray module)))
1590
1591 \f
1592
1593 ;;; {Low Level Bootstrapping}
1594 ;;;
1595
1596 ;; make-root-module
1597
1598 ;; A root module uses the pre-modules-obarray as its obarray. This
1599 ;; special obarray accumulates all bindings that have been established
1600 ;; before the module system is fully booted.
1601 ;;
1602 ;; (The obarray continues to be used by code that has been closed over
1603 ;; before the module system has been booted.)
1604
1605 (define (make-root-module)
1606 (let ((m (make-module 0)))
1607 (set-module-obarray! m (%get-pre-modules-obarray))
1608 m))
1609
1610 ;; make-scm-module
1611
1612 ;; The root interface is a module that uses the same obarray as the
1613 ;; root module. It does not allow new definitions, tho.
1614
1615 (define (make-scm-module)
1616 (let ((m (make-module 0)))
1617 (set-module-obarray! m (%get-pre-modules-obarray))
1618 (set-module-eval-closure! m (standard-interface-eval-closure m))
1619 m))
1620
1621
1622 \f
1623
1624 ;;; {Module-based Loading}
1625 ;;;
1626
1627 (define (save-module-excursion thunk)
1628 (let ((inner-module (current-module))
1629 (outer-module #f))
1630 (dynamic-wind (lambda ()
1631 (set! outer-module (current-module))
1632 (set-current-module inner-module)
1633 (set! inner-module #f))
1634 thunk
1635 (lambda ()
1636 (set! inner-module (current-module))
1637 (set-current-module outer-module)
1638 (set! outer-module #f)))))
1639
1640 (define basic-load load)
1641
1642 (define (load-module filename)
1643 (save-module-excursion
1644 (lambda ()
1645 (let ((oldname (and (current-load-port)
1646 (port-filename (current-load-port)))))
1647 (basic-load (if (and oldname
1648 (> (string-length filename) 0)
1649 (not (char=? (string-ref filename 0) #\/))
1650 (not (string=? (dirname oldname) ".")))
1651 (string-append (dirname oldname) "/" filename)
1652 filename))))))
1653
1654
1655 \f
1656
1657 ;;; {MODULE-REF -- exported}
1658 ;;;
1659
1660 ;; Returns the value of a variable called NAME in MODULE or any of its
1661 ;; used modules. If there is no such variable, then if the optional third
1662 ;; argument DEFAULT is present, it is returned; otherwise an error is signaled.
1663 ;;
1664 (define (module-ref module name . rest)
1665 (let ((variable (module-variable module name)))
1666 (if (and variable (variable-bound? variable))
1667 (variable-ref variable)
1668 (if (null? rest)
1669 (error "No variable named" name 'in module)
1670 (car rest) ; default value
1671 ))))
1672
1673 ;; MODULE-SET! -- exported
1674 ;;
1675 ;; Sets the variable called NAME in MODULE (or in a module that MODULE uses)
1676 ;; to VALUE; if there is no such variable, an error is signaled.
1677 ;;
1678 (define (module-set! module name value)
1679 (let ((variable (module-variable module name)))
1680 (if variable
1681 (variable-set! variable value)
1682 (error "No variable named" name 'in module))))
1683
1684 ;; MODULE-DEFINE! -- exported
1685 ;;
1686 ;; Sets the variable called NAME in MODULE to VALUE; if there is no such
1687 ;; variable, it is added first.
1688 ;;
1689 (define (module-define! module name value)
1690 (let ((variable (module-local-variable module name)))
1691 (if variable
1692 (begin
1693 (variable-set! variable value)
1694 (module-modified module))
1695 (let ((variable (make-variable value)))
1696 (module-add! module name variable)))))
1697
1698 ;; MODULE-DEFINED? -- exported
1699 ;;
1700 ;; Return #t iff NAME is defined in MODULE (or in a module that MODULE
1701 ;; uses)
1702 ;;
1703 (define (module-defined? module name)
1704 (let ((variable (module-variable module name)))
1705 (and variable (variable-bound? variable))))
1706
1707 ;; MODULE-USE! module interface
1708 ;;
1709 ;; Add INTERFACE to the list of interfaces used by MODULE.
1710 ;;
1711 (define (module-use! module interface)
1712 (set-module-uses! module
1713 (cons interface
1714 (filter (lambda (m)
1715 (not (equal? (module-name m)
1716 (module-name interface))))
1717 (module-uses module))))
1718 (module-modified module))
1719
1720 ;; MODULE-USE-INTERFACES! module interfaces
1721 ;;
1722 ;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
1723 ;;
1724 (define (module-use-interfaces! module interfaces)
1725 (let* ((duplicates-handlers? (or (module-duplicates-handlers module)
1726 (default-duplicate-binding-procedures)))
1727 (uses (module-uses module)))
1728 ;; remove duplicates-interface
1729 (set! uses (delq! (module-duplicates-interface module) uses))
1730 ;; remove interfaces to be added
1731 (for-each (lambda (interface)
1732 (set! uses
1733 (filter (lambda (m)
1734 (not (equal? (module-name m)
1735 (module-name interface))))
1736 uses)))
1737 interfaces)
1738 ;; add interfaces to use list
1739 (set-module-uses! module uses)
1740 (for-each (lambda (interface)
1741 (and duplicates-handlers?
1742 ;; perform duplicate checking
1743 (process-duplicates module interface))
1744 (set! uses (cons interface uses))
1745 (set-module-uses! module uses))
1746 interfaces)
1747 ;; add duplicates interface
1748 (if (module-duplicates-interface module)
1749 (set-module-uses! module
1750 (cons (module-duplicates-interface module) uses)))
1751 (module-modified module)))
1752
1753 \f
1754
1755 ;;; {Recursive Namespaces}
1756 ;;;
1757 ;;; A hierarchical namespace emerges if we consider some module to be
1758 ;;; root, and variables bound to modules as nested namespaces.
1759 ;;;
1760 ;;; The routines in this file manage variable names in hierarchical namespace.
1761 ;;; Each variable name is a list of elements, looked up in successively nested
1762 ;;; modules.
1763 ;;;
1764 ;;; (nested-ref some-root-module '(foo bar baz))
1765 ;;; => <value of a variable named baz in the module bound to bar in
1766 ;;; the module bound to foo in some-root-module>
1767 ;;;
1768 ;;;
1769 ;;; There are:
1770 ;;;
1771 ;;; ;; a-root is a module
1772 ;;; ;; name is a list of symbols
1773 ;;;
1774 ;;; nested-ref a-root name
1775 ;;; nested-set! a-root name val
1776 ;;; nested-define! a-root name val
1777 ;;; nested-remove! a-root name
1778 ;;;
1779 ;;;
1780 ;;; (current-module) is a natural choice for a-root so for convenience there are
1781 ;;; also:
1782 ;;;
1783 ;;; local-ref name == nested-ref (current-module) name
1784 ;;; local-set! name val == nested-set! (current-module) name val
1785 ;;; local-define! name val == nested-define! (current-module) name val
1786 ;;; local-remove! name == nested-remove! (current-module) name
1787 ;;;
1788
1789
1790 (define (nested-ref root names)
1791 (let loop ((cur root)
1792 (elts names))
1793 (cond
1794 ((null? elts) cur)
1795 ((not (module? cur)) #f)
1796 (else (loop (module-ref cur (car elts) #f) (cdr elts))))))
1797
1798 (define (nested-set! root names val)
1799 (let loop ((cur root)
1800 (elts names))
1801 (if (null? (cdr elts))
1802 (module-set! cur (car elts) val)
1803 (loop (module-ref cur (car elts)) (cdr elts)))))
1804
1805 (define (nested-define! root names val)
1806 (let loop ((cur root)
1807 (elts names))
1808 (if (null? (cdr elts))
1809 (module-define! cur (car elts) val)
1810 (loop (module-ref cur (car elts)) (cdr elts)))))
1811
1812 (define (nested-remove! root names)
1813 (let loop ((cur root)
1814 (elts names))
1815 (if (null? (cdr elts))
1816 (module-remove! cur (car elts))
1817 (loop (module-ref cur (car elts)) (cdr elts)))))
1818
1819 (define (local-ref names) (nested-ref (current-module) names))
1820 (define (local-set! names val) (nested-set! (current-module) names val))
1821 (define (local-define names val) (nested-define! (current-module) names val))
1822 (define (local-remove names) (nested-remove! (current-module) names))
1823
1824
1825 \f
1826
1827 ;;; {The (%app) module}
1828 ;;;
1829 ;;; The root of conventionally named objects not directly in the top level.
1830 ;;;
1831 ;;; (%app modules)
1832 ;;; (%app modules guile)
1833 ;;;
1834 ;;; The directory of all modules and the standard root module.
1835 ;;;
1836
1837 (define (module-public-interface m)
1838 (module-ref m '%module-public-interface #f))
1839 (define (set-module-public-interface! m i)
1840 (module-define! m '%module-public-interface i))
1841 (define (set-system-module! m s)
1842 (set-procedure-property! (module-eval-closure m) 'system-module s))
1843 (define the-root-module (make-root-module))
1844 (define the-scm-module (make-scm-module))
1845 (set-module-public-interface! the-root-module the-scm-module)
1846 (set-module-name! the-root-module '(guile))
1847 (set-module-name! the-scm-module '(guile))
1848 (set-module-kind! the-scm-module 'interface)
1849 (for-each set-system-module! (list the-root-module the-scm-module) '(#t #t))
1850
1851 ;; NOTE: This binding is used in libguile/modules.c.
1852 ;;
1853 (define (make-modules-in module name)
1854 (if (null? name)
1855 module
1856 (cond
1857 ((module-ref module (car name) #f)
1858 => (lambda (m) (make-modules-in m (cdr name))))
1859 (else (let ((m (make-module 31)))
1860 (set-module-kind! m 'directory)
1861 (set-module-name! m (append (or (module-name module)
1862 '())
1863 (list (car name))))
1864 (module-define! module (car name) m)
1865 (make-modules-in m (cdr name)))))))
1866
1867 (define (beautify-user-module! module)
1868 (let ((interface (module-public-interface module)))
1869 (if (or (not interface)
1870 (eq? interface module))
1871 (let ((interface (make-module 31)))
1872 (set-module-name! interface (module-name module))
1873 (set-module-kind! interface 'interface)
1874 (set-module-public-interface! module interface))))
1875 (if (and (not (memq the-scm-module (module-uses module)))
1876 (not (eq? module the-root-module)))
1877 (set-module-uses! module
1878 (append (module-uses module) (list the-scm-module)))))
1879
1880 ;; NOTE: This binding is used in libguile/modules.c.
1881 ;;
1882 (define (resolve-module name . maybe-autoload)
1883 (let ((full-name (append '(%app modules) name)))
1884 (let ((already (nested-ref the-root-module full-name)))
1885 (if already
1886 ;; The module already exists...
1887 (if (and (or (null? maybe-autoload) (car maybe-autoload))
1888 (not (module-public-interface already)))
1889 ;; ...but we are told to load and it doesn't contain source, so
1890 (begin
1891 (try-load-module name)
1892 already)
1893 ;; simply return it.
1894 already)
1895 (begin
1896 ;; Try to autoload it if we are told so
1897 (if (or (null? maybe-autoload) (car maybe-autoload))
1898 (try-load-module name))
1899 ;; Get/create it.
1900 (make-modules-in (current-module) full-name))))))
1901
1902 ;; Cheat. These bindings are needed by modules.c, but we don't want
1903 ;; to move their real definition here because that would be unnatural.
1904 ;;
1905 (define try-module-autoload #f)
1906 (define process-define-module #f)
1907 (define process-use-modules #f)
1908 (define module-export! #f)
1909
1910 ;; This boots the module system. All bindings needed by modules.c
1911 ;; must have been defined by now.
1912 ;;
1913 (set-current-module the-root-module)
1914
1915 (define %app (make-module 31))
1916 (define app %app) ;; for backwards compatability
1917 (local-define '(%app modules) (make-module 31))
1918 (local-define '(%app modules guile) the-root-module)
1919
1920 ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
1921
1922 (define (try-load-module name)
1923 (or (begin-deprecated (try-module-linked name))
1924 (try-module-autoload name)
1925 (begin-deprecated (try-module-dynamic-link name))))
1926
1927 (define (purify-module! module)
1928 "Removes bindings in MODULE which are inherited from the (guile) module."
1929 (let ((use-list (module-uses module)))
1930 (if (and (pair? use-list)
1931 (eq? (car (last-pair use-list)) the-scm-module))
1932 (set-module-uses! module (reverse (cdr (reverse use-list)))))))
1933
1934 ;; Return a module that is an interface to the module designated by
1935 ;; NAME.
1936 ;;
1937 ;; `resolve-interface' takes four keyword arguments:
1938 ;;
1939 ;; #:select SELECTION
1940 ;;
1941 ;; SELECTION is a list of binding-specs to be imported; A binding-spec
1942 ;; is either a symbol or a pair of symbols (ORIG . SEEN), where ORIG
1943 ;; is the name in the used module and SEEN is the name in the using
1944 ;; module. Note that SEEN is also passed through RENAMER, below. The
1945 ;; default is to select all bindings. If you specify no selection but
1946 ;; a renamer, only the bindings that already exist in the used module
1947 ;; are made available in the interface. Bindings that are added later
1948 ;; are not picked up.
1949 ;;
1950 ;; #:hide BINDINGS
1951 ;;
1952 ;; BINDINGS is a list of bindings which should not be imported.
1953 ;;
1954 ;; #:prefix PREFIX
1955 ;;
1956 ;; PREFIX is a symbol that will be appended to each exported name.
1957 ;; The default is to not perform any renaming.
1958 ;;
1959 ;; #:renamer RENAMER
1960 ;;
1961 ;; RENAMER is a procedure that takes a symbol and returns its new
1962 ;; name. The default is not perform any renaming.
1963 ;;
1964 ;; Signal "no code for module" error if module name is not resolvable
1965 ;; or its public interface is not available. Signal "no binding"
1966 ;; error if selected binding does not exist in the used module.
1967 ;;
1968 (define (resolve-interface name . args)
1969
1970 (define (get-keyword-arg args kw def)
1971 (cond ((memq kw args)
1972 => (lambda (kw-arg)
1973 (if (null? (cdr kw-arg))
1974 (error "keyword without value: " kw))
1975 (cadr kw-arg)))
1976 (else
1977 def)))
1978
1979 (let* ((select (get-keyword-arg args #:select #f))
1980 (hide (get-keyword-arg args #:hide '()))
1981 (renamer (or (get-keyword-arg args #:renamer #f)
1982 (let ((prefix (get-keyword-arg args #:prefix #f)))
1983 (and prefix (symbol-prefix-proc prefix)))
1984 identity))
1985 (module (resolve-module name))
1986 (public-i (and module (module-public-interface module))))
1987 (and (or (not module) (not public-i))
1988 (error "no code for module" name))
1989 (if (and (not select) (null? hide) (eq? renamer identity))
1990 public-i
1991 (let ((selection (or select (module-map (lambda (sym var) sym)
1992 public-i)))
1993 (custom-i (make-module 31)))
1994 (set-module-kind! custom-i 'custom-interface)
1995 (set-module-name! custom-i name)
1996 ;; XXX - should use a lazy binder so that changes to the
1997 ;; used module are picked up automatically.
1998 (for-each (lambda (bspec)
1999 (let* ((direct? (symbol? bspec))
2000 (orig (if direct? bspec (car bspec)))
2001 (seen (if direct? bspec (cdr bspec)))
2002 (var (or (module-local-variable public-i orig)
2003 (module-local-variable module orig)
2004 (error
2005 ;; fixme: format manually for now
2006 (simple-format
2007 #f "no binding `~A' in module ~A"
2008 orig name)))))
2009 (if (memq orig hide)
2010 (set! hide (delq! orig hide))
2011 (module-add! custom-i
2012 (renamer seen)
2013 var))))
2014 selection)
2015 ;; Check that we are not hiding bindings which don't exist
2016 (for-each (lambda (binding)
2017 (if (not (module-local-variable public-i binding))
2018 (error
2019 (simple-format
2020 #f "no binding `~A' to hide in module ~A"
2021 binding name))))
2022 hide)
2023 custom-i))))
2024
2025 (define (symbol-prefix-proc prefix)
2026 (lambda (symbol)
2027 (symbol-append prefix symbol)))
2028
2029 ;; This function is called from "modules.c". If you change it, be
2030 ;; sure to update "modules.c" as well.
2031
2032 (define (process-define-module args)
2033 (let* ((module-id (car args))
2034 (module (resolve-module module-id #f))
2035 (kws (cdr args))
2036 (unrecognized (lambda (arg)
2037 (error "unrecognized define-module argument" arg))))
2038 (beautify-user-module! module)
2039 (let loop ((kws kws)
2040 (reversed-interfaces '())
2041 (exports '())
2042 (re-exports '())
2043 (replacements '()))
2044 (if (null? kws)
2045 (call-with-deferred-observers
2046 (lambda ()
2047 (module-use-interfaces! module (reverse reversed-interfaces))
2048 (module-export! module exports)
2049 (module-replace! module replacements)
2050 (module-re-export! module re-exports)))
2051 (case (car kws)
2052 ((#:use-module #:use-syntax)
2053 (or (pair? (cdr kws))
2054 (unrecognized kws))
2055 (let* ((interface-args (cadr kws))
2056 (interface (apply resolve-interface interface-args)))
2057 (and (eq? (car kws) #:use-syntax)
2058 (or (symbol? (caar interface-args))
2059 (error "invalid module name for use-syntax"
2060 (car interface-args)))
2061 (set-module-transformer!
2062 module
2063 (module-ref interface
2064 (car (last-pair (car interface-args)))
2065 #f)))
2066 (loop (cddr kws)
2067 (cons interface reversed-interfaces)
2068 exports
2069 re-exports
2070 replacements)))
2071 ((#:autoload)
2072 (or (and (pair? (cdr kws)) (pair? (cddr kws)))
2073 (unrecognized kws))
2074 (loop (cdddr kws)
2075 (cons (make-autoload-interface module
2076 (cadr kws)
2077 (caddr kws))
2078 reversed-interfaces)
2079 exports
2080 re-exports
2081 replacements))
2082 ((#:no-backtrace)
2083 (set-system-module! module #t)
2084 (loop (cdr kws) reversed-interfaces exports re-exports replacements))
2085 ((#:pure)
2086 (purify-module! module)
2087 (loop (cdr kws) reversed-interfaces exports re-exports replacements))
2088 ((#:duplicates)
2089 (if (not (pair? (cdr kws)))
2090 (unrecognized kws))
2091 (set-module-duplicates-handlers!
2092 module
2093 (lookup-duplicates-handlers (cadr kws)))
2094 (loop (cddr kws) reversed-interfaces exports re-exports replacements))
2095 ((#:export #:export-syntax)
2096 (or (pair? (cdr kws))
2097 (unrecognized kws))
2098 (loop (cddr kws)
2099 reversed-interfaces
2100 (append (cadr kws) exports)
2101 re-exports
2102 replacements))
2103 ((#:re-export #:re-export-syntax)
2104 (or (pair? (cdr kws))
2105 (unrecognized kws))
2106 (loop (cddr kws)
2107 reversed-interfaces
2108 exports
2109 (append (cadr kws) re-exports)
2110 replacements))
2111 ((#:replace #:replace-syntax)
2112 (or (pair? (cdr kws))
2113 (unrecognized kws))
2114 (loop (cddr kws)
2115 reversed-interfaces
2116 exports
2117 re-exports
2118 (append (cadr kws) replacements)))
2119 (else
2120 (unrecognized kws)))))
2121 (run-hook module-defined-hook module)
2122 module))
2123
2124 ;; `module-defined-hook' is a hook that is run whenever a new module
2125 ;; is defined. Its members are called with one argument, the new
2126 ;; module.
2127 (define module-defined-hook (make-hook 1))
2128
2129 \f
2130
2131 ;;; {Autoload}
2132 ;;;
2133
2134 (define (make-autoload-interface module name bindings)
2135 (let ((b (lambda (a sym definep)
2136 (and (memq sym bindings)
2137 (let ((i (module-public-interface (resolve-module name))))
2138 (if (not i)
2139 (error "missing interface for module" name))
2140 ;; Replace autoload-interface with interface
2141 (set-car! (memq a (module-uses module)) i)
2142 (module-local-variable i sym))))))
2143 (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f #f
2144 '() (make-weak-value-hash-table 31) 0)))
2145
2146 ;;; {Compiled module}
2147
2148 (define load-compiled #f)
2149
2150 \f
2151
2152 ;;; {Autoloading modules}
2153 ;;;
2154
2155 (define autoloads-in-progress '())
2156
2157 ;; This function is called from "modules.c". If you change it, be
2158 ;; sure to update "modules.c" as well.
2159
2160 (define (try-module-autoload module-name)
2161 (let* ((reverse-name (reverse module-name))
2162 (name (symbol->string (car reverse-name)))
2163 (dir-hint-module-name (reverse (cdr reverse-name)))
2164 (dir-hint (apply string-append
2165 (map (lambda (elt)
2166 (string-append (symbol->string elt) "/"))
2167 dir-hint-module-name))))
2168 (resolve-module dir-hint-module-name #f)
2169 (and (not (autoload-done-or-in-progress? dir-hint name))
2170 (let ((didit #f))
2171 (define (load-file proc file)
2172 (save-module-excursion (lambda () (proc file)))
2173 (set! didit #t))
2174 (dynamic-wind
2175 (lambda () (autoload-in-progress! dir-hint name))
2176 (lambda ()
2177 (let ((file (in-vicinity dir-hint name)))
2178 (cond ((and load-compiled
2179 (%search-load-path (string-append file ".go")))
2180 => (lambda (full)
2181 (load-file load-compiled full)))
2182 ((%search-load-path file)
2183 => (lambda (full)
2184 (load-file primitive-load full))))))
2185 (lambda () (set-autoloaded! dir-hint name didit)))
2186 didit))))
2187
2188 \f
2189
2190 ;;; {Dynamic linking of modules}
2191 ;;;
2192
2193 (define autoloads-done '((guile . guile)))
2194
2195 (define (autoload-done-or-in-progress? p m)
2196 (let ((n (cons p m)))
2197 (->bool (or (member n autoloads-done)
2198 (member n autoloads-in-progress)))))
2199
2200 (define (autoload-done! p m)
2201 (let ((n (cons p m)))
2202 (set! autoloads-in-progress
2203 (delete! n autoloads-in-progress))
2204 (or (member n autoloads-done)
2205 (set! autoloads-done (cons n autoloads-done)))))
2206
2207 (define (autoload-in-progress! p m)
2208 (let ((n (cons p m)))
2209 (set! autoloads-done
2210 (delete! n autoloads-done))
2211 (set! autoloads-in-progress (cons n autoloads-in-progress))))
2212
2213 (define (set-autoloaded! p m done?)
2214 (if done?
2215 (autoload-done! p m)
2216 (let ((n (cons p m)))
2217 (set! autoloads-done (delete! n autoloads-done))
2218 (set! autoloads-in-progress (delete! n autoloads-in-progress)))))
2219
2220 \f
2221
2222 ;;; {Run-time options}
2223 ;;;
2224
2225 (define define-option-interface
2226 (let* ((option-name car)
2227 (option-value cadr)
2228 (option-documentation caddr)
2229
2230 (print-option (lambda (option)
2231 (display (option-name option))
2232 (if (< (string-length
2233 (symbol->string (option-name option)))
2234 8)
2235 (display #\tab))
2236 (display #\tab)
2237 (display (option-value option))
2238 (display #\tab)
2239 (display (option-documentation option))
2240 (newline)))
2241
2242 ;; Below follow the macros defining the run-time option interfaces.
2243
2244 (make-options (lambda (interface)
2245 `(lambda args
2246 (cond ((null? args) (,interface))
2247 ((list? (car args))
2248 (,interface (car args)) (,interface))
2249 (else (for-each ,print-option
2250 (,interface #t)))))))
2251
2252 (make-enable (lambda (interface)
2253 `(lambda flags
2254 (,interface (append flags (,interface)))
2255 (,interface))))
2256
2257 (make-disable (lambda (interface)
2258 `(lambda flags
2259 (let ((options (,interface)))
2260 (for-each (lambda (flag)
2261 (set! options (delq! flag options)))
2262 flags)
2263 (,interface options)
2264 (,interface))))))
2265 (procedure->memoizing-macro
2266 (lambda (exp env)
2267 (let* ((option-group (cadr exp))
2268 (interface (car option-group))
2269 (options/enable/disable (cadr option-group)))
2270 `(begin
2271 (define ,(car options/enable/disable)
2272 ,(make-options interface))
2273 (define ,(cadr options/enable/disable)
2274 ,(make-enable interface))
2275 (define ,(caddr options/enable/disable)
2276 ,(make-disable interface))
2277 (defmacro ,(caaddr option-group) (opt val)
2278 `(,,(car options/enable/disable)
2279 (append (,,(car options/enable/disable))
2280 (list ',opt ,val))))))))))
2281
2282 (define-option-interface
2283 (eval-options-interface
2284 (eval-options eval-enable eval-disable)
2285 (eval-set!)))
2286
2287 (define-option-interface
2288 (debug-options-interface
2289 (debug-options debug-enable debug-disable)
2290 (debug-set!)))
2291
2292 (define-option-interface
2293 (evaluator-traps-interface
2294 (traps trap-enable trap-disable)
2295 (trap-set!)))
2296
2297 (define-option-interface
2298 (read-options-interface
2299 (read-options read-enable read-disable)
2300 (read-set!)))
2301
2302 (define-option-interface
2303 (print-options-interface
2304 (print-options print-enable print-disable)
2305 (print-set!)))
2306
2307 \f
2308
2309 ;;; {Running Repls}
2310 ;;;
2311
2312 (define (repl read evaler print)
2313 (let loop ((source (read (current-input-port))))
2314 (print (evaler source))
2315 (loop (read (current-input-port)))))
2316
2317 ;; A provisional repl that acts like the SCM repl:
2318 ;;
2319 (define scm-repl-silent #f)
2320 (define (assert-repl-silence v) (set! scm-repl-silent v))
2321
2322 (define *unspecified* (if #f #f))
2323 (define (unspecified? v) (eq? v *unspecified*))
2324
2325 (define scm-repl-print-unspecified #f)
2326 (define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v))
2327
2328 (define scm-repl-verbose #f)
2329 (define (assert-repl-verbosity v) (set! scm-repl-verbose v))
2330
2331 (define scm-repl-prompt "guile> ")
2332
2333 (define (set-repl-prompt! v) (set! scm-repl-prompt v))
2334
2335 (define (default-lazy-handler key . args)
2336 (save-stack lazy-handler-dispatch)
2337 (apply throw key args))
2338
2339 (define (lazy-handler-dispatch key . args)
2340 (apply default-lazy-handler key args))
2341
2342 (define abort-hook (make-hook))
2343
2344 ;; these definitions are used if running a script.
2345 ;; otherwise redefined in error-catching-loop.
2346 (define (set-batch-mode?! arg) #t)
2347 (define (batch-mode?) #t)
2348
2349 (define (error-catching-loop thunk)
2350 (let ((status #f)
2351 (interactive #t))
2352 (define (loop first)
2353 (let ((next
2354 (catch #t
2355
2356 (lambda ()
2357 (lazy-catch #t
2358 (lambda ()
2359 (call-with-unblocked-asyncs
2360 (lambda ()
2361 (with-traps
2362 (lambda ()
2363 (first)
2364
2365 ;; This line is needed because mark
2366 ;; doesn't do closures quite right.
2367 ;; Unreferenced locals should be
2368 ;; collected.
2369 ;;
2370 (set! first #f)
2371 (let loop ((v (thunk)))
2372 (loop (thunk)))
2373 #f)))))
2374
2375 ;; Note that having just
2376 ;; `lazy-handler-dispatch' here is
2377 ;; connected with the mechanism that
2378 ;; produces a nice backtrace upon
2379 ;; error. If, for example, this is
2380 ;; replaced with (lambda args (apply
2381 ;; lazy-handler-dispatch args)), the
2382 ;; stack cutting (in save-stack)
2383 ;; goes wrong and ends up saving no
2384 ;; stack at all, so there is no
2385 ;; backtrace.
2386 lazy-handler-dispatch))
2387
2388 (lambda (key . args)
2389 (case key
2390 ((quit)
2391 (set! status args)
2392 #f)
2393
2394 ((switch-repl)
2395 (apply throw 'switch-repl args))
2396
2397 ((abort)
2398 ;; This is one of the closures that require
2399 ;; (set! first #f) above
2400 ;;
2401 (lambda ()
2402 (run-hook abort-hook)
2403 (force-output (current-output-port))
2404 (display "ABORT: " (current-error-port))
2405 (write args (current-error-port))
2406 (newline (current-error-port))
2407 (if interactive
2408 (begin
2409 (if (and
2410 (not has-shown-debugger-hint?)
2411 (not (memq 'backtrace
2412 (debug-options-interface)))
2413 (stack? (fluid-ref the-last-stack)))
2414 (begin
2415 (newline (current-error-port))
2416 (display
2417 "Type \"(backtrace)\" to get more information or \"(debug)\" to enter the debugger.\n"
2418 (current-error-port))
2419 (set! has-shown-debugger-hint? #t)))
2420 (force-output (current-error-port)))
2421 (begin
2422 (primitive-exit 1)))
2423 (set! stack-saved? #f)))
2424
2425 (else
2426 ;; This is the other cons-leak closure...
2427 (lambda ()
2428 (cond ((= (length args) 4)
2429 (apply handle-system-error key args))
2430 (else
2431 (apply bad-throw key args))))))))))
2432 (if next (loop next) status)))
2433 (set! set-batch-mode?! (lambda (arg)
2434 (cond (arg
2435 (set! interactive #f)
2436 (restore-signals))
2437 (#t
2438 (error "sorry, not implemented")))))
2439 (set! batch-mode? (lambda () (not interactive)))
2440 (call-with-blocked-asyncs
2441 (lambda () (loop (lambda () #t))))))
2442
2443 ;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()
2444 (define before-signal-stack (make-fluid))
2445 (define stack-saved? #f)
2446
2447 (define (save-stack . narrowing)
2448 (or stack-saved?
2449 (cond ((not (memq 'debug (debug-options-interface)))
2450 (fluid-set! the-last-stack #f)
2451 (set! stack-saved? #t))
2452 (else
2453 (fluid-set!
2454 the-last-stack
2455 (case (stack-id #t)
2456 ((repl-stack)
2457 (apply make-stack #t save-stack primitive-eval #t 0 narrowing))
2458 ((load-stack)
2459 (apply make-stack #t save-stack 0 #t 0 narrowing))
2460 ((tk-stack)
2461 (apply make-stack #t save-stack tk-stack-mark #t 0 narrowing))
2462 ((#t)
2463 (apply make-stack #t save-stack 0 1 narrowing))
2464 (else
2465 (let ((id (stack-id #t)))
2466 (and (procedure? id)
2467 (apply make-stack #t save-stack id #t 0 narrowing))))))
2468 (set! stack-saved? #t)))))
2469
2470 (define before-error-hook (make-hook))
2471 (define after-error-hook (make-hook))
2472 (define before-backtrace-hook (make-hook))
2473 (define after-backtrace-hook (make-hook))
2474
2475 (define has-shown-debugger-hint? #f)
2476
2477 (define (handle-system-error key . args)
2478 (let ((cep (current-error-port)))
2479 (cond ((not (stack? (fluid-ref the-last-stack))))
2480 ((memq 'backtrace (debug-options-interface))
2481 (let ((highlights (if (or (eq? key 'wrong-type-arg)
2482 (eq? key 'out-of-range))
2483 (list-ref args 3)
2484 '())))
2485 (run-hook before-backtrace-hook)
2486 (newline cep)
2487 (display "Backtrace:\n")
2488 (display-backtrace (fluid-ref the-last-stack) cep
2489 #f #f highlights)
2490 (newline cep)
2491 (run-hook after-backtrace-hook))))
2492 (run-hook before-error-hook)
2493 (apply display-error (fluid-ref the-last-stack) cep args)
2494 (run-hook after-error-hook)
2495 (force-output cep)
2496 (throw 'abort key)))
2497
2498 (define (quit . args)
2499 (apply throw 'quit args))
2500
2501 (define exit quit)
2502
2503 ;;(define has-shown-backtrace-hint? #f) Defined by scm_init_backtrace ()
2504
2505 ;; Replaced by C code:
2506 ;;(define (backtrace)
2507 ;; (if (fluid-ref the-last-stack)
2508 ;; (begin
2509 ;; (newline)
2510 ;; (display-backtrace (fluid-ref the-last-stack) (current-output-port))
2511 ;; (newline)
2512 ;; (if (and (not has-shown-backtrace-hint?)
2513 ;; (not (memq 'backtrace (debug-options-interface))))
2514 ;; (begin
2515 ;; (display
2516 ;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace
2517 ;;automatically if an error occurs in the future.\n")
2518 ;; (set! has-shown-backtrace-hint? #t))))
2519 ;; (display "No backtrace available.\n")))
2520
2521 (define (error-catching-repl r e p)
2522 (error-catching-loop
2523 (lambda ()
2524 (call-with-values (lambda () (e (r)))
2525 (lambda the-values (for-each p the-values))))))
2526
2527 (define (gc-run-time)
2528 (cdr (assq 'gc-time-taken (gc-stats))))
2529
2530 (define before-read-hook (make-hook))
2531 (define after-read-hook (make-hook))
2532 (define before-eval-hook (make-hook 1))
2533 (define after-eval-hook (make-hook 1))
2534 (define before-print-hook (make-hook 1))
2535 (define after-print-hook (make-hook 1))
2536
2537 ;;; The default repl-reader function. We may override this if we've
2538 ;;; the readline library.
2539 (define repl-reader
2540 (lambda (prompt)
2541 (display prompt)
2542 (force-output)
2543 (run-hook before-read-hook)
2544 (read (current-input-port))))
2545
2546 (define (scm-style-repl)
2547
2548 (letrec (
2549 (start-gc-rt #f)
2550 (start-rt #f)
2551 (repl-report-start-timing (lambda ()
2552 (set! start-gc-rt (gc-run-time))
2553 (set! start-rt (get-internal-run-time))))
2554 (repl-report (lambda ()
2555 (display ";;; ")
2556 (display (inexact->exact
2557 (* 1000 (/ (- (get-internal-run-time) start-rt)
2558 internal-time-units-per-second))))
2559 (display " msec (")
2560 (display (inexact->exact
2561 (* 1000 (/ (- (gc-run-time) start-gc-rt)
2562 internal-time-units-per-second))))
2563 (display " msec in gc)\n")))
2564
2565 (consume-trailing-whitespace
2566 (lambda ()
2567 (let ((ch (peek-char)))
2568 (cond
2569 ((eof-object? ch))
2570 ((or (char=? ch #\space) (char=? ch #\tab))
2571 (read-char)
2572 (consume-trailing-whitespace))
2573 ((char=? ch #\newline)
2574 (read-char))))))
2575 (-read (lambda ()
2576 (let ((val
2577 (let ((prompt (cond ((string? scm-repl-prompt)
2578 scm-repl-prompt)
2579 ((thunk? scm-repl-prompt)
2580 (scm-repl-prompt))
2581 (scm-repl-prompt "> ")
2582 (else ""))))
2583 (repl-reader prompt))))
2584
2585 ;; As described in R4RS, the READ procedure updates the
2586 ;; port to point to the first character past the end of
2587 ;; the external representation of the object. This
2588 ;; means that it doesn't consume the newline typically
2589 ;; found after an expression. This means that, when
2590 ;; debugging Guile with GDB, GDB gets the newline, which
2591 ;; it often interprets as a "continue" command, making
2592 ;; breakpoints kind of useless. So, consume any
2593 ;; trailing newline here, as well as any whitespace
2594 ;; before it.
2595 ;; But not if EOF, for control-D.
2596 (if (not (eof-object? val))
2597 (consume-trailing-whitespace))
2598 (run-hook after-read-hook)
2599 (if (eof-object? val)
2600 (begin
2601 (repl-report-start-timing)
2602 (if scm-repl-verbose
2603 (begin
2604 (newline)
2605 (display ";;; EOF -- quitting")
2606 (newline)))
2607 (quit 0)))
2608 val)))
2609
2610 (-eval (lambda (sourc)
2611 (repl-report-start-timing)
2612 (run-hook before-eval-hook sourc)
2613 (let ((val (start-stack 'repl-stack
2614 ;; If you change this procedure
2615 ;; (primitive-eval), please also
2616 ;; modify the repl-stack case in
2617 ;; save-stack so that stack cutting
2618 ;; continues to work.
2619 (primitive-eval sourc))))
2620 (run-hook after-eval-hook sourc)
2621 val)))
2622
2623
2624 (-print (let ((maybe-print (lambda (result)
2625 (if (or scm-repl-print-unspecified
2626 (not (unspecified? result)))
2627 (begin
2628 (write result)
2629 (newline))))))
2630 (lambda (result)
2631 (if (not scm-repl-silent)
2632 (begin
2633 (run-hook before-print-hook result)
2634 (maybe-print result)
2635 (run-hook after-print-hook result)
2636 (if scm-repl-verbose
2637 (repl-report))
2638 (force-output))))))
2639
2640 (-quit (lambda (args)
2641 (if scm-repl-verbose
2642 (begin
2643 (display ";;; QUIT executed, repl exitting")
2644 (newline)
2645 (repl-report)))
2646 args))
2647
2648 (-abort (lambda ()
2649 (if scm-repl-verbose
2650 (begin
2651 (display ";;; ABORT executed.")
2652 (newline)
2653 (repl-report)))
2654 (repl -read -eval -print))))
2655
2656 (let ((status (error-catching-repl -read
2657 -eval
2658 -print)))
2659 (-quit status))))
2660
2661
2662 \f
2663
2664 ;;; {IOTA functions: generating lists of numbers}
2665 ;;;
2666
2667 (define (iota n)
2668 (let loop ((count (1- n)) (result '()))
2669 (if (< count 0) result
2670 (loop (1- count) (cons count result)))))
2671
2672 \f
2673
2674 ;;; {collect}
2675 ;;;
2676 ;;; Similar to `begin' but returns a list of the results of all constituent
2677 ;;; forms instead of the result of the last form.
2678 ;;; (The definition relies on the current left-to-right
2679 ;;; order of evaluation of operands in applications.)
2680 ;;;
2681
2682 (defmacro collect forms
2683 (cons 'list forms))
2684
2685 \f
2686
2687 ;;; {with-fluids}
2688 ;;;
2689
2690 ;; with-fluids is a convenience wrapper for the builtin procedure
2691 ;; `with-fluids*'. The syntax is just like `let':
2692 ;;
2693 ;; (with-fluids ((fluid val)
2694 ;; ...)
2695 ;; body)
2696
2697 (defmacro with-fluids (bindings . body)
2698 (let ((fluids (map car bindings))
2699 (values (map cadr bindings)))
2700 (if (and (= (length fluids) 1) (= (length values) 1))
2701 `(with-fluid* ,(car fluids) ,(car values) (lambda () ,@body))
2702 `(with-fluids* (list ,@fluids) (list ,@values)
2703 (lambda () ,@body)))))
2704
2705 \f
2706
2707 ;;; {Macros}
2708 ;;;
2709
2710 ;; actually....hobbit might be able to hack these with a little
2711 ;; coaxing
2712 ;;
2713
2714 (define (primitive-macro? m)
2715 (and (macro? m)
2716 (not (macro-transformer m))))
2717
2718 (defmacro define-macro (first . rest)
2719 (let ((name (if (symbol? first) first (car first)))
2720 (transformer
2721 (if (symbol? first)
2722 (car rest)
2723 `(lambda ,(cdr first) ,@rest))))
2724 `(eval-case
2725 ((load-toplevel)
2726 (define ,name (defmacro:transformer ,transformer)))
2727 (else
2728 (error "define-macro can only be used at the top level")))))
2729
2730
2731 (defmacro define-syntax-macro (first . rest)
2732 (let ((name (if (symbol? first) first (car first)))
2733 (transformer
2734 (if (symbol? first)
2735 (car rest)
2736 `(lambda ,(cdr first) ,@rest))))
2737 `(eval-case
2738 ((load-toplevel)
2739 (define ,name (defmacro:syntax-transformer ,transformer)))
2740 (else
2741 (error "define-syntax-macro can only be used at the top level")))))
2742
2743 \f
2744
2745 ;;; {While}
2746 ;;;
2747 ;;; with `continue' and `break'.
2748 ;;;
2749
2750 ;; The inner `do' loop avoids re-establishing a catch every iteration,
2751 ;; that's only necessary if continue is actually used. A new key is
2752 ;; generated every time, so break and continue apply to their originating
2753 ;; `while' even when recursing. `while-helper' is an easy way to keep the
2754 ;; `key' binding away from the cond and body code.
2755 ;;
2756 (define-macro (while cond . body)
2757 (define (while-helper proc)
2758 (do ((key (make-symbol "while-key")))
2759 ((catch key
2760 (lambda ()
2761 (proc (lambda () (throw key #t))
2762 (lambda () (throw key #f))))
2763 (lambda (key arg) arg)))))
2764 `(,while-helper (,lambda (break continue)
2765 (,do ()
2766 ((,not ,cond))
2767 ,@body)
2768 #t)))
2769
2770
2771 \f
2772
2773 ;;; {Module System Macros}
2774 ;;;
2775
2776 ;; Return a list of expressions that evaluate to the appropriate
2777 ;; arguments for resolve-interface according to SPEC.
2778
2779 (define (compile-interface-spec spec)
2780 (define (make-keyarg sym key quote?)
2781 (cond ((or (memq sym spec)
2782 (memq key spec))
2783 => (lambda (rest)
2784 (if quote?
2785 (list key (list 'quote (cadr rest)))
2786 (list key (cadr rest)))))
2787 (else
2788 '())))
2789 (define (map-apply func list)
2790 (map (lambda (args) (apply func args)) list))
2791 (define keys
2792 ;; sym key quote?
2793 '((:select #:select #t)
2794 (:hide #:hide #t)
2795 (:prefix #:prefix #t)
2796 (:renamer #:renamer #f)))
2797 (if (not (pair? (car spec)))
2798 `(',spec)
2799 `(',(car spec)
2800 ,@(apply append (map-apply make-keyarg keys)))))
2801
2802 (define (keyword-like-symbol->keyword sym)
2803 (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
2804
2805 (define (compile-define-module-args args)
2806 ;; Just quote everything except #:use-module and #:use-syntax. We
2807 ;; need to know about all arguments regardless since we want to turn
2808 ;; symbols that look like keywords into real keywords, and the
2809 ;; keyword args in a define-module form are not regular
2810 ;; (i.e. no-backtrace doesn't take a value).
2811 (let loop ((compiled-args `((quote ,(car args))))
2812 (args (cdr args)))
2813 (cond ((null? args)
2814 (reverse! compiled-args))
2815 ;; symbol in keyword position
2816 ((symbol? (car args))
2817 (loop compiled-args
2818 (cons (keyword-like-symbol->keyword (car args)) (cdr args))))
2819 ((memq (car args) '(#:no-backtrace #:pure))
2820 (loop (cons (car args) compiled-args)
2821 (cdr args)))
2822 ((null? (cdr args))
2823 (error "keyword without value:" (car args)))
2824 ((memq (car args) '(#:use-module #:use-syntax))
2825 (loop (cons* `(list ,@(compile-interface-spec (cadr args)))
2826 (car args)
2827 compiled-args)
2828 (cddr args)))
2829 ((eq? (car args) #:autoload)
2830 (loop (cons* `(quote ,(caddr args))
2831 `(quote ,(cadr args))
2832 (car args)
2833 compiled-args)
2834 (cdddr args)))
2835 (else
2836 (loop (cons* `(quote ,(cadr args))
2837 (car args)
2838 compiled-args)
2839 (cddr args))))))
2840
2841 (defmacro define-module args
2842 `(eval-case
2843 ((load-toplevel)
2844 (let ((m (process-define-module
2845 (list ,@(compile-define-module-args args)))))
2846 (set-current-module m)
2847 m))
2848 (else
2849 (error "define-module can only be used at the top level"))))
2850
2851 ;; The guts of the use-modules macro. Add the interfaces of the named
2852 ;; modules to the use-list of the current module, in order.
2853
2854 ;; This function is called by "modules.c". If you change it, be sure
2855 ;; to change scm_c_use_module as well.
2856
2857 (define (process-use-modules module-interface-args)
2858 (let ((interfaces (map (lambda (mif-args)
2859 (or (apply resolve-interface mif-args)
2860 (error "no such module" mif-args)))
2861 module-interface-args)))
2862 (call-with-deferred-observers
2863 (lambda ()
2864 (module-use-interfaces! (current-module) interfaces)))))
2865
2866 (defmacro use-modules modules
2867 `(eval-case
2868 ((load-toplevel)
2869 (process-use-modules
2870 (list ,@(map (lambda (m)
2871 `(list ,@(compile-interface-spec m)))
2872 modules)))
2873 *unspecified*)
2874 (else
2875 (error "use-modules can only be used at the top level"))))
2876
2877 (defmacro use-syntax (spec)
2878 `(eval-case
2879 ((load-toplevel)
2880 ,@(if (pair? spec)
2881 `((process-use-modules (list
2882 (list ,@(compile-interface-spec spec))))
2883 (set-module-transformer! (current-module)
2884 ,(car (last-pair spec))))
2885 `((set-module-transformer! (current-module) ,spec)))
2886 *unspecified*)
2887 (else
2888 (error "use-syntax can only be used at the top level"))))
2889
2890 ;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed
2891 ;; as soon as guile supports hygienic macros.
2892 (define define-private define)
2893
2894 (defmacro define-public args
2895 (define (syntax)
2896 (error "bad syntax" (list 'define-public args)))
2897 (define (defined-name n)
2898 (cond
2899 ((symbol? n) n)
2900 ((pair? n) (defined-name (car n)))
2901 (else (syntax))))
2902 (cond
2903 ((null? args)
2904 (syntax))
2905 (#t
2906 (let ((name (defined-name (car args))))
2907 `(begin
2908 (define-private ,@args)
2909 (eval-case ((load-toplevel) (export ,name))))))))
2910
2911 (defmacro defmacro-public args
2912 (define (syntax)
2913 (error "bad syntax" (list 'defmacro-public args)))
2914 (define (defined-name n)
2915 (cond
2916 ((symbol? n) n)
2917 (else (syntax))))
2918 (cond
2919 ((null? args)
2920 (syntax))
2921 (#t
2922 (let ((name (defined-name (car args))))
2923 `(begin
2924 (eval-case ((load-toplevel) (export-syntax ,name)))
2925 (defmacro ,@args))))))
2926
2927 ;; Export a local variable
2928
2929 ;; This function is called from "modules.c". If you change it, be
2930 ;; sure to update "modules.c" as well.
2931
2932 (define (module-export! m names)
2933 (let ((public-i (module-public-interface m)))
2934 (for-each (lambda (name)
2935 (let ((var (module-ensure-local-variable! m name)))
2936 (module-add! public-i name var)))
2937 names)))
2938
2939 (define (module-replace! m names)
2940 (let ((public-i (module-public-interface m)))
2941 (for-each (lambda (name)
2942 (let ((var (module-ensure-local-variable! m name)))
2943 (set-object-property! var 'replace #t)
2944 (module-add! public-i name var)))
2945 names)))
2946
2947 ;; Re-export a imported variable
2948 ;;
2949 (define (module-re-export! m names)
2950 (let ((public-i (module-public-interface m)))
2951 (for-each (lambda (name)
2952 (let ((var (module-variable m name)))
2953 (cond ((not var)
2954 (error "Undefined variable:" name))
2955 ((eq? var (module-local-variable m name))
2956 (error "re-exporting local variable:" name))
2957 (else
2958 (module-add! public-i name var)))))
2959 names)))
2960
2961 (defmacro export names
2962 `(eval-case
2963 ((load-toplevel)
2964 (call-with-deferred-observers
2965 (lambda ()
2966 (module-export! (current-module) ',names))))
2967 (else
2968 (error "export can only be used at the top level"))))
2969
2970 (defmacro re-export names
2971 `(eval-case
2972 ((load-toplevel)
2973 (call-with-deferred-observers
2974 (lambda ()
2975 (module-re-export! (current-module) ',names))))
2976 (else
2977 (error "re-export can only be used at the top level"))))
2978
2979 (defmacro export-syntax names
2980 `(export ,@names))
2981
2982 (defmacro re-export-syntax names
2983 `(re-export ,@names))
2984
2985 (define load load-module)
2986
2987 ;; The following macro allows one to write, for example,
2988 ;;
2989 ;; (@ (ice-9 pretty-print) pretty-print)
2990 ;;
2991 ;; to refer directly to the pretty-print variable in module (ice-9
2992 ;; pretty-print). It works by looking up the variable and inserting
2993 ;; it directly into the code. This is understood by the evaluator.
2994 ;; Indeed, all references to global variables are memoized into such
2995 ;; variable objects.
2996
2997 (define-macro (@ mod-name var-name)
2998 (let ((var (module-variable (resolve-interface mod-name) var-name)))
2999 (if (not var)
3000 (error "no such public variable" (list '@ mod-name var-name)))
3001 var))
3002
3003 ;; The '@@' macro is like '@' but it can also access bindings that
3004 ;; have not been explicitely exported.
3005
3006 (define-macro (@@ mod-name var-name)
3007 (let ((var (module-variable (resolve-module mod-name) var-name)))
3008 (if (not var)
3009 (error "no such variable" (list '@@ mod-name var-name)))
3010 var))
3011
3012 \f
3013
3014 ;;; {Parameters}
3015 ;;;
3016
3017 (define make-mutable-parameter
3018 (let ((make (lambda (fluid converter)
3019 (lambda args
3020 (if (null? args)
3021 (fluid-ref fluid)
3022 (fluid-set! fluid (converter (car args))))))))
3023 (lambda (init . converter)
3024 (let ((fluid (make-fluid))
3025 (converter (if (null? converter)
3026 identity
3027 (car converter))))
3028 (fluid-set! fluid (converter init))
3029 (make fluid converter)))))
3030
3031 \f
3032
3033 ;;; {Handling of duplicate imported bindings}
3034 ;;;
3035
3036 ;; Duplicate handlers take the following arguments:
3037 ;;
3038 ;; module importing module
3039 ;; name conflicting name
3040 ;; int1 old interface where name occurs
3041 ;; val1 value of binding in old interface
3042 ;; int2 new interface where name occurs
3043 ;; val2 value of binding in new interface
3044 ;; var previous resolution or #f
3045 ;; val value of previous resolution
3046 ;;
3047 ;; A duplicate handler can take three alternative actions:
3048 ;;
3049 ;; 1. return #f => leave responsibility to next handler
3050 ;; 2. exit with an error
3051 ;; 3. return a variable resolving the conflict
3052 ;;
3053
3054 (define duplicate-handlers
3055 (let ((m (make-module 7)))
3056
3057 (define (check module name int1 val1 int2 val2 var val)
3058 (scm-error 'misc-error
3059 #f
3060 "~A: `~A' imported from both ~A and ~A"
3061 (list (module-name module)
3062 name
3063 (module-name int1)
3064 (module-name int2))
3065 #f))
3066
3067 (define (warn module name int1 val1 int2 val2 var val)
3068 (format #t
3069 "WARNING: ~A: `~A' imported from both ~A and ~A\n"
3070 (module-name module)
3071 name
3072 (module-name int1)
3073 (module-name int2))
3074 #f)
3075
3076 (define (replace module name int1 val1 int2 val2 var val)
3077 (let ((old (or (and var (object-property var 'replace) var)
3078 (module-variable int1 name)))
3079 (new (module-variable int2 name)))
3080 (if (object-property old 'replace)
3081 (and (or (eq? old new)
3082 (not (object-property new 'replace)))
3083 old)
3084 (and (object-property new 'replace)
3085 new))))
3086
3087 (define (warn-override-core module name int1 val1 int2 val2 var val)
3088 (and (eq? int1 the-scm-module)
3089 (begin
3090 (format #t
3091 "WARNING: ~A: imported module ~A overrides core binding `~A'\n"
3092 (module-name module)
3093 (module-name int2)
3094 name)
3095 (module-local-variable int2 name))))
3096
3097 (define (first module name int1 val1 int2 val2 var val)
3098 (or var (module-local-variable int1 name)))
3099
3100 (define (last module name int1 val1 int2 val2 var val)
3101 (module-local-variable int2 name))
3102
3103 (define (noop module name int1 val1 int2 val2 var val)
3104 #f)
3105
3106 (set-module-name! m 'duplicate-handlers)
3107 (set-module-kind! m 'interface)
3108 (module-define! m 'check check)
3109 (module-define! m 'warn warn)
3110 (module-define! m 'replace replace)
3111 (module-define! m 'warn-override-core warn-override-core)
3112 (module-define! m 'first first)
3113 (module-define! m 'last last)
3114 (module-define! m 'merge-generics noop)
3115 (module-define! m 'merge-accessors noop)
3116 m))
3117
3118 (define (lookup-duplicates-handlers handler-names)
3119 (and handler-names
3120 (map (lambda (handler-name)
3121 (or (module-symbol-local-binding
3122 duplicate-handlers handler-name #f)
3123 (error "invalid duplicate handler name:"
3124 handler-name)))
3125 (if (list? handler-names)
3126 handler-names
3127 (list handler-names)))))
3128
3129 (define default-duplicate-binding-procedures
3130 (make-mutable-parameter #f))
3131
3132 (define default-duplicate-binding-handler
3133 (make-mutable-parameter '(replace warn-override-core warn last)
3134 (lambda (handler-names)
3135 (default-duplicate-binding-procedures
3136 (lookup-duplicates-handlers handler-names))
3137 handler-names)))
3138
3139 (define (make-duplicates-interface)
3140 (let ((m (make-module)))
3141 (set-module-kind! m 'custom-interface)
3142 (set-module-name! m 'duplicates)
3143 m))
3144
3145 (define (process-duplicates module interface)
3146 (let* ((duplicates-handlers (or (module-duplicates-handlers module)
3147 (default-duplicate-binding-procedures)))
3148 (duplicates-interface (module-duplicates-interface module)))
3149 (module-for-each
3150 (lambda (name var)
3151 (cond ((module-import-interface module name)
3152 =>
3153 (lambda (prev-interface)
3154 (let ((var1 (module-local-variable prev-interface name))
3155 (var2 (module-local-variable interface name)))
3156 (if (not (eq? var1 var2))
3157 (begin
3158 (if (not duplicates-interface)
3159 (begin
3160 (set! duplicates-interface
3161 (make-duplicates-interface))
3162 (set-module-duplicates-interface!
3163 module
3164 duplicates-interface)))
3165 (let* ((var (module-local-variable duplicates-interface
3166 name))
3167 (val (and var
3168 (variable-bound? var)
3169 (variable-ref var))))
3170 (let loop ((duplicates-handlers duplicates-handlers))
3171 (cond ((null? duplicates-handlers))
3172 (((car duplicates-handlers)
3173 module
3174 name
3175 prev-interface
3176 (and (variable-bound? var1)
3177 (variable-ref var1))
3178 interface
3179 (and (variable-bound? var2)
3180 (variable-ref var2))
3181 var
3182 val)
3183 =>
3184 (lambda (var)
3185 (module-add! duplicates-interface name var)))
3186 (else
3187 (loop (cdr duplicates-handlers)))))))))))))
3188 interface)))
3189
3190 \f
3191
3192 ;;; {`cond-expand' for SRFI-0 support.}
3193 ;;;
3194 ;;; This syntactic form expands into different commands or
3195 ;;; definitions, depending on the features provided by the Scheme
3196 ;;; implementation.
3197 ;;;
3198 ;;; Syntax:
3199 ;;;
3200 ;;; <cond-expand>
3201 ;;; --> (cond-expand <cond-expand-clause>+)
3202 ;;; | (cond-expand <cond-expand-clause>* (else <command-or-definition>))
3203 ;;; <cond-expand-clause>
3204 ;;; --> (<feature-requirement> <command-or-definition>*)
3205 ;;; <feature-requirement>
3206 ;;; --> <feature-identifier>
3207 ;;; | (and <feature-requirement>*)
3208 ;;; | (or <feature-requirement>*)
3209 ;;; | (not <feature-requirement>)
3210 ;;; <feature-identifier>
3211 ;;; --> <a symbol which is the name or alias of a SRFI>
3212 ;;;
3213 ;;; Additionally, this implementation provides the
3214 ;;; <feature-identifier>s `guile' and `r5rs', so that programs can
3215 ;;; determine the implementation type and the supported standard.
3216 ;;;
3217 ;;; Currently, the following feature identifiers are supported:
3218 ;;;
3219 ;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14
3220 ;;;
3221 ;;; Remember to update the features list when adding more SRFIs.
3222 ;;;
3223
3224 (define %cond-expand-features
3225 ;; Adjust the above comment when changing this.
3226 '(guile
3227 r5rs
3228 srfi-0 ;; cond-expand itself
3229 srfi-4 ;; homogenous numeric vectors
3230 srfi-6 ;; open-input-string etc, in the guile core
3231 srfi-13 ;; string library
3232 srfi-14 ;; character sets
3233 ))
3234
3235 ;; This table maps module public interfaces to the list of features.
3236 ;;
3237 (define %cond-expand-table (make-hash-table 31))
3238
3239 ;; Add one or more features to the `cond-expand' feature list of the
3240 ;; module `module'.
3241 ;;
3242 (define (cond-expand-provide module features)
3243 (let ((mod (module-public-interface module)))
3244 (and mod
3245 (hashq-set! %cond-expand-table mod
3246 (append (hashq-ref %cond-expand-table mod '())
3247 features)))))
3248
3249 (define cond-expand
3250 (procedure->memoizing-macro
3251 (lambda (exp env)
3252 (let ((clauses (cdr exp))
3253 (syntax-error (lambda (cl)
3254 (error "invalid clause in `cond-expand'" cl))))
3255 (letrec
3256 ((test-clause
3257 (lambda (clause)
3258 (cond
3259 ((symbol? clause)
3260 (or (memq clause %cond-expand-features)
3261 (let lp ((uses (module-uses (env-module env))))
3262 (if (pair? uses)
3263 (or (memq clause
3264 (hashq-ref %cond-expand-table
3265 (car uses) '()))
3266 (lp (cdr uses)))
3267 #f))))
3268 ((pair? clause)
3269 (cond
3270 ((eq? 'and (car clause))
3271 (let lp ((l (cdr clause)))
3272 (cond ((null? l)
3273 #t)
3274 ((pair? l)
3275 (and (test-clause (car l)) (lp (cdr l))))
3276 (else
3277 (syntax-error clause)))))
3278 ((eq? 'or (car clause))
3279 (let lp ((l (cdr clause)))
3280 (cond ((null? l)
3281 #f)
3282 ((pair? l)
3283 (or (test-clause (car l)) (lp (cdr l))))
3284 (else
3285 (syntax-error clause)))))
3286 ((eq? 'not (car clause))
3287 (cond ((not (pair? (cdr clause)))
3288 (syntax-error clause))
3289 ((pair? (cddr clause))
3290 ((syntax-error clause))))
3291 (not (test-clause (cadr clause))))
3292 (else
3293 (syntax-error clause))))
3294 (else
3295 (syntax-error clause))))))
3296 (let lp ((c clauses))
3297 (cond
3298 ((null? c)
3299 (error "Unfulfilled `cond-expand'"))
3300 ((not (pair? c))
3301 (syntax-error c))
3302 ((not (pair? (car c)))
3303 (syntax-error (car c)))
3304 ((test-clause (caar c))
3305 `(begin ,@(cdar c)))
3306 ((eq? (caar c) 'else)
3307 (if (pair? (cdr c))
3308 (syntax-error c))
3309 `(begin ,@(cdar c)))
3310 (else
3311 (lp (cdr c))))))))))
3312
3313 ;; This procedure gets called from the startup code with a list of
3314 ;; numbers, which are the numbers of the SRFIs to be loaded on startup.
3315 ;;
3316 (define (use-srfis srfis)
3317 (let lp ((s srfis))
3318 (if (pair? s)
3319 (let* ((srfi (string->symbol
3320 (string-append "srfi-" (number->string (car s)))))
3321 (mod-i (resolve-interface (list 'srfi srfi))))
3322 (module-use! (current-module) mod-i)
3323 (lp (cdr s))))))
3324
3325 \f
3326
3327 ;;; {Load emacs interface support if emacs option is given.}
3328 ;;;
3329
3330 (define (named-module-use! user usee)
3331 (module-use! (resolve-module user) (resolve-interface usee)))
3332
3333 (define (load-emacs-interface)
3334 (and (provided? 'debug-extensions)
3335 (debug-enable 'backtrace))
3336 (named-module-use! '(guile-user) '(ice-9 emacs)))
3337
3338 \f
3339
3340 (define using-readline?
3341 (let ((using-readline? (make-fluid)))
3342 (make-procedure-with-setter
3343 (lambda () (fluid-ref using-readline?))
3344 (lambda (v) (fluid-set! using-readline? v)))))
3345
3346 (define (top-repl)
3347 (let ((guile-user-module (resolve-module '(guile-user))))
3348
3349 ;; Load emacs interface support if emacs option is given.
3350 (if (and (module-defined? guile-user-module 'use-emacs-interface)
3351 (module-ref guile-user-module 'use-emacs-interface))
3352 (load-emacs-interface))
3353
3354 ;; Use some convenient modules (in reverse order)
3355
3356 (if (provided? 'regex)
3357 (module-use! guile-user-module (resolve-interface '(ice-9 regex))))
3358 (if (provided? 'threads)
3359 (module-use! guile-user-module (resolve-interface '(ice-9 threads))))
3360 ;; load debugger on demand
3361 (module-use! guile-user-module
3362 (make-autoload-interface guile-user-module
3363 '(ice-9 debugger) '(debug)))
3364 (module-use! guile-user-module (resolve-interface '(ice-9 session)))
3365 (module-use! guile-user-module (resolve-interface '(ice-9 debug)))
3366 ;; so that builtin bindings will be checked first
3367 (module-use! guile-user-module (resolve-interface '(ice-9 r5rs)))
3368 (module-use! guile-user-module (resolve-interface '(guile)))
3369
3370 (set-current-module guile-user-module)
3371
3372 (let ((old-handlers #f)
3373 (signals (if (provided? 'posix)
3374 `((,SIGINT . "User interrupt")
3375 (,SIGFPE . "Arithmetic error")
3376 (,SIGBUS . "Bad memory access (bus error)")
3377 (,SIGSEGV
3378 . "Bad memory access (Segmentation violation)"))
3379 '())))
3380
3381 (dynamic-wind
3382
3383 ;; call at entry
3384 (lambda ()
3385 (let ((make-handler (lambda (msg)
3386 (lambda (sig)
3387 ;; Make a backup copy of the stack
3388 (fluid-set! before-signal-stack
3389 (fluid-ref the-last-stack))
3390 (save-stack 2)
3391 (scm-error 'signal
3392 #f
3393 msg
3394 #f
3395 (list sig))))))
3396 (set! old-handlers
3397 (map (lambda (sig-msg)
3398 (sigaction (car sig-msg)
3399 (make-handler (cdr sig-msg))))
3400 signals))))
3401
3402 ;; the protected thunk.
3403 (lambda ()
3404 (let ((status (scm-style-repl)))
3405 (run-hook exit-hook)
3406 status))
3407
3408 ;; call at exit.
3409 (lambda ()
3410 (map (lambda (sig-msg old-handler)
3411 (if (not (car old-handler))
3412 ;; restore original C handler.
3413 (sigaction (car sig-msg) #f)
3414 ;; restore Scheme handler, SIG_IGN or SIG_DFL.
3415 (sigaction (car sig-msg)
3416 (car old-handler)
3417 (cdr old-handler))))
3418 signals old-handlers))))))
3419
3420 ;;; This hook is run at the very end of an interactive session.
3421 ;;;
3422 (define exit-hook (make-hook))
3423
3424 \f
3425
3426 ;;; {Deprecated stuff}
3427 ;;;
3428
3429 (begin-deprecated
3430 (define (feature? sym)
3431 (issue-deprecation-warning
3432 "`feature?' is deprecated. Use `provided?' instead.")
3433 (provided? sym)))
3434
3435 (begin-deprecated
3436 (primitive-load-path "ice-9/deprecated.scm"))
3437
3438 \f
3439
3440 ;;; Place the user in the guile-user module.
3441 ;;;
3442
3443 (define-module (guile-user))
3444
3445 ;;; boot-9.scm ends here