3 ;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
5 ;;;; This program is free software; you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation; either version 2, or (at your option)
8 ;;;; any later version.
10 ;;;; This program is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with this software; see the file COPYING. If not, write to
17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18 ;;;; Boston, MA 02111-1307 USA
22 ;;; This file is the first thing loaded into Guile. It adds many mundane
23 ;;; definitions and a few that are interesting.
25 ;;; The module system (hence the hierarchical namespace) are defined in this
34 (if (not (memq sym *features*))
35 (set! *features* (cons sym *features*))))
40 (primitive-load-path "ice-9/r4rs.scm")
43 ;;; {Simple Debugging Tools}
47 ;; peek takes any number of arguments, writes them to the
48 ;; current ouput port, and returns the last argument.
49 ;; It is handy to wrap around an expression to look at
50 ;; a value each time is evaluated, e.g.:
52 ;; (+ 10 (troublesome-fn))
53 ;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
56 (define (peek . stuff)
61 (car (last-pair stuff)))
65 (define (warn . stuff)
66 (with-output-to-port (current-error-port)
69 (display ";;; WARNING ")
72 (car (last-pair stuff)))))
75 ;;; {Trivial Functions}
79 (define (1+ n) (+ n 1))
80 (define (-1+ n) (+ n -1))
82 (define return-it noop)
83 (define (and=> value procedure) (and value (procedure value)))
84 (define (make-hash-table k) (make-vector k '()))
86 ;;; apply-to-args is functionally redunant with apply and, worse,
87 ;;; is less general than apply since it only takes two arguments.
89 ;;; On the other hand, apply-to-args is a syntacticly convenient way to
90 ;;; perform binding in many circumstances when the "let" family of
91 ;;; of forms don't cut it. E.g.:
93 ;;; (apply-to-args (return-3d-mouse-coords)
98 (define (apply-to-args args fn) (apply fn args))
104 (define (ipow-by-squaring x k acc proc)
105 (cond ((zero? k) acc)
106 ((= 1 k) (proc acc x))
107 (else (ipow-by-squaring (proc x x)
109 (if (even? k) acc (proc acc x))
112 (define string-character-length string-length)
116 ;; A convenience function for combining flag bits. Like logior, but
117 ;; handles the cases of 0 and 1 arguments.
119 (define (flags . args)
122 ((null? (cdr args)) (car args))
123 (else (apply logior args))))
126 ;;; {Symbol Properties}
129 (define (symbol-property sym prop)
130 (let ((pair (assoc prop (symbol-pref sym))))
131 (and pair (cdr pair))))
133 (define (set-symbol-property! sym prop val)
134 (let ((pair (assoc prop (symbol-pref sym))))
137 (symbol-pset! sym (acons prop val (symbol-pref sym))))))
139 (define (symbol-property-remove! sym prop)
140 (let ((pair (assoc prop (symbol-pref sym))))
142 (symbol-pset! sym (delq! pair (symbol-pref sym))))))
146 ;;; {Line and Delimited I/O}
148 ;;; corresponds to SCM_LINE_INCREMENTORS in libguile.
149 (define scm-line-incrementors "\n")
151 (define (read-line! string . maybe-port)
152 (let* ((port (if (pair? maybe-port)
154 (current-input-port))))
155 (let* ((rv (%read-delimited! scm-line-incrementors
159 (terminator (car rv))
161 (cond ((and (= nchars 0)
162 (eof-object? terminator))
164 ((not terminator) #f)
167 (define (read-delimited! delims buf . args)
168 (let* ((num-args (length args))
169 (port (if (> num-args 0)
171 (current-input-port)))
172 (handle-delim (if (> num-args 1)
175 (start (if (> num-args 2)
178 (end (if (> num-args 3)
180 (string-length buf))))
181 (let* ((rv (%read-delimited! delims
183 (not (eq? handle-delim 'peek))
187 (terminator (car rv))
189 (cond ((or (not terminator) ; buffer filled
190 (eof-object? terminator))
192 (if (eq? handle-delim 'split)
193 (cons terminator terminator)
195 (if (eq? handle-delim 'split)
196 (cons nchars terminator)
201 ((concat) (string-set! buf nchars terminator)
203 ((split) (cons nchars terminator))
204 (else (error "unexpected handle-delim value: "
207 (define (read-delimited delims . args)
208 (let* ((port (if (pair? args)
209 (let ((pt (car args)))
210 (set! args (cdr args))
212 (current-input-port)))
213 (handle-delim (if (pair? args)
216 (let loop ((substrings ())
218 (buf-size 100)) ; doubled each time through.
219 (let* ((buf (make-string buf-size))
220 (rv (%read-delimited! delims
222 (not (eq? handle-delim 'peek))
224 (terminator (car rv))
230 (cons (if (and (eq? handle-delim 'concat)
231 (not (eof-object? terminator)))
234 (cons (make-shared-substring buf 0 nchars)
236 (new-total (+ total-chars nchars)))
237 (cond ((not terminator)
239 (loop (cons (substring buf 0 nchars) substrings)
242 ((eof-object? terminator)
243 (if (zero? new-total)
244 (if (eq? handle-delim 'split)
245 (cons terminator terminator)
247 (if (eq? handle-delim 'split)
248 (cons (join-substrings) terminator)
252 ((trim peek concat) (join-substrings))
253 ((split) (cons (join-substrings) terminator))
254 (else (error "unexpected handle-delim value: "
255 handle-delim)))))))))
257 (define (read-line . args)
258 (apply read-delimited scm-line-incrementors args))
265 (define uniform-vector? array?)
266 (define make-uniform-vector dimensions->uniform-array)
267 ; (define uniform-vector-ref array-ref)
268 (define (uniform-vector-set! u i o)
269 (uniform-array-set1! u o i))
270 (define uniform-vector-fill! array-fill!)
271 (define uniform-vector-read! uniform-array-read!)
272 (define uniform-vector-write uniform-array-write)
274 (define (make-array fill . args)
275 (dimensions->uniform-array args () fill))
276 (define (make-uniform-array prot . args)
277 (dimensions->uniform-array args prot))
278 (define (list->array ndim lst)
279 (list->uniform-array ndim '() lst))
280 (define (list->uniform-vector prot lst)
281 (list->uniform-array 1 prot lst))
282 (define (array-shape a)
283 (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
284 (array-dimensions a))))
290 (define (symbol->keyword symbol)
291 (make-keyword-from-dash-symbol (symbol-append '- symbol)))
293 (define (keyword->symbol kw)
294 (let ((sym (keyword-dash-symbol kw)))
295 (string->symbol (substring sym 1 (length sym)))))
297 (define (kw-arg-ref args kw)
298 (let ((rem (member kw args)))
299 (and rem (pair? (cdr rem)) (cadr rem))))
305 ;; The printing of structures can be customized by setting the builtin
306 ;; variable *struct-printer* to a procedure. A second dispatching
307 ;; step is implemented here to allow for struct-type specific printing
310 ;; A particular type of structures is characterized by its vtable. In
311 ;; addition to some internal fields, such a vtable can contain
312 ;; arbitrary user-defined fields. We use the first of these fields to
313 ;; hold the specific printing procedure. To avoid breaking code that
314 ;; already uses this first extra-field for some other purposes, we use
315 ;; a unique tag to decide whether it really contains a structure
318 ;; XXX - Printing structures is probably fundamental enough that we
319 ;; can simply hardcode the vtable slot convention and expect everyone
322 ;; A structure-type specific printer follows the same calling
323 ;; convention as the builtin *struct-printer*.
325 ;; A shorthand for one already hardcoded vtable convention
327 (define (struct-layout s)
328 (struct-ref (struct-vtable s) 0))
330 ;; This is our new convention for storing printing procedures
332 (define %struct-printer-tag (cons '%struct-printer-tag #f))
334 (define (struct-printer s)
335 (let ((vtable (struct-vtable s)))
336 (and (> (string-length (struct-layout vtable))
337 (* 2 struct-vtable-offset))
338 (let ((p (struct-ref vtable struct-vtable-offset)))
340 (eq? (car p) %struct-printer-tag)
343 (define (make-struct-printer printer)
344 (cons %struct-printer-tag printer))
346 ;; Note: While the printer is extracted from a structure itself, it
347 ;; has to be set in the vtable of the structure.
349 (define (set-struct-printer-in-vtable! vtable printer)
350 (struct-set! vtable struct-vtable-offset (make-struct-printer printer)))
354 (set! *struct-printer* (lambda (s p)
355 (let ((printer (struct-printer s)))
363 ;; Printing records: by default, records are printed as
365 ;; #<type-name field1: val1 field2: val2 ...>
367 ;; You can change that by giving a custom printing function to
368 ;; MAKE-RECORD-TYPE (after the list of field symbols). This function
369 ;; will be called like
371 ;; (<printer> object port)
373 ;; It should print OBJECT to PORT.
375 ;; 0: printer, 1: type-name, 2: fields
376 (define record-type-vtable
377 (make-vtable-vtable "prprpr" 0
380 (cond ((eq? s record-type-vtable)
381 (display "#<record-type-vtable>" p))
383 (display "#<record-type " p)
384 (display (record-type-name s) p)
385 (display ">" p)))))))
387 (define (record-type? obj)
388 (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
390 (define (make-record-type type-name fields . opt)
391 (let ((printer-fn (and (pair? opt) (car opt))))
392 (let ((struct (make-struct record-type-vtable 0
395 (map (lambda (f) "pw") fields)))
400 (display type-name p)
401 (let loop ((fields fields)
404 ((not (null? fields))
406 (display (car fields) p)
408 (display (struct-ref s off) p)
409 (loop (cdr fields) (+ 1 off)))))
412 (copy-tree fields))))
415 (define (record-type-name obj)
416 (if (record-type? obj)
417 (struct-ref obj (+ 1 struct-vtable-offset))
418 (error 'not-a-record-type obj)))
420 (define (record-type-fields obj)
421 (if (record-type? obj)
422 (struct-ref obj (+ 2 struct-vtable-offset))
423 (error 'not-a-record-type obj)))
425 (define (record-constructor rtd . opt)
426 (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd))))
427 (eval `(lambda ,field-names
428 (make-struct ',rtd 0 ,@(map (lambda (f)
429 (if (memq f field-names)
432 (record-type-fields rtd)))))))
434 (define (record-predicate rtd)
435 (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
437 (define (record-accessor rtd field-name)
438 (let* ((pos (list-index (record-type-fields rtd) field-name)))
440 (error 'no-such-field field-name))
442 (and (eq? ',rtd (record-type-descriptor obj))
443 (struct-ref obj ,pos))))))
445 (define (record-modifier rtd field-name)
446 (let* ((pos (list-index (record-type-fields rtd) field-name)))
448 (error 'no-such-field field-name))
449 (eval `(lambda (obj val)
450 (and (eq? ',rtd (record-type-descriptor obj))
451 (struct-set! obj ,pos val))))))
454 (define (record? obj)
455 (and (struct? obj) (record-type? (struct-vtable obj))))
457 (define (record-type-descriptor obj)
460 (error 'not-a-record obj)))
468 (define (->bool x) (not (not x)))
474 (define (symbol-append . args)
475 (string->symbol (apply string-append args)))
477 (define (list->symbol . args)
478 (string->symbol (apply list->string args)))
480 (define (symbol . args)
481 (string->symbol (apply string args)))
483 (define (obarray-symbol-append ob . args)
484 (string->obarray-symbol (apply string-append ob args)))
486 (define obarray-gensym
488 (lambda (obarray . opt)
490 (set! opt '(%%gensym)))
491 (let loop ((proposed-name (apply string-append opt)))
492 (if (string->obarray-symbol obarray proposed-name #t)
493 (loop (apply string-append (append opt (begin (set! n (1+ n)) (list (number->string n))))))
494 (string->obarray-symbol obarray proposed-name))))))
496 (define (gensym . args) (apply obarray-gensym #f args))
502 (define (list-index l k)
508 (loop (+ n 1) (cdr l))))))
510 (define (make-list n . init)
511 (if (pair? init) (set! init (car init)))
512 (let loop ((answer '())
516 (loop (cons init answer) (- n 1)))))
520 ;;; {and-map, or-map, and map-in-order}
522 ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
523 ;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
524 ;;; (map-in-order fn lst) is like (map fn lst) but definately in order of lst.
529 ;; Apply f to successive elements of l until exhaustion or f returns #f.
530 ;; If returning early, return #f. Otherwise, return the last value returned
531 ;; by f. If f has never been called because l is empty, return #t.
533 (define (and-map f lst)
534 (let loop ((result #t)
539 (loop (f (car l)) (cdr l))))))
543 ;; Apply f to successive elements of l until exhaustion or while f returns #f.
544 ;; If returning early, return the return value of f.
546 (define (or-map f lst)
547 (let loop ((result #f)
551 (loop (f (car l)) (cdr l))))))
555 ;; Like map, but guaranteed to process the list in order.
557 (define (map-in-order fn l)
561 (map-in-order fn (cdr l)))))
565 (define (run-hooks hook)
566 (for-each (lambda (thunk) (thunk)) hook))
571 `(let ((thunk ,(caddr exp)))
572 (if (not (memq thunk ,(cadr exp)))
574 (cons thunk ,(cadr exp))))))))
578 ;;; !!!! these should be implemented using Tcl commands, not fports.
581 (define (feature? feature)
582 (and (memq feature *features*) #t))
584 ;; Using the vector returned by stat directly is probably not a good
585 ;; idea (it could just as well be a record). Hence some accessors.
586 (define (stat:dev f) (vector-ref f 0))
587 (define (stat:ino f) (vector-ref f 1))
588 (define (stat:mode f) (vector-ref f 2))
589 (define (stat:nlink f) (vector-ref f 3))
590 (define (stat:uid f) (vector-ref f 4))
591 (define (stat:gid f) (vector-ref f 5))
592 (define (stat:rdev f) (vector-ref f 6))
593 (define (stat:size f) (vector-ref f 7))
594 (define (stat:atime f) (vector-ref f 8))
595 (define (stat:mtime f) (vector-ref f 9))
596 (define (stat:ctime f) (vector-ref f 10))
597 (define (stat:blksize f) (vector-ref f 11))
598 (define (stat:blocks f) (vector-ref f 12))
600 ;; derived from stat mode.
601 (define (stat:type f) (vector-ref f 13))
602 (define (stat:perms f) (vector-ref f 14))
605 (if (feature? 'posix)
609 (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
611 (if port (begin (close-port port) #t)
614 (define file-is-directory?
615 (if (feature? 'i/o-extensions)
617 (eq? (stat:type (stat str)) 'directory))
621 (let ((port (catch 'system-error
622 (lambda () (open-file (string-append str "/.")
625 (if port (begin (close-port port) #t)
628 (define (has-suffix? str suffix)
629 (let ((sufl (string-length suffix))
630 (sl (string-length str)))
632 (string=? (substring str (- sl sufl) sl) suffix))))
638 (define (error . args)
641 (scm-error 'misc-error #f "?" #f #f)
642 (let loop ((msg "%s")
644 (if (not (null? rest))
645 (loop (string-append msg " %S")
647 (scm-error 'misc-error #f msg args #f)))))
649 ;; bad-throw is the hook that is called upon a throw to a an unhandled
650 ;; key (unless the throw has four arguments, in which case
651 ;; it's usually interpreted as an error throw.)
652 ;; If the key has a default handler (a throw-handler-default property),
653 ;; it is applied to the throw.
655 (define (bad-throw key . args)
656 (let ((default (symbol-property key 'throw-handler-default)))
657 (or (and default (apply default key args))
658 (apply error "unhandled-exception:" key args))))
661 ;;; {Non-polymorphic versions of POSIX functions}
663 (define (getgrnam name) (getgr name))
664 (define (getgrgid id) (getgr id))
665 (define (gethostbyaddr addr) (gethost addr))
666 (define (gethostbyname name) (gethost name))
667 (define (getnetbyaddr addr) (getnet addr))
668 (define (getnetbyname name) (getnet name))
669 (define (getprotobyname name) (getproto name))
670 (define (getprotobynumber addr) (getproto addr))
671 (define (getpwnam name) (getpw name))
672 (define (getpwuid uid) (getpw uid))
673 (define (getservbyname name proto) (getserv name proto))
674 (define (getservbyport port proto) (getserv port proto))
675 (define (endgrent) (setgr))
676 (define (endhostent) (sethost))
677 (define (endnetent) (setnet))
678 (define (endprotoent) (setproto))
679 (define (endpwent) (setpw))
680 (define (endservent) (setserv))
681 (define (getgrent) (getgr))
682 (define (gethostent) (gethost))
683 (define (getnetent) (getnet))
684 (define (getprotoent) (getproto))
685 (define (getpwent) (getpw))
686 (define (getservent) (getserv))
687 (define (reopen-file . args) (apply freopen args))
688 (define (setgrent) (setgr #f))
689 (define (sethostent) (sethost #t))
690 (define (setnetent) (setnet #t))
691 (define (setprotoent) (setproto #t))
692 (define (setpwent) (setpw #t))
693 (define (setservent) (setserv #t))
695 (define (passwd:name obj) (vector-ref obj 0))
696 (define (passwd:passwd obj) (vector-ref obj 1))
697 (define (passwd:uid obj) (vector-ref obj 2))
698 (define (passwd:gid obj) (vector-ref obj 3))
699 (define (passwd:gecos obj) (vector-ref obj 4))
700 (define (passwd:dir obj) (vector-ref obj 5))
701 (define (passwd:shell obj) (vector-ref obj 6))
703 (define (group:name obj) (vector-ref obj 0))
704 (define (group:passwd obj) (vector-ref obj 1))
705 (define (group:gid obj) (vector-ref obj 2))
706 (define (group:mem obj) (vector-ref obj 3))
708 (define (hostent:name obj) (vector-ref obj 0))
709 (define (hostent:aliases obj) (vector-ref obj 1))
710 (define (hostent:addrtype obj) (vector-ref obj 2))
711 (define (hostent:length obj) (vector-ref obj 3))
712 (define (hostent:addr-list obj) (vector-ref obj 4))
714 (define (netent:name obj) (vector-ref obj 0))
715 (define (netent:aliases obj) (vector-ref obj 1))
716 (define (netent:addrtype obj) (vector-ref obj 2))
717 (define (netent:net obj) (vector-ref obj 3))
719 (define (protoent:name obj) (vector-ref obj 0))
720 (define (protoent:aliases obj) (vector-ref obj 1))
721 (define (protoent:proto obj) (vector-ref obj 2))
723 (define (servent:name obj) (vector-ref obj 0))
724 (define (servent:aliases obj) (vector-ref obj 1))
725 (define (servent:port obj) (vector-ref obj 2))
726 (define (servent:proto obj) (vector-ref obj 3))
728 (define (sockaddr:fam obj) (vector-ref obj 0))
729 (define (sockaddr:path obj) (vector-ref obj 1))
730 (define (sockaddr:addr obj) (vector-ref obj 1))
731 (define (sockaddr:port obj) (vector-ref obj 2))
733 (define (utsname:sysname obj) (vector-ref obj 0))
734 (define (utsname:nodename obj) (vector-ref obj 1))
735 (define (utsname:release obj) (vector-ref obj 2))
736 (define (utsname:version obj) (vector-ref obj 3))
737 (define (utsname:machine obj) (vector-ref obj 4))
739 (define (tm:sec obj) (vector-ref obj 0))
740 (define (tm:min obj) (vector-ref obj 1))
741 (define (tm:hour obj) (vector-ref obj 2))
742 (define (tm:mday obj) (vector-ref obj 3))
743 (define (tm:mon obj) (vector-ref obj 4))
744 (define (tm:year obj) (vector-ref obj 5))
745 (define (tm:wday obj) (vector-ref obj 6))
746 (define (tm:yday obj) (vector-ref obj 7))
747 (define (tm:isdst obj) (vector-ref obj 8))
748 (define (tm:gmtoff obj) (vector-ref obj 9))
749 (define (tm:zone obj) (vector-ref obj 10))
751 (define (set-tm:sec obj val) (vector-set! obj 0 val))
752 (define (set-tm:min obj val) (vector-set! obj 1 val))
753 (define (set-tm:hour obj val) (vector-set! obj 2 val))
754 (define (set-tm:mday obj val) (vector-set! obj 3 val))
755 (define (set-tm:mon obj val) (vector-set! obj 4 val))
756 (define (set-tm:year obj val) (vector-set! obj 5 val))
757 (define (set-tm:wday obj val) (vector-set! obj 6 val))
758 (define (set-tm:yday obj val) (vector-set! obj 7 val))
759 (define (set-tm:isdst obj val) (vector-set! obj 8 val))
760 (define (set-tm:gmtoff obj val) (vector-set! obj 9 val))
761 (define (set-tm:zone obj val) (vector-set! obj 10 val))
763 (define (file-position . args) (apply ftell args))
764 (define (file-set-position . args) (apply fseek args))
766 (define (open-input-pipe command) (open-pipe command OPEN_READ))
767 (define (open-output-pipe command) (open-pipe command OPEN_WRITE))
769 (define (move->fdes fd/port fd)
770 (cond ((integer? fd/port)
771 (primitive-dup2 fd/port fd)
775 (primitive-move->fdes fd/port fd)
776 (set-port-revealed! fd/port 1)
779 (define (release-port-handle port)
780 (let ((revealed (port-revealed port)))
782 (set-port-revealed! port (- revealed 1)))))
784 (define (dup->port port/fd mode . maybe-fd)
785 (let ((port (fdopen (if (pair? maybe-fd)
786 (primitive-dup2 port/fd (car maybe-fd))
787 (primitive-dup port/fd))
790 (set-port-revealed! port 1))
793 (define (dup->inport port/fd . maybe-fd)
794 (apply dup->port port/fd "r" maybe-fd))
796 (define (dup->outport port/fd . maybe-fd)
797 (apply dup->port port/fd "w" maybe-fd))
799 (define (dup->fdes port/fd . maybe-fd)
801 (primitive-dup2 port/fd (car maybe-fd))
802 (primitive-dup port/fd)))
804 (define (dup port/fd . maybe-fd)
805 (if (integer? port/fd)
806 (apply dup->fdes port/fd maybe-fd)
807 (apply dup->port port/fd (port-mode port/fd) maybe-fd)))
809 (define (duplicate-port port modes)
810 (dup->port port modes))
812 (define (fdes->inport fdes)
813 (let loop ((rest-ports (fdes->ports fdes)))
814 (cond ((null? rest-ports)
815 (let ((result (fdopen fdes "r")))
816 (set-port-revealed! result 1)
818 ((input-port? (car rest-ports))
819 (set-port-revealed! (car rest-ports)
820 (+ (port-revealed (car rest-ports)) 1))
823 (loop (cdr rest-ports))))))
825 (define (fdes->outport fdes)
826 (let loop ((rest-ports (fdes->ports fdes)))
827 (cond ((null? rest-ports)
828 (let ((result (fdopen fdes "w")))
829 (set-port-revealed! result 1)
831 ((output-port? (car rest-ports))
832 (set-port-revealed! (car rest-ports)
833 (+ (port-revealed (car rest-ports)) 1))
836 (loop (cdr rest-ports))))))
838 (define (port->fdes port)
839 (set-port-revealed! port (+ (port-revealed port) 1))
846 ;;; Here for backward compatability
848 (define scheme-file-suffix (lambda () ".scm"))
850 (define (in-vicinity vicinity file)
851 (let ((tail (let ((len (string-length vicinity)))
853 (string-ref vicinity (- len 1))))))
854 (string-append vicinity
855 (if (eq? tail #\/) "" "/")
859 ;;; {Help for scm_shell}
860 ;;; The argument-processing code used by Guile-based shells generates
861 ;;; Scheme code based on the argument list. This page contains help
862 ;;; functions for the code it generates.
864 (define (command-line) (program-arguments))
866 ;; This is mostly for the internal use of the code generated by
867 ;; scm_compile_shell_switches.
868 (define (load-user-init)
869 (define (has-init? dir)
870 (let ((path (in-vicinity dir ".guile")))
873 (let ((stats (stat path)))
874 (if (not (eq? (stat:type stats) 'directory))
877 (let ((path (or (has-init? (or (getenv "HOME") "/"))
878 (has-init? (passwd:dir (getpw (getuid)))))))
879 (if path (primitive-load path))))
882 ;;; {Loading by paths}
884 ;;; Load a Scheme source file named NAME, searching for it in the
885 ;;; directories listed in %load-path, and applying each of the file
886 ;;; name extensions listed in %load-extensions.
887 (define (load-from-path name)
888 (start-stack 'load-stack
889 (primitive-load-path name)))
893 ;;; {Transcendental Functions}
895 ;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
896 ;;; Copyright (C) 1992, 1993 Jerry D. Hedden.
897 ;;; See the file `COPYING' for terms applying to this program.
901 (if (real? z) ($exp z)
902 (make-polar ($exp (real-part z)) (imag-part z))))
905 (if (and (real? z) (>= z 0))
907 (make-rectangular ($log (magnitude z)) (angle z))))
911 (if (negative? z) (make-rectangular 0 ($sqrt (- z)))
913 (make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
916 (let ((integer-expt integer-expt))
919 (integer-expt z1 z2))
920 ((and (real? z2) (real? z1) (>= z1 0))
923 (exp (* z2 (log z1))))))))
926 (if (real? z) ($sinh z)
927 (let ((x (real-part z)) (y (imag-part z)))
928 (make-rectangular (* ($sinh x) ($cos y))
929 (* ($cosh x) ($sin y))))))
931 (if (real? z) ($cosh z)
932 (let ((x (real-part z)) (y (imag-part z)))
933 (make-rectangular (* ($cosh x) ($cos y))
934 (* ($sinh x) ($sin y))))))
936 (if (real? z) ($tanh z)
937 (let* ((x (* 2 (real-part z)))
938 (y (* 2 (imag-part z)))
939 (w (+ ($cosh x) ($cos y))))
940 (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
943 (if (real? z) ($asinh z)
944 (log (+ z (sqrt (+ (* z z) 1))))))
947 (if (and (real? z) (>= z 1))
949 (log (+ z (sqrt (- (* z z) 1))))))
952 (if (and (real? z) (> z -1) (< z 1))
954 (/ (log (/ (+ 1 z) (- 1 z))) 2)))
957 (if (real? z) ($sin z)
958 (let ((x (real-part z)) (y (imag-part z)))
959 (make-rectangular (* ($sin x) ($cosh y))
960 (* ($cos x) ($sinh y))))))
962 (if (real? z) ($cos z)
963 (let ((x (real-part z)) (y (imag-part z)))
964 (make-rectangular (* ($cos x) ($cosh y))
965 (- (* ($sin x) ($sinh y)))))))
967 (if (real? z) ($tan z)
968 (let* ((x (* 2 (real-part z)))
969 (y (* 2 (imag-part z)))
970 (w (+ ($cos x) ($cosh y))))
971 (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
974 (if (and (real? z) (>= z -1) (<= z 1))
976 (* -i (asinh (* +i z)))))
979 (if (and (real? z) (>= z -1) (<= z 1))
981 (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
985 (if (real? z) ($atan z)
986 (/ (log (/ (- +i z) (+ +i z))) +2i))
992 (/ (log arg) (log 10)))
996 ;;; {Reader Extensions}
999 ;;; Reader code for various "#c" forms.
1002 ;;; Parse the portion of a #/ list that comes after the first slash.
1003 (define (read-path-list-notation slash port)
1006 ;; Is C a delimiter?
1007 ((delimiter? (lambda (c) (or (eof-object? c)
1008 (char-whitespace? c)
1009 (string-index "()\";" c))))
1011 ;; Read and return one component of a path list.
1014 (let loop ((reversed-chars '()))
1015 (let ((c (peek-char port)))
1016 (if (or (delimiter? c)
1018 (string->symbol (list->string (reverse reversed-chars)))
1019 (loop (cons (read-char port) reversed-chars))))))))
1021 ;; Read and return a path list.
1022 (let loop ((reversed-path (list (read-component))))
1023 (let ((c (peek-char port)))
1024 (if (and (char? c) (char=? c #\/))
1027 (loop (cons (read-component) reversed-path)))
1028 (reverse reversed-path))))))
1030 (read-hash-extend #\' (lambda (c port)
1032 (read-hash-extend #\. (lambda (c port)
1033 (eval (read port))))
1035 (if (feature? 'array)
1037 (let ((make-array-proc (lambda (template)
1039 (read:uniform-vector template port)))))
1040 (for-each (lambda (char template)
1041 (read-hash-extend char
1042 (make-array-proc template)))
1043 '(#\b #\a #\u #\e #\s #\i #\c)
1044 '(#t #\a 1 -1 1.0 1/3 0+i)))
1045 (let ((array-proc (lambda (c port)
1046 (read:array c port))))
1047 (for-each (lambda (char) (read-hash-extend char array-proc))
1048 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))))
1050 ;; pushed to the beginning of the alist since it's used more than the
1051 ;; others at present.
1052 (read-hash-extend #\/ read-path-list-notation)
1054 (define (read:array digit port)
1055 (define chr0 (char->integer #\0))
1056 (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
1057 (if (char-numeric? (peek-char port))
1058 (readnum (+ (* 10 val)
1059 (- (char->integer (read-char port)) chr0)))
1061 (prot (if (eq? #\( (peek-char port))
1063 (let ((c (read-char port)))
1071 (else (error "read:array unknown option " c)))))))
1072 (if (eq? (peek-char port) #\()
1073 (list->uniform-array rank prot (read port))
1074 (error "read:array list not found"))))
1076 (define (read:uniform-vector proto port)
1077 (if (eq? #\( (peek-char port))
1078 (list->uniform-array 1 proto (read port))
1079 (error "read:uniform-vector list not found")))
1082 ;;; {Command Line Options}
1085 (define (get-option argv kw-opts kw-args return)
1088 (return #f #f argv))
1090 ((or (not (eq? #\- (string-ref (car argv) 0)))
1091 (eq? (string-length (car argv)) 1))
1092 (return 'normal-arg (car argv) (cdr argv)))
1094 ((eq? #\- (string-ref (car argv) 1))
1095 (let* ((kw-arg-pos (or (string-index (car argv) #\=)
1096 (string-length (car argv))))
1097 (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
1098 (kw-opt? (member kw kw-opts))
1099 (kw-arg? (member kw kw-args))
1100 (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
1101 (substring (car argv)
1103 (string-length (car argv))))
1105 (begin (set! argv (cdr argv)) (car argv))))))
1106 (if (or kw-opt? kw-arg?)
1107 (return kw arg (cdr argv))
1108 (return 'usage-error kw (cdr argv)))))
1111 (let* ((char (substring (car argv) 1 2))
1112 (kw (symbol->keyword char)))
1115 ((member kw kw-opts)
1116 (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
1117 (new-argv (if (= 0 (string-length rest-car))
1119 (cons (string-append "-" rest-car) (cdr argv)))))
1120 (return kw #f new-argv)))
1122 ((member kw kw-args)
1123 (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
1124 (arg (if (= 0 (string-length rest-car))
1127 (new-argv (if (= 0 (string-length rest-car))
1130 (return kw arg new-argv)))
1132 (else (return 'usage-error kw argv)))))))
1134 (define (for-next-option proc argv kw-opts kw-args)
1135 (let loop ((argv argv))
1136 (get-option argv kw-opts kw-args
1137 (lambda (opt opt-arg argv)
1138 (and opt (proc opt opt-arg argv loop))))))
1140 (define (display-usage-report kw-desc)
1143 (or (eq? (car kw) #t)
1144 (eq? (car kw) 'else)
1145 (let* ((opt-desc kw)
1146 (help (cadr opt-desc))
1147 (opts (car opt-desc))
1148 (opts-proper (if (string? (car opts)) (cdr opts) opts))
1149 (arg-name (if (string? (car opts))
1150 (string-append "<" (car opts) ">")
1152 (left-part (string-append
1153 (with-output-to-string
1155 (map (lambda (x) (display (keyword-symbol x)) (display " "))
1158 (middle-part (if (and (< (length left-part) 30)
1159 (< (length help) 40))
1160 (make-string (- 30 (length left-part)) #\ )
1163 (display middle-part)
1170 (define (transform-usage-lambda cases)
1171 (let* ((raw-usage (delq! 'else (map car cases)))
1172 (usage-sans-specials (map (lambda (x)
1173 (or (and (not (list? x)) x)
1174 (and (symbol? (car x)) #t)
1175 (and (boolean? (car x)) #t)
1178 (usage-desc (delq! #t usage-sans-specials))
1179 (kw-desc (map car usage-desc))
1180 (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
1181 (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
1182 (transmogrified-cases (map (lambda (case)
1183 (cons (let ((opts (car case)))
1184 (if (or (boolean? opts) (eq? 'else opts))
1187 ((symbol? (car opts)) opts)
1188 ((boolean? (car opts)) opts)
1189 ((string? (caar opts)) (cdar opts))
1190 (else (car opts)))))
1193 `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
1195 (let %next-arg ((%argv %argv))
1199 (lambda (%opt %arg %new-argv)
1201 ,@ transmogrified-cases))))))))
1206 ;;; {Low Level Modules}
1208 ;;; These are the low level data structures for modules.
1210 ;;; !!! warning: The interface to lazy binder procedures is going
1211 ;;; to be changed in an incompatible way to permit all the basic
1212 ;;; module ops to be virtualized.
1214 ;;; (make-module size use-list lazy-binding-proc) => module
1215 ;;; module-{obarray,uses,binder}[|-set!]
1216 ;;; (module? obj) => [#t|#f]
1217 ;;; (module-locally-bound? module symbol) => [#t|#f]
1218 ;;; (module-bound? module symbol) => [#t|#f]
1219 ;;; (module-symbol-locally-interned? module symbol) => [#t|#f]
1220 ;;; (module-symbol-interned? module symbol) => [#t|#f]
1221 ;;; (module-local-variable module symbol) => [#<variable ...> | #f]
1222 ;;; (module-variable module symbol) => [#<variable ...> | #f]
1223 ;;; (module-symbol-binding module symbol opt-value)
1224 ;;; => [ <obj> | opt-value | an error occurs ]
1225 ;;; (module-make-local-var! module symbol) => #<variable...>
1226 ;;; (module-add! module symbol var) => unspecified
1227 ;;; (module-remove! module symbol) => unspecified
1228 ;;; (module-for-each proc module) => unspecified
1229 ;;; (make-scm-module) => module ; a lazy copy of the symhash module
1230 ;;; (set-current-module module) => unspecified
1231 ;;; (current-module) => #<module...>
1236 ;;; {Printing Modules}
1237 ;; This is how modules are printed. You can re-define it.
1238 ;; (Redefining is actually more complicated than simply redefining
1239 ;; %print-module because that would only change the binding and not
1240 ;; the value stored in the vtable that determines how record are
1243 (define (%print-module mod port) ; unused args: depth length style table)
1245 (display (or (module-kind mod) "module") port)
1246 (let ((name (module-name mod)))
1250 (display name port))))
1252 (display (number->string (object-address mod) 16) port)
1257 ;; A module is characterized by an obarray in which local symbols
1258 ;; are interned, a list of modules, "uses", from which non-local
1259 ;; bindings can be inherited, and an optional lazy-binder which
1260 ;; is a (CLOSURE module symbol) which, as a last resort, can provide
1261 ;; bindings that would otherwise not be found locally in the module.
1264 (make-record-type 'module '(obarray uses binder eval-closure name kind)
1267 ;; make-module &opt size uses binder
1269 ;; Create a new module, perhaps with a particular size of obarray,
1270 ;; initial uses list, or binding procedure.
1275 (define (parse-arg index default)
1276 (if (> (length args) index)
1277 (list-ref args index)
1280 (if (> (length args) 3)
1281 (error "Too many args to make-module." args))
1283 (let ((size (parse-arg 0 1021))
1284 (uses (parse-arg 1 '()))
1285 (binder (parse-arg 2 #f)))
1287 (if (not (integer? size))
1288 (error "Illegal size to make-module." size))
1289 (if (not (and (list? uses)
1290 (and-map module? uses)))
1291 (error "Incorrect use list." uses))
1292 (if (and binder (not (procedure? binder)))
1294 "Lazy-binder expected to be a procedure or #f." binder))
1296 (let ((module (module-constructor (make-vector size '())
1297 uses binder #f #f #f)))
1299 ;; We can't pass this as an argument to module-constructor,
1300 ;; because we need it to close over a pointer to the module
1302 (set-module-eval-closure! module
1303 (lambda (symbol define?)
1305 (module-make-local-var! module symbol)
1306 (module-variable module symbol))))
1310 (define module-constructor (record-constructor module-type))
1311 (define module-obarray (record-accessor module-type 'obarray))
1312 (define set-module-obarray! (record-modifier module-type 'obarray))
1313 (define module-uses (record-accessor module-type 'uses))
1314 (define set-module-uses! (record-modifier module-type 'uses))
1315 (define module-binder (record-accessor module-type 'binder))
1316 (define set-module-binder! (record-modifier module-type 'binder))
1317 (define module-eval-closure (record-accessor module-type 'eval-closure))
1318 (define set-module-eval-closure! (record-modifier module-type 'eval-closure))
1319 (define module-name (record-accessor module-type 'name))
1320 (define set-module-name! (record-modifier module-type 'name))
1321 (define module-kind (record-accessor module-type 'kind))
1322 (define set-module-kind! (record-modifier module-type 'kind))
1323 (define module? (record-predicate module-type))
1326 (define (eval-in-module exp module)
1327 (eval2 exp (module-eval-closure module)))
1330 ;;; {Module Searching in General}
1332 ;;; We sometimes want to look for properties of a symbol
1333 ;;; just within the obarray of one module. If the property
1334 ;;; holds, then it is said to hold ``locally'' as in, ``The symbol
1335 ;;; DISPLAY is locally rebound in the module `safe-guile'.''
1338 ;;; Other times, we want to test for a symbol property in the obarray
1339 ;;; of M and, if it is not found there, try each of the modules in the
1340 ;;; uses list of M. This is the normal way of testing for some
1341 ;;; property, so we state these properties without qualification as
1342 ;;; in: ``The symbol 'fnord is interned in module M because it is
1343 ;;; interned locally in module M2 which is a member of the uses list
1347 ;; module-search fn m
1349 ;; return the first non-#f result of FN applied to M and then to
1350 ;; the modules in the uses of m, and so on recursively. If all applications
1351 ;; return #f, then so does this function.
1353 (define (module-search fn m v)
1356 (or (module-search fn (car pos) v)
1359 (loop (module-uses m))))
1362 ;;; {Is a symbol bound in a module?}
1364 ;;; Symbol S in Module M is bound if S is interned in M and if the binding
1365 ;;; of S in M has been set to some well-defined value.
1368 ;; module-locally-bound? module symbol
1370 ;; Is a symbol bound (interned and defined) locally in a given module?
1372 (define (module-locally-bound? m v)
1373 (let ((var (module-local-variable m v)))
1375 (variable-bound? var))))
1377 ;; module-bound? module symbol
1379 ;; Is a symbol bound (interned and defined) anywhere in a given module
1382 (define (module-bound? m v)
1383 (module-search module-locally-bound? m v))
1385 ;;; {Is a symbol interned in a module?}
1387 ;;; Symbol S in Module M is interned if S occurs in
1388 ;;; of S in M has been set to some well-defined value.
1390 ;;; It is possible to intern a symbol in a module without providing
1391 ;;; an initial binding for the corresponding variable. This is done
1393 ;;; (module-add! module symbol (make-undefined-variable))
1395 ;;; In that case, the symbol is interned in the module, but not
1396 ;;; bound there. The unbound symbol shadows any binding for that
1397 ;;; symbol that might otherwise be inherited from a member of the uses list.
1400 (define (module-obarray-get-handle ob key)
1401 ((if (symbol? key) hashq-get-handle hash-get-handle) ob key))
1403 (define (module-obarray-ref ob key)
1404 ((if (symbol? key) hashq-ref hash-ref) ob key))
1406 (define (module-obarray-set! ob key val)
1407 ((if (symbol? key) hashq-set! hash-set!) ob key val))
1409 (define (module-obarray-remove! ob key)
1410 ((if (symbol? key) hashq-remove! hash-remove!) ob key))
1412 ;; module-symbol-locally-interned? module symbol
1414 ;; is a symbol interned (not neccessarily defined) locally in a given module
1415 ;; or its uses? Interned symbols shadow inherited bindings even if
1416 ;; they are not themselves bound to a defined value.
1418 (define (module-symbol-locally-interned? m v)
1419 (not (not (module-obarray-get-handle (module-obarray m) v))))
1421 ;; module-symbol-interned? module symbol
1423 ;; is a symbol interned (not neccessarily defined) anywhere in a given module
1424 ;; or its uses? Interned symbols shadow inherited bindings even if
1425 ;; they are not themselves bound to a defined value.
1427 (define (module-symbol-interned? m v)
1428 (module-search module-symbol-locally-interned? m v))
1431 ;;; {Mapping modules x symbols --> variables}
1434 ;; module-local-variable module symbol
1435 ;; return the local variable associated with a MODULE and SYMBOL.
1437 ;;; This function is very important. It is the only function that can
1438 ;;; return a variable from a module other than the mutators that store
1439 ;;; new variables in modules. Therefore, this function is the location
1440 ;;; of the "lazy binder" hack.
1442 ;;; If symbol is defined in MODULE, and if the definition binds symbol
1443 ;;; to a variable, return that variable object.
1445 ;;; If the symbols is not found at first, but the module has a lazy binder,
1446 ;;; then try the binder.
1448 ;;; If the symbol is not found at all, return #f.
1450 (define (module-local-variable m v)
1453 (let ((b (module-obarray-ref (module-obarray m) v)))
1454 (or (and (variable? b) b)
1455 (and (module-binder m)
1456 ((module-binder m) m v #f)))))
1459 ;; module-variable module symbol
1461 ;; like module-local-variable, except search the uses in the
1462 ;; case V is not found in M.
1464 (define (module-variable m v)
1465 (module-search module-local-variable m v))
1468 ;;; {Mapping modules x symbols --> bindings}
1470 ;;; These are similar to the mapping to variables, except that the
1471 ;;; variable is dereferenced.
1474 ;; module-symbol-binding module symbol opt-value
1476 ;; return the binding of a variable specified by name within
1477 ;; a given module, signalling an error if the variable is unbound.
1478 ;; If the OPT-VALUE is passed, then instead of signalling an error,
1479 ;; return OPT-VALUE.
1481 (define (module-symbol-local-binding m v . opt-val)
1482 (let ((var (module-local-variable m v)))
1485 (if (not (null? opt-val))
1487 (error "Locally unbound variable." v)))))
1489 ;; module-symbol-binding module symbol opt-value
1491 ;; return the binding of a variable specified by name within
1492 ;; a given module, signalling an error if the variable is unbound.
1493 ;; If the OPT-VALUE is passed, then instead of signalling an error,
1494 ;; return OPT-VALUE.
1496 (define (module-symbol-binding m v . opt-val)
1497 (let ((var (module-variable m v)))
1500 (if (not (null? opt-val))
1502 (error "Unbound variable." v)))))
1506 ;;; {Adding Variables to Modules}
1511 ;; module-make-local-var! module symbol
1513 ;; ensure a variable for V in the local namespace of M.
1514 ;; If no variable was already there, then create a new and uninitialzied
1517 (define (module-make-local-var! m v)
1518 (or (let ((b (module-obarray-ref (module-obarray m) v)))
1519 (and (variable? b) b))
1520 (and (module-binder m)
1521 ((module-binder m) m v #t))
1523 (let ((answer (make-undefined-variable v)))
1524 (module-obarray-set! (module-obarray m) v answer)
1527 ;; module-add! module symbol var
1529 ;; ensure a particular variable for V in the local namespace of M.
1531 (define (module-add! m v var)
1532 (if (not (variable? var))
1533 (error "Bad variable to module-add!" var))
1534 (module-obarray-set! (module-obarray m) v var))
1538 ;; make sure that a symbol is undefined in the local namespace of M.
1540 (define (module-remove! m v)
1541 (module-obarray-remove! (module-obarray m) v))
1543 (define (module-clear! m)
1544 (vector-fill! (module-obarray m) '()))
1546 ;; MODULE-FOR-EACH -- exported
1548 ;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
1550 (define (module-for-each proc module)
1551 (let ((obarray (module-obarray module)))
1552 (do ((index 0 (+ index 1))
1553 (end (vector-length obarray)))
1557 (proc (car bucket) (cdr bucket)))
1558 (vector-ref obarray index)))))
1561 (define (module-map proc module)
1562 (let* ((obarray (module-obarray module))
1563 (end (vector-length obarray)))
1571 (map (lambda (bucket)
1572 (proc (car bucket) (cdr bucket)))
1573 (vector-ref obarray i))
1577 ;;; {Low Level Bootstrapping}
1582 ;; A root module uses the symhash table (the system's privileged
1583 ;; obarray). Being inside a root module is like using SCM without
1584 ;; any module system.
1588 (define (root-module-closure m s define?)
1589 (let ((bi (and (symbol-interned? #f s)
1590 (builtin-variable s))))
1592 (or define? (variable-bound? bi))
1594 (module-add! m s bi)
1597 (define (make-root-module)
1598 (make-module 1019 '() root-module-closure))
1603 ;; An scm module is a module into which the lazy binder copies
1604 ;; variable bindings from the system symhash table. The mapping is
1605 ;; one way only; newly introduced bindings in an scm module are not
1606 ;; copied back into the system symhash table (and can be used to override
1607 ;; bindings from the symhash table).
1610 (define (make-scm-module)
1611 (make-module 1019 '()
1612 (lambda (m s define?)
1613 (let ((bi (and (symbol-interned? #f s)
1614 (builtin-variable s))))
1616 (variable-bound? bi)
1618 (module-add! m s bi)
1626 (define the-module #f)
1628 ;; set-current-module module
1630 ;; set the current module as viewed by the normalizer.
1632 (define (set-current-module m)
1635 (set! *top-level-lookup-closure* (module-eval-closure the-module))
1636 (set! *top-level-lookup-closure* #f)))
1641 ;; return the current module as viewed by the normalizer.
1643 (define (current-module) the-module)
1645 ;;; {Module-based Loading}
1648 (define (save-module-excursion thunk)
1649 (let ((inner-module (current-module))
1651 (dynamic-wind (lambda ()
1652 (set! outer-module (current-module))
1653 (set-current-module inner-module)
1654 (set! inner-module #f))
1657 (set! inner-module (current-module))
1658 (set-current-module outer-module)
1659 (set! outer-module #f)))))
1661 (define basic-load load)
1663 (define (load-module . args)
1664 (save-module-excursion (lambda () (apply basic-load args))))
1668 ;;; {MODULE-REF -- exported}
1670 ;; Returns the value of a variable called NAME in MODULE or any of its
1671 ;; used modules. If there is no such variable, then if the optional third
1672 ;; argument DEFAULT is present, it is returned; otherwise an error is signaled.
1674 (define (module-ref module name . rest)
1675 (let ((variable (module-variable module name)))
1676 (if (and variable (variable-bound? variable))
1677 (variable-ref variable)
1679 (error "No variable named" name 'in module)
1680 (car rest) ; default value
1683 ;; MODULE-SET! -- exported
1685 ;; Sets the variable called NAME in MODULE (or in a module that MODULE uses)
1686 ;; to VALUE; if there is no such variable, an error is signaled.
1688 (define (module-set! module name value)
1689 (let ((variable (module-variable module name)))
1691 (variable-set! variable value)
1692 (error "No variable named" name 'in module))))
1694 ;; MODULE-DEFINE! -- exported
1696 ;; Sets the variable called NAME in MODULE to VALUE; if there is no such
1697 ;; variable, it is added first.
1699 (define (module-define! module name value)
1700 (let ((variable (module-local-variable module name)))
1702 (variable-set! variable value)
1703 (module-add! module name (make-variable value name)))))
1705 ;; MODULE-DEFINED? -- exported
1707 ;; Return #t iff NAME is defined in MODULE (or in a module that MODULE
1710 (define (module-defined? module name)
1711 (let ((variable (module-variable module name)))
1712 (and variable (variable-bound? variable))))
1714 ;; MODULE-USE! module interface
1716 ;; Add INTERFACE to the list of interfaces used by MODULE.
1718 (define (module-use! module interface)
1719 (set-module-uses! module
1720 (cons interface (delq! interface (module-uses module)))))
1723 ;;; {Recursive Namespaces}
1726 ;;; A hierarchical namespace emerges if we consider some module to be
1727 ;;; root, and variables bound to modules as nested namespaces.
1729 ;;; The routines in this file manage variable names in hierarchical namespace.
1730 ;;; Each variable name is a list of elements, looked up in successively nested
1733 ;;; (nested-ref some-root-module '(foo bar baz))
1734 ;;; => <value of a variable named baz in the module bound to bar in
1735 ;;; the module bound to foo in some-root-module>
1740 ;;; ;; a-root is a module
1741 ;;; ;; name is a list of symbols
1743 ;;; nested-ref a-root name
1744 ;;; nested-set! a-root name val
1745 ;;; nested-define! a-root name val
1746 ;;; nested-remove! a-root name
1749 ;;; (current-module) is a natural choice for a-root so for convenience there are
1752 ;;; local-ref name == nested-ref (current-module) name
1753 ;;; local-set! name val == nested-set! (current-module) name val
1754 ;;; local-define! name val == nested-define! (current-module) name val
1755 ;;; local-remove! name == nested-remove! (current-module) name
1759 (define (nested-ref root names)
1760 (let loop ((cur root)
1764 ((not (module? cur)) #f)
1765 (else (loop (module-ref cur (car elts) #f) (cdr elts))))))
1767 (define (nested-set! root names val)
1768 (let loop ((cur root)
1770 (if (null? (cdr elts))
1771 (module-set! cur (car elts) val)
1772 (loop (module-ref cur (car elts)) (cdr elts)))))
1774 (define (nested-define! root names val)
1775 (let loop ((cur root)
1777 (if (null? (cdr elts))
1778 (module-define! cur (car elts) val)
1779 (loop (module-ref cur (car elts)) (cdr elts)))))
1781 (define (nested-remove! root names)
1782 (let loop ((cur root)
1784 (if (null? (cdr elts))
1785 (module-remove! cur (car elts))
1786 (loop (module-ref cur (car elts)) (cdr elts)))))
1788 (define (local-ref names) (nested-ref (current-module) names))
1789 (define (local-set! names val) (nested-set! (current-module) names val))
1790 (define (local-define names val) (nested-define! (current-module) names val))
1791 (define (local-remove names) (nested-remove! (current-module) names))
1795 ;;; {The (app) module}
1797 ;;; The root of conventionally named objects not directly in the top level.
1800 ;;; (app modules guile)
1802 ;;; The directory of all modules and the standard root module.
1805 (define (module-public-interface m) (module-ref m '%module-public-interface #f))
1806 (define (set-module-public-interface! m i) (module-define! m '%module-public-interface i))
1807 (define the-root-module (make-root-module))
1808 (define the-scm-module (make-scm-module))
1809 (set-module-public-interface! the-root-module the-scm-module)
1810 (set-module-name! the-root-module 'the-root-module)
1811 (set-module-name! the-scm-module 'the-scm-module)
1813 (set-current-module the-root-module)
1815 (define app (make-module 31))
1816 (local-define '(app modules) (make-module 31))
1817 (local-define '(app modules guile) the-root-module)
1819 ;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module)))
1821 (define (resolve-module name . maybe-autoload)
1822 (let ((full-name (append '(app modules) name)))
1823 (let ((already (local-ref full-name)))
1826 (if (or (null? maybe-autoload) (car maybe-autoload))
1827 (or (try-module-autoload name)
1828 (try-module-dynamic-link name)))
1829 (make-modules-in (current-module) full-name))))))
1831 (define (beautify-user-module! module)
1832 (if (not (module-public-interface module))
1833 (let ((interface (make-module 31)))
1834 (set-module-name! interface (module-name module))
1835 (set-module-kind! interface 'interface)
1836 (set-module-public-interface! module interface)))
1837 (if (and (not (memq the-scm-module (module-uses module)))
1838 (not (eq? module the-root-module)))
1839 (set-module-uses! module (append (module-uses module) (list the-scm-module)))))
1841 (define (make-modules-in module name)
1845 ((module-ref module (car name) #f) => (lambda (m) (make-modules-in m (cdr name))))
1846 (else (let ((m (make-module 31)))
1847 (set-module-kind! m 'directory)
1848 (set-module-name! m (car name))
1849 (module-define! module (car name) m)
1850 (make-modules-in m (cdr name)))))))
1852 (define (resolve-interface name)
1853 (let ((module (resolve-module name)))
1854 (and module (module-public-interface module))))
1857 (define %autoloader-developer-mode #t)
1859 (define (process-define-module args)
1860 (let* ((module-id (car args))
1861 (module (resolve-module module-id #f))
1863 (beautify-user-module! module)
1864 (let loop ((kws kws)
1865 (reversed-interfaces '()))
1867 (for-each (lambda (interface)
1868 (module-use! module interface))
1869 reversed-interfaces)
1870 (case (cond ((keyword? (car kws))
1871 (keyword->symbol (car kws)))
1872 ((and (symbol? (car kws))
1873 (eq? (string-ref (car kws) 0) #\:))
1874 (string->symbol (substring (car kws) 1)))
1877 (if (not (pair? (cdr kws)))
1878 (error "unrecognized defmodule argument" kws))
1879 (let* ((used-name (cadr kws))
1880 (used-module (resolve-module used-name)))
1881 (if (not (module-ref used-module '%module-public-interface #f))
1883 ((if %autoloader-developer-mode warn error)
1884 "no code for module" (module-name used-module))
1885 (beautify-user-module! used-module)))
1886 (let ((interface (module-public-interface used-module)))
1888 (error "missing interface for use-module" used-module))
1889 (loop (cddr kws) (cons interface reversed-interfaces)))))
1891 (error "unrecognized defmodule argument" kws)))))
1894 ;;; {Autoloading modules}
1896 (define autoloads-in-progress '())
1898 (define (try-module-autoload module-name)
1900 (define (sfx name) (string-append name (scheme-file-suffix)))
1901 (let* ((reverse-name (reverse module-name))
1902 (name (car reverse-name))
1903 (dir-hint-module-name (reverse (cdr reverse-name)))
1904 (dir-hint (apply symbol-append (map (lambda (elt) (symbol-append elt "/")) dir-hint-module-name))))
1905 (resolve-module dir-hint-module-name #f)
1906 (and (not (autoload-done-or-in-progress? dir-hint name))
1909 (lambda () (autoload-in-progress! dir-hint name))
1911 (let loop ((dirs %load-path))
1912 (and (not (null? dirs))
1914 (let ((d (car dirs))
1918 (in-vicinity dir-hint name)
1919 (in-vicinity dir-hint (sfx name)))))
1920 (and (or-map (lambda (f)
1921 (let ((full (in-vicinity d f)))
1923 (and (file-exists? full)
1924 (not (file-is-directory? full))
1926 (save-module-excursion
1928 (load (string-append
1935 (loop (cdr dirs))))))
1936 (lambda () (set-autoloaded! dir-hint name didit)))
1939 ;;; Dynamic linking of modules
1941 ;; Initializing a module that is written in C is a two step process.
1942 ;; First the module's `module init' function is called. This function
1943 ;; is expected to call `scm_register_module_xxx' to register the `real
1944 ;; init' function. Later, when the module is referenced for the first
1945 ;; time, this real init function is called in the right context. See
1946 ;; gtcltk-lib/gtcltk-module.c for an example.
1948 ;; The code for the module can be in a regular shared library (so that
1949 ;; the `module init' function will be called when libguile is
1950 ;; initialized). Or it can be dynamically linked.
1952 ;; You can safely call `scm_register_module_xxx' before libguile
1953 ;; itself is initialized. You could call it from an C++ constructor
1954 ;; of a static object, for example.
1956 ;; To make your Guile extension into a dynamic linkable module, follow
1957 ;; these easy steps:
1959 ;; - Find a name for your module, like (ice-9 gtcltk)
1960 ;; - Write a function with a name like
1962 ;; scm_init_ice_9_gtcltk_module
1964 ;; This is your `module init' function. It should call
1966 ;; scm_register_module_xxx ("ice-9 gtcltk", scm_init_gtcltk);
1968 ;; "ice-9 gtcltk" is the C version of the module name. Slashes are
1969 ;; replaced by spaces, the rest is untouched. `scm_init_gtcltk' is
1970 ;; the real init function that executes the usual initializations
1971 ;; like making new smobs, etc.
1973 ;; - Make a shared library with your code and a name like
1975 ;; ice-9/libgtcltk.so
1977 ;; and put it somewhere in %load-path.
1979 ;; - Then you can simply write `:use-module (ice-9 gtcltk)' and it
1980 ;; will be linked automatically.
1982 ;; This is all very experimental.
1984 (define (split-c-module-name str)
1985 (let loop ((rev '())
1988 (end (string-length str)))
1991 (reverse (cons (string->symbol (substring str start pos)) rev)))
1992 ((eq? (string-ref str pos) #\space)
1993 (loop (cons (string->symbol (substring str start pos)) rev)
1998 (loop rev start (+ pos 1) end)))))
2000 (define (convert-c-registered-modules dynobj)
2001 (let ((res (map (lambda (c)
2002 (list (split-c-module-name (car c)) (cdr c) dynobj))
2003 (c-registered-modules))))
2004 (c-clear-registered-modules)
2007 (define registered-modules (convert-c-registered-modules #f))
2009 (define (init-dynamic-module modname)
2010 (or-map (lambda (modinfo)
2011 (if (equal? (car modinfo) modname)
2012 (let ((mod (resolve-module modname #f)))
2013 (save-module-excursion
2015 (set-current-module mod)
2016 (dynamic-call (cadr modinfo) (caddr modinfo))
2017 (set-module-public-interface! mod mod)))
2018 (set! registered-modules (delq! modinfo registered-modules))
2021 registered-modules))
2023 (define (dynamic-maybe-call name dynobj)
2024 (catch #t ; could use false-if-exception here
2026 (dynamic-call name dynobj))
2030 (define (dynamic-maybe-link filename)
2031 (catch #t ; could use false-if-exception here
2033 (dynamic-link filename))
2037 (define (find-and-link-dynamic-module module-name)
2038 (define (make-init-name mod-name)
2039 (string-append 'scm_init
2040 (list->string (map (lambda (c)
2041 (if (or (char-alphabetic? c)
2045 (string->list mod-name)))
2048 (let loop ((dirs "")
2052 (string-append dirs "lib" (car syms) ".so"))
2054 (loop (string-append dirs (car syms) "/") (cdr syms))))))
2055 (init (make-init-name (apply string-append
2057 (string-append "_" s))
2059 ;; (pk 'libname libname 'init init)
2062 (let ((full (in-vicinity dir libname)))
2063 ;; (pk 'trying full)
2064 (if (file-exists? full)
2066 (link-dynamic-module full init)
2071 (define (link-dynamic-module filename initname)
2072 (let ((dynobj (dynamic-link filename)))
2073 (dynamic-call initname dynobj)
2074 (set! registered-modules
2075 (append! (convert-c-registered-modules dynobj)
2076 registered-modules))))
2078 (define (try-module-dynamic-link module-name)
2079 (or (init-dynamic-module module-name)
2080 (and (find-and-link-dynamic-module module-name)
2081 (init-dynamic-module module-name))))
2085 (define autoloads-done '((guile . guile)))
2087 (define (autoload-done-or-in-progress? p m)
2088 (let ((n (cons p m)))
2089 (->bool (or (member n autoloads-done)
2090 (member n autoloads-in-progress)))))
2092 (define (autoload-done! p m)
2093 (let ((n (cons p m)))
2094 (set! autoloads-in-progress
2095 (delete! n autoloads-in-progress))
2096 (or (member n autoloads-done)
2097 (set! autoloads-done (cons n autoloads-done)))))
2099 (define (autoload-in-progress! p m)
2100 (let ((n (cons p m)))
2101 (set! autoloads-done
2102 (delete! n autoloads-done))
2103 (set! autoloads-in-progress (cons n autoloads-in-progress))))
2105 (define (set-autoloaded! p m done?)
2107 (autoload-done! p m)
2108 (let ((n (cons p m)))
2109 (set! autoloads-done (delete! n autoloads-done))
2110 (set! autoloads-in-progress (delete! n autoloads-in-progress)))))
2119 (define macro-table (make-weak-key-hash-table 523))
2120 (define xformer-table (make-weak-key-hash-table 523))
2122 (define (defmacro? m) (hashq-ref macro-table m))
2123 (define (assert-defmacro?! m) (hashq-set! macro-table m #t))
2124 (define (defmacro-transformer m) (hashq-ref xformer-table m))
2125 (define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))
2127 (define defmacro:transformer
2129 (let* ((xform (lambda (exp env)
2130 (copy-tree (apply f (cdr exp)))))
2131 (a (procedure->memoizing-macro xform)))
2132 (assert-defmacro?! a)
2133 (set-defmacro-transformer! a f)
2138 (let ((defmacro-transformer
2139 (lambda (name parms . body)
2140 (let ((transformer `(lambda ,parms ,@body)))
2142 (,(lambda (transformer)
2143 (defmacro:transformer transformer))
2145 (defmacro:transformer defmacro-transformer)))
2147 (define defmacro:syntax-transformer
2151 (copy-tree (apply f (cdr exp)))))))
2154 ;; XXX - should the definition of the car really be looked up in the
2157 (define (macroexpand-1 e)
2159 ((pair? e) (let* ((a (car e))
2160 (val (and (symbol? a) (local-ref (list a)))))
2162 (apply (defmacro-transformer val) (cdr e))
2166 (define (macroexpand e)
2168 ((pair? e) (let* ((a (car e))
2169 (val (and (symbol? a) (local-ref (list a)))))
2171 (macroexpand (apply (defmacro-transformer val) (cdr e)))
2176 (let ((*gensym-counter* -1))
2178 (set! *gensym-counter* (+ *gensym-counter* 1))
2180 (string-append "scm:G" (number->string *gensym-counter*))))))
2188 (define (repl read evaler print)
2189 (let loop ((source (read (current-input-port))))
2190 (print (evaler source))
2191 (loop (read (current-input-port)))))
2193 ;; A provisional repl that acts like the SCM repl:
2195 (define scm-repl-silent #f)
2196 (define (assert-repl-silence v) (set! scm-repl-silent v))
2198 (define *unspecified* (if #f #f))
2199 (define (unspecified? v) (eq? v *unspecified*))
2201 (define scm-repl-print-unspecified #f)
2202 (define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v))
2204 (define scm-repl-verbose #f)
2205 (define (assert-repl-verbosity v) (set! scm-repl-verbose v))
2207 (define scm-repl-prompt "guile> ")
2209 (define (set-repl-prompt! v) (set! scm-repl-prompt v))
2211 (define (default-lazy-handler key . args)
2212 (save-stack lazy-handler-dispatch)
2213 (apply throw key args))
2215 (define apply-frame-handler default-lazy-handler)
2216 (define exit-frame-handler default-lazy-handler)
2218 (define (lazy-handler-dispatch key . args)
2221 (apply apply-frame-handler key args))
2223 (apply exit-frame-handler key args))
2225 (apply default-lazy-handler key args))))
2227 (define abort-hook '())
2229 (define (error-catching-loop thunk)
2231 (define (loop first)
2239 (lambda () (unmask-signals))
2243 ;; This line is needed because mark
2244 ;; doesn't do closures quite right.
2245 ;; Unreferenced locals should be
2249 (let loop ((v (thunk)))
2252 (lambda () (mask-signals))))
2254 lazy-handler-dispatch))
2256 (lambda (key . args)
2264 (apply throw 'switch-repl args))
2267 ;; This is one of the closures that require
2268 ;; (set! first #f) above
2271 (run-hooks abort-hook)
2273 (display "ABORT: " (current-error-port))
2274 (write args (current-error-port))
2275 (newline (current-error-port))
2276 (if (and (not has-shown-debugger-hint?)
2277 (not (memq 'backtrace
2278 (debug-options-interface)))
2279 (stack? the-last-stack))
2281 (newline (current-error-port))
2283 "Type \"(backtrace)\" to get more information.\n"
2284 (current-error-port))
2285 (set! has-shown-debugger-hint? #t)))
2286 (set! stack-saved? #f)))
2289 ;; This is the other cons-leak closure...
2291 (cond ((= (length args) 4)
2292 (apply handle-system-error key args))
2294 (apply bad-throw key args))))))))))
2295 (if next (loop next) status)))
2296 (loop (lambda () #t))))
2298 ;;(define the-last-stack #f) Defined by scm_init_backtrace ()
2299 (define stack-saved? #f)
2301 (define (save-stack . narrowing)
2302 (cond (stack-saved?)
2303 ((not (memq 'debug (debug-options-interface)))
2304 (set! the-last-stack #f)
2305 (set! stack-saved? #t))
2307 (set! the-last-stack
2310 (apply make-stack #t save-stack eval narrowing))
2312 (apply make-stack #t save-stack gsubr-apply narrowing))
2314 (apply make-stack #t save-stack tk-stack-mark narrowing))
2316 (apply make-stack #t save-stack 0 1 narrowing))
2317 (else (let ((id (stack-id #t)))
2318 (and (procedure? id)
2319 (apply make-stack #t save-stack id narrowing))))))
2320 (set! stack-saved? #t))))
2322 (define before-error-hook '())
2323 (define after-error-hook '())
2324 (define before-backtrace-hook '())
2325 (define after-backtrace-hook '())
2327 (define has-shown-debugger-hint? #f)
2329 (define (handle-system-error key . args)
2330 (let ((cep (current-error-port)))
2331 (cond ((not (stack? the-last-stack)))
2332 ((memq 'backtrace (debug-options-interface))
2333 (run-hooks before-backtrace-hook)
2335 (display-backtrace the-last-stack cep)
2337 (run-hooks after-backtrace-hook)))
2338 (run-hooks before-error-hook)
2339 (apply display-error the-last-stack cep args)
2340 (run-hooks after-error-hook)
2342 (throw 'abort key)))
2344 (define (quit . args)
2345 (apply throw 'quit args))
2349 ;;(define has-shown-backtrace-hint? #f) Defined by scm_init_backtrace ()
2351 ;; Replaced by C code:
2352 ;;(define (backtrace)
2353 ;; (if the-last-stack
2356 ;; (display-backtrace the-last-stack (current-output-port))
2358 ;; (if (and (not has-shown-backtrace-hint?)
2359 ;; (not (memq 'backtrace (debug-options-interface))))
2362 ;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace
2363 ;;automatically if an error occurs in the future.\n")
2364 ;; (set! has-shown-backtrace-hint? #t))))
2365 ;; (display "No backtrace available.\n")))
2367 (define (error-catching-repl r e p)
2368 (error-catching-loop (lambda () (p (e (r))))))
2370 (define (gc-run-time)
2371 (cdr (assq 'gc-time-taken (gc-stats))))
2373 (define before-read-hook '())
2374 (define after-read-hook '())
2376 (define (scm-style-repl)
2380 (repl-report-reset (lambda () #f))
2381 (repl-report-start-timing (lambda ()
2382 (set! start-gc-rt (gc-run-time))
2383 (set! start-rt (get-internal-run-time))))
2384 (repl-report (lambda ()
2386 (display (inexact->exact
2387 (* 1000 (/ (- (get-internal-run-time) start-rt)
2388 internal-time-units-per-second))))
2390 (display (inexact->exact
2391 (* 1000 (/ (- (gc-run-time) start-gc-rt)
2392 internal-time-units-per-second))))
2393 (display " msec in gc)\n")))
2395 (consume-trailing-whitespace
2397 (let ((ch (peek-char)))
2400 ((or (char=? ch #\space) (char=? ch #\tab))
2402 (consume-trailing-whitespace))
2403 ((char=? ch #\newline)
2408 (display (cond ((string? scm-repl-prompt)
2410 ((thunk? scm-repl-prompt)
2414 (repl-report-reset)))
2415 (run-hooks before-read-hook)
2416 (let ((val (read (current-input-port))))
2417 ;; As described in R4RS, the READ procedure updates the
2418 ;; port to point to the first characetr past the end of
2419 ;; the external representation of the object. This
2420 ;; means that it doesn't consume the newline typically
2421 ;; found after an expression. This means that, when
2422 ;; debugging Guile with GDB, GDB gets the newline, which
2423 ;; it often interprets as a "continue" command, making
2424 ;; breakpoints kind of useless. So, consume any
2425 ;; trailing newline here, as well as any whitespace
2427 (consume-trailing-whitespace)
2428 (run-hooks after-read-hook)
2429 (if (eof-object? val)
2431 (repl-report-start-timing)
2432 (if scm-repl-verbose
2435 (display ";;; EOF -- quitting")
2440 (-eval (lambda (sourc)
2441 (repl-report-start-timing)
2442 (start-stack 'repl-stack (eval sourc))))
2444 (-print (lambda (result)
2445 (if (not scm-repl-silent)
2447 (if (or scm-repl-print-unspecified
2448 (not (unspecified? result)))
2452 (if scm-repl-verbose
2456 (-quit (lambda (args)
2457 (if scm-repl-verbose
2459 (display ";;; QUIT executed, repl exitting")
2465 (if scm-repl-verbose
2467 (display ";;; ABORT executed.")
2470 (repl -read -eval -print))))
2472 (let ((status (error-catching-repl -read
2479 ;;; {IOTA functions: generating lists of numbers}
2481 (define (reverse-iota n) (if (> n 0) (cons (1- n) (reverse-iota (1- n))) '()))
2482 (define (iota n) (list-reverse! (reverse-iota n)))
2487 ;;; with `continue' and `break'.
2490 (defmacro while (cond . body)
2491 `(letrec ((continue (lambda () (or (not ,cond) (begin (begin ,@ body) (continue)))))
2492 (break (lambda val (apply throw 'break val))))
2494 (lambda () (continue))
2495 (lambda v (cadr v)))))
2503 ;; actually....hobbit might be able to hack these with a little
2507 (defmacro define-macro (first . rest)
2508 (let ((name (if (symbol? first) first (car first)))
2512 `(lambda ,(cdr first) ,@rest))))
2513 `(define ,name (defmacro:transformer ,transformer))))
2516 (defmacro define-syntax-macro (first . rest)
2517 (let ((name (if (symbol? first) first (car first)))
2521 `(lambda ,(cdr first) ,@rest))))
2522 `(define ,name (defmacro:syntax-transformer ,transformer))))
2524 ;;; {Module System Macros}
2527 (defmacro define-module args
2528 `(let* ((process-define-module process-define-module)
2529 (set-current-module set-current-module)
2530 (module (process-define-module ',args)))
2531 (set-current-module module)
2534 ;; the guts of the use-modules macro. add the interfaces of the named
2535 ;; modules to the use-list of the current module, in order
2536 (define (process-use-modules module-names)
2537 (for-each (lambda (module-name)
2538 (let ((mod-iface (resolve-interface module-name)))
2540 (error "no such module" module-name))
2541 (module-use! (current-module) mod-iface)))
2542 (reverse module-names)))
2544 (defmacro use-modules modules
2545 `(process-use-modules ',modules))
2547 (define define-private define)
2549 (defmacro define-public args
2551 (error "bad syntax" (list 'define-public args)))
2552 (define (defined-name n)
2555 ((pair? n) (defined-name (car n)))
2558 ((null? args) (syntax))
2560 (#t (let ((name (defined-name (car args))))
2562 (let ((public-i (module-public-interface (current-module))))
2563 ;; Make sure there is a local variable:
2565 (module-define! (current-module)
2567 (module-ref (current-module) ',name #f))
2569 ;; Make sure that local is exported:
2571 (module-add! public-i ',name
2572 (module-variable (current-module) ',name)))
2574 ;; Now (re)define the var normally. Bernard URBAN
2575 ;; suggests we use eval here to accomodate Hobbit; it lets
2576 ;; the interpreter handle the define-private form, which
2577 ;; Hobbit can't digest.
2578 (eval '(define-private ,@ args)))))))
2582 (defmacro defmacro-public args
2584 (error "bad syntax" (list 'defmacro-public args)))
2585 (define (defined-name n)
2590 ((null? args) (syntax))
2592 (#t (let ((name (defined-name (car args))))
2594 (let ((public-i (module-public-interface (current-module))))
2595 ;; Make sure there is a local variable:
2597 (module-define! (current-module)
2599 (module-ref (current-module) ',name #f))
2601 ;; Make sure that local is exported:
2603 (module-add! public-i ',name (module-variable (current-module) ',name)))
2605 ;; Now (re)define the var normally.
2607 (defmacro ,@ args))))))
2612 (define load load-module)
2613 ;(define (load . args)
2614 ; (start-stack 'load-stack (apply load-module args)))
2618 ;;; {I/O functions for Tcl channels (disabled)}
2620 ;; (define in-ch (get-standard-channel TCL_STDIN))
2621 ;; (define out-ch (get-standard-channel TCL_STDOUT))
2622 ;; (define err-ch (get-standard-channel TCL_STDERR))
2624 ;; (define inp (%make-channel-port in-ch "r"))
2625 ;; (define outp (%make-channel-port out-ch "w"))
2626 ;; (define errp (%make-channel-port err-ch "w"))
2628 ;; (define %system-char-ready? char-ready?)
2630 ;; (define (char-ready? p)
2631 ;; (if (not (channel-port? p))
2632 ;; (%system-char-ready? p)
2633 ;; (let* ((channel (%channel-port-channel p))
2634 ;; (old-blocking (channel-option-ref channel :blocking)))
2636 ;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking "0"))
2637 ;; (lambda () (not (eof-object? (peek-char p))))
2638 ;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking old-blocking))))))
2640 ;; (define (top-repl)
2641 ;; (with-input-from-port inp
2643 ;; (with-output-to-port outp
2645 ;; (with-error-to-port errp
2647 ;; (scm-style-repl))))))))
2649 ;; (set-current-input-port inp)
2650 ;; (set-current-output-port outp)
2651 ;; (set-current-error-port errp)
2653 ;; this is just (scm-style-repl) with a wrapper to install and remove
2656 (let ((old-handlers #f)
2657 (signals `((,SIGINT . "User interrupt")
2658 (,SIGFPE . "Arithmetic error")
2659 (,SIGBUS . "Bad memory access (bus error)")
2660 (,SIGSEGV . "Bad memory access (Segmentation violation)"))))
2666 (let ((make-handler (lambda (msg)
2674 (map (lambda (sig-msg)
2675 (sigaction (car sig-msg)
2676 (make-handler (cdr sig-msg))))
2679 ;; the protected thunk.
2685 (map (lambda (sig-msg old-handler)
2686 (if (not (car old-handler))
2687 ;; restore original C handler.
2688 (sigaction (car sig-msg) #f)
2689 ;; restore Scheme handler, SIG_IGN or SIG_DFL.
2690 (sigaction (car sig-msg)
2692 (cdr old-handler))))
2693 signals old-handlers)))))
2695 (defmacro false-if-exception (expr)
2696 `(catch #t (lambda () ,expr)
2700 ;;; {Calling Conventions}
2701 (define-module (ice-9 calling))
2705 ;;; This file contains a number of macros that support
2706 ;;; common calling conventions.
2709 ;;; with-excursion-function <vars> proc
2710 ;;; <vars> is an unevaluated list of names that are bound in the caller.
2711 ;;; proc is a procedure, called:
2712 ;;; (proc excursion)
2714 ;;; excursion is a procedure isolates all changes to <vars>
2715 ;;; in the dynamic scope of the call to proc. In other words,
2716 ;;; the values of <vars> are saved when proc is entered, and when
2717 ;;; proc returns, those values are restored. Values are also restored
2718 ;;; entering and leaving the call to proc non-locally, such as using
2719 ;;; call-with-current-continuation, error, or throw.
2721 (defmacro-public with-excursion-function (vars proc)
2722 `(,proc ,(excursion-function-syntax vars)))
2726 ;;; with-getter-and-setter <vars> proc
2727 ;;; <vars> is an unevaluated list of names that are bound in the caller.
2728 ;;; proc is a procedure, called:
2729 ;;; (proc getter setter)
2731 ;;; getter and setter are procedures used to access
2732 ;;; or modify <vars>.
2734 ;;; setter, called with keywords arguments, modifies the named
2735 ;;; values. If "foo" and "bar" are among <vars>, then:
2737 ;;; (setter :foo 1 :bar 2)
2738 ;;; == (set! foo 1 bar 2)
2740 ;;; getter, called with just keywords, returns
2741 ;;; a list of the corresponding values. For example,
2742 ;;; if "foo" and "bar" are among the <vars>, then
2744 ;;; (getter :foo :bar)
2745 ;;; => (<value-of-foo> <value-of-bar>)
2747 ;;; getter, called with no arguments, returns a list of all accepted
2748 ;;; keywords and the corresponding values. If "foo" and "bar" are
2749 ;;; the *only* <vars>, then:
2752 ;;; => (:foo <value-of-bar> :bar <value-of-foo>)
2754 ;;; The unusual calling sequence of a getter supports too handy
2757 ;;; (apply setter (getter)) ;; save and restore
2759 ;;; (apply-to-args (getter :foo :bar) ;; fetch and bind
2760 ;;; (lambda (foo bar) ....))
2762 ;;; ;; [ "apply-to-args" is just like two-argument "apply" except that it
2763 ;;; ;; takes its arguments in a different order.
2766 (defmacro-public with-getter-and-setter (vars proc)
2767 `(,proc ,@ (getter-and-setter-syntax vars)))
2769 ;;; with-getter vars proc
2770 ;;; A short-hand for a call to with-getter-and-setter.
2771 ;;; The procedure is called:
2774 (defmacro-public with-getter (vars proc)
2775 `(,proc ,(car (getter-and-setter-syntax vars))))
2778 ;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
2779 ;;; Compose getters and setters.
2781 ;;; <vars> is an unevaluated list of names that are bound in the caller.
2783 ;;; get-delegate is called by the new getter to extend the set of
2784 ;;; gettable variables beyond just <vars>
2785 ;;; set-delegate is called by the new setter to extend the set of
2786 ;;; gettable variables beyond just <vars>
2788 ;;; proc is a procedure that is called
2789 ;;; (proc getter setter)
2791 (defmacro-public with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
2792 `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
2795 ;;; with-excursion-getter-and-setter <vars> proc
2796 ;;; <vars> is an unevaluated list of names that are bound in the caller.
2799 ;;; (proc excursion getter setter)
2802 ;;; with-getter-and-setter
2803 ;;; with-excursion-function
2805 (defmacro-public with-excursion-getter-and-setter (vars proc)
2806 `(,proc ,(excursion-function-syntax vars)
2807 ,@ (getter-and-setter-syntax vars)))
2810 (define (excursion-function-syntax vars)
2811 (let ((saved-value-names (map gensym vars))
2812 (tmp-var-name (gensym 'temp))
2813 (swap-fn-name (gensym 'swap))
2814 (thunk-name (gensym 'thunk)))
2815 `(lambda (,thunk-name)
2816 (letrec ((,tmp-var-name #f)
2818 (lambda () ,@ (map (lambda (n sn) `(set! ,tmp-var-name ,n ,n ,sn ,sn ,tmp-var-name))
2819 vars saved-value-names)))
2820 ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
2827 (define (getter-and-setter-syntax vars)
2828 (let ((args-name (gensym 'args))
2829 (an-arg-name (gensym 'an-arg))
2830 (new-val-name (gensym 'new-value))
2831 (loop-name (gensym 'loop))
2832 (kws (map symbol->keyword vars)))
2833 (list `(lambda ,args-name
2834 (let ,loop-name ((,args-name ,args-name))
2835 (if (null? ,args-name)
2838 `(let ((all-vals (,loop-name ',kws)))
2839 (let ,loop-name ((vals all-vals)
2843 `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
2844 (map (lambda (,an-arg-name)
2847 (map (lambda (kw v) `((,kw) ,v)) kws vars)
2848 `((else (throw 'bad-get-option ,an-arg-name))))))
2852 (let ,loop-name ((,args-name ,args-name))
2853 (or (null? ,args-name)
2854 (null? (cdr ,args-name))
2855 (let ((,an-arg-name (car ,args-name))
2856 (,new-val-name (cadr ,args-name)))
2859 (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
2860 `((else (throw 'bad-set-option ,an-arg-name)))))
2861 (,loop-name (cddr ,args-name)))))))))
2863 (define (delegating-getter-and-setter-syntax vars get-delegate set-delegate)
2864 (let ((args-name (gensym 'args))
2865 (an-arg-name (gensym 'an-arg))
2866 (new-val-name (gensym 'new-value))
2867 (loop-name (gensym 'loop))
2868 (kws (map symbol->keyword vars)))
2869 (list `(lambda ,args-name
2870 (let ,loop-name ((,args-name ,args-name))
2871 (if (null? ,args-name)
2875 `(let ((all-vals (,loop-name ',kws)))
2876 (let ,loop-name ((vals all-vals)
2880 `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
2882 (map (lambda (,an-arg-name)
2885 (map (lambda (kw v) `((,kw) ,v)) kws vars)
2886 `((else (car (,get-delegate ,an-arg-name)))))))
2890 (let ,loop-name ((,args-name ,args-name))
2891 (or (null? ,args-name)
2892 (null? (cdr ,args-name))
2893 (let ((,an-arg-name (car ,args-name))
2894 (,new-val-name (cadr ,args-name)))
2897 (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
2898 `((else (,set-delegate ,an-arg-name ,new-val-name)))))
2899 (,loop-name (cddr ,args-name)))))))))
2904 ;;; with-configuration-getter-and-setter <vars-etc> proc
2906 ;;; Create a getter and setter that can trigger arbitrary computation.
2908 ;;; <vars-etc> is a list of variable specifiers, explained below.
2911 ;;; (proc getter setter)
2913 ;;; Each element of the <vars-etc> list is of the form:
2915 ;;; (<var> getter-hook setter-hook)
2917 ;;; Both hook elements are evaluated; the variable name is not.
2918 ;;; Either hook may be #f or procedure.
2920 ;;; A getter hook is a thunk that returns a value for the corresponding
2921 ;;; variable. If omitted (#f is passed), the binding of <var> is
2924 ;;; A setter hook is a procedure of one argument that accepts a new value
2925 ;;; for the corresponding variable. If omitted, the binding of <var>
2926 ;;; is simply set using set!.
2928 (defmacro-public with-configuration-getter-and-setter (vars-etc proc)
2929 `((lambda (simpler-get simpler-set body-proc)
2930 (with-delegating-getter-and-setter ()
2931 simpler-get simpler-set body-proc))
2935 ,@(map (lambda (v) `((,(symbol->keyword (car v)))
2938 (else `(list ,(car v))))))
2941 (lambda (kw new-val)
2943 ,@(map (lambda (v) `((,(symbol->keyword (car v)))
2945 ((caddr v) => (lambda (proc) `(,proc new-val)))
2946 (else `(set! ,(car v) new-val)))))
2951 (defmacro-public with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
2952 `((lambda (simpler-get simpler-set body-proc)
2953 (with-delegating-getter-and-setter ()
2954 simpler-get simpler-set body-proc))
2958 ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
2961 (else `(list ,(car v))))))
2963 `((else (,delegate-get kw))))))
2965 (lambda (kw new-val)
2967 ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
2969 ((caddr v) => (lambda (proc) `(,proc new-val)))
2970 (else `(set! ,(car v) new-val)))))
2972 `((else (,delegate-set kw new-val))))))
2977 ;;; let-configuration-getter-and-setter <vars-etc> proc
2979 ;;; This procedure is like with-configuration-getter-and-setter (q.v.)
2980 ;;; except that each element of <vars-etc> is:
2982 ;;; (<var> initial-value getter-hook setter-hook)
2984 ;;; Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
2985 ;;; introduces bindings for the variables named in <vars-etc>.
2986 ;;; It is short-hand for:
2988 ;;; (let ((<var1> initial-value-1)
2989 ;;; (<var2> initial-value-2)
2991 ;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
2993 (defmacro-public let-with-configuration-getter-and-setter (vars-etc proc)
2994 `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
2995 (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
3001 ;;; {Implementation of COMMON LISP list functions for Scheme}
3003 (define-module (ice-9 common-list))
3005 ;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
3006 ; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
3008 ;Permission to copy this software, to redistribute it, and to use it
3009 ;for any purpose is granted, subject to the following restrictions and
3012 ;1. Any copy made of this software must include this copyright notice
3015 ;2. I have made no warrantee or representation that the operation of
3016 ;this software will be error-free, and I am under no obligation to
3017 ;provide any services, by way of maintenance, update, or otherwise.
3019 ;3. In conjunction with products arising from the use of this
3020 ;material, there shall be no use of my name in any advertising,
3021 ;promotional, or sales literature without prior written consent in
3024 (define-public (adjoin e l) (if (memq e l) l (cons e l)))
3026 (define-public (union l1 l2)
3027 (cond ((null? l1) l2)
3029 (else (union (cdr l1) (adjoin (car l1) l2)))))
3031 (define-public (intersection l1 l2)
3032 (cond ((null? l1) l1)
3034 ((memv (car l1) l2) (cons (car l1) (intersection (cdr l1) l2)))
3035 (else (intersection (cdr l1) l2))))
3037 (define-public (set-difference l1 l2)
3038 (cond ((null? l1) l1)
3039 ((memv (car l1) l2) (set-difference (cdr l1) l2))
3040 (else (cons (car l1) (set-difference (cdr l1) l2)))))
3042 (define-public (reduce-init p init l)
3045 (reduce-init p (p init (car l)) (cdr l))))
3047 (define-public (reduce p l)
3049 ((null? (cdr l)) (car l))
3050 (else (reduce-init p (car l) (cdr l)))))
3052 (define-public (some pred l . rest)
3055 (and (not (null? l))
3056 (or (pred (car l)) (mapf (cdr l))))))
3057 (else (let mapf ((l l) (rest rest))
3058 (and (not (null? l))
3059 (or (apply pred (car l) (map car rest))
3060 (mapf (cdr l) (map cdr rest))))))))
3062 (define-public (every pred l . rest)
3066 (and (pred (car l)) (mapf (cdr l))))))
3067 (else (let mapf ((l l) (rest rest))
3069 (and (apply pred (car l) (map car rest))
3070 (mapf (cdr l) (map cdr rest))))))))
3072 (define-public (notany pred . ls) (not (apply some pred ls)))
3074 (define-public (notevery pred . ls) (not (apply every pred ls)))
3076 (define-public (find-if t l)
3077 (cond ((null? l) #f)
3078 ((t (car l)) (car l))
3079 (else (find-if t (cdr l)))))
3081 (define-public (member-if t l)
3082 (cond ((null? l) #f)
3084 (else (member-if t (cdr l)))))
3086 (define-public (remove-if p l)
3087 (cond ((null? l) '())
3088 ((p (car l)) (remove-if p (cdr l)))
3089 (else (cons (car l) (remove-if p (cdr l))))))
3091 (define-public (delete-if! pred list)
3092 (let delete-if ((list list))
3093 (cond ((null? list) '())
3094 ((pred (car list)) (delete-if (cdr list)))
3096 (set-cdr! list (delete-if (cdr list)))
3099 (define-public (delete-if-not! pred list)
3100 (let delete-if ((list list))
3101 (cond ((null? list) '())
3102 ((not (pred (car list))) (delete-if (cdr list)))
3104 (set-cdr! list (delete-if (cdr list)))
3107 (define-public (butlast lst n)
3108 (letrec ((l (- (length lst) n))
3110 (cond ((null? lst) lst)
3112 (cons (car lst) (bl (cdr lst) (+ -1 n))))
3114 (bl lst (if (negative? n)
3115 (error "negative argument to butlast" n)
3118 (define-public (and? . args)
3119 (cond ((null? args) #t)
3120 ((car args) (apply and? (cdr args)))
3123 (define-public (or? . args)
3124 (cond ((null? args) #f)
3126 (else (apply or? (cdr args)))))
3128 (define-public (has-duplicates? lst)
3129 (cond ((null? lst) #f)
3130 ((member (car lst) (cdr lst)) #t)
3131 (else (has-duplicates? (cdr lst)))))
3133 (define-public (list* x . y)
3137 (cons (car x) (list*1 (cdr x)))))
3140 (cons x (list*1 y))))
3143 ;; Apply P to each element of L, returning a list of elts
3144 ;; for which P returns a non-#f value.
3146 (define-public (pick p l)
3151 ((p (car l)) (loop (cons (car l) s) (cdr l)))
3152 (else (loop s (cdr l))))))
3155 ;; Apply P to each element of L, returning a list of the
3156 ;; non-#f return values of P.
3158 (define-public (pick-mappings p l)
3163 ((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l))))
3164 (else (loop s (cdr l))))))
3166 (define-public (uniq l)
3169 (let ((u (uniq (cdr l))))
3170 (if (memq (car l) u)
3172 (cons (car l) u)))))
3175 ;;; {Functions for browsing modules}
3177 (define-module (ice-9 ls)
3178 :use-module (ice-9 common-list))
3181 ;;; local-definitions-in root name
3182 ;;; Returns a list of names defined locally in the named
3183 ;;; subdirectory of root.
3184 ;;; definitions-in root name
3185 ;;; Returns a list of all names defined in the named
3186 ;;; subdirectory of root. The list includes alll locally
3187 ;;; defined names as well as all names inherited from a
3188 ;;; member of a use-list.
3190 ;;; A convenient interface for examining the nature of things:
3192 ;;; ls . various-names
3194 ;;; With just one argument, interpret that argument as the
3195 ;;; name of a subdirectory of the current module and
3196 ;;; return a list of names defined there.
3198 ;;; With more than one argument, still compute
3199 ;;; subdirectory lists, but return a list:
3200 ;;; ((<subdir-name> . <names-defined-there>)
3201 ;;; (<subdir-name> . <names-defined-there>)
3205 (define-public (local-definitions-in root names)
3206 (let ((m (nested-ref root names))
3208 (if (not (module? m))
3210 (module-for-each (lambda (k v) (set! answer (cons k answer))) m))
3213 (define-public (definitions-in root names)
3214 (let ((m (nested-ref root names)))
3215 (if (not (module? m))
3218 (cons (local-definitions-in m '())
3219 (map (lambda (m2) (definitions-in m2 '()))
3220 (module-uses m)))))))
3222 (define-public (ls . various-refs)
3224 (if (cdr various-refs)
3226 (cons ref (definitions-in (current-module) ref)))
3228 (definitions-in (current-module) (car various-refs)))))
3230 (define-public (lls . various-refs)
3232 (if (cdr various-refs)
3234 (cons ref (local-definitions-in (current-module) ref)))
3236 (local-definitions-in (current-module) (car various-refs)))))
3238 (define-public (recursive-local-define name value)
3239 (let ((parent (reverse! (cdr (reverse name)))))
3240 (and parent (make-modules-in (current-module) parent))
3241 (local-define name value)))
3245 (define-module (ice-9 q))
3247 ;;;; Copyright (C) 1995 Free Software Foundation, Inc.
3249 ;;;; This program is free software; you can redistribute it and/or modify
3250 ;;;; it under the terms of the GNU General Public License as published by
3251 ;;;; the Free Software Foundation; either version 2, or (at your option)
3252 ;;;; any later version.
3254 ;;;; This program is distributed in the hope that it will be useful,
3255 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
3256 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3257 ;;;; GNU General Public License for more details.
3259 ;;;; You should have received a copy of the GNU General Public License
3260 ;;;; along with this software; see the file COPYING. If not, write to
3261 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
3262 ;;;; Boston, MA 02111-1307 USA
3266 ;;; Q: Based on the interface to
3268 ;;; "queue.scm" Queues/Stacks for Scheme
3269 ;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
3275 ;;; A list is just a bunch of cons pairs that follows some constrains, right?
3276 ;;; Association lists are the same. Hash tables are just vectors and association
3277 ;;; lists. You can print them, read them, write them as constants, pun them off as other data
3278 ;;; structures etc. This is good. This is lisp. These structures are fast and compact
3279 ;;; and easy to manipulate arbitrarily because of their simple, regular structure and
3280 ;;; non-disjointedness (associations being lists and so forth).
3282 ;;; So I figured, queues should be the same -- just a "subtype" of cons-pair
3283 ;;; structures in general.
3285 ;;; A queue is a cons pair:
3286 ;;; ( <the-q> . <last-pair> )
3288 ;;; <the-q> is a list of things in the q. New elements go at the end of that list.
3290 ;;; <last-pair> is #f if the q is empty, and otherwise is the last pair of <the-q>.
3292 ;;; q's print nicely, but alas, they do not read well because the eq?-ness of
3293 ;;; <last-pair> and (last-pair <the-q>) is lost by read. The procedure
3297 ;;; recomputes and resets the <last-pair> component of a queue.
3300 (define-public (sync-q! obj) (set-cdr! obj (and (car obj) (last-pair (car obj)))))
3305 (define-public (make-q) (cons '() '()))
3308 ;;; Return true if obj is a Q.
3309 ;;; An object is a queue if it is equal? to '(#f . #f) or
3310 ;;; if it is a pair P with (list? (car P)) and (eq? (cdr P) (last-pair P)).
3312 (define-public (q? obj) (and (pair? obj)
3313 (or (and (null? (car obj))
3317 (eq? (cdr obj) (last-pair (car obj)))))))
3321 (define-public (q-empty? obj) (null? (car obj)))
3324 ;;; Throw a q-empty exception if Q is empty.
3325 (define-public (q-empty-check q) (if (q-empty? q) (throw 'q-empty q)))
3329 ;;; Return the first element of Q.
3330 (define-public (q-front q) (q-empty-check q) (caar q))
3333 ;;; Return the last element of Q.
3334 (define-public (q-rear q) (q-empty-check q) (cadr q))
3337 ;;; Remove all occurences of obj from Q.
3338 (define-public (q-remove! q obj)
3339 (while (memq obj (car q))
3340 (set-car! q (delq! obj (car q))))
3341 (set-cdr! q (last-pair (car q))))
3344 ;;; Add obj to the front of Q
3345 (define-public (q-push! q d)
3346 (let ((h (cons d (car q))))
3352 ;;; Add obj to the rear of Q
3353 (define-public (enq! q d)
3354 (let ((h (cons d '())))
3355 (if (not (null? (cdr q)))
3356 (set-cdr! (cdr q) h)
3361 ;;; Take the front of Q and return it.
3362 (define-public (q-pop! q)
3372 ;;; Take the front of Q and return it.
3373 (define-public deq! q-pop!)
3376 ;;; Return the number of enqueued elements.
3378 (define-public (q-length q) (length (car q)))
3383 ;;; {The runq data structure}
3385 (define-module (ice-9 runq)
3386 :use-module (ice-9 q))
3388 ;;;; Copyright (C) 1996 Free Software Foundation, Inc.
3390 ;;;; This program is free software; you can redistribute it and/or modify
3391 ;;;; it under the terms of the GNU General Public License as published by
3392 ;;;; the Free Software Foundation; either version 2, or (at your option)
3393 ;;;; any later version.
3395 ;;;; This program is distributed in the hope that it will be useful,
3396 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
3397 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3398 ;;;; GNU General Public License for more details.
3400 ;;;; You should have received a copy of the GNU General Public License
3401 ;;;; along with this software; see the file COPYING. If not, write to
3402 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
3403 ;;;; Boston, MA 02111-1307 USA
3408 ;;; One way to schedule parallel computations in a serial environment is
3409 ;;; to explicitly divide each task up into small, finite execution time,
3410 ;;; strips. Then you interleave the execution of strips from various
3411 ;;; tasks to achieve a kind of parallelism. Runqs are a handy data
3412 ;;; structure for this style of programming.
3414 ;;; We use thunks (nullary procedures) and lists of thunks to represent
3415 ;;; strips. By convention, the return value of a strip-thunk must either
3416 ;;; be another strip or the value #f.
3418 ;;; A runq is a procedure that manages a queue of strips. Called with no
3419 ;;; arguments, it processes one strip from the queue. Called with
3420 ;;; arguments, the arguments form a control message for the queue. The
3421 ;;; first argument is a symbol which is the message selector.
3423 ;;; A strip is processed this way: If the strip is a thunk, the thunk is
3424 ;;; called -- if it returns a strip, that strip is added back to the
3425 ;;; queue. To process a strip which is a list of thunks, the CAR of that
3426 ;;; list is called. After a call to that CAR, there are 0, 1, or 2 strips
3427 ;;; -- perhaps one returned by the thunk, and perhaps the CDR of the
3428 ;;; original strip if that CDR is not nil. The runq puts whichever of
3429 ;;; these strips exist back on the queue. (The exact order in which
3430 ;;; strips are put back on the queue determines the scheduling behavior of
3431 ;;; a particular queue -- it's a parameter.)
3438 ;;; (runq-control q msg . args)
3440 ;;; processes in the default way the control messages that
3441 ;;; can be sent to a runq. Q should be an ordinary
3442 ;;; Q (see utils/q.scm).
3444 ;;; The standard runq messages are:
3446 ;;; 'add! strip0 strip1... ;; to enqueue one or more strips
3447 ;;; 'enqueue! strip0 strip1... ;; to enqueue one or more strips
3448 ;;; 'push! strip0 ... ;; add strips to the front of the queue
3449 ;;; 'empty? ;; true if it is
3450 ;;; 'length ;; how many strips in the queue?
3451 ;;; 'kill! ;; empty the queue
3452 ;;; else ;; throw 'not-understood
3454 (define-public (runq-control q msg . args)
3456 ((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
3457 ((enque!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
3458 ((push!) (for-each (lambda (t) (q-push! q t)) args) '*unspecified*)
3459 ((empty?) (q-empty? q))
3460 ((length) (q-length q))
3461 ((kill!) (set! q (make-q)))
3462 (else (throw 'not-understood msg args))))
3464 (define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f)))
3469 ;;; Make a runq that discards all messages except "length", for which
3472 (define-public (make-void-runq)
3476 (lambda (msg . args)
3482 ;;; (make-fair-runq)
3484 ;;; Returns a runq procedure.
3485 ;;; Called with no arguments, the procedure processes one strip from the queue.
3486 ;;; Called with arguments, it uses runq-control.
3488 ;;; In a fair runq, if a strip returns a new strip X, X is added
3489 ;;; to the end of the queue, meaning it will be the last to execute
3490 ;;; of all the remaining procedures.
3492 (define-public (make-fair-runq)
3493 (letrec ((q (make-q))
3497 (apply runq-control q ctl)
3498 (and (not (q-empty? q))
3499 (let ((next-strip (deq! q)))
3501 ((procedure? next-strip) (let ((k (run-strip next-strip)))
3502 (and k (enq! q k))))
3503 ((pair? next-strip) (let ((k (run-strip (car next-strip))))
3505 (if (not (null? (cdr next-strip)))
3506 (enq! q (cdr next-strip)))))
3512 ;;; (make-exclusive-runq)
3514 ;;; Returns a runq procedure.
3515 ;;; Called with no arguments, the procedure processes one strip from the queue.
3516 ;;; Called with arguments, it uses runq-control.
3518 ;;; In an exclusive runq, if a strip W returns a new strip X, X is added
3519 ;;; to the front of the queue, meaning it will be the next to execute
3520 ;;; of all the remaining procedures.
3522 ;;; An exception to this occurs if W was the CAR of a list of strips.
3523 ;;; In that case, after the return value of W is pushed onto the front
3524 ;;; of the queue, the CDR of the list of strips is pushed in front
3525 ;;; of that (if the CDR is not nil). This way, the rest of the thunks
3526 ;;; in the list that contained W have priority over the return value of W.
3528 (define-public (make-exclusive-runq)
3529 (letrec ((q (make-q))
3533 (apply runq-control q ctl)
3534 (and (not (q-empty? q))
3535 (let ((next-strip (deq! q)))
3537 ((procedure? next-strip) (let ((k (run-strip next-strip)))
3538 (and k (q-push! q k))))
3539 ((pair? next-strip) (let ((k (run-strip (car next-strip))))
3540 (and k (q-push! q k)))
3541 (if (not (null? (cdr next-strip)))
3542 (q-push! q (cdr next-strip)))))
3548 ;;; (make-subordinate-runq-to superior basic-inferior)
3550 ;;; Returns a runq proxy for the runq basic-inferior.
3552 ;;; The proxy watches for operations on the basic-inferior that cause
3553 ;;; a transition from a queue length of 0 to a non-zero length and
3554 ;;; vice versa. While the basic-inferior queue is not empty,
3555 ;;; the proxy installs a task on the superior runq. Each strip
3556 ;;; of that task processes N strips from the basic-inferior where
3557 ;;; N is the length of the basic-inferior queue when the proxy
3558 ;;; strip is entered. [Countless scheduling variations are possible.]
3560 (define-public (make-subordinate-runq-to superior-runq basic-runq)
3561 (let ((runq-task (cons #f #f)))
3564 (if (basic-runq 'empty?)
3565 (set-cdr! runq-task #f)
3566 (do ((n (basic-runq 'length) (1- n)))
3572 (let ((answer (basic-runq)))
3577 ((suspend) (set-cdr! runq-task #f))
3578 (else (let ((answer (apply basic-runq ctl)))
3579 (if (and (not (cdr runq-task)) (not (basic-runq 'empty?)))
3581 (set-cdr! runq-task runq-task)
3582 (superior-runq 'add! runq-task)))
3587 ;;; (define fork-strips (lambda args args))
3588 ;;; Return a strip that starts several strips in
3589 ;;; parallel. If this strip is enqueued on a fair
3590 ;;; runq, strips of the parallel subtasks will run
3591 ;;; round-robin style.
3593 (define fork-strips (lambda args args))
3597 ;;; (strip-sequence . strips)
3599 ;;; Returns a new strip which is the concatenation of the argument strips.
3601 (define-public ((strip-sequence . strips))
3602 (let loop ((st (let ((a strips)) (set! strips #f) a)))
3603 (and (not (null? st))
3604 (let ((then ((car st))))
3606 (lambda () (loop (cons then (cdr st))))
3607 (lambda () (loop (cdr st))))))))
3611 ;;; (fair-strip-subtask . initial-strips)
3613 ;;; Returns a new strip which is the synchronos, fair,
3614 ;;; parallel execution of the argument strips.
3618 (define-public (fair-strip-subtask . initial-strips)
3619 (let ((st (make-fair-runq)))
3620 (apply st 'add! initial-strips)
3626 (define-module (ice-9 string-fun))
3630 ;;; Various string funcitons, particularly those that take
3631 ;;; advantage of the "shared substring" capability.
3634 ;;; {String Fun: Dividing Strings Into Fields}
3636 ;;; The names of these functions are very regular.
3637 ;;; Here is a grammar of a call to one of these:
3639 ;;; <string-function-invocation>
3640 ;;; := (<action>-<seperator-disposition>-<seperator-determination> <seperator-param> <str> <ret>)
3642 ;;; <str> = the string
3644 ;;; <ret> = The continuation. String functions generally return
3645 ;;; multiple values by passing them to this procedure.
3647 ;;; <action> = split
3648 ;;; | separate-fields
3650 ;;; "split" means to divide a string into two parts.
3651 ;;; <ret> will be called with two arguments.
3653 ;;; "separate-fields" means to divide a string into as many
3654 ;;; parts as possible. <ret> will be called with
3655 ;;; however many fields are found.
3657 ;;; <seperator-disposition> = before
3661 ;;; "before" means to leave the seperator attached to
3662 ;;; the beginning of the field to its right.
3663 ;;; "after" means to leave the seperator attached to
3664 ;;; the end of the field to its left.
3665 ;;; "discarding" means to discard seperators.
3667 ;;; Other dispositions might be handy. For example, "isolate"
3668 ;;; could mean to treat the separator as a field unto itself.
3670 ;;; <seperator-determination> = char
3673 ;;; "char" means to use a particular character as field seperator.
3674 ;;; "predicate" means to check each character using a particular predicate.
3676 ;;; Other determinations might be handy. For example, "character-set-member".
3678 ;;; <seperator-param> = A parameter that completes the meaning of the determinations.
3679 ;;; For example, if the determination is "char", then this parameter
3680 ;;; says which character. If it is "predicate", the parameter is the
3686 ;;; (separate-fields-discarding-char #\, "foo, bar, baz, , bat" list)
3687 ;;; => ("foo" " bar" " baz" " " " bat")
3689 ;;; (split-after-char #\- 'an-example-of-split list)
3690 ;;; => ("an-" "example-of-split")
3692 ;;; As an alternative to using a determination "predicate", or to trying to do anything
3693 ;;; complicated with these functions, consider using regular expressions.
3696 (define-public (split-after-char char str ret)
3698 ((string-index str char) => 1+)
3699 (else (string-length str)))))
3700 (ret (make-shared-substring str 0 end)
3701 (make-shared-substring str end))))
3703 (define-public (split-before-char char str ret)
3704 (let ((end (or (string-index str char)
3705 (string-length str))))
3706 (ret (make-shared-substring str 0 end)
3707 (make-shared-substring str end))))
3709 (define-public (split-discarding-char char str ret)
3710 (let ((end (string-index str char)))
3713 (ret (make-shared-substring str 0 end)
3714 (make-shared-substring str (1+ end))))))
3716 (define-public (split-after-char-last char str ret)
3718 ((string-rindex str char) => 1+)
3720 (ret (make-shared-substring str 0 end)
3721 (make-shared-substring str end))))
3723 (define-public (split-before-char-last char str ret)
3724 (let ((end (or (string-rindex str char) 0)))
3725 (ret (make-shared-substring str 0 end)
3726 (make-shared-substring str end))))
3728 (define-public (split-discarding-char-last char str ret)
3729 (let ((end (string-rindex str char)))
3732 (ret (make-shared-substring str 0 end)
3733 (make-shared-substring str (1+ end))))))
3735 (define (split-before-predicate pred str ret)
3738 ((= n (length str)) (ret str ""))
3739 ((not (pred (string-ref str n))) (loop (1+ n)))
3740 (else (ret (make-shared-substring str 0 n)
3741 (make-shared-substring str n))))))
3742 (define (split-after-predicate pred str ret)
3745 ((= n (length str)) (ret str ""))
3746 ((not (pred (string-ref str n))) (loop (1+ n)))
3747 (else (ret (make-shared-substring str 0 (1+ n))
3748 (make-shared-substring str (1+ n)))))))
3750 (define (split-discarding-predicate pred str ret)
3753 ((= n (length str)) (ret str ""))
3754 ((not (pred (string-ref str n))) (loop (1+ n)))
3755 (else (ret (make-shared-substring str 0 n)
3756 (make-shared-substring str (1+ n)))))))
3758 (define-public (separate-fields-discarding-char ch str ret)
3759 (let loop ((fields '())
3762 ((string-rindex str ch)
3763 => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 w)) fields)
3764 (make-shared-substring str 0 w))))
3765 (else (ret (cons str fields))))))
3767 (define-public (separate-fields-after-char ch str ret)
3768 (let loop ((fields '())
3771 ((string-rindex str ch)
3772 => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 w)) fields)
3773 (make-shared-substring str 0 (+ 1 w)))))
3774 (else (ret (cons str fields))))))
3776 (define-public (separate-fields-before-char ch str ret)
3777 (let loop ((fields '())
3780 ((string-rindex str ch)
3781 => (lambda (pos) (loop (cons (make-shared-substring str w) fields)
3782 (make-shared-substring str 0 w))))
3783 (else (ret (cons str fields))))))
3786 ;;; {String Fun: String Prefix Predicates}
3790 ;;; (define-public ((string-prefix-predicate pred?) prefix str)
3791 ;;; (and (<= (length prefix) (length str))
3792 ;;; (pred? prefix (make-shared-substring str 0 (length prefix)))))
3794 ;;; (define-public string-prefix=? (string-prefix-predicate string=?))
3797 (define-public ((string-prefix-predicate pred?) prefix str)
3798 (and (<= (length prefix) (length str))
3799 (pred? prefix (make-shared-substring str 0 (length prefix)))))
3801 (define-public string-prefix=? (string-prefix-predicate string=?))
3804 ;;; {String Fun: Strippers}
3806 ;;; <stripper> = sans-<removable-part>
3808 ;;; <removable-part> = surrounding-whitespace
3809 ;;; | trailing-whitespace
3810 ;;; | leading-whitespace
3814 (define-public (sans-surrounding-whitespace s)
3816 (end (string-length s)))
3817 (while (and (< st (string-length s))
3818 (char-whitespace? (string-ref s st)))
3820 (while (and (< 0 end)
3821 (char-whitespace? (string-ref s (1- end))))
3822 (set! end (1- end)))
3825 (make-shared-substring s st end))))
3827 (define-public (sans-trailing-whitespace s)
3829 (end (string-length s)))
3830 (while (and (< 0 end)
3831 (char-whitespace? (string-ref s (1- end))))
3832 (set! end (1- end)))
3835 (make-shared-substring s st end))))
3837 (define-public (sans-leading-whitespace s)
3839 (end (string-length s)))
3840 (while (and (< st (string-length s))
3841 (char-whitespace? (string-ref s st)))
3845 (make-shared-substring s st end))))
3847 (define-public (sans-final-newline str)
3849 ((= 0 (string-length str))
3852 ((char=? #\nl (string-ref str (1- (string-length str))))
3853 (make-shared-substring str 0 (1- (string-length str))))
3857 ;;; {String Fun: has-trailing-newline?}
3860 (define-public (has-trailing-newline? str)
3861 (and (< 0 (string-length str))
3862 (char=? #\nl (string-ref str (1- (string-length str))))))
3866 ;;; {String Fun: with-regexp-parts}
3868 ;;; This relies on the older, hairier regexp interface, which we don't
3869 ;;; particularly want to implement, and it's not used anywhere, so
3870 ;;; we're just going to drop it for now.
3871 ;;; (define-public (with-regexp-parts regexp fields str return fail)
3872 ;;; (let ((parts (regexec regexp str fields)))
3873 ;;; (if (number? parts)
3875 ;;; (apply return parts))))
3878 ;;; {Load debug extension code if debug extensions present.}
3880 ;;; *fixme* This is a temporary solution.
3883 (if (memq 'debug-extensions *features*)
3884 (define-module (guile) :use-module (ice-9 debug)))
3887 ;;; {Load session support if present.}
3889 ;;; *fixme* This is a temporary solution.
3892 (if (%search-load-path "ice-9/session.scm")
3893 (define-module (guile) :use-module (ice-9 session)))
3896 ;;; {Load thread code if threads are present.}
3898 ;;; *fixme* This is a temporary solution.
3901 (if (memq 'threads *features*)
3902 (define-module (guile) :use-module (ice-9 threads)))
3905 ;;; {Load emacs interface support if emacs option is given.}
3907 ;;; *fixme* This is a temporary solution.
3910 (if (and (module-defined? the-root-module 'use-emacs-interface)
3911 use-emacs-interface)
3913 (if (memq 'debug-extensions *features*)
3914 (debug-enable 'backtrace))
3915 (define-module (guile) :use-module (ice-9 emacs))))
3918 ;;; {Load regexp code if regexp primitives are available.}
3920 (if (memq 'regex *features*)
3921 (define-module (guile) :use-module (ice-9 regex)))
3924 ;;; {Check that the interpreter and scheme code match up.}
3928 (with-output-to-port (current-error-port)
3930 (display (car (command-line)))
3932 (for-each (lambda (string) (display string))
3936 (load-from-path "ice-9/version.scm")
3939 (libguile-config-stamp) ; from the interprpreter
3940 (ice-9-config-stamp))) ; from the Scheme code
3942 (show-line "warning: different versions of libguile and ice-9:")
3943 (show-line "libguile: configured on " (libguile-config-stamp))
3944 (show-line "ice-9: configured on " (ice-9-config-stamp)))))
3948 (define-module (guile))
3950 (append! %load-path (cons "." ()))