3 ;;;; Copyright (C) 1995, 1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
21 ;;; This file is the first thing loaded into Guile. It adds many mundane
22 ;;; definitions and a few that are interesting.
24 ;;; The module system (hence the hierarchical namespace) are defined in this
30 ;; {Simple Debugging Tools}
34 ;; peek takes any number of arguments, writes them to the
35 ;; current ouput port, and returns the last argument.
36 ;; It is handy to wrap around an expression to look at
37 ;; a value each time is evaluated, e.g.:
39 ;; (+ 10 (troublesome-fn))
40 ;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
43 (define (peek . stuff)
48 (car (last-pair stuff)))
52 (define (warn . stuff)
53 (with-output-to-port (current-error-port)
56 (display ";;; WARNING ")
59 (car (last-pair stuff)))))
62 ;;; {apply and call-with-current-continuation}
64 ;;; These turn syntax, @apply and @call-with-current-continuation,
68 (set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
69 (define (call-with-current-continuation proc) (@call-with-current-continuation proc))
75 ;;; apply-to-args is functionally redunant with apply and, worse,
76 ;;; is less general than apply since it only takes two arguments.
78 ;;; On the other hand, apply-to-args is a syntacticly convenient way to
79 ;;; perform binding in many circumstances when the "let" family of
80 ;;; of forms don't cut it. E.g.:
82 ;;; (apply-to-args (return-3d-mouse-coords)
87 (define (apply-to-args args fn) (apply fn args))
90 ;;; {Silly Naming Cleanups and Trivial Functions}
93 (define %open-file open-file)
100 (define (1+ n) (+ n 1))
101 (define (-1+ n) (+ n -1))
103 (define return-it noop)
104 (define (and=> value thunk) (and value (thunk value)))
105 (define (make-hash-table k) (make-vector k '()))
110 (define (integer? x) (and (number? x) (= x (inexact->exact x))))
112 (define (ipow-by-squaring x k acc proc)
113 (cond ((zero? k) acc)
114 ((= 1 k) (proc acc x))
115 (else (logical:ipow-by-squaring (proc x x)
117 (if (even? k) acc (proc acc x))
120 (define string-character-length string-length)
124 ;; A convenience function for combining flag bits. Like logior, but
125 ;; handles the cases of 0 and 1 arguments.
127 (define (flags . args)
130 ((null? (cdr args)) (car args))
131 (else (apply logior args))))
134 ;;; {Basic Port Code}
136 ;;; Specificly, the parts of the low-level port code that are written in
137 ;;; Scheme rather than C.
139 ;;; WARNING: the parts of this interface that refer to file ports
140 ;;; is going away. It would be gone already except that it is used
141 ;;; "internally" in a few places.
145 ;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
146 ;; mode to open files in. MSDOS does carraige return - newline
147 ;; translation if not opened in `b' mode.
149 (define OPEN_READ (case (software-type)
150 ((MS-DOS WINDOWS ATARIST) "rb")
152 (define OPEN_WRITE (case (software-type)
153 ((MS-DOS WINDOWS ATARIST) "wb")
155 (define OPEN_BOTH (case (software-type)
156 ((MS-DOS WINDOWS ATARIST) "r+b")
159 (define (open-input-file str)
160 (or (open-file str OPEN_READ)
161 (error "OPEN-INPUT-FILE couldn't find file " str)))
163 (define (open-output-file str)
164 (or (open-file str OPEN_WRITE)
165 (error "OPEN-OUTPUT-FILE couldn't find file " str)))
167 (define (open-io-file str) (open-file str OPEN_BOTH))
168 (define close-input-port close-port)
169 (define close-output-port close-port)
170 (define close-io-port close-port)
172 (define (call-with-input-file str proc)
173 (let* ((file (open-input-file str))
175 (close-input-port file)
178 (define (call-with-output-file str proc)
179 (let* ((file (open-output-file str))
181 (close-output-port file)
184 (define (with-input-from-port port thunk)
185 (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
186 (dynamic-wind swaports thunk swaports)))
188 (define (with-output-to-port port thunk)
189 (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
190 (dynamic-wind swaports thunk swaports)))
192 (define (with-error-to-port port thunk)
193 (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
194 (dynamic-wind swaports thunk swaports)))
196 (define (with-input-from-file file thunk)
197 (let* ((nport (open-input-file file))
198 (ans (with-input-from-port nport thunk)))
202 (define (with-output-to-file file thunk)
203 (let* ((nport (open-output-file file))
204 (ans (with-output-to-port nport thunk)))
208 (define (with-error-to-file file thunk)
209 (let* ((nport (open-output-file file))
210 (ans (with-error-to-port nport thunk)))
214 (define (with-input-from-string string thunk)
215 (call-with-input-string string
216 (lambda (p) (with-input-from-port p thunk))))
218 (define (with-output-to-string thunk)
219 (call-with-output-string
220 (lambda (p) (with-output-to-port p thunk))))
222 (define (with-error-to-string thunk)
223 (call-with-output-string
224 (lambda (p) (with-error-to-port p thunk))))
226 (define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
230 ;;; {Symbol Properties}
233 (define (symbol-property sym prop)
234 (let ((pair (assoc prop (symbol-pref sym))))
235 (and pair (cdr pair))))
237 (define (set-symbol-property! sym prop val)
238 (let ((pair (assoc prop (symbol-pref sym))))
241 (symbol-pset! sym (acons prop val (symbol-pref sym))))))
243 (define (symbol-property-remove! sym prop)
244 (let ((pair (assoc prop (symbol-pref sym))))
246 (symbol-pset! sym (delq! pair (symbol-pref sym))))))
253 (define uniform-vector? array?)
254 (define make-uniform-vector dimensions->uniform-array)
255 ; (define uniform-vector-ref array-ref)
256 (define (uniform-vector-set! u i o)
257 (uniform-vector-set1! u o i))
258 (define uniform-vector-fill! array-fill!)
259 (define uniform-vector-read! uniform-array-read!)
260 (define uniform-vector-write uniform-array-write)
262 (define (make-array fill . args)
263 (dimensions->uniform-array args () fill))
264 (define (make-uniform-array prot . args)
265 (dimensions->uniform-array args prot))
266 (define (list->array ndim lst)
267 (list->uniform-array ndim '() lst))
268 (define (list->uniform-vector prot lst)
269 (list->uniform-array 1 prot lst))
270 (define (array-shape a)
271 (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
272 (array-dimensions a))))
278 (define (symbol->keyword symbol)
279 (make-keyword-from-dash-symbol (symbol-append '- symbol)))
281 (define (keyword->symbol kw)
282 (let ((sym (keyword-dash-symbol kw)))
283 (string->symbol (substring sym 1 (length sym)))))
285 (define (kw-arg-ref args kw)
286 (let ((rem (member kw args)))
287 (and rem (pair? (cdr rem)) (cadr rem))))
294 (define (print obj . args)
295 (let ((default-args (list (current-output-port) 0 0 default-print-style #f)))
296 (apply-to-args (append args (list-cdr-ref default-args (length args)))
297 (lambda (port depth length style table)
299 ((and table (print-table-ref table obj)) ((print-style-tag-hook style 'eq-val)
300 obj port depth length style table))
302 (and table (print-table-add! table obj))
304 ((print-style-max-depth? style depth) ((print-style-excess-depth-hook style)))
305 ((print-style-max-length? style length) ((print-style-excess-length-hook style)))
306 (else ((print-style-hook style obj)
307 obj port depth length style table)))))))))
309 (define (make-print-style) (make-vector 59))
311 (define (extend-print-style! style utag printer) (hashq-set! style utag printer))
313 (define (print-style-hook style obj)
314 (let ((type-tag (tag obj)))
315 (or (hashq-ref style type-tag)
316 (hashq-ref style (logand type-tag 255))
319 (define (print-style-tag-hook style type-tag)
320 (or (hashq-ref style type-tag)
323 (define (print-style-max-depth? style d) #f)
324 (define (print-style-max-length? style l) #f)
325 (define (print-style-excess-length-hook style) (hashq-ref style 'excess-length-hook))
326 (define (print-style-excess-depth-hook style) (hashq-ref style 'excess-depth-hook))
328 (define (make-print-table) (make-vector 59))
329 (define (print-table-ref table obj) (hashq-ref table obj))
330 (define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref)))
332 (define (print-obj obj port depth length style table) (write obj port))
334 (define (print-pair pair port depth length style table)
338 (print (car pair) port (+ 1 depth) 0 style table)
341 ((and (pair? (cdr pair))
343 (not (print-table-ref table (cdr pair)))))
345 (display #\space port)
346 (print (cdr pair) port depth (+ 1 length) style table))
348 ((null? (cdr pair)) (display #\) port))
350 (else (display " . " port)
351 (print (cdr pair) port (+ 1 depth) 0 style table)
352 (display #\) port))))
354 (define (print-vector obj port depth length style table)
357 ((weak-hash-table? obj) (display "#wh(" port))
358 ((weak-value-hash-table? obj) (display "#whv(" port))
359 ((doubly-weak-hash-table? obj) (display "#whd(" port))
360 (else (display "#(" port))))
362 (if (< length (vector-length obj))
363 (print (vector-ref obj length) port (+ 1 depth) 0 style table))
366 ((>= (+ 1 length) (vector-length obj)) (display #\) port))
367 (else (display #\space port)
368 (print obj port depth (+ 1 length) style table))))
370 (define default-print-style (make-print-style))
372 (extend-print-style! default-print-style utag_vector print-vector)
373 (extend-print-style! default-print-style utag_wvect print-vector)
374 (extend-print-style! default-print-style utag_pair print-pair)
375 (extend-print-style! default-print-style 'eq-val
376 (lambda (obj port depth length style table)
381 (display (print-table-ref table obj))))))
387 (define record-type-vtable (make-vtable-vtable "prpr" 0))
389 (define (record-type? obj)
390 (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
392 (define (make-record-type type-name fields . opt)
393 (let ((printer-fn (and opt (car opt))))
394 (let ((struct (make-struct record-type-vtable 0
395 (make-struct-layout (apply symbol-append (map (lambda (f) "pw") fields)))
397 (copy-tree fields))))
398 ;; !!! leaks printer functions
400 (extend-print-style! default-print-style
401 (logior utag_struct_base (ash (struct-vtable-tag struct) 8))
405 (define (record-type-name obj)
406 (if (record-type? obj)
407 (struct-ref obj struct-vtable-offset)
408 (error 'not-a-record-type obj)))
410 (define (record-type-fields obj)
411 (if (record-type? obj)
412 (struct-ref obj (+ 1 struct-vtable-offset))
413 (error 'not-a-record-type obj)))
415 (define (record-constructor rtd . opt)
416 (let ((field-names (if opt (car opt) (record-type-fields rtd))))
417 (eval `(lambda ,field-names
418 (make-struct ',rtd 0 ,@(map (lambda (f)
419 (if (memq f field-names)
422 (record-type-fields rtd)))))))
424 (define (record-predicate rtd)
425 (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
427 (define (record-accessor rtd field-name)
428 (let* ((pos (list-index (record-type-fields rtd) field-name)))
430 (error 'no-such-field field-name))
432 (and (eq? ',rtd (record-type-descriptor obj))
433 (struct-ref obj ,pos))))))
435 (define (record-modifier rtd field-name)
436 (let* ((pos (list-index (record-type-fields rtd) field-name)))
438 (error 'no-such-field field-name))
439 (eval `(lambda (obj val)
440 (and (eq? ',rtd (record-type-descriptor obj))
441 (struct-set! obj ,pos val))))))
444 (define (record? obj)
445 (and (struct? obj) (record-type? (struct-vtable obj))))
447 (define (record-type-descriptor obj)
450 (error 'not-a-record obj)))
456 (define (->bool x) (not (not x)))
462 (define (symbol-append . args)
463 (string->symbol (apply string-append args)))
465 (define (list->symbol . args)
466 (string->symbol (apply list->string args)))
468 (define (symbol . args)
469 (string->symbol (apply string args)))
471 (define (obarray-symbol-append ob . args)
472 (string->obarray-symbol (apply string-append ob args)))
474 (define obarray-gensym
476 (lambda (obarray . opt)
478 (set! opt '(%%gensym)))
479 (let loop ((proposed-name (apply string-append opt)))
480 (if (string->obarray-symbol obarray proposed-name #t)
481 (loop (apply string-append (append opt (begin (set! n (1+ n)) (list (number->string n))))))
482 (string->obarray-symbol obarray proposed-name))))))
484 (define (gensym . args) (apply obarray-gensym #f args))
490 (define (list-index l k)
496 (loop (+ n 1) (cdr l))))))
498 (define (make-list n init)
499 (let loop ((answer '())
503 (loop (cons init answer) (- n 1)))))
507 ;;; {and-map, or-map, and map-in-order}
509 ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
510 ;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
511 ;;; (map-in-order fn lst) is like (map fn lst) but definately in order of lst.
516 ;; Apply f to successive elements of l until exhaustion or f returns #f.
517 ;; If returning early, return #f. Otherwise, return the last value returned
518 ;; by f. If f has never been called because l is empty, return #t.
520 (define (and-map f lst)
521 (let loop ((result #t)
526 (loop (f (car l)) (cdr l))))))
530 ;; Apply f to successive elements of l until exhaustion or while f returns #f.
531 ;; If returning early, return the return value of f.
533 (define (or-map f lst)
534 (let loop ((result #f)
538 (loop (f (car l)) (cdr l))))))
542 ;; Like map, but guaranteed to process the list in order.
544 (define (map-in-order fn l)
548 (map-in-order fn (cdr l)))))
552 ;;; !!!! these should be implemented using Tcl commands, not fports.
555 (define (file-exists? str)
556 (let ((port (open-file str OPEN_READ)))
557 (if port (begin (close-port port) #t)
560 (define (file-is-directory? str)
561 (let ((port (open-file (string-append str "/.") OPEN_READ)))
562 (if port (begin (close-port port) #t)
565 (define (has-suffix? str suffix)
566 (let ((sufl (string-length suffix))
567 (sl (string-length str)))
569 (string=? (substring str (- sl sufl) sl) suffix))))
578 ;; (error . args) is short for (throw (quote error) . args)
580 (define (error . args)
581 (apply throw 'error args))
586 ;; Error handling a la SCM.
588 (define (%%default-error-handler tag . args)
589 (define cep (current-error-port))
592 (display "ERROR: " cep)
593 (if (not (null? args))
594 (begin (display (car args) cep)
595 (for-each (lambda (x) (display #\ cep) (write x cep))
599 (apply throw 'abort tag args))
603 ;; Install SCM error handling as the default.
605 (set-symbol-property! 'error
606 'throw-handler-default
607 %%default-error-handler)
613 ;; %%bad-throw is the hook that is called upon a throw to a an unhandled
614 ;; key. If the key has a default handler (a throw-handler-default property),
615 ;; it is applied to the throw.
617 (define (%%bad-throw key . args)
618 (let ((default (symbol-property key 'throw-handler-default)))
619 (or (and default (apply default key args))
620 (throw 'error 'unhandled-exception key args))))
626 ;; A number of internally defined error types are represented
627 ;; as integers. Here is the mapping to symbolic names
628 ;; and error messages.
630 (define %%system-errors
631 '((-1 UNKNOWN "Unknown error")
632 (0 ARGn "Wrong type argument to ")
633 (1 ARG1 "Wrong type argument in position 1 to ")
634 (2 ARG2 "Wrong type argument in position 2 to ")
635 (3 ARG3 "Wrong type argument in position 3 to ")
636 (4 ARG4 "Wrong type argument in position 4 to ")
637 (5 ARG5 "Wrong type argument in position 5 to ")
638 (6 ARG5 "Wrong type argument in position 5 to ")
639 (7 ARG5 "Wrong type argument in position 5 to ")
640 (8 WNA "Wrong number of arguments to ")
641 (9 OVFLOW "Numerical overflow to ")
642 (10 OUTOFRANGE "Argument out of range to ")
643 (11 NALLOC "Could not allocate to ")
644 (12 STACK_OVFLOW "Stack overflow")
645 (13 EXIT "Exit (internal error?).")
646 (14 HUP_SIGNAL "hang-up")
647 (15 INT_SIGNAL "user interrupt")
648 (16 FPE_SIGNAL "arithmetic error")
649 (17 BUS_SIGNAL "bus error")
650 (18 SEGV_SIGNAL "segmentation violation")
651 (19 ALRM_SIGNAL "alarm")
653 (21 TICK_SIGNAL "tick")))
656 (define (timer-thunk) #t)
657 (define (gc-thunk) #t)
658 (define (alarm-thunk) #t)
660 (define (signal-handler n)
662 ((= n 21) (unmask-signals) (timer-thunk))
663 ((= n 20) (unmask-signals) (gc-thunk))
664 ((= n 19) (unmask-signals) (alarm-thunk))
665 (else (unmask-signals) (throw '%%system-error n #f))))
668 ;; The default handler for built-in error types when
669 ;; thrown by their symbolic name. The action is to
670 ;; convert the error into a generic error, building
671 ;; a descriptive message for the error.
673 (define (%%handle-system-error ignored desc proc . args)
674 (let* ((b (assoc desc %%system-errors))
677 ((or (symbol? desc) (string? desc))
678 (string-append desc " "))
679 (#t "Unknown error")))
680 (msg (if (symbol? proc)
681 (string-append msghead proc ":")
683 (rest (if (and proc (not (symbol? proc)))
686 (fixed-args (cons msg rest)))
687 (apply error fixed-args)))
690 (set-symbol-property! '%%system-error
691 'throw-handler-default
692 %%handle-system-error)
695 ;; Install default handlers for built-in errors.
698 (set-symbol-property! (cadr err)
699 'throw-handler-default
700 %%handle-system-error))
701 (cdr %%system-errors))
706 (define ((make-simple-wrapper func) . args)
707 (or (apply func args)
708 (apply throw 'syserror func (errno) args)))
710 (define ((make-eof-wrapper func) . args)
711 (let ((rv (apply func args)))
713 (apply throw 'syserror func (errno) args)
716 (define ((make-errno-wrapper func) . args)
717 (let ((rv (apply func args)))
719 (apply throw 'syserror func rv args)
722 (define ((make-errpair-wrapper func) . args)
723 (let ((rv (apply func args)))
727 (apply throw 'syserror func (car rv) args)
731 (define (syserror key fn err . args)
733 (apply error (cons fn args)))
734 (set-symbol-property! 'syserror 'throw-handler-default syserror))
737 (define (%getgrnam name) (%getgr name))
738 (define (%getgrgid id) (%getgr id))
739 (define (%gethostbyaddr addr) (%gethost addr))
740 (define (%gethostbyname name) (%gethost name))
741 (define (%getnetbyaddr addr) (%getnet addr))
742 (define (%getnetbyname name) (%getnet name))
743 (define (%getprotobyname name) (%getproto name))
744 (define (%getprotobynumber addr) (%getproto addr))
745 (define (%getpwnam name) (%getpw name))
746 (define (%getpwuid uid) (%getpw uid))
747 (define (%getservbyname name proto) (%getserv name proto))
748 (define (%getservbyport port proto) (%getserv port proto))
749 (define (endgrent) (setgr))
750 (define (endhostent) (sethost))
751 (define (endnetent) (setnet))
752 (define (endprotoent) (setproto))
753 (define (endpwent) (setpw))
754 (define (endservent) (setserv))
755 (define (file-position . args) (apply ftell args))
756 (define (file-set-position . args) (apply fseek args))
757 (define (getgrent) (%getgr))
758 (define (gethostent) (%gethost))
759 (define (getnetent) (%getnet))
760 (define (getprotoent) (%getproto))
761 (define (getpwent) (%getpw))
762 (define (getservent) (%getserv))
763 (define (reopen-file . args) (apply freopen args))
764 (define (setgrent arg) (setgr arg))
765 (define (sethostent arg) (sethost arg))
766 (define (setnetent arg) (setnet arg))
767 (define (setprotoent arg) (setproto arg))
768 (define (setpwent arg) (setpw arg))
769 (define (setservent arg) (setserv arg))
770 (define (%move->fdes port fd)
771 (if (= 1 (primitive-move->fdes port fd))
772 (set-port-revealed! port 1)
775 (define accept (make-errno-wrapper %accept))
776 (define bind (make-errno-wrapper %bind))
777 (define chdir (make-errno-wrapper %chdir))
778 (define chmod (make-errno-wrapper %chmod))
779 (define chown (make-errno-wrapper %chown))
780 (define close (make-errno-wrapper %close))
781 (define closedir (make-errno-wrapper %closedir))
782 (define connect (make-errno-wrapper %connect))
783 (define copy-file (make-simple-wrapper %copy-file))
784 (define ctermid (make-simple-wrapper %ctermid))
785 (define delete-file (make-errno-wrapper %delete-file))
786 (define duplicate-port (make-simple-wrapper %duplicate-port))
787 (define execl (make-errno-wrapper %execl))
788 (define execlp (make-errno-wrapper %execlp))
789 (define fdopen (make-errno-wrapper %fdopen))
790 (define fileno (make-simple-wrapper %fileno))
791 (define fork (make-simple-wrapper %fork))
792 (define freopen (make-errno-wrapper %freopen))
793 (define fseek (make-errno-wrapper %fseek))
794 (define ftell (make-errno-wrapper %ftell))
795 (define getcwd (make-errno-wrapper %getcwd))
796 (define getenv (make-simple-wrapper %getenv))
797 (define getgrgid (make-errno-wrapper %getgrgid))
798 (define getgrnam (make-errno-wrapper %getgrnam))
799 (define getgroups (make-errno-wrapper %getgroups))
800 (define gethostbyaddr (make-simple-wrapper %gethostbyaddr))
801 (define gethost (make-simple-wrapper %gethost))
802 (define gethostbyname (make-simple-wrapper %gethostbyname))
803 (define getnetbyaddr (make-simple-wrapper %getnetbyaddr))
804 (define getnetbyname (make-simple-wrapper %getnetbyname))
805 (define getpeername (make-errno-wrapper %getpeername))
806 (define getprotobyname (make-simple-wrapper %getprotobyname))
807 (define getprotobynumber (make-simple-wrapper %getprotobynumber))
808 (define getpwnam (make-simple-wrapper %getpwnam))
809 (define getpwuid (make-simple-wrapper %getpwuid))
810 (define getservbyname (make-simple-wrapper %getservbyname))
811 (define getservbyport (make-simple-wrapper %getservbyport))
812 (define getsockname (make-errno-wrapper %getsockname))
813 (define getsockopt (make-errpair-wrapper %getsockopt))
814 (define inet-aton (make-simple-wrapper %inet-aton))
815 (define isatty? (make-errno-wrapper %isatty?))
816 (define kill (make-errno-wrapper %kill))
817 (define link (make-errno-wrapper %link))
818 (define listen (make-errno-wrapper %listen))
819 (define lstat (make-errno-wrapper %lstat))
820 (define mkdir (make-errno-wrapper %mkdir))
821 (define mknod (make-errno-wrapper %mknod))
822 (define nice (make-errno-wrapper %nice))
823 (define opendir (make-errno-wrapper %opendir))
824 (define pipe (make-errno-wrapper %pipe))
825 (define primitive-move->fdes (make-simple-wrapper %primitive-move->fdes))
826 (define putenv (make-errno-wrapper %putenv))
827 (define read-fd (make-errpair-wrapper %read-fd))
828 (define readdir (make-errno-wrapper %readdir))
829 (define readlink (make-errno-wrapper %readlink))
830 (define recv (make-errno-wrapper %recv))
831 (define recvfrom (make-errno-wrapper %recvfrom))
832 (define redirect-port (make-errno-wrapper %redirect-port))
833 (define rename-file (make-errno-wrapper %rename-file))
834 (define rmdir (make-errno-wrapper %rmdir))
835 (define select (make-errno-wrapper %select))
836 (define send (make-errpair-wrapper %send))
837 (define sendto (make-errpair-wrapper %sendto))
838 (define setegid (make-errno-wrapper %setegid))
839 (define seteuid (make-errno-wrapper %seteuid))
840 (define setgid (make-errno-wrapper %setgid))
841 (define setlocale (make-errno-wrapper %setlocale))
842 (define setpgid (make-errno-wrapper %setpgid))
843 (define setsid (make-simple-wrapper %setsid))
844 (define setsockopt (make-errno-wrapper %setsockopt))
845 (define setuid (make-errno-wrapper %setuid))
846 (define shutdown (make-errno-wrapper %shutdown))
847 (define socket (make-errno-wrapper %socket))
848 (define socketpair (make-errno-wrapper %socketpair))
849 (define stat (make-errno-wrapper %stat))
850 (define strptime (make-simple-wrapper %strptime))
851 (define symlink (make-simple-wrapper %symlink))
852 (define tcgetpgrp (make-simple-wrapper %tcgetpgrp))
853 (define tcsetpgrp (make-simple-wrapper %tcsetpgrp))
854 (define ttyname (make-errno-wrapper %ttyname))
855 (define uname (make-errno-wrapper %uname))
856 (define utime (make-errno-wrapper %utime))
857 (define waitpid (make-errno-wrapper %waitpid))
858 (define write-fd (make-errpair-wrapper %write-fd))
859 (define move->fdes (make-simple-wrapper %move->fdes))
865 (define implementation-vicinity compiled-library-path)
867 ;;; Here for backward compatability
869 (define scheme-file-suffix (lambda () ".scm"))
871 (define in-vicinity string-append)
873 (define (parse-path env_path)
874 (cond ((string? env_path)
875 (let loop ((curdir "") (env env_path) (path '()))
876 (cond ((= (string-length env) 0)
877 (if (> (string-length curdir) 0)
878 (append path (list curdir))
880 ((char=? (string-ref env 0) #\:)
882 (substring env 1 (string-length env))
883 (append path (list curdir))))
885 (loop (string-append curdir (substring env 0 1))
886 (substring env 1 (string-length env))
890 (define %load-path (append (parse-path (%getenv "SCHEME_LOAD_PATH"))
892 (in-vicinity (implementation-vicinity) "gls/guile/")
893 (in-vicinity (implementation-vicinity) "gls/")
894 (in-vicinity (implementation-vicinity) "slib/"))))
899 (define (try-load-with-path file-name path)
901 (let ((f (in-vicinity d file-name)))
902 (and (not (file-is-directory? f))
903 (%try-load f #t read-sharp))))
906 (define (try-load name)
907 (if (eval '(defined? %load-path))
908 (try-load-with-path name (eval '%load-path))
909 (%try-load name #t read-sharp)))
914 (define %load-verbosely #t)
915 (define (assert-load-verbosity v) (set! %load-verbosely v))
916 (define %load-indent -2)
920 (or (and (not (file-is-directory? f))
921 (%try-load f #t read-sharp))
922 (and (not (has-suffix? f (scheme-file-suffix)))
923 (%try-load (string-append f (scheme-file-suffix)) #t read-sharp))))
925 (define (%load-announce file)
927 (with-output-to-port (current-error-port)
930 (display (make-string %load-indent #\ ))
937 (define (%load-announce-win file)
939 (with-output-to-port (current-error-port)
942 (display (make-string %load-indent #\ ))
943 (display "...loaded ")
949 (define (%load-announce-lossage file path)
951 (with-output-to-port (current-error-port)
954 (display (make-string %load-indent #\ ))
955 (display "...COULD NOT LOAD ")
961 (throw 'could-not-load file path))
964 (define (load-with-path name path)
966 (%load-announce name)
967 (if (not (or-map (lambda (d)
968 (if (%load (in-vicinity d name))
970 (%load-announce-win (in-vicinity d name))
974 (%load-announce-lossage name path)))
976 (let ((indent %load-indent))
978 (lambda () (set! %load-indent (modulo (+ indent 2) 16)))
980 (lambda () (set! %load-indent indent))))
985 (if (eval '(defined? %load-path))
986 (load-with-path name (eval '%load-path))
987 (load-with-path name '())))
991 ;;; {Transcendental Functions}
993 ;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
994 ;;; Copyright (C) 1992, 1993 Jerry D. Hedden.
995 ;;; See the file `COPYING' for terms applying to this program.
999 (if (real? z) ($exp z)
1000 (make-polar ($exp (real-part z)) (imag-part z))))
1003 (if (and (real? z) (>= z 0))
1005 (make-rectangular ($log (magnitude z)) (angle z))))
1009 (if (negative? z) (make-rectangular 0 ($sqrt (- z)))
1011 (make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
1014 (let ((integer-expt integer-expt))
1017 (integer-expt z1 z2))
1018 ((and (real? z2) (real? z1) (>= z1 0))
1021 (exp (* z2 (log z1))))))))
1024 (if (real? z) ($sinh z)
1025 (let ((x (real-part z)) (y (imag-part z)))
1026 (make-rectangular (* ($sinh x) ($cos y))
1027 (* ($cosh x) ($sin y))))))
1029 (if (real? z) ($cosh z)
1030 (let ((x (real-part z)) (y (imag-part z)))
1031 (make-rectangular (* ($cosh x) ($cos y))
1032 (* ($sinh x) ($sin y))))))
1034 (if (real? z) ($tanh z)
1035 (let* ((x (* 2 (real-part z)))
1036 (y (* 2 (imag-part z)))
1037 (w (+ ($cosh x) ($cos y))))
1038 (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
1041 (if (real? z) ($asinh z)
1042 (log (+ z (sqrt (+ (* z z) 1))))))
1045 (if (and (real? z) (>= z 1))
1047 (log (+ z (sqrt (- (* z z) 1))))))
1050 (if (and (real? z) (> z -1) (< z 1))
1052 (/ (log (/ (+ 1 z) (- 1 z))) 2)))
1055 (if (real? z) ($sin z)
1056 (let ((x (real-part z)) (y (imag-part z)))
1057 (make-rectangular (* ($sin x) ($cosh y))
1058 (* ($cos x) ($sinh y))))))
1060 (if (real? z) ($cos z)
1061 (let ((x (real-part z)) (y (imag-part z)))
1062 (make-rectangular (* ($cos x) ($cosh y))
1063 (- (* ($sin x) ($sinh y)))))))
1065 (if (real? z) ($tan z)
1066 (let* ((x (* 2 (real-part z)))
1067 (y (* 2 (imag-part z)))
1068 (w (+ ($cos x) ($cosh y))))
1069 (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
1072 (if (and (real? z) (>= z -1) (<= z 1))
1074 (* -i (asinh (* +i z)))))
1077 (if (and (real? z) (>= z -1) (<= z 1))
1079 (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
1081 (define (atan z . y)
1083 (if (real? z) ($atan z)
1084 (/ (log (/ (- +i z) (+ +i z))) +2i))
1085 ($atan2 z (car y))))
1087 (set! abs magnitude)
1090 ;;; {User Settable Hooks}
1092 ;;; Parts of the C code check the bindings of these variables.
1095 (define ticks-interrupt #f)
1096 (define user-interrupt #f)
1097 (define alarm-interrupt #f)
1098 (define out-of-storage #f)
1099 (define could-not-open #f)
1100 (define end-of-program #f)
1102 (define arithmetic-error #f)
1103 (define read-sharp #f)
1107 ;;; {Reader Extensions}
1110 ;;; Reader code for various "#c" forms.
1113 (define (parse-path-symbol s)
1114 (define (seperate-fields-discarding-char ch str ret)
1115 (let loop ((fields '())
1118 ((string-rindex str ch)
1119 => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 pos)) fields)
1120 (make-shared-substring str 0 pos))))
1121 (else (ret (cons str fields))))))
1122 (seperate-fields-discarding-char #\/
1125 (map string->symbol fields))))
1128 (define (%read-sharp c port)
1130 (error "unknown # object" c))
1133 ((#\/) (let ((look (peek-char port)))
1134 (if (or (eof-object? look)
1136 (or (char-whitespace? look)
1137 (string-index ")" look))))
1139 (parse-path-symbol (read port #t read-sharp)))))
1140 ((#\') (read port #t read-sharp))
1141 ((#\.) (eval (read port #t read-sharp)))
1142 ((#\b) (read:uniform-vector #t port))
1143 ((#\a) (read:uniform-vector #\a port))
1144 ((#\u) (read:uniform-vector 1 port))
1145 ((#\e) (read:uniform-vector -1 port))
1146 ((#\s) (read:uniform-vector 1.0 port))
1147 ((#\i) (read:uniform-vector 1/3 port))
1148 ((#\c) (read:uniform-vector 0+i port))
1149 ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
1150 (read:array c port))
1151 ((#\!) (if (= 1 (line-number))
1152 (let skip () (if (eq? #\newline (peek-char port))
1153 (read port #t read-sharp)
1154 (begin (read-char port) (skip))))
1158 (define (read:array digit port)
1159 (define chr0 (char->integer #\0))
1160 (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
1161 (if (char-numeric? (peek-char port))
1162 (readnum (+ (* 10 val)
1163 (- (char->integer (read-char port)) chr0)))
1165 (prot (if (eq? #\( (peek-char port))
1167 (let ((c (read-char port)))
1175 (else (error "read:array unknown option " c)))))))
1176 (if (eq? (peek-char port) #\()
1177 (list->uniform-array rank prot (read port #t read-sharp))
1178 (error "read:array list not found"))))
1180 (define (read:uniform-vector proto port)
1181 (if (eq? #\( (peek-char port))
1182 (list->uniform-array 1 proto (read port #t read-sharp))
1183 (error "read:uniform-vector list not found")))
1186 (define read-sharp (lambda a (apply %read-sharp a)))
1193 ; mystery integers passed dynamic root error handlers
1194 (define repl-quit -1)
1195 (define repl-abort -2)
1199 ;;; {Command Line Options}
1202 (define (get-option argv kw-opts kw-args return)
1205 (return #f #f argv))
1207 ((or (not (eq? #\- (string-ref (car argv) 0)))
1208 (eq? (string-length (car argv)) 1))
1209 (return 'normal-arg (car argv) (cdr argv)))
1211 ((eq? #\- (string-ref (car argv) 1))
1212 (let* ((kw-arg-pos (or (string-index (car argv) #\=)
1213 (string-length (car argv))))
1214 (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
1215 (kw-opt? (member kw kw-opts))
1216 (kw-arg? (member kw kw-args))
1217 (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
1218 (substring (car argv)
1220 (string-length (car argv))))
1222 (begin (set! argv (cdr argv)) (car argv))))))
1223 (if (or kw-opt? kw-arg?)
1224 (return kw arg (cdr argv))
1225 (return 'usage-error kw (cdr argv)))))
1228 (let* ((char (substring (car argv) 1 2))
1229 (kw (symbol->keyword char)))
1232 ((member kw kw-opts)
1233 (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
1234 (new-argv (if (= 0 (string-length rest-car))
1236 (cons (string-append "-" rest-car) (cdr argv)))))
1237 (return kw #f new-argv)))
1239 ((member kw kw-args)
1240 (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
1241 (arg (if (= 0 (string-length rest-car))
1244 (new-argv (if (= 0 (string-length rest-car))
1247 (return kw arg new-argv)))
1249 (else (return 'usage-error kw argv)))))))
1251 (define (for-next-option proc argv kw-opts kw-args)
1252 (let loop ((argv argv))
1253 (get-option argv kw-opts kw-args
1254 (lambda (opt opt-arg argv)
1255 (and opt (proc opt opt-arg argv loop))))))
1257 (define (display-usage-report kw-desc)
1260 (or (eq? (car kw) #t)
1261 (eq? (car kw) 'else)
1262 (let* ((opt-desc kw)
1263 (help (cadr opt-desc))
1264 (opts (car opt-desc))
1265 (opts-proper (if (string? (car opts)) (cdr opts) opts))
1266 (arg-name (if (string? (car opts))
1267 (string-append "<" (car opts) ">")
1269 (left-part (string-append
1270 (with-output-to-string
1272 (map (lambda (x) (display (keyword-symbol x)) (display " "))
1275 (middle-part (if (and (< (length left-part) 30)
1276 (< (length help) 40))
1277 (make-string (- 30 (length left-part)) #\ )
1280 (display middle-part)
1287 (define (delq-all! obj l)
1288 (let ((answer (cons '() l)))
1289 (let loop ((pos answer))
1291 ((null? (cdr pos)) (cdr answer))
1292 ((eq? (cadr pos) obj) (set-cdr! pos (cddr pos))
1294 (else (loop (cdr pos)))))))
1296 (define (transform-usage-lambda cases)
1297 (let* ((raw-usage (delq! 'else (map car cases)))
1298 (usage-sans-specials (map (lambda (x)
1299 (or (and (not (list? x)) x)
1300 (and (symbol? (car x)) #t)
1301 (and (boolean? (car x)) #t)
1304 (usage-desc (delq-all! #t usage-sans-specials))
1305 (kw-desc (map car usage-desc))
1306 (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
1307 (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
1308 (transmogrified-cases (map (lambda (case)
1309 (cons (let ((opts (car case)))
1310 (if (or (boolean? opts) (eq? 'else opts))
1313 ((symbol? (car opts)) opts)
1314 ((boolean? (car opts)) opts)
1315 ((string? (caar opts)) (cdar opts))
1316 (else (car opts)))))
1319 `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
1321 (let %next-arg ((%argv %argv))
1325 (lambda (%opt %arg %new-argv)
1327 ,@ transmogrified-cases))))))))
1332 ;;; {Low Level Modules}
1334 ;;; These are the low level data structures for modules.
1336 ;;; !!! warning: The interface to lazy binder procedures is going
1337 ;;; to be changed in an incompatible way to permit all the basic
1338 ;;; module ops to be virtualized.
1340 ;;; (make-module size use-list lazy-binding-proc) => module
1341 ;;; module-{obarray,uses,binder}[|-set!]
1342 ;;; (module? obj) => [#t|#f]
1343 ;;; (module-locally-bound? module symbol) => [#t|#f]
1344 ;;; (module-bound? module symbol) => [#t|#f]
1345 ;;; (module-symbol-locally-interned? module symbol) => [#t|#f]
1346 ;;; (module-symbol-interned? module symbol) => [#t|#f]
1347 ;;; (module-local-variable module symbol) => [#<variable ...> | #f]
1348 ;;; (module-variable module symbol) => [#<variable ...> | #f]
1349 ;;; (module-symbol-binding module symbol opt-value)
1350 ;;; => [ <obj> | opt-value | an error occurs ]
1351 ;;; (module-make-local-var! module symbol) => #<variable...>
1352 ;;; (module-add! module symbol var) => unspecified
1353 ;;; (module-remove! module symbol) => unspecified
1354 ;;; (module-for-each proc module) => unspecified
1355 ;;; (make-scm-module) => module ; a lazy copy of the symhash module
1356 ;;; (set-current-module module) => unspecified
1357 ;;; (current-module) => #<module...>
1362 ;; This is how modules are printed.
1363 ;; You can re-define it.
1365 (define (%print-module mod port depth length style table)
1367 (display (or (module-kind mod) "module") port)
1368 (let ((name (module-name mod)))
1372 (display name port))))
1374 (display (number->string (object-address mod) 16) port)
1379 ;; A module is characterized by an obarray in which local symbols
1380 ;; are interned, a list of modules, "uses", from which non-local
1381 ;; bindings can be inherited, and an optional lazy-binder which
1382 ;; is a (THUNK module symbol) which, as a last resort, can provide
1383 ;; bindings that would otherwise not be found locally in the module.
1386 (make-record-type 'module '(obarray uses binder eval-thunk name kind) %print-module))
1388 ;; make-module &opt size uses
1390 ;; Create a new module, perhaps with a particular size of obarray
1391 ;; or initial uses list.
1393 (define module-constructor (record-constructor module-type))
1402 (lambda (symbol define?)
1404 (module-make-local-var! answer symbol)
1405 (module-variable answer symbol)))))
1407 (if (> (length args) 0)
1409 (set! size (or (car args) size))
1410 (set! args (cdr args))))
1412 (if (> (length args) 0)
1414 (set! uses (or (car args) uses))
1415 (set! args (cdr args))))
1417 (if (> (length args) 0)
1419 (set! binder (or (car args) binder))
1420 (set! args (cdr args))))
1422 (if (not (null? args))
1423 (error "Too many args to make-module." args))
1425 (if (not (integer? size))
1426 (error "Illegal size to make-module." size))
1429 (or (and-map module? uses)
1430 (error "Incorrect use list." uses)))
1432 (if (and binder (not (procedure? binder)))
1434 "Lazy-binder expected to be a procedure or #f." binder))
1437 (module-constructor (make-vector size '())
1445 (define module-obarray (record-accessor module-type 'obarray))
1446 (define set-module-obarray! (record-modifier module-type 'obarray))
1447 (define module-uses (record-accessor module-type 'uses))
1448 (define set-module-uses! (record-modifier module-type 'uses))
1449 (define module-binder (record-accessor module-type 'binder))
1450 (define set-module-binder! (record-modifier module-type 'binder))
1451 (define module-eval-thunk (record-accessor module-type 'eval-thunk))
1452 (define set-module-eval-thunk! (record-modifier module-type 'eval-thunk))
1453 (define module-name (record-accessor module-type 'name))
1454 (define set-module-name! (record-modifier module-type 'name))
1455 (define module-kind (record-accessor module-type 'kind))
1456 (define set-module-kind! (record-modifier module-type 'kind))
1457 (define module? (record-predicate module-type))
1459 (define (eval-in-module exp module)
1460 (eval2 exp (module-eval-thunk module)))
1463 ;;; {Module Searching in General}
1465 ;;; We sometimes want to look for properties of a symbol
1466 ;;; just within the obarray of one module. If the property
1467 ;;; holds, then it is said to hold ``locally'' as in, ``The symbol
1468 ;;; DISPLAY is locally rebound in the module `safe-guile'.''
1471 ;;; Other times, we want to test for a symbol property in the obarray
1472 ;;; of M and, if it is not found there, try each of the modules in the
1473 ;;; uses list of M. This is the normal way of testing for some
1474 ;;; property, so we state these properties without qualification as
1475 ;;; in: ``The symbol 'fnord is interned in module M because it is
1476 ;;; interned locally in module M2 which is a member of the uses list
1480 ;; module-search fn m
1482 ;; return the first non-#f result of FN applied to M and then to
1483 ;; the modules in the uses of m, and so on recursively. If all applications
1484 ;; return #f, then so does this function.
1486 (define (module-search fn m v)
1489 (or (module-search fn (car pos) v)
1492 (loop (module-uses m))))
1495 ;;; {Is a symbol bound in a module?}
1497 ;;; Symbol S in Module M is bound if S is interned in M and if the binding
1498 ;;; of S in M has been set to some well-defined value.
1501 ;; module-locally-bound? module symbol
1503 ;; Is a symbol bound (interned and defined) locally in a given module?
1505 (define (module-locally-bound? m v)
1506 (let ((var (module-local-variable m v)))
1508 (variable-bound? var))))
1510 ;; module-bound? module symbol
1512 ;; Is a symbol bound (interned and defined) anywhere in a given module
1515 (define (module-bound? m v)
1516 (module-search module-locally-bound? m v))
1518 ;;; {Is a symbol interned in a module?}
1520 ;;; Symbol S in Module M is interned if S occurs in
1521 ;;; of S in M has been set to some well-defined value.
1523 ;;; It is possible to intern a symbol in a module without providing
1524 ;;; an initial binding for the corresponding variable. This is done
1526 ;;; (module-add! module symbol (make-undefined-variable))
1528 ;;; In that case, the symbol is interned in the module, but not
1529 ;;; bound there. The unbound symbol shadows any binding for that
1530 ;;; symbol that might otherwise be inherited from a member of the uses list.
1533 (define (module-obarray-get-handle ob key)
1534 ((if (symbol? key) hashq-get-handle hash-get-handle) ob key))
1536 (define (module-obarray-ref ob key)
1537 ((if (symbol? key) hashq-ref hash-ref) ob key))
1539 (define (module-obarray-set! ob key val)
1540 ((if (symbol? key) hashq-set! hash-set!) ob key val))
1542 (define (module-obarray-remove! ob key)
1543 ((if (symbol? key) hashq-remove! hash-remove!) ob key))
1545 ;; module-symbol-locally-interned? module symbol
1547 ;; is a symbol interned (not neccessarily defined) locally in a given module
1548 ;; or its uses? Interned symbols shadow inherited bindings even if
1549 ;; they are not themselves bound to a defined value.
1551 (define (module-symbol-locally-interned? m v)
1552 (not (not (module-obarray-get-handle (module-obarray m) v))))
1554 ;; module-symbol-interned? module symbol
1556 ;; is a symbol interned (not neccessarily defined) anywhere in a given module
1557 ;; or its uses? Interned symbols shadow inherited bindings even if
1558 ;; they are not themselves bound to a defined value.
1560 (define (module-symbol-interned? m v)
1561 (module-search module-symbol-locally-interned? m v))
1564 ;;; {Mapping modules x symbols --> variables}
1567 ;; module-local-variable module symbol
1568 ;; return the local variable associated with a MODULE and SYMBOL.
1570 ;;; This function is very important. It is the only function that can
1571 ;;; return a variable from a module other than the mutators that store
1572 ;;; new variables in modules. Therefore, this function is the location
1573 ;;; of the "lazy binder" hack.
1575 ;;; If symbol is defined in MODULE, and if the definition binds symbol
1576 ;;; to a variable, return that variable object.
1578 ;;; If the symbols is not found at first, but the module has a lazy binder,
1579 ;;; then try the binder.
1581 ;;; If the symbol is not found at all, return #f.
1583 (define (module-local-variable m v)
1586 (let ((b (module-obarray-ref (module-obarray m) v)))
1587 (or (and (variable? b) b)
1588 (and (module-binder m)
1589 ((module-binder m) m v #f)))))))
1591 ;; module-variable module symbol
1593 ;; like module-local-variable, except search the uses in the
1594 ;; case V is not found in M.
1596 (define (module-variable m v)
1597 (module-search module-local-variable m v))
1600 ;;; {Mapping modules x symbols --> bindings}
1602 ;;; These are similar to the mapping to variables, except that the
1603 ;;; variable is dereferenced.
1606 ;; module-symbol-binding module symbol opt-value
1608 ;; return the binding of a variable specified by name within
1609 ;; a given module, signalling an error if the variable is unbound.
1610 ;; If the OPT-VALUE is passed, then instead of signalling an error,
1611 ;; return OPT-VALUE.
1613 (define (module-symbol-local-binding m v . opt-val)
1614 (let ((var (module-local-variable m v)))
1617 (if (not (null? opt-val))
1619 (error "Locally unbound variable." v)))))
1621 ;; module-symbol-binding module symbol opt-value
1623 ;; return the binding of a variable specified by name within
1624 ;; a given module, signalling an error if the variable is unbound.
1625 ;; If the OPT-VALUE is passed, then instead of signalling an error,
1626 ;; return OPT-VALUE.
1628 (define (module-symbol-binding m v . opt-val)
1629 (let ((var (module-variable m v)))
1632 (if (not (null? opt-val))
1634 (error "Unbound variable." v)))))
1638 ;;; {Adding Variables to Modules}
1643 ;; module-make-local-var! module symbol
1645 ;; ensure a variable for V in the local namespace of M.
1646 ;; If no variable was already there, then create a new and uninitialzied
1649 (define (module-make-local-var! m v)
1650 (or (let ((b (module-obarray-ref (module-obarray m) v)))
1651 (and (variable? b) b))
1652 (and (module-binder m)
1653 ((module-binder m) m v #t))
1655 (let ((answer (make-undefined-variable v)))
1656 (module-obarray-set! (module-obarray m) v answer)
1659 ;; module-add! module symbol var
1661 ;; ensure a particular variable for V in the local namespace of M.
1663 (define (module-add! m v var)
1664 (if (not (variable? var))
1665 (error "Bad variable to module-add!" var))
1666 (module-obarray-set! (module-obarray m) v var))
1670 ;; make sure that a symbol is undefined in the local namespace of M.
1672 (define (module-remove! m v)
1673 (module-obarray-remove! (module-obarray m) v))
1675 (define (module-clear! m)
1676 (vector-fill! (module-obarray m) '()))
1678 ;; MODULE-FOR-EACH -- exported
1680 ;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
1682 (define (module-for-each proc module)
1683 (let ((obarray (module-obarray module)))
1684 (do ((index 0 (+ index 1))
1685 (end (vector-length obarray)))
1689 (proc (car bucket) (cdr bucket)))
1690 (vector-ref obarray index)))))
1693 (define (module-map proc module)
1694 (let* ((obarray (module-obarray module))
1695 (end (vector-length obarray)))
1703 (map (lambda (bucket)
1704 (proc (car bucket) (cdr bucket)))
1705 (vector-ref obarray i))
1709 ;;; {Low Level Bootstrapping}
1714 :; A root module uses the symhash table (the system's privileged
1715 ;; obarray). Being inside a root module is like using SCM without
1716 ;; any module system.
1720 (define (root-module-thunk m s define?)
1721 (let ((bi (and (symbol-interned? #f s)
1722 (builtin-variable s))))
1724 (or define? (variable-bound? bi))
1726 (module-add! m s bi)
1729 (define (make-root-module)
1730 (make-module 1019 #f root-module-thunk))
1735 ;; An scm module is a module into which the lazy binder copies
1736 ;; variable bindings from the system symhash table. The mapping is
1737 ;; one way only; newly introduced bindings in an scm module are not
1738 ;; copied back into the system symhash table (and can be used to override
1739 ;; bindings from the symhash table).
1742 (define (make-scm-module)
1743 (make-module 1019 #f
1744 (lambda (m s define?)
1745 (let ((bi (and (symbol-interned? #f s)
1746 (builtin-variable s))))
1748 (variable-bound? bi)
1750 (module-add! m s bi)
1758 (define the-module #f)
1760 ;; set-current-module module
1762 ;; set the current module as viewed by the normalizer.
1764 (define (set-current-module m)
1767 (set! *top-level-lookup-thunk* (module-eval-thunk the-module))
1768 (set! *top-level-lookup-thunk* #f)))
1773 ;; return the current module as viewed by the normalizer.
1775 (define (current-module) the-module)
1777 ;;; {Module-based Loading}
1780 (define (save-module-excursion thunk)
1781 (let ((inner-module (current-module))
1783 (dynamic-wind (lambda ()
1784 (set! outer-module (current-module))
1785 (set-current-module inner-module)
1786 (set! inner-module #f))
1789 (set! inner-module (current-module))
1790 (set-current-module outer-module)
1791 (set! outer-module #f)))))
1793 (define basic-try-load-with-path try-load-with-path)
1794 (define basic-try-load try-load)
1795 (define basic-load-with-path load-with-path)
1796 (define basic-load load)
1799 (define (try-load-module-with-path . args)
1800 (save-module-excursion (lambda () (apply basic-try-load-with-path args))))
1802 (define (try-load-module . args)
1803 (save-module-excursion (lambda () (apply basic-try-load args))))
1805 (define (load-module-with-path . args)
1806 (save-module-excursion (lambda () (apply basic-load-with-path args))))
1808 (define (load-module . args)
1809 (save-module-excursion (lambda () (apply basic-load args))))
1814 ;; MODULE-REF -- exported
1816 ;; Returns the value of a variable called NAME in MODULE or any of its
1817 ;; used modules. If there is no such variable, then if the optional third
1818 ;; argument DEFAULT is present, it is returned; otherwise an error is signaled.
1820 (define (module-ref module name . rest)
1821 (let ((variable (module-variable module name)))
1822 (if (and variable (variable-bound? variable))
1823 (variable-ref variable)
1825 (error "No variable named" name 'in module)
1826 (car rest) ; default value
1829 ;; MODULE-SET! -- exported
1831 ;; Sets the variable called NAME in MODULE (or in a module that MODULE uses)
1832 ;; to VALUE; if there is no such variable, an error is signaled.
1834 (define (module-set! module name value)
1835 (let ((variable (module-variable module name)))
1837 (variable-set! variable value)
1838 (error "No variable named" name 'in module))))
1840 ;; MODULE-DEFINE! -- exported
1842 ;; Sets the variable called NAME in MODULE to VALUE; if there is no such
1843 ;; variable, it is added first.
1845 (define (module-define! module name value)
1846 (let ((variable (module-local-variable module name)))
1848 (variable-set! variable value)
1849 (module-add! module name (make-variable value name)))))
1851 ;; MODULE-USE! module interface
1853 ;; Add INTERFACE to the list of interfaces used by MODULE.
1855 (define (module-use! module interface)
1856 (set-module-uses! module
1857 (cons interface (delq! interface (module-uses module)))))
1863 ;;; {Recursive Namespaces}
1866 ;;; A hierarchical namespace emerges if we consider some module to be
1867 ;;; root, and variables bound to modules as nested namespaces.
1869 ;;; The routines in this file manage variable names in hierarchical namespace.
1870 ;;; Each variable name is a list of elements, looked up in successively nested
1873 ;;; (resolved-ref some-root-module '(foo bar baz))
1874 ;;; => <value of a variable named baz in the module bound to bar in
1875 ;;; the module bound to foo in some-root-module>
1880 ;;; ;; a-root is a module
1881 ;;; ;; name is a list of symbols
1883 ;;; resolved-ref a-root name
1884 ;;; resolved-set! a-root name val
1885 ;;; resolved-define! a-root name val
1886 ;;; resolved-remove! a-root name
1889 ;;; (current-module) is a natural choice for a-root so for convenience there are
1892 ;;; value-ref name == resolved-ref (current-module) name
1893 ;;; value-set! name val == resolved-set! (current-module) name val
1894 ;;; value-define! name val == resolved-define! (current-module) name val
1895 ;;; value-remove! name == resolved-remove! (current-module) name
1899 (define (resolved-ref root names)
1900 (let loop ((cur root)
1904 ((not (module? cur)) #f)
1905 (else (loop (module-ref cur (car elts) #f) (cdr elts))))))
1907 (define (resolved-set! root names val)
1908 (let loop ((cur root)
1910 (if (null? (cdr elts))
1911 (module-set! cur (car elts) val)
1912 (loop (module-ref cur (car elts)) (cdr elts)))))
1914 (define (resolved-define! root names val)
1915 (let loop ((cur root)
1917 (if (null? (cdr elts))
1918 (module-define! cur (car elts) val)
1919 (loop (module-ref cur (car elts)) (cdr elts)))))
1921 (define (resolved-remove! root names)
1922 (let loop ((cur root)
1924 (if (null? (cdr elts))
1925 (module-remove! cur (car elts))
1926 (loop (module-ref cur (car elts)) (cdr elts)))))
1928 (define (value-ref names) (resolved-ref (current-module) names))
1929 (define (value-set! names val) (resolved-set! (current-module) names val))
1930 (define (value-define names val) (resolved-define! (current-module) names val))
1931 (define (value-remove names) (resolved-remove! (current-module) names))
1939 ;;; The root of conventionally named objects not directly in the top level.
1942 ;;; #/app/modules/guile
1944 ;;; The directory of all modules and the standard root module.
1947 (define (module-public-interface m) (module-ref m '%module-public-interface #f))
1948 (define (set-module-public-interface! m i) (module-define! m '%module-public-interface i))
1949 (define the-root-module (make-root-module))
1950 (define the-scm-module (make-scm-module))
1951 (set-module-public-interface! the-root-module the-scm-module)
1952 (set-module-name! the-root-module 'the-root-module)
1953 (set-module-name! the-scm-module 'the-scm-module)
1955 (set-current-module the-root-module)
1957 (define app (make-module 31))
1958 (value-define '(app modules) (make-module 31))
1959 (value-define '(app modules guile) the-root-module)
1961 ;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module)))
1963 (define (resolve-module name)
1964 (let ((full-name (append '(app modules) name)))
1965 (let ((already (value-ref full-name)))
1968 (try-module-autoload name)
1969 (make-modules-in (current-module) full-name))))))
1971 (define (beautify-user-module! module)
1972 (if (not (module-public-interface module))
1973 (let ((interface (make-module 31)))
1974 (set-module-name! interface (module-name module))
1975 (set-module-kind! interface 'interface)
1976 (set-module-public-interface! module interface)))
1977 (if (not (memq the-scm-module (module-uses module)))
1978 (set-module-uses! module (append (module-uses module) (list the-scm-module)))))
1980 (define (make-modules-in module name)
1984 ((module-ref module (car name) #f) => (lambda (m) (make-modules-in m (cdr name))))
1985 (else (let ((m (make-module 31)))
1986 (set-module-kind! m 'directory)
1987 (set-module-name! m (car name))
1988 (module-define! module (car name) m)
1989 (make-modules-in m (cdr name)))))))
1991 (define (resolve-interface name)
1992 (let ((module (resolve-module name)))
1993 (and module (module-public-interface module))))
1996 (define %autoloader-developer-mode #t)
1998 (define (process-define-module args)
1999 (let* ((module-id (car args))
2000 (module (resolve-module module-id))
2002 (beautify-user-module! module)
2003 (let loop ((kws kws))
2004 (and (not (null? kws))
2007 (if (not (pair? (cdr kws)))
2008 (error "unrecognized defmodule argument" kws))
2009 (let* ((used-name (cadr kws))
2010 (used-module (resolve-module used-name)))
2011 (if (not (module-ref used-module '%module-public-interface #f))
2013 ((if %autoloader-developer-mode warn error) "no code for module" used-module)
2014 (beautify-user-module! used-module)))
2015 (let ((interface (module-ref used-module '%module-public-interface #f)))
2017 (error "missing interface for use-module" used-module))
2018 (set-module-uses! module
2019 (append! (delq! interface (module-uses module))
2020 (list interface)))))
2023 (else (error "unrecognized defmodule argument" kws)))))
2027 (define autoloads-in-progress '())
2029 (define (try-module-autoload module-name)
2031 (define (sfx name) (string-append name (scheme-file-suffix)))
2032 (let* ((reverse-name (reverse module-name))
2033 (name (car reverse-name))
2034 (dir-hint-module-name (reverse (cdr reverse-name)))
2035 (dir-hint (apply symbol-append (map (lambda (elt) (symbol-append elt "/")) dir-hint-module-name))))
2036 (resolve-module dir-hint-module-name)
2037 (and (not (autoload-done-or-in-progress? dir-hint name))
2040 (lambda () (autoload-in-progress! dir-hint name))
2042 (let loop ((dirs %load-path))
2043 (and (not (null? dirs))
2045 (let ((d (car dirs))
2049 (in-vicinity dir-hint name)
2050 (in-vicinity dir-hint (sfx name)))))
2051 (and (or-map (lambda (f)
2052 (let ((full (in-vicinity d f)))
2054 (and (not (file-is-directory? full))
2057 (save-module-excursion
2060 (load-with-path f (list d))))
2066 (loop (cdr dirs))))))
2067 (lambda () (set-autoloaded! dir-hint name didit)))
2070 (define autoloads-done '((guile . guile)))
2072 (define (autoload-done-or-in-progress? p m)
2073 (let ((n (cons p m)))
2074 (->bool (or (member n autoloads-done)
2075 (member n autoloads-in-progress)))))
2077 (define (autoload-done! p m)
2078 (let ((n (cons p m)))
2079 (set! autoloads-in-progress
2080 (delete! n autoloads-in-progress))
2081 (or (member n autoloads-done)
2082 (set! autoloads-done (cons n autoloads-done)))))
2084 (define (autoload-in-progress! p m)
2085 (let ((n (cons p m)))
2086 (set! autoloads-done
2087 (delete! n autoloads-done))
2088 (set! autoloads-in-progress (cons n autoloads-in-progress))))
2090 (define (set-autoloaded! p m done?)
2092 (autoload-done! p m)
2093 (let ((n (cons p m)))
2094 (set! autoloads-done (delete! n autoloads-done))
2095 (set! autoloads-in-progress (delete! n autoloads-in-progress)))))
2104 (define macro-table (make-weak-hash-table 523))
2105 (define xformer-table (make-weak-hash-table 523))
2107 (define (defmacro? m) (hashq-ref macro-table m))
2108 (define (assert-defmacro?! m) (hashq-set! macro-table m #t))
2109 (define (defmacro-transformer m) (hashq-ref xformer-table m))
2110 (define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))
2112 (define defmacro:transformer
2114 (let* ((xform (lambda (exp env)
2115 (copy-tree (apply f (cdr exp)))))
2116 (a (procedure->memoizing-macro xform)))
2117 (assert-defmacro?! a)
2118 (set-defmacro-transformer! a f)
2123 (let ((defmacro-transformer
2124 (lambda (name parms . body)
2125 (let ((transformer `(lambda ,parms ,@body)))
2127 (,(lambda (transformer)
2128 (defmacro:transformer transformer))
2130 (defmacro:transformer defmacro-transformer)))
2132 (define defmacro:syntax-transformer
2136 (copy-tree (apply f (cdr exp)))))))
2138 (define (macroexpand-1 e)
2140 ((pair? e) (let* ((a (car e))
2141 (val (and (symbol? a) (eval `(defined? ,a)) (eval a))))
2143 (apply (defmacro-transformer val) (cdr e))
2147 (define (macroexpand e)
2149 ((pair? e) (let* ((a (car e))
2150 (val (and (symbol? a) (eval `(defined? ,a)) (eval a))))
2152 (macroexpand (apply (defmacro-transformer val) (cdr e)))
2157 (let ((*gensym-counter* -1))
2159 (set! *gensym-counter* (+ *gensym-counter* 1))
2161 (string-append "scm:G" (number->string *gensym-counter*))))))
2169 (define (repl read evaler print)
2170 (let loop ((source (read (current-input-port) #t read-sharp)))
2171 (print (evaler source))
2172 (loop (read (current-input-port) #t read-sharp))))
2174 ;; A provisional repl that acts like the SCM repl:
2176 (define scm-repl-silent #f)
2177 (define (assert-repl-silence v) (set! scm-repl-silent v))
2179 (define scm-repl-verbose #t)
2180 (define (assert-repl-verbosity v) (set! scm-repl-verbose v))
2182 (define scm-repl-prompt #t)
2183 (define (assert-repl-prompt v) (set! scm-repl-prompt v))
2185 (define the-prompt-string "guile> ")
2187 (define (error-catching-loop thunk)
2188 (define (loop first)
2193 (lambda () (unmask-signals))
2197 ;; This line is needed because mark doesn't do closures quite right.
2198 ;; Unreferenced locals should be collected.
2201 (let loop ((v (thunk)))
2204 (lambda () (mask-signals))))
2206 (lambda (key . args)
2208 ((quit) (force-output)
2212 ((abort) ;; This is one of the closures that require (set! first #f)
2217 (display "ABORT: " (current-error-port))
2218 (write args (current-error-port))
2219 (newline (current-error-port))))
2221 (else ;; This is the other cons-leak closure...
2223 (apply %%bad-throw key args))))))))
2224 (and next (loop next))))
2225 (loop (lambda () #t)))
2227 (define (quit . args)
2228 (apply throw 'quit args))
2230 (define (error-catching-repl r e p)
2231 (error-catching-loop (lambda () (p (e (r))))))
2233 (define (gc-run-time)
2234 (cdr (assq 'gc-time-taken (gc-stats))))
2236 (define (scm-style-repl)
2240 (repl-report-reset (lambda () #f))
2241 (repl-report-start-timing (lambda ()
2242 (set! start-gc-rt (gc-run-time))
2243 (set! start-rt (get-internal-run-time))))
2244 (repl-report (lambda ()
2246 (display (inexact->exact
2247 (* 1000 (/ (- (get-internal-run-time) start-rt)
2248 internal-time-units-per-second))))
2250 (display (inexact->exact
2251 (* 1000 (/ (- (gc-run-time) start-gc-rt)
2252 internal-time-units-per-second))))
2253 (display " msec in gc)\n")))
2257 (display the-prompt-string)
2259 (repl-report-reset)))
2260 (let ((val (read (current-input-port) #t read-sharp)))
2261 (if (eof-object? val)
2263 (if scm-repl-verbose
2266 (display ";;; EOF -- quitting")
2271 (-eval (lambda (sourc)
2272 (repl-report-start-timing)
2275 (-print (lambda (result)
2276 (if (not scm-repl-silent)
2280 (if scm-repl-verbose
2285 (if scm-repl-verbose
2287 (display ";;; QUIT executed, repl exitting")
2293 (if scm-repl-verbose
2295 (display ";;; ABORT executed.")
2298 (repl -read -eval -print))))
2300 (error-catching-repl -read
2304 (define (stand-alone-repl)
2305 (let ((oport (current-input-port)))
2306 (set-current-input-port *stdin*)
2308 (set-current-input-port oport)))
2314 (define (reverse-iota n) (if (> n 0) (cons (1- n) (reverse-iota (1- n))) '()))
2315 (define (iota n) (list-reverse! (reverse-iota n)))
2320 ;;; with `continue' and `break'.
2323 (defmacro while (cond . body)
2324 `(letrec ((continue (lambda () (or (not ,cond) (begin (begin ,@ body) (continue)))))
2325 (break (lambda val (apply throw 'break val))))
2327 (lambda () (continue))
2328 (lambda v (cadr v)))))
2336 ;; actually....hobbit might be able to hack these with a little
2340 (defmacro define-macro (first . rest)
2341 (let ((name (if (symbol? first) first (car first)))
2345 `(lambda ,(cdr first) ,@rest))))
2346 `(define ,name (defmacro:transformer ,transformer))))
2349 (defmacro define-syntax-macro (first . rest)
2350 (let ((name (if (symbol? first) first (car first)))
2354 `(lambda ,(cdr first) ,@rest))))
2355 `(define ,name (defmacro:syntax-transformer ,transformer))))
2357 ;;; {Module System Macros}
2360 (defmacro define-module args
2361 `(let* ((process-define-module process-define-module)
2362 (set-current-module set-current-module)
2363 (module (process-define-module ',args)))
2364 (set-current-module module)
2367 (define define-private define)
2369 (defmacro define-public args
2371 (error "bad syntax" (list 'define-public args)))
2372 (define (defined-name n)
2375 ((pair? n) (defined-name (car n)))
2378 ((null? args) (syntax))
2380 (#t (let ((name (defined-name (car args))))
2382 (let ((public-i (module-public-interface (current-module))))
2383 ;; Make sure there is a local variable:
2385 (module-define! (current-module)
2387 (module-ref (current-module) ',name #f))
2389 ;; Make sure that local is exported:
2391 (module-add! public-i ',name (module-variable (current-module) ',name)))
2393 ;; Now (re)define the var normally.
2395 (define-private ,@ args))))))
2399 (defmacro defmacro-public args
2401 (error "bad syntax" (list 'defmacro-public args)))
2402 (define (defined-name n)
2407 ((null? args) (syntax))
2409 (#t (let ((name (defined-name (car args))))
2411 (let ((public-i (module-public-interface (current-module))))
2412 ;; Make sure there is a local variable:
2414 (module-define! (current-module)
2416 (module-ref (current-module) ',name #f))
2418 ;; Make sure that local is exported:
2420 (module-add! public-i ',name (module-variable (current-module) ',name)))
2422 ;; Now (re)define the var normally.
2424 (defmacro ,@ args))))))
2429 (define try-load-with-path try-load-module-with-path)
2430 (define try-load try-load-module)
2431 (define load-with-path load-module-with-path)
2432 (define load load-module)
2437 ;; (define in-ch (get-standard-channel TCL_STDIN))
2438 ;; (define out-ch (get-standard-channel TCL_STDOUT))
2439 ;; (define err-ch (get-standard-channel TCL_STDERR))
2441 ;; (define inp (%make-channel-port in-ch "r"))
2442 ;; (define outp (%make-channel-port out-ch "w"))
2443 ;; (define errp (%make-channel-port err-ch "w"))
2445 ;; (define %system-char-ready? char-ready?)
2447 ;; (define (char-ready? p)
2448 ;; (if (not (channel-port? p))
2449 ;; (%system-char-ready? p)
2450 ;; (let* ((channel (%channel-port-channel p))
2451 ;; (old-blocking (channel-option-ref channel :blocking)))
2453 ;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking "0"))
2454 ;; (lambda () (not (eof-object? (peek-char p))))
2455 ;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking old-blocking))))))
2457 ;; (define (top-repl)
2458 ;; (with-input-from-port inp
2460 ;; (with-output-to-port outp
2462 ;; (with-error-to-port errp
2464 ;; (scm-style-repl))))))))
2466 ;; (set-current-input-port inp)
2467 ;; (set-current-output-port outp)
2468 ;; (set-current-error-port errp)
2470 (define (top-repl) (scm-style-repl))
2473 (define-module (ice-9 calling))
2476 ;;; {Calling Conventions}
2478 ;;; This file contains a number of macros that support
2479 ;;; common calling conventions.
2482 ;;; with-excursion-function <vars> proc
2483 ;;; <vars> is an unevaluated list of names that are bound in the caller.
2484 ;;; proc is a procedure, called:
2485 ;;; (proc excursion)
2487 ;;; excursion is a procedure isolates all changes to <vars>
2488 ;;; in the dynamic scope of the call to proc. In other words,
2489 ;;; the values of <vars> are saved when proc is entered, and when
2490 ;;; proc returns, those values are restored. Values are also restored
2491 ;;; entering and leaving the call to proc non-locally, such as using
2492 ;;; call-with-current-continuation, error, or throw.
2494 (defmacro-public with-excursion-function (vars proc)
2495 `(,proc ,(excursion-function-syntax vars)))
2499 ;;; with-getter-and-setter <vars> proc
2500 ;;; <vars> is an unevaluated list of names that are bound in the caller.
2501 ;;; proc is a procedure, called:
2502 ;;; (proc getter setter)
2504 ;;; getter and setter are procedures used to access
2505 ;;; or modify <vars>.
2507 ;;; setter, called with keywords arguments, modifies the named
2508 ;;; values. If "foo" and "bar" are among <vars>, then:
2510 ;;; (setter :foo 1 :bar 2)
2511 ;;; == (set! foo 1 bar 2)
2513 ;;; getter, called with just keywords, returns
2514 ;;; a list of the corresponding values. For example,
2515 ;;; if "foo" and "bar" are among the <vars>, then
2517 ;;; (getter :foo :bar)
2518 ;;; => (<value-of-foo> <value-of-bar>)
2520 ;;; getter, called with no arguments, returns a list of all accepted
2521 ;;; keywords and the corresponding values. If "foo" and "bar" are
2522 ;;; the *only* <vars>, then:
2525 ;;; => (:foo <value-of-bar> :bar <value-of-foo>)
2527 ;;; The unusual calling sequence of a getter supports too handy
2530 ;;; (apply setter (getter)) ;; save and restore
2532 ;;; (apply-to-args (getter :foo :bar) ;; fetch and bind
2533 ;;; (lambda (foo bar) ....))
2535 ;;; ;; [ "apply-to-args" is just like two-argument "apply" except that it
2536 ;;; ;; takes its arguments in a different order.
2539 (defmacro-public with-getter-and-setter (vars proc)
2540 `(,proc ,@ (getter-and-setter-syntax vars)))
2542 ;;; with-getter vars proc
2543 ;;; A short-hand for a call to with-getter-and-setter.
2544 ;;; The procedure is called:
2547 (defmacro-public with-getter (vars proc)
2548 `(,proc ,(car (getter-and-setter-syntax vars))))
2551 ;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
2552 ;;; Compose getters and setters.
2554 ;;; <vars> is an unevaluated list of names that are bound in the caller.
2556 ;;; get-delegate is called by the new getter to extend the set of
2557 ;;; gettable variables beyond just <vars>
2558 ;;; set-delegate is called by the new setter to extend the set of
2559 ;;; gettable variables beyond just <vars>
2561 ;;; proc is a procedure that is called
2562 ;;; (proc getter setter)
2564 (defmacro-public with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
2565 `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
2568 ;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
2569 ;;; <vars> is an unevaluated list of names that are bound in the caller.
2572 ;;; (proc excursion getter setter)
2575 ;;; with-getter-and-setter
2576 ;;; with-excursion-function
2578 (defmacro-public with-excursion-getter-and-setter (vars proc)
2579 `(,proc ,(excursion-function-syntax vars)
2580 ,@ (getter-and-setter-syntax vars)))
2583 (define (excursion-function-syntax vars)
2584 (let ((saved-value-names (map gensym vars))
2585 (tmp-var-name (gensym 'temp))
2586 (swap-fn-name (gensym 'swap))
2587 (thunk-name (gensym 'thunk)))
2588 `(lambda (,thunk-name)
2589 (letrec ((,tmp-var-name #f)
2591 (lambda () ,@ (map (lambda (n sn) `(set! ,tmp-var-name ,n ,n ,sn ,sn ,tmp-var-name))
2592 vars saved-value-names)))
2593 ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
2600 (define (getter-and-setter-syntax vars)
2601 (let ((args-name (gensym 'args))
2602 (an-arg-name (gensym 'an-arg))
2603 (new-val-name (gensym 'new-value))
2604 (loop-name (gensym 'loop))
2605 (kws (map symbol->keyword vars)))
2606 (list `(lambda ,args-name
2607 (let ,loop-name ((,args-name ,args-name))
2608 (if (null? ,args-name)
2611 `(let ((all-vals (,loop-name ',kws)))
2612 (let ,loop-name ((vals all-vals)
2616 `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
2617 (map (lambda (,an-arg-name)
2620 (map (lambda (kw v) `((,kw) ,v)) kws vars)
2621 `((else (throw 'bad-get-option ,an-arg-name))))))
2625 (let ,loop-name ((,args-name ,args-name))
2626 (or (null? ,args-name)
2627 (null? (cdr ,args-name))
2628 (let ((,an-arg-name (car ,args-name))
2629 (,new-val-name (cadr ,args-name)))
2632 (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
2633 `((else (throw 'bad-set-option ,an-arg-name)))))
2634 (,loop-name (cddr ,args-name)))))))))
2636 (define (delegating-getter-and-setter-syntax vars get-delegate set-delegate)
2637 (let ((args-name (gensym 'args))
2638 (an-arg-name (gensym 'an-arg))
2639 (new-val-name (gensym 'new-value))
2640 (loop-name (gensym 'loop))
2641 (kws (map symbol->keyword vars)))
2642 (list `(lambda ,args-name
2643 (let ,loop-name ((,args-name ,args-name))
2644 (if (null? ,args-name)
2648 `(let ((all-vals (,loop-name ',kws)))
2649 (let ,loop-name ((vals all-vals)
2653 `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
2655 (map (lambda (,an-arg-name)
2658 (map (lambda (kw v) `((,kw) ,v)) kws vars)
2659 `((else (car (,get-delegate ,an-arg-name)))))))
2663 (let ,loop-name ((,args-name ,args-name))
2664 (or (null? ,args-name)
2665 (null? (cdr ,args-name))
2666 (let ((,an-arg-name (car ,args-name))
2667 (,new-val-name (cadr ,args-name)))
2670 (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
2671 `((else (,set-delegate ,an-arg-name ,new-val-name)))))
2672 (,loop-name (cddr ,args-name)))))))))
2677 ;;; with-configuration-getter-and-setter <vars-etc> proc
2679 ;;; Create a getter and setter that can trigger arbitrary computation.
2681 ;;; <vars-etc> is a list of variable specifiers, explained below.
2684 ;;; (proc getter setter)
2686 ;;; Each element of the <vars-etc> list is of the form:
2688 ;;; (<var> getter-hook setter-hook)
2690 ;;; Both hook elements are evaluated; the variable name is not.
2691 ;;; Either hook may be #f or procedure.
2693 ;;; A getter hook is a thunk that returns a value for the corresponding
2694 ;;; variable. If omitted (#f is passed), the binding of <var> is
2697 ;;; A setter hook is a procedure of one argument that accepts a new value
2698 ;;; for the corresponding variable. If omitted, the binding of <var>
2699 ;;; is simply set using set!.
2701 (defmacro-public with-configuration-getter-and-setter (vars-etc proc)
2702 `((lambda (simpler-get simpler-set body-proc)
2703 (with-delegating-getter-and-setter ()
2704 simpler-get simpler-set body-proc))
2708 ,@(map (lambda (v) `((,(symbol->keyword (car v)))
2711 (else `(list ,(car v))))))
2714 (lambda (kw new-val)
2716 ,@(map (lambda (v) `((,(symbol->keyword (car v)))
2718 ((caddr v) => (lambda (proc) `(,proc new-val)))
2719 (else `(set! ,(car v) new-val)))))
2724 (defmacro-public with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
2725 `((lambda (simpler-get simpler-set body-proc)
2726 (with-delegating-getter-and-setter ()
2727 simpler-get simpler-set body-proc))
2731 ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
2734 (else `(list ,(car v))))))
2736 `((else (,delegate-get kw))))))
2738 (lambda (kw new-val)
2740 ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
2742 ((caddr v) => (lambda (proc) `(,proc new-val)))
2743 (else `(set! ,(car v) new-val)))))
2745 `((else (,delegate-set kw new-val))))))
2750 ;;; let-configuration-getter-and-setter <vars-etc> proc
2752 ;;; This procedure is like with-configuration-getter-and-setter (q.v.)
2753 ;;; except that each element of <vars-etc> is:
2755 ;;; (<var> initial-value getter-hook setter-hook)
2757 ;;; Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
2758 ;;; introduces bindings for the variables named in <vars-etc>.
2759 ;;; It is short-hand for:
2761 ;;; (let ((<var1> initial-value-1)
2762 ;;; (<var2> initial-value-2)
2764 ;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
2766 (defmacro-public let-with-configuration-getter-and-setter (vars-etc proc)
2767 `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
2768 (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
2774 (define-module (ice-9 common-list))
2776 ;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
2777 ; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
2779 ;Permission to copy this software, to redistribute it, and to use it
2780 ;for any purpose is granted, subject to the following restrictions and
2783 ;1. Any copy made of this software must include this copyright notice
2786 ;2. I have made no warrantee or representation that the operation of
2787 ;this software will be error-free, and I am under no obligation to
2788 ;provide any services, by way of maintenance, update, or otherwise.
2790 ;3. In conjunction with products arising from the use of this
2791 ;material, there shall be no use of my name in any advertising,
2792 ;promotional, or sales literature without prior written consent in
2798 ;;;From: hugh@ear.mit.edu (Hugh Secker-Walker)
2799 (define-public (make-list k . init)
2800 (set! init (if (pair? init) (car init)))
2802 (result '() (cons init result)))
2805 (define-public (adjoin e l) (if (memq e l) l (cons e l)))
2807 (define-public (union l1 l2)
2808 (cond ((null? l1) l2)
2810 (else (union (cdr l1) (adjoin (car l1) l2)))))
2812 (define-public (intersection l1 l2)
2813 (cond ((null? l1) l1)
2815 ((memv (car l1) l2) (cons (car l1) (intersection (cdr l1) l2)))
2816 (else (intersection (cdr l1) l2))))
2818 (define-public (set-difference l1 l2)
2819 (cond ((null? l1) l1)
2820 ((memv (car l1) l2) (set-difference (cdr l1) l2))
2821 (else (cons (car l1) (set-difference (cdr l1) l2)))))
2823 (define-public (reduce-init p init l)
2826 (reduce-init p (p init (car l)) (cdr l))))
2828 (define-public (reduce p l)
2830 ((null? (cdr l)) (car l))
2831 (else (reduce-init p (car l) (cdr l)))))
2833 (define-public (some pred l . rest)
2836 (and (not (null? l))
2837 (or (pred (car l)) (mapf (cdr l))))))
2838 (else (let mapf ((l l) (rest rest))
2839 (and (not (null? l))
2840 (or (apply pred (car l) (map car rest))
2841 (mapf (cdr l) (map cdr rest))))))))
2843 (define-public (every pred l . rest)
2847 (and (pred (car l)) (mapf (cdr l))))))
2848 (else (let mapf ((l l) (rest rest))
2850 (and (apply pred (car l) (map car rest))
2851 (mapf (cdr l) (map cdr rest))))))))
2853 (define-public (notany pred . ls) (not (apply some pred ls)))
2855 (define-public (notevery pred . ls) (not (apply every pred ls)))
2857 (define-public (find-if t l)
2858 (cond ((null? l) #f)
2859 ((t (car l)) (car l))
2860 (else (find-if t (cdr l)))))
2862 (define-public (member-if t l)
2863 (cond ((null? l) #f)
2865 (else (member-if t (cdr l)))))
2867 (define-public (remove-if p l)
2868 (cond ((null? l) '())
2869 ((p (car l)) (remove-if p (cdr l)))
2870 (else (cons (car l) (remove-if p (cdr l))))))
2872 (define-public (delete-if! pred list)
2873 (let delete-if ((list list))
2874 (cond ((null? list) '())
2875 ((pred (car list)) (delete-if (cdr list)))
2877 (set-cdr! list (delete-if (cdr list)))
2880 (define-public (delete-if-not! pred list)
2881 (let delete-if ((list list))
2882 (cond ((null? list) '())
2883 ((not (pred (car list))) (delete-if (cdr list)))
2885 (set-cdr! list (delete-if (cdr list)))
2888 (define-public (butlast lst n)
2889 (letrec ((l (- (length lst) n))
2891 (cond ((null? lst) lst)
2893 (cons (car lst) (bl (cdr lst) (+ -1 n))))
2895 (bl lst (if (negative? n)
2896 (slib:error "negative argument to butlast" n)
2899 (define-public (and? . args)
2900 (cond ((null? args) #t)
2901 ((car args) (apply and? (cdr args)))
2904 (define-public (or? . args)
2905 (cond ((null? args) #f)
2907 (else (apply or? (cdr args)))))
2909 (define-public (has-duplicates? lst)
2910 (cond ((null? lst) #f)
2911 ((member (car lst) (cdr lst)) #t)
2912 (else (has-duplicates? (cdr lst)))))
2914 (define-public (list* x . y)
2918 (cons (car x) (list*1 (cdr x)))))
2921 (cons x (list*1 y))))
2924 ;; Apply P to each element of L, returning a list of elts
2925 ;; for which P returns a non-#f value.
2927 (define-public (pick p l)
2932 ((p (car l)) (loop (cons (car l) s) (cdr l)))
2933 (else (loop s (cdr l))))))
2936 ;; Apply P to each element of L, returning a list of the
2937 ;; non-#f return values of P.
2939 (define-public (pick-mappings p l)
2944 ((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l))))
2945 (else (loop s (cdr l))))))
2947 (define-public (uniq l)
2950 (let ((u (uniq (cdr l))))
2951 (if (memq (car l) u)
2953 (cons (car l) u)))))
2956 (define-module (ice-9 ls)
2957 :use-module (ice-9 common-list))
2962 ;;; local-definitions-in root name
2963 ;;; Returns a list of names defined locally in the named subdirectory of root.
2964 ;;; definitions-in root name
2965 ;;; Returns a list of all names defined in the named subdirectory of root.
2966 ;;; The list includes alll locally defined names as well as all names inherited
2967 ;;; from a member of a use-list.
2969 ;;; A convenient interface for examining the nature of things:
2971 ;;; ls . various-names
2973 ;;; With just one argument, interpret that argument as the name of a subdirectory
2974 ;;; of the current module and return a list of names defined there.
2976 ;;; With more than one argument, still compute subdirectory lists, but
2978 ;;; ((<subdir-name> . <names-defined-there>)
2979 ;;; (<subdir-name> . <names-defined-there>)
2983 (define-public (local-definitions-in root names)
2984 (let ((m (resolved-ref root names))
2986 (if (not (module? m))
2988 (module-for-each (lambda (k v) (set! answer (cons k answer))) m))
2991 (define-public (definitions-in root names)
2992 (let ((m (resolved-ref root names)))
2993 (if (not (module? m))
2996 (cons (local-definitions-in m '())
2997 (map (lambda (m2) (definitions-in m2 '())) (module-uses m)))))))
2999 (define-public (ls . various-refs)
3001 (if (cdr various-refs)
3003 (cons ref (definitions-in (current-module) ref)))
3005 (definitions-in (current-module) (car various-refs)))))
3007 (define-public (lls . various-refs)
3009 (if (cdr various-refs)
3011 (cons ref (local-definitions-in (current-module) ref)))
3013 (local-definitions-in (current-module) (car various-refs)))))
3015 (define-public (recursive-value-define name value)
3016 (let ((parent (reverse! (cdr (reverse name)))))
3017 (and parent (make-modules-in (current-module) parent))
3018 (value-define name value)))
3020 (define-module (ice-9 q))
3022 ;;;; Copyright (C) 1995 Free Software Foundation, Inc.
3024 ;;;; This program is free software; you can redistribute it and/or modify
3025 ;;;; it under the terms of the GNU General Public License as published by
3026 ;;;; the Free Software Foundation; either version 2, or (at your option)
3027 ;;;; any later version.
3029 ;;;; This program is distributed in the hope that it will be useful,
3030 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
3031 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3032 ;;;; GNU General Public License for more details.
3034 ;;;; You should have received a copy of the GNU General Public License
3035 ;;;; along with this software; see the file COPYING. If not, write to
3036 ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
3041 ;;; Q: Based on the interface to
3043 ;;; "queue.scm" Queues/Stacks for Scheme
3044 ;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
3051 ;;; A list is just a bunch of cons pairs that follows some constrains, right?
3052 ;;; Association lists are the same. Hash tables are just vectors and association
3053 ;;; lists. You can print them, read them, write them as constants, pun them off as other data
3054 ;;; structures etc. This is good. This is lisp. These structures are fast and compact
3055 ;;; and easy to manipulate arbitrarily because of their simple, regular structure and
3056 ;;; non-disjointedness (associations being lists and so forth).
3058 ;;; So I figured, queues should be the same -- just a "subtype" of cons-pair
3059 ;;; structures in general.
3061 ;;; A queue is a cons pair:
3062 ;;; ( <the-q> . <last-pair> )
3064 ;;; <the-q> is a list of things in the q. New elements go at the end of that list.
3066 ;;; <last-pair> is #f if the q is empty, and otherwise is the last pair of <the-q>.
3068 ;;; q's print nicely, but alas, they do not read well because the eq?-ness of
3069 ;;; <last-pair> and (last-pair <the-q>) is lost by read. The procedure
3073 ;;; recomputes and resets the <last-pair> component of a queue.
3076 (define-public (sync-q! obj) (set-cdr! obj (and (car obj) (last-pair (car obj)))))
3081 (define-public (make-q) (cons '() '()))
3084 ;;; Return true if obj is a Q.
3085 ;;; An object is a queue if it is equal? to '(#f . #f) or
3086 ;;; if it is a pair P with (list? (car P)) and (eq? (cdr P) (last-pair P)).
3088 (define-public (q? obj) (and (pair? obj)
3089 (or (and (null? (car obj))
3093 (eq? (cdr obj) (last-pair (car obj)))))))
3097 (define-public (q-empty? obj) (null? (car obj)))
3100 ;;; Throw a q-empty exception if Q is empty.
3101 (define-public (q-empty-check q) (if (q-empty? q) (throw 'q-empty q)))
3105 ;;; Return the first element of Q.
3106 (define-public (q-front q) (q-empty-check q) (caar q))
3109 ;;; Return the last element of Q.
3110 (define-public (q-rear q) (q-empty-check q) (cadr q))
3113 ;;; Remove all occurences of obj from Q.
3114 (define-public (q-remove! q obj)
3115 (while (memq obj (car q))
3116 (set-car! q (delq! obj (car q))))
3117 (set-cdr! q (last-pair (car q))))
3120 ;;; Add obj to the front of Q
3121 (define-public (q-push! q d)
3122 (let ((h (cons d (car q))))
3128 ;;; Add obj to the rear of Q
3129 (define-public (enq! q d)
3130 (let ((h (cons d '())))
3131 (if (not (null? (cdr q)))
3132 (set-cdr! (cdr q) h)
3137 ;;; Take the front of Q and return it.
3138 (define-public (q-pop! q)
3148 ;;; Take the front of Q and return it.
3149 (define-public deq! q-pop!)
3152 ;;; Return the number of enqueued elements.
3154 (define-public (q-length q) (length (car q)))
3159 ;;; installed-scm-file
3160 (define-module (ice-9 runq)
3161 :use-module (ice-9 q))
3165 ;;;; Copyright (C) 1996 Free Software Foundation, Inc.
3167 ;;;; This program is free software; you can redistribute it and/or modify
3168 ;;;; it under the terms of the GNU General Public License as published by
3169 ;;;; the Free Software Foundation; either version 2, or (at your option)
3170 ;;;; any later version.
3172 ;;;; This program is distributed in the hope that it will be useful,
3173 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
3174 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3175 ;;;; GNU General Public License for more details.
3177 ;;;; You should have received a copy of the GNU General Public License
3178 ;;;; along with this software; see the file COPYING. If not, write to
3179 ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
3185 ;;; {The runq data structure}
3187 ;;; One way to schedule parallel computations in a serial environment is
3188 ;;; to explicitly divide each task up into small, finite execution time,
3189 ;;; strips. Then you interleave the execution of strips from various
3190 ;;; tasks to achieve a kind of parallelism. Runqs are a handy data
3191 ;;; structure for this style of programming.
3193 ;;; We use thunks (nullary procedures) and lists of thunks to represent
3194 ;;; strips. By convention, the return value of a strip-thunk must either
3195 ;;; be another strip or the value #f.
3197 ;;; A runq is a procedure that manages a queue of strips. Called with no
3198 ;;; arguments, it processes one strip from the queue. Called with
3199 ;;; arguments, the arguments form a control message for the queue. The
3200 ;;; first argument is a symbol which is the message selector.
3202 ;;; A strip is processed this way: If the strip is a thunk, the thunk is
3203 ;;; called -- if it returns a strip, that strip is added back to the
3204 ;;; queue. To process a strip which is a list of thunks, the CAR of that
3205 ;;; list is called. After a call to that CAR, there are 0, 1, or 2 strips
3206 ;;; -- perhaps one returned by the thunk, and perhaps the CDR of the
3207 ;;; original strip if that CDR is not nil. The runq puts whichever of
3208 ;;; these strips exist back on the queue. (The exact order in which
3209 ;;; strips are put back on the queue determines the scheduling behavior of
3210 ;;; a particular queue -- it's a parameter.)
3217 ;;; (runq-control q msg . args)
3219 ;;; processes in the default way the control messages that
3220 ;;; can be sent to a runq. Q should be an ordinary
3221 ;;; Q (see utils/q.scm).
3223 ;;; The standard runq messages are:
3225 ;;; 'add! strip0 strip1... ;; to enqueue one or more strips
3226 ;;; 'enqueue! strip0 strip1... ;; to enqueue one or more strips
3227 ;;; 'push! strip0 ... ;; add strips to the front of the queue
3228 ;;; 'empty? ;; true if it is
3229 ;;; 'length ;; how many strips in the queue?
3230 ;;; 'kill! ;; empty the queue
3231 ;;; else ;; throw 'not-understood
3233 (define-public (runq-control q msg . args)
3235 ((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
3236 ((enque!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
3237 ((push!) (for-each (lambda (t) (q-push! q t)) args) '*unspecified*)
3238 ((empty?) (q-empty? q))
3239 ((length) (q-length q))
3240 ((kill!) (set! q (make-q)))
3241 (else (throw 'not-understood msg args))))
3243 (define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f)))
3248 ;;; Make a runq that discards all messages except "length", for which
3251 (define-public (make-void-runq)
3255 (lambda (msg . args)
3261 ;;; (make-fair-runq)
3263 ;;; Returns a runq procedure.
3264 ;;; Called with no arguments, the procedure processes one strip from the queue.
3265 ;;; Called with arguments, it uses runq-control.
3267 ;;; In a fair runq, if a strip returns a new strip X, X is added
3268 ;;; to the end of the queue, meaning it will be the last to execute
3269 ;;; of all the remaining procedures.
3271 (define-public (make-fair-runq)
3272 (letrec ((q (make-q))
3276 (apply runq-control q ctl)
3277 (and (not (q-empty? q))
3278 (let ((next-strip (deq! q)))
3280 ((procedure? next-strip) (let ((k (run-strip next-strip)))
3281 (and k (enq! q k))))
3282 ((pair? next-strip) (let ((k (run-strip (car next-strip))))
3284 (if (not (null? (cdr next-strip)))
3285 (enq! q (cdr next-strip)))))
3291 ;;; (make-exclusive-runq)
3293 ;;; Returns a runq procedure.
3294 ;;; Called with no arguments, the procedure processes one strip from the queue.
3295 ;;; Called with arguments, it uses runq-control.
3297 ;;; In an exclusive runq, if a strip W returns a new strip X, X is added
3298 ;;; to the front of the queue, meaning it will be the next to execute
3299 ;;; of all the remaining procedures.
3301 ;;; An exception to this occurs if W was the CAR of a list of strips.
3302 ;;; In that case, after the return value of W is pushed onto the front
3303 ;;; of the queue, the CDR of the list of strips is pushed in front
3304 ;;; of that (if the CDR is not nil). This way, the rest of the thunks
3305 ;;; in the list that contained W have priority over the return value of W.
3307 (define-public (make-exclusive-runq)
3308 (letrec ((q (make-q))
3312 (apply runq-control q ctl)
3313 (and (not (q-empty? q))
3314 (let ((next-strip (deq! q)))
3316 ((procedure? next-strip) (let ((k (run-strip next-strip)))
3317 (and k (q-push! q k))))
3318 ((pair? next-strip) (let ((k (run-strip (car next-strip))))
3319 (and k (q-push! q k)))
3320 (if (not (null? (cdr next-strip)))
3321 (q-push! q (cdr next-strip)))))
3327 ;;; (make-subordinate-runq-to superior basic-inferior)
3329 ;;; Returns a runq proxy for the runq basic-inferior.
3331 ;;; The proxy watches for operations on the basic-inferior that cause
3332 ;;; a transition from a queue length of 0 to a non-zero length and
3333 ;;; vice versa. While the basic-inferior queue is not empty,
3334 ;;; the proxy installs a task on the superior runq. Each strip
3335 ;;; of that task processes N strips from the basic-inferior where
3336 ;;; N is the length of the basic-inferior queue when the proxy
3337 ;;; strip is entered. [Countless scheduling variations are possible.]
3339 (define-public (make-subordinate-runq-to superior-runq basic-runq)
3340 (let ((runq-task (cons #f #f)))
3343 (if (basic-runq 'empty?)
3344 (set-cdr! runq-task #f)
3345 (do ((n (basic-runq 'length) (1- n)))
3351 (let ((answer (basic-runq)))
3356 ((suspend) (set-cdr! runq-task #f))
3357 (else (let ((answer (apply basic-runq ctl)))
3358 (if (and (not (cdr runq-task)) (not (basic-runq 'empty?)))
3360 (set-cdr! runq-task runq-task)
3361 (superior-runq 'add! runq-task)))
3366 ;;; (define fork-strips (lambda args args))
3367 ;;; Return a strip that starts several strips in
3368 ;;; parallel. If this strip is enqueued on a fair
3369 ;;; runq, strips of the parallel subtasks will run
3370 ;;; round-robin style.
3372 (define fork-strips (lambda args args))
3376 ;;; (strip-sequence . strips)
3378 ;;; Returns a new strip which is the concatenation of the argument strips.
3380 (define-public ((strip-sequence . strips))
3381 (let loop ((st (let ((a strips)) (set! strips #f) a)))
3382 (and (not (null? st))
3383 (let ((then ((car st))))
3385 (lambda () (loop (cons then (cdr st))))
3386 (lambda () (loop (cdr st))))))))
3390 ;;; (fair-strip-subtask . initial-strips)
3392 ;;; Returns a new strip which is the synchronos, fair,
3393 ;;; parallel execution of the argument strips.
3397 (define-public (fair-strip-subtask . initial-strips)
3398 (let ((st (make-fair-runq)))
3399 (apply st 'add! initial-strips)
3404 ;;; installed-scm-file
3406 (define-module (ice-9 string-fun))
3412 ;;; Various string funcitons, particularly those that take
3413 ;;; advantage of the "shared substring" capability.
3417 ;;; {Dividing Strings Into Fields}
3419 ;;; The names of these functions are very regular.
3420 ;;; Here is a grammar of a call to one of these:
3422 ;;; <string-function-invocation>
3423 ;;; := (<action>-<seperator-disposition>-<seperator-determination> <seperator-param> <str> <ret>)
3425 ;;; <str> = the string
3427 ;;; <ret> = The continuation. String functions generally return
3428 ;;; multiple values by passing them to this procedure.
3430 ;;; <action> = split
3431 ;;; | separate-fields
3433 ;;; "split" means to divide a string into two parts.
3434 ;;; <ret> will be called with two arguments.
3436 ;;; "separate-fields" means to divide a string into as many
3437 ;;; parts as possible. <ret> will be called with
3438 ;;; however many fields are found.
3440 ;;; <seperator-disposition> = before
3444 ;;; "before" means to leave the seperator attached to
3445 ;;; the beginning of the field to its right.
3446 ;;; "after" means to leave the seperator attached to
3447 ;;; the end of the field to its left.
3448 ;;; "discarding" means to discard seperators.
3450 ;;; Other dispositions might be handy. For example, "isolate"
3451 ;;; could mean to treat the separator as a field unto itself.
3453 ;;; <seperator-determination> = char
3456 ;;; "char" means to use a particular character as field seperator.
3457 ;;; "predicate" means to check each character using a particular predicate.
3459 ;;; Other determinations might be handy. For example, "character-set-member".
3461 ;;; <seperator-param> = A parameter that completes the meaning of the determinations.
3462 ;;; For example, if the determination is "char", then this parameter
3463 ;;; says which character. If it is "predicate", the parameter is the
3469 ;;; (separate-fields-discarding-char #\, "foo, bar, baz, , bat" list)
3470 ;;; => ("foo" " bar" " baz" " " " bat")
3472 ;;; (split-after-char #\- 'an-example-of-split list)
3473 ;;; => ("an-" "example-of-split")
3475 ;;; As an alternative to using a determination "predicate", or to trying to do anything
3476 ;;; complicated with these functions, consider using regular expressions.
3479 (define-public (split-after-char char str ret)
3481 ((string-index str char) => 1+)
3482 (else (string-length str)))))
3483 (ret (make-shared-substring str 0 end)
3484 (make-shared-substring str end))))
3486 (define-public (split-before-char char str ret)
3487 (let ((end (or (string-index str char)
3488 (string-length str))))
3489 (ret (make-shared-substring str 0 end)
3490 (make-shared-substring str end))))
3492 (define-public (split-discarding-char char str ret)
3493 (let ((end (string-index str char)))
3496 (ret (make-shared-substring str 0 end)
3497 (make-shared-substring str (1+ end))))))
3499 (define-public (split-after-char-last char str ret)
3501 ((string-rindex str char) => 1+)
3503 (ret (make-shared-substring str 0 end)
3504 (make-shared-substring str end))))
3506 (define-public (split-before-char-last char str ret)
3507 (let ((end (or (string-rindex str char) 0)))
3508 (ret (make-shared-substring str 0 end)
3509 (make-shared-substring str end))))
3511 (define-public (split-discarding-char-last char str ret)
3512 (let ((end (string-rindex str char)))
3515 (ret (make-shared-substring str 0 end)
3516 (make-shared-substring str (1+ end))))))
3518 (define (split-before-predicate pred str ret)
3521 ((= n (length str)) (ret str ""))
3522 ((not (pred (string-ref str n))) (loop (1+ n)))
3523 (else (ret (make-shared-substring str 0 n)
3524 (make-shared-substring str n))))))
3525 (define (split-after-predicate pred str ret)
3528 ((= n (length str)) (ret str ""))
3529 ((not (pred (string-ref str n))) (loop (1+ n)))
3530 (else (ret (make-shared-substring str 0 (1+ n))
3531 (make-shared-substring str (1+ n)))))))
3533 (define (split-discarding-predicate pred str ret)
3536 ((= n (length str)) (ret str ""))
3537 ((not (pred (string-ref str n))) (loop (1+ n)))
3538 (else (ret (make-shared-substring str 0 n)
3539 (make-shared-substring str (1+ n)))))))
3541 (define-public (seperate-fields-discarding-char ch str ret)
3542 (let loop ((fields '())
3545 ((string-rindex str ch)
3546 => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 w)) fields)
3547 (make-shared-substring str 0 w))))
3548 (else (ret (cons str fields))))))
3550 (define-public (seperate-fields-after-char ch str ret)
3551 (let loop ((fields '())
3554 ((string-rindex str ch)
3555 => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 w)) fields)
3556 (make-shared-substring str 0 (+ 1 w)))))
3557 (else (ret (cons str fields))))))
3559 (define-public (seperate-fields-before-char ch str ret)
3560 (let loop ((fields '())
3563 ((string-rindex str ch)
3564 => (lambda (pos) (loop (cons (make-shared-substring str w) fields)
3565 (make-shared-substring str 0 w))))
3566 (else (ret (cons str fields))))))
3570 ;;; {String Prefix Predicates}
3574 :;; (define-public ((string-prefix-predicate pred?) prefix str)
3575 ;;; (and (<= (length prefix) (length str))
3576 ;;; (pred? prefix (make-shared-substring str 0 (length prefix)))))
3578 ;;; (define-public string-prefix=? (string-prefix-predicate string=?))
3581 (define-public ((string-prefix-predicate pred?) prefix str)
3582 (and (<= (length prefix) (length str))
3583 (pred? prefix (make-shared-substring str 0 (length prefix)))))
3585 (define-public string-prefix=? (string-prefix-predicate string=?))
3591 ;;; <stripper> = sans-<removable-part>
3593 ;;; <removable-part> = surrounding-whitespace
3594 ;;; | trailing-whitespace
3595 ;;; | leading-whitespace
3599 (define-public (sans-surrounding-whitespace s)
3601 (end (string-length s)))
3602 (while (and (< st (string-length s))
3603 (char-whitespace? (string-ref s st)))
3605 (while (and (< 0 end)
3606 (char-whitespace? (string-ref s (1- end))))
3607 (set! end (1- end)))
3610 (make-shared-substring s st end))))
3612 (define-public (sans-trailing-whitespace s)
3614 (end (string-length s)))
3615 (while (and (< 0 end)
3616 (char-whitespace? (string-ref s (1- end))))
3617 (set! end (1- end)))
3620 (make-shared-substring s st end))))
3622 (define-public (sans-leading-whitespace s)
3624 (end (string-length s)))
3625 (while (and (< st (string-length s))
3626 (char-whitespace? (string-ref s st)))
3630 (make-shared-substring s st end))))
3632 (define-public (sans-final-newline str)
3634 ((= 0 (string-length str))
3637 ((char=? #\nl (string-ref str (1- (string-length str))))
3638 (make-shared-substring str 0 (1- (string-length str))))
3643 ;;; {has-trailing-newline?}
3646 (define-public (has-trailing-newline? str)
3647 (and (< 0 (string-length str))
3648 (char=? #\nl (string-ref str (1- (string-length str))))))
3654 (define-public (with-regexp-parts regexp fields str return fail)
3655 (let ((parts (regexec regexp str fields)))
3658 (apply return parts))))
3662 (define-module (guile))