X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/708bf0f343e5aab8ed2066111860bcae53fc9c6d..49e5d550cb011819cc3d878d82a99a005002d0db:/ice-9/boot-9.scm diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index e94f360ae..846960702 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. +;;;; Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -14,7 +14,8 @@ ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA ;;;; @@ -103,10 +104,10 @@ (define (ipow-by-squaring x k acc proc) (cond ((zero? k) acc) ((= 1 k) (proc acc x)) - (else (logical:ipow-by-squaring (proc x x) - (quotient k 2) - (if (even? k) acc (proc acc x)) - proc)))) + (else (ipow-by-squaring (proc x x) + (quotient k 2) + (if (even? k) acc (proc acc x)) + proc)))) (define string-character-length string-length) @@ -250,11 +251,42 @@ (case handle-delim ((trim peek concat) (join-substrings)) ((split) (cons (join-substrings) terminator)) + + (else (error "unexpected handle-delim value: " handle-delim))))))))) - + +;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string +;;; from PORT. The return value depends on the value of HANDLE-DELIM, +;;; which may be one of the symbols `trim', `concat', `peek' and +;;; `split'. If it is `trim' (the default), the trailing newline is +;;; removed and the string is returned. If `concat', the string is +;;; returned with the trailing newline intact. If `peek', the newline +;;; is left in the input port buffer and the string is returned. If +;;; `split', the newline is split from the string and read-line +;;; returns a pair consisting of the truncated string and the newline. + (define (read-line . args) - (apply read-delimited scm-line-incrementors args)) + (let* ((port (if (null? args) + (current-input-port) + (car args))) + (handle-delim (if (> (length args) 1) + (cadr args) + 'trim)) + (line/delim (%read-line port)) + (line (car line/delim)) + (delim (cdr line/delim))) + (case handle-delim + ((trim) line) + ((split) line/delim) + ((concat) (if (and (string? line) (char? delim)) + (string-append line (string delim)) + line)) + ((peek) (if (char? delim) + (unread-char delim port)) + line) + (else + (error "unexpected handle-delim value: " handle-delim))))) ;;; {Arrays} @@ -291,17 +323,51 @@ (define (keyword->symbol kw) (let ((sym (keyword-dash-symbol kw))) - (string->symbol (substring sym 1 (length sym))))) + (string->symbol (substring sym 1 (string-length sym))))) (define (kw-arg-ref args kw) (let ((rem (member kw args))) (and rem (pair? (cdr rem)) (cadr rem)))) + +;;; {Structs} + +(define (struct-layout s) + (struct-ref (struct-vtable s) vtable-index-layout)) + + ;;; {Records} ;;; -(define record-type-vtable (make-vtable-vtable "prpr" 0)) +;; Printing records: by default, records are printed as +;; +;; # +;; +;; You can change that by giving a custom printing function to +;; MAKE-RECORD-TYPE (after the list of field symbols). This function +;; will be called like +;; +;; ( object port) +;; +;; It should print OBJECT to PORT. + +(define (inherit-print-state old-port new-port) + (if (pair? old-port) + (cons (if (pair? new-port) (car new-port) new-port) + (cdr old-port)) + new-port)) + +;; 0: type-name, 1: fields +(define record-type-vtable + (make-vtable-vtable "prpr" 0 + (lambda (s p) + (cond ((eq? s record-type-vtable) + (display "#" p)) + (else + (display "#" p)))))) (define (record-type? obj) (and (struct? obj) (eq? record-type-vtable (struct-vtable obj)))) @@ -312,25 +378,32 @@ (make-struct-layout (apply symbol-append (map (lambda (f) "pw") fields))) + (or printer-fn + (lambda (s p) + (display "#<" p) + (display type-name p) + (let loop ((fields fields) + (off 0)) + (cond + ((not (null? fields)) + (display " " p) + (display (car fields) p) + (display ": " p) + (display (struct-ref s off) p) + (loop (cdr fields) (+ 1 off))))) + (display ">" p))) type-name (copy-tree fields)))) - ;; !!! leaks printer functions - ;; MDJ 960919 : *fixme* need to make it - ;; possible to print records nicely. - ;(if printer-fn -; (extend-print-style! default-print-style -; (logior utag_struct_base (ash (struct-vtable-tag struct) 8)) -; printer-fn)) struct))) (define (record-type-name obj) (if (record-type? obj) - (struct-ref obj struct-vtable-offset) + (struct-ref obj vtable-offset-user) (error 'not-a-record-type obj))) (define (record-type-fields obj) (if (record-type? obj) - (struct-ref obj (+ 1 struct-vtable-offset)) + (struct-ref obj (+ 1 vtable-offset-user)) (error 'not-a-record-type obj))) (define (record-constructor rtd . opt) @@ -394,17 +467,10 @@ (define (obarray-symbol-append ob . args) (string->obarray-symbol (apply string-append ob args))) -(define obarray-gensym - (let ((n -1)) - (lambda (obarray . opt) - (if (null? opt) - (set! opt '(%%gensym))) - (let loop ((proposed-name (apply string-append opt))) - (if (string->obarray-symbol obarray proposed-name #t) - (loop (apply string-append (append opt (begin (set! n (1+ n)) (list (number->string n)))))) - (string->obarray-symbol obarray proposed-name)))))) - -(define (gensym . args) (apply obarray-gensym #f args)) +(define (obarray-gensym obarray . opt) + (if (null? opt) + (gensym "%%gensym" obarray) + (gensym (car opt) obarray))) ;;; {Lists} @@ -418,7 +484,8 @@ n (loop (+ n 1) (cdr l)))))) -(define (make-list n init) +(define (make-list n . init) + (if (pair? init) (set! init (car init))) (let loop ((answer '()) (n n)) (if (<= n 0) @@ -427,7 +494,32 @@ -;;; {and-map, or-map, and map-in-order} +;;; {Multiple return values} + +(define *values-rtd* + (make-record-type "values" + '(values))) + +(define values + (let ((make-values (record-constructor *values-rtd*))) + (lambda x + (if (and (not (null? x)) + (null? (cdr x))) + (car x) + (make-values x))))) + +(define call-with-values + (let ((access-values (record-accessor *values-rtd* 'values)) + (values-predicate? (record-predicate *values-rtd*))) + (lambda (producer consumer) + (let ((result (producer))) + (if (values-predicate? result) + (apply consumer (access-values result)) + (consumer result)))))) + + + +;;; {and-map and or-map} ;;; ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) ;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...) @@ -460,33 +552,54 @@ (and (not (null? l)) (loop (f (car l)) (cdr l)))))) -;; map-in-order -;; -;; Like map, but guaranteed to process the list in order. -;; -(define (map-in-order fn l) - (if (null? l) - '() - (cons (fn (car l)) - (map-in-order fn (cdr l))))) - ;;; {Hooks} +;;; +;;; Warning: Hooks are now first class objects and add-hook! and remove-hook! +;;; procedures. This interface is only provided for backward compatibility +;;; and will be removed. +;;; +(if (not (defined? 'new-add-hook!)) + (begin + (define new-add-hook! add-hook!) + (define new-remove-hook! remove-hook!))) + (define (run-hooks hook) - (for-each (lambda (thunk) (thunk)) hook)) + (if (and (pair? hook) (eq? (car hook) 'hook)) + (run-hook hook) + (for-each (lambda (thunk) (thunk)) hook))) (define add-hook! - (procedure->macro + (procedure->memoizing-macro (lambda (exp env) - `(let ((thunk ,(caddr exp))) - (if (not (memq thunk ,(cadr exp))) - (set! ,(cadr exp) - (cons thunk ,(cadr exp)))))))) + (let ((hook (local-eval (cadr exp) env))) + (if (and (pair? hook) (eq? (car hook) 'hook)) + `(new-add-hook! ,@(cdr exp)) + (begin + (display "Warning: Old style hooks\n" (current-error-port)) + `(let ((thunk ,(caddr exp))) + (if (not (memq thunk ,(cadr exp))) + (set! ,(cadr exp) + (cons thunk ,(cadr exp))))))))))) + +(define remove-hook! + (procedure->memoizing-macro + (lambda (exp env) + (let ((hook (local-eval (cadr exp) env))) + (if (and (pair? hook) (eq? (car hook) 'hook)) + `(new-remove-hook! ,@(cdr exp)) + (begin + (display "Warning: Old style hooks\n" (current-error-port)) + `(let ((thunk ,(caddr exp))) + (set! ,(cadr exp) + (delq! thunk ,(cadr exp)))))))))) ;;; {Files} -;;; !!!! these should be implemented using Tcl commands, not fports. ;;; +;;; If no one can explain this comment to me by 31 Jan 1998, I will +;;; assume it is meaningless and remove it. -twp +;;; !!!! these should be implemented using Tcl commands, not fports. (define (feature? feature) (and (memq feature *features*) #t)) @@ -567,78 +680,6 @@ (or (and default (apply default key args)) (apply error "unhandled-exception:" key args)))) -;; mostly obsolete. -;; A number of internally defined error types were represented -;; as integers. Here is the mapping to symbolic names -;; and error messages. -;; -;(define %%system-errors -; '((-1 UNKNOWN "Unknown error") -; (0 ARGn "Wrong type argument to ") -; (1 ARG1 "Wrong type argument in position 1 to ") -; (2 ARG2 "Wrong type argument in position 2 to ") -; (3 ARG3 "Wrong type argument in position 3 to ") -; (4 ARG4 "Wrong type argument in position 4 to ") -; (5 ARG5 "Wrong type argument in position 5 to ") -; (6 ARG5 "Wrong type argument in position 5 to ") -; (7 ARG5 "Wrong type argument in position 5 to ") -; (8 WNA "Wrong number of arguments to ") -; (9 OVFLOW "Numerical overflow to ") -; (10 OUTOFRANGE "Argument out of range to ") -; (11 NALLOC "Could not allocate to ") -; (12 STACK_OVFLOW "Stack overflow") -; (13 EXIT "Exit (internal error?).") -; (14 HUP_SIGNAL "hang-up") -; (15 INT_SIGNAL "user interrupt") -; (16 FPE_SIGNAL "arithmetic error") -; (17 BUS_SIGNAL "bus error") -; (18 SEGV_SIGNAL "segmentation violation") -; (19 ALRM_SIGNAL "alarm") -; (20 GC_SIGNAL "gc") -; (21 TICK_SIGNAL "tick"))) - - -(define (timer-thunk) #t) -(define (gc-thunk) #t) -(define (alarm-thunk) #t) - -(define (signal-handler n) - (let* ( - ;; these numbers are set in libguile, not the same as those - ;; interned in posix.c for SIGSEGV etc. - ;; - (signal-messages `((14 . "hang-up") - (15 . "user interrupt") - (16 . "arithmetic error") - (17 . "bus error") - (18 . "segmentation violation")))) - (cond - ((= n 21) (unmask-signals) (timer-thunk)) - ((= n 20) (unmask-signals) (gc-thunk)) - ((= n 19) (unmask-signals) (alarm-thunk)) - (else (set! the-last-stack - (make-stack #t - (list-ref (list %hup-thunk - %int-thunk - %fpe-thunk - %bus-thunk - %segv-thunk) - (- n 14)) - 1)) - (set! stack-saved? #t) - (if (not (and (memq 'debug (debug-options-interface)) - (eq? (stack-id the-last-stack) 'repl-stack))) - (set! the-last-stack #f)) - (unmask-signals) - (let ((sig-pair (assoc n signal-messages))) - (scm-error 'error-signal #f - (cdr (or sig-pair - (cons n "Unknown signal: %s"))) - (if sig-pair - #f - (list n)) - (list n))))))) - ;;; {Non-polymorphic versions of POSIX functions} @@ -742,22 +783,89 @@ (define (set-tm:gmtoff obj val) (vector-set! obj 9 val)) (define (set-tm:zone obj val) (vector-set! obj 10 val)) +(define (tms:clock obj) (vector-ref obj 0)) +(define (tms:utime obj) (vector-ref obj 1)) +(define (tms:stime obj) (vector-ref obj 2)) +(define (tms:cutime obj) (vector-ref obj 3)) +(define (tms:cstime obj) (vector-ref obj 4)) + (define (file-position . args) (apply ftell args)) (define (file-set-position . args) (apply fseek args)) (define (open-input-pipe command) (open-pipe command OPEN_READ)) (define (open-output-pipe command) (open-pipe command OPEN_WRITE)) -(define (move->fdes port fd) - (primitive-move->fdes port fd) - (set-port-revealed! port 1) - port) +(define (move->fdes fd/port fd) + (cond ((integer? fd/port) + (dup->fdes fd/port fd) + (close fd/port) + fd) + (else + (primitive-move->fdes fd/port fd) + (set-port-revealed! fd/port 1) + fd/port))) (define (release-port-handle port) (let ((revealed (port-revealed port))) (if (> revealed 0) (set-port-revealed! port (- revealed 1))))) +(define (dup->port port/fd mode . maybe-fd) + (let ((port (fdopen (apply dup->fdes port/fd maybe-fd) + mode))) + (if (pair? maybe-fd) + (set-port-revealed! port 1)) + port)) + +(define (dup->inport port/fd . maybe-fd) + (apply dup->port port/fd "r" maybe-fd)) + +(define (dup->outport port/fd . maybe-fd) + (apply dup->port port/fd "w" maybe-fd)) + +(define (dup port/fd . maybe-fd) + (if (integer? port/fd) + (apply dup->fdes port/fd maybe-fd) + (apply dup->port port/fd (port-mode port/fd) maybe-fd))) + +(define (duplicate-port port modes) + (dup->port port modes)) + +(define (fdes->inport fdes) + (let loop ((rest-ports (fdes->ports fdes))) + (cond ((null? rest-ports) + (let ((result (fdopen fdes "r"))) + (set-port-revealed! result 1) + result)) + ((input-port? (car rest-ports)) + (set-port-revealed! (car rest-ports) + (+ (port-revealed (car rest-ports)) 1)) + (car rest-ports)) + (else + (loop (cdr rest-ports)))))) + +(define (fdes->outport fdes) + (let loop ((rest-ports (fdes->ports fdes))) + (cond ((null? rest-ports) + (let ((result (fdopen fdes "w"))) + (set-port-revealed! result 1) + result)) + ((output-port? (car rest-ports)) + (set-port-revealed! (car rest-ports) + (+ (port-revealed (car rest-ports)) 1)) + (car rest-ports)) + (else + (loop (cdr rest-ports)))))) + +(define (port->fdes port) + (set-port-revealed! port (+ (port-revealed port) 1)) + (fileno port)) + +(define (setenv name value) + (if value + (putenv (string-append name "=" value)) + (putenv name))) + ;;; {Load Paths} ;;; @@ -768,13 +876,40 @@ (define (in-vicinity vicinity file) (let ((tail (let ((len (string-length vicinity))) - (if (zero? len) #f + (if (zero? len) + #f (string-ref vicinity (- len 1)))))) (string-append vicinity - (if (eq? tail #\/) "" "/") + (if (or (not tail) + (eq? tail #\/)) + "" + "/") file))) +;;; {Help for scm_shell} +;;; The argument-processing code used by Guile-based shells generates +;;; Scheme code based on the argument list. This page contains help +;;; functions for the code it generates. + +(define (command-line) (program-arguments)) + +;; This is mostly for the internal use of the code generated by +;; scm_compile_shell_switches. +(define (load-user-init) + (define (has-init? dir) + (let ((path (in-vicinity dir ".guile"))) + (catch 'system-error + (lambda () + (let ((stats (stat path))) + (if (not (eq? (stat:type stats) 'directory)) + path))) + (lambda dummy #f)))) + (let ((path (or (has-init? (or (getenv "HOME") "/")) + (has-init? (passwd:dir (getpw (getuid))))))) + (if path (primitive-load path)))) + + ;;; {Loading by paths} ;;; Load a Scheme source file named NAME, searching for it in the @@ -789,7 +924,7 @@ ;;; {Transcendental Functions} ;;; ;;; Derived from "Transcen.scm", Complex trancendental functions for SCM. -;;; Copyright (C) 1992, 1993 Jerry D. Hedden. +;;; Written by Jerry D. Hedden, (C) FSF. ;;; See the file `COPYING' for terms applying to this program. ;;; @@ -884,20 +1019,8 @@ (set! abs magnitude) - -;;; {User Settable Hooks} -;;; -;;; Parts of the C code check the bindings of these variables. -;;; - -(define ticks-interrupt #f) -(define user-interrupt #f) -(define alarm-interrupt #f) -(define out-of-storage #f) -(define could-not-open #f) -(define end-of-program #f) -(define hang-up #f) -(define arithmetic-error #f) +(define (log10 arg) + (/ (log arg) (log 10))) @@ -907,20 +1030,48 @@ ;;; Reader code for various "#c" forms. ;;; -(define (parse-path-symbol s) - (define (separate-fields-discarding-char ch str ret) - (let loop ((fields '()) - (str str)) - (cond - ((string-rindex str ch) - => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 pos)) fields) - (make-shared-substring str 0 pos)))) - (else (ret (cons str fields)))))) - (separate-fields-discarding-char #\/ - s - (lambda (fields) - (map string->symbol fields)))) - +;;; Parse the portion of a #/ list that comes after the first slash. +(define (read-path-list-notation slash port) + (letrec + + ;; Is C a delimiter? + ((delimiter? (lambda (c) (or (eof-object? c) + (char-whitespace? c) + (string-index "()\";" c)))) + + ;; Read and return one component of a path list. + (read-component + (lambda () + (let loop ((reversed-chars '())) + (let ((c (peek-char port))) + (if (or (delimiter? c) + (char=? c #\/)) + (string->symbol (list->string (reverse reversed-chars))) + (loop (cons (read-char port) reversed-chars)))))))) + + ;; Read and return a path list. + (let loop ((reversed-path (list (read-component)))) + (let ((c (peek-char port))) + (if (and (char? c) (char=? c #\/)) + (begin + (read-char port) + (loop (cons (read-component) reversed-path))) + (reverse reversed-path)))))) + +(define (read-path-list-notation-warning slash port) + (if (not (getenv "GUILE_HUSH")) + (begin + (display "warning: obsolete `#/' list notation read from " + (current-error-port)) + (display (port-filename port) (current-error-port)) + (display "; see guile-core/NEWS." (current-error-port)) + (newline (current-error-port)) + (display " Set the GUILE_HUSH environment variable to disable this warning." + (current-error-port)) + (newline (current-error-port)))) + (read-hash-extend #\/ read-path-list-notation) + (read-path-list-notation slash port)) + (read-hash-extend #\' (lambda (c port) (read port))) @@ -935,8 +1086,8 @@ (for-each (lambda (char template) (read-hash-extend char (make-array-proc template))) - '(#\b #\a #\u #\e #\s #\i #\c) - '(#t #\a 1 -1 1.0 1/3 0+i))) + '(#\b #\a #\u #\e #\s #\i #\c #\y #\h) + '(#t #\a 1 -1 1.0 1/3 0+i #\nul s))) (let ((array-proc (lambda (c port) (read:array c port)))) (for-each (lambda (char) (read-hash-extend char array-proc)) @@ -944,40 +1095,7 @@ ;; pushed to the beginning of the alist since it's used more than the ;; others at present. -(read-hash-extend #\/ - (lambda (c port) - (let ((look (peek-char port))) - (if (or (eof-object? look) - (and (char? look) - (or (char-whitespace? look) - (string-index ")" look)))) - '() - (parse-path-symbol (read port)))))) - -;(define (read-sharp c port) -; (define (barf) -; (error "unknown # object" c)) - -; (case c -; ((#\/) (let ((look (peek-char port))) -; (if (or (eof-object? look) -; (and (char? look) -; (or (char-whitespace? look) -; (string-index ")" look)))) -; '() -; (parse-path-symbol (read port #t read-sharp))))) -; ((#\') (read port #t read-sharp)) -; ((#\.) (eval (read port #t read-sharp))) -; ((#\b) (read:uniform-vector #t port)) -; ((#\a) (read:uniform-vector #\a port)) -; ((#\u) (read:uniform-vector 1 port)) -; ((#\e) (read:uniform-vector -1 port)) -; ((#\s) (read:uniform-vector 1.0 port)) -; ((#\i) (read:uniform-vector 1/3 port)) -; ((#\c) (read:uniform-vector 0+i port)) -; ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) -; (read:array c port)) -; (else (barf)))) +(read-hash-extend #\/ read-path-list-notation-warning) (define (read:array digit port) (define chr0 (char->integer #\0)) @@ -1083,9 +1201,9 @@ (map (lambda (x) (display (keyword-symbol x)) (display " ")) opts-proper))) arg-name)) - (middle-part (if (and (< (length left-part) 30) - (< (length help) 40)) - (make-string (- 30 (length left-part)) #\ ) + (middle-part (if (and (< (string-length left-part) 30) + (< (string-length help) 40)) + (make-string (- 30 (string-length left-part)) #\ ) "\n\t"))) (display left-part) (display middle-part) @@ -1163,8 +1281,12 @@ ;;; {Printing Modules} ;; This is how modules are printed. You can re-define it. -;; -(define (%print-module mod port depth length style table) +;; (Redefining is actually more complicated than simply redefining +;; %print-module because that would only change the binding and not +;; the value stored in the vtable that determines how record are +;; printed. Sigh.) + +(define (%print-module mod port) ; unused args: depth length style table) (display "#<" port) (display (or (module-kind mod) "module") port) (let ((name (module-name mod))) @@ -1185,7 +1307,8 @@ ;; bindings that would otherwise not be found locally in the module. ;; (define module-type - (make-record-type 'module '(obarray uses binder eval-closure name kind) + (make-record-type 'module + '(obarray uses binder eval-closure transformer name kind) %print-module)) ;; make-module &opt size uses binder @@ -1218,7 +1341,7 @@ "Lazy-binder expected to be a procedure or #f." binder)) (let ((module (module-constructor (make-vector size '()) - uses binder #f #f #f))) + uses binder #f #f #f #f))) ;; We can't pass this as an argument to module-constructor, ;; because we need it to close over a pointer to the module @@ -1238,8 +1361,13 @@ (define set-module-uses! (record-modifier module-type 'uses)) (define module-binder (record-accessor module-type 'binder)) (define set-module-binder! (record-modifier module-type 'binder)) + +;; NOTE: This binding is used in libguile/modules.c. (define module-eval-closure (record-accessor module-type 'eval-closure)) + (define set-module-eval-closure! (record-modifier module-type 'eval-closure)) +(define module-transformer (record-accessor module-type 'transformer)) +(define set-module-transformer! (record-modifier module-type 'transformer)) (define module-name (record-accessor module-type 'name)) (define set-module-name! (record-modifier module-type 'name)) (define module-kind (record-accessor module-type 'kind)) @@ -1546,17 +1674,27 @@ ;; the-module -;; +;; +;; NOTE: This binding is used in libguile/modules.c. +;; (define the-module #f) +;; scm:eval-transformer +;; +(define scm:eval-transformer #f) + ;; set-current-module module ;; ;; set the current module as viewed by the normalizer. ;; +;; NOTE: This binding is used in libguile/modules.c. +;; (define (set-current-module m) (set! the-module m) (if m - (set! *top-level-lookup-closure* (module-eval-closure the-module)) + (begin + (set! *top-level-lookup-closure* (module-eval-closure the-module)) + (set! scm:eval-transformer (module-transformer the-module))) (set! *top-level-lookup-closure* #f))) @@ -1584,8 +1722,17 @@ (define basic-load load) -(define (load-module . args) - (save-module-excursion (lambda () (apply basic-load args)))) +(define (load-module filename) + (save-module-excursion + (lambda () + (let ((oldname (and (current-load-port) + (port-filename (current-load-port))))) + (basic-load (if (and oldname + (> (string-length filename) 0) + (not (char=? (string-ref filename 0) #\/)) + (not (string=? (dirname oldname) "."))) + (string-append (dirname oldname) "/" filename) + filename)))))) @@ -1716,12 +1863,12 @@ -;;; {#/app} +;;; {The (app) module} ;;; ;;; The root of conventionally named objects not directly in the top level. ;;; -;;; #/app/modules -;;; #/app/modules/guile +;;; (app modules) +;;; (app modules guile) ;;; ;;; The directory of all modules and the standard root module. ;;; @@ -1742,31 +1889,39 @@ ;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module))) +;; NOTE: This binding is used in libguile/modules.c. +;; (define (resolve-module name . maybe-autoload) (let ((full-name (append '(app modules) name))) (let ((already (local-ref full-name))) - (or already - (begin - (if (or (null? maybe-autoload) (car maybe-autoload)) - (or (try-module-autoload name) - (try-module-dynamic-link name))) - (make-modules-in (current-module) full-name)))))) + (or already + (begin + (if (or (null? maybe-autoload) (car maybe-autoload)) + (or (try-module-linked name) + (try-module-autoload name) + (try-module-dynamic-link name))) + (make-modules-in (current-module) full-name)))))) (define (beautify-user-module! module) - (if (not (module-public-interface module)) - (let ((interface (make-module 31))) - (set-module-name! interface (module-name module)) - (set-module-kind! interface 'interface) - (set-module-public-interface! module interface))) + (let ((interface (module-public-interface module))) + (if (or (not interface) + (eq? interface module)) + (let ((interface (make-module 31))) + (set-module-name! interface (module-name module)) + (set-module-kind! interface 'interface) + (set-module-public-interface! module interface)))) (if (and (not (memq the-scm-module (module-uses module))) (not (eq? module the-root-module))) (set-module-uses! module (append (module-uses module) (list the-scm-module))))) +;; NOTE: This binding is used in libguile/modules.c. +;; (define (make-modules-in module name) (if (null? name) module (cond - ((module-ref module (car name) #f) => (lambda (m) (make-modules-in m (cdr name)))) + ((module-ref module (car name) #f) + => (lambda (m) (make-modules-in m (cdr name)))) (else (let ((m (make-module 31))) (set-module-kind! m 'directory) (set-module-name! m (car name)) @@ -1780,6 +1935,10 @@ (define %autoloader-developer-mode #t) +(define (internal-use-syntax transformer) + (set-module-transformer! (current-module) transformer) + (set! scm:eval-transformer transformer)) + (define (process-define-module args) (let* ((module-id (car args)) (module (resolve-module module-id #f)) @@ -1791,28 +1950,43 @@ (for-each (lambda (interface) (module-use! module interface)) reversed-interfaces) - (case (cond ((keyword? (car kws)) - (keyword->symbol (car kws))) - ((and (symbol? (car kws)) - (eq? (string-ref (car kws) 0) #\:)) - (string->symbol (substring (car kws) 1))) - (else #f)) - ((use-module) - (if (not (pair? (cdr kws))) - (error "unrecognized defmodule argument" kws)) - (let* ((used-name (cadr kws)) - (used-module (resolve-module used-name))) - (if (not (module-ref used-module '%module-public-interface #f)) - (begin - ((if %autoloader-developer-mode warn error) - "no code for module" (module-name used-module)) - (beautify-user-module! used-module))) - (let ((interface (module-public-interface used-module))) - (if (not interface) - (error "missing interface for use-module" used-module)) - (loop (cddr kws) (cons interface reversed-interfaces))))) - (else - (error "unrecognized defmodule argument" kws))))) + (let ((keyword (cond ((keyword? (car kws)) + (keyword->symbol (car kws))) + ((and (symbol? (car kws)) + (eq? (string-ref (car kws) 0) #\:)) + (string->symbol (substring (car kws) 1))) + (else #f)))) + (case keyword + ((use-module use-syntax) + (if (not (pair? (cdr kws))) + (error "unrecognized defmodule argument" kws)) + (let* ((used-name (cadr kws)) + (used-module (resolve-module used-name))) + (if (eq? used-module module) + (begin + (or (try-module-linked used-name) + (try-module-dynamic-link used-name)) + (loop (cddr kws) reversed-interfaces)) + (begin + (if (not (module-ref used-module + '%module-public-interface + #f)) + (begin + ((if %autoloader-developer-mode warn error) + "no code for module" (module-name used-module)) + (beautify-user-module! used-module))) + (let ((interface (module-public-interface used-module))) + (if (not interface) + (error "missing interface for use-module" + used-module)) + (if (eq? keyword 'use-syntax) + (internal-use-syntax + (module-ref interface (car (last-pair used-name)) + #f))) + (loop (cddr kws) + (cons interface reversed-interfaces))))))) + (else + (error "unrecognized defmodule argument" kws)))))) module)) ;;; {Autoloading modules} @@ -1880,7 +2054,7 @@ ;; To make your Guile extension into a dynamic linkable module, follow ;; these easy steps: ;; -;; - Find a name for your module, like #/ice-9/gtcltk +;; - Find a name for your module, like (ice-9 gtcltk) ;; - Write a function with a name like ;; ;; scm_init_ice_9_gtcltk_module @@ -1900,7 +2074,7 @@ ;; ;; and put it somewhere in %load-path. ;; -;; - Then you can simply write `:use-module #/ice-9/gtcltk' and it +;; - Then you can simply write `:use-module (ice-9 gtcltk)' and it ;; will be linked automatically. ;; ;; This is all very experimental. @@ -1928,19 +2102,28 @@ (c-clear-registered-modules) res)) -(define registered-modules (convert-c-registered-modules #f)) - +(define registered-modules '()) + +(define (register-modules dynobj) + (set! registered-modules + (append! (convert-c-registered-modules dynobj) + registered-modules))) + (define (init-dynamic-module modname) + ;; Register any linked modules which has been registered on the C level + (register-modules #f) (or-map (lambda (modinfo) (if (equal? (car modinfo) modname) - (let ((mod (resolve-module modname #f))) - (save-module-excursion - (lambda () - (set-current-module mod) - (dynamic-call (cadr modinfo) (caddr modinfo)) - (set-module-public-interface! mod mod))) + (begin (set! registered-modules (delq! modinfo registered-modules)) - #t) + (let ((mod (resolve-module modname #f))) + (save-module-excursion + (lambda () + (set-current-module mod) + (set-module-public-interface! mod mod) + (dynamic-call (cadr modinfo) (caddr modinfo)) + )) + #t)) #f)) registered-modules)) @@ -1968,45 +2151,72 @@ #\_)) (string->list mod-name))) '_module)) - (let ((libname + + ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME, + ;; and the `libname' (the name of the module prepended by `lib') in the cdr + ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then + ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp"). + (let ((subdir-and-libname (let loop ((dirs "") (syms module-name)) - (cond - ((null? (cdr syms)) - (string-append dirs "lib" (car syms) ".so")) - (else - (loop (string-append dirs (car syms) "/") (cdr syms)))))) + (if (null? (cdr syms)) + (cons dirs (string-append "lib" (car syms))) + (loop (string-append dirs (car syms) "/") (cdr syms))))) (init (make-init-name (apply string-append (map (lambda (s) (string-append "_" s)) module-name))))) - ;; (pk 'libname libname 'init init) - (or-map - (lambda (dir) - (let ((full (in-vicinity dir libname))) - ;; (pk 'trying full) - (if (file-exists? full) - (begin - (link-dynamic-module full init) - #t) - #f))) - %load-path))) + (let ((subdir (car subdir-and-libname)) + (libname (cdr subdir-and-libname))) + + ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that + ;; file exists, fetch the dlname from that file and attempt to link + ;; against it. If `subdir/libfoo.la' does not exist, or does not seem + ;; to name any shared library, look for `subdir/libfoo.so' instead and + ;; link against that. + (let check-dirs ((dir-list %load-path)) + (if (null? dir-list) + #f + (let* ((dir (in-vicinity (car dir-list) subdir)) + (sharlib-full + (or (try-using-libtool-name dir libname) + (try-using-sharlib-name dir libname)))) + (if (and sharlib-full (file-exists? sharlib-full)) + (link-dynamic-module sharlib-full init) + (check-dirs (cdr dir-list))))))))) + +(define (try-using-libtool-name libdir libname) + (let ((libtool-filename (in-vicinity libdir + (string-append libname ".la")))) + (and (file-exists? libtool-filename) + (with-input-from-file libtool-filename + (lambda () + (let loop ((ln (read-line))) + (cond ((eof-object? ln) #f) + ((and (> (string-length ln) 9) + (string=? "dlname='" (substring ln 0 8)) + (string-index ln #\' 8)) + => + (lambda (end) + (in-vicinity libdir (substring ln 8 end)))) + (else (loop (read-line)))))))))) + +(define (try-using-sharlib-name libdir libname) + (in-vicinity libdir (string-append libname ".so"))) (define (link-dynamic-module filename initname) - (let ((dynobj (dynamic-maybe-link filename))) - (if dynobj - (if (dynamic-maybe-call initname dynobj) - (set! registered-modules - (append! (convert-c-registered-modules dynobj) - registered-modules)) - (begin - (pk 'no_init) - (dynamic-unlink dynobj)))))) - + ;; Register any linked modules which has been registered on the C level + (register-modules #f) + (let ((dynobj (dynamic-link filename))) + (dynamic-call initname dynobj) + (register-modules dynobj))) + +(define (try-module-linked module-name) + (init-dynamic-module module-name)) + (define (try-module-dynamic-link module-name) - (or (init-dynamic-module module-name) - (and (find-and-link-dynamic-module module-name) - (init-dynamic-module module-name)))) + (and (find-and-link-dynamic-module module-name) + (init-dynamic-module module-name))) @@ -2044,6 +2254,12 @@ ;;; {Macros} ;;; +(define (primitive-macro? m) + (and (macro? m) + (not (macro-transformer m)))) + +;;; {Defmacros} +;;; (define macro-table (make-weak-key-hash-table 523)) (define xformer-table (make-weak-key-hash-table 523)) @@ -2100,13 +2316,106 @@ e))) (#t e))) -(define gentemp - (let ((*gensym-counter* -1)) - (lambda () - (set! *gensym-counter* (+ *gensym-counter* 1)) - (string->symbol - (string-append "scm:G" (number->string *gensym-counter*)))))) +(define (gentemp) + (gensym "scm:G")) +(provide 'defmacro) + + + +;;; {Run-time options} + +((let* ((names '((eval-options-interface + (eval-options eval-enable eval-disable) + (eval-set!)) + + (debug-options-interface + (debug-options debug-enable debug-disable) + (debug-set!)) + + (evaluator-traps-interface + (traps trap-enable trap-disable) + (trap-set!)) + + (read-options-interface + (read-options read-enable read-disable) + (read-set!)) + + (print-options-interface + (print-options print-enable print-disable) + (print-set!)) + + (readline-options-interface + (readline-options readline-enable readline-disable) + (readline-set!)) + )) + (option-name car) + (option-value cadr) + (option-documentation caddr) + + (print-option (lambda (option) + (display (option-name option)) + (if (< (string-length + (symbol->string (option-name option))) + 8) + (display #\tab)) + (display #\tab) + (display (option-value option)) + (display #\tab) + (display (option-documentation option)) + (newline))) + + ;; Below follows the macros defining the run-time option interfaces. + + (make-options (lambda (interface) + `(lambda args + (cond ((null? args) (,interface)) + ((list? (car args)) + (,interface (car args)) (,interface)) + (else (for-each ,print-option + (,interface #t))))))) + + (make-enable (lambda (interface) + `(lambda flags + (,interface (append flags (,interface))) + (,interface)))) + + (make-disable (lambda (interface) + `(lambda flags + (let ((options (,interface))) + (for-each (lambda (flag) + (set! options (delq! flag options))) + flags) + (,interface options) + (,interface))))) + + (make-set! (lambda (interface) + `((name exp) + (,'quasiquote + (begin (,interface (append (,interface) + (list '(,'unquote name) + (,'unquote exp)))) + (,interface)))))) + ) + (procedure->macro + (lambda (exp env) + (cons 'begin + (apply append + (map (lambda (group) + (let ((interface (car group))) + (append (map (lambda (name constructor) + `(define ,name + ,(constructor interface))) + (cadr group) + (list make-options + make-enable + make-disable)) + (map (lambda (name constructor) + `(defmacro ,name + ,@(constructor interface))) + (caddr group) + (list make-set!))))) + names))))))) @@ -2140,6 +2449,7 @@ (save-stack lazy-handler-dispatch) (apply throw key args)) +(define enter-frame-handler default-lazy-handler) (define apply-frame-handler default-lazy-handler) (define exit-frame-handler default-lazy-handler) @@ -2149,13 +2459,28 @@ (apply apply-frame-handler key args)) ((exit-frame) (apply exit-frame-handler key args)) + ((enter-frame) + (apply enter-frame-handler key args)) (else (apply default-lazy-handler key args)))) -(define abort-hook '()) +(define abort-hook (make-hook)) + +;; these definitions are used if running a script. +;; otherwise redefined in error-catching-loop. +(define (set-batch-mode?! arg) #t) +(define (batch-mode?) #t) (define (error-catching-loop thunk) - (let ((status #f)) + (let ((status #f) + (interactive #t)) + (set! set-batch-mode?! (lambda (arg) + (cond (arg + (set! interactive #f) + (restore-signals)) + (#t + (error "sorry, not implemented"))))) + (set! batch-mode? (lambda () (not interactive))) (define (loop first) (let ((next (catch #t @@ -2166,17 +2491,19 @@ (dynamic-wind (lambda () (unmask-signals)) (lambda () - (first) + (with-traps + (lambda () + (first) - ;; This line is needed because mark - ;; doesn't do closures quite right. - ;; Unreferenced locals should be - ;; collected. - ;; - (set! first #f) - (let loop ((v (thunk))) - (loop (thunk))) - #f) + ;; This line is needed because mark + ;; doesn't do closures quite right. + ;; Unreferenced locals should be + ;; collected. + ;; + (set! first #f) + (let loop ((v (thunk))) + (loop (thunk))) + #f))) (lambda () (mask-signals)))) lazy-handler-dispatch)) @@ -2184,7 +2511,6 @@ (lambda (key . args) (case key ((quit) - (read-line) ; discard trailing junk and linefeed. (force-output) (set! status args) #f) @@ -2197,21 +2523,23 @@ ;; (set! first #f) above ;; (lambda () - (run-hooks abort-hook) + (run-hook abort-hook) (force-output) (display "ABORT: " (current-error-port)) (write args (current-error-port)) (newline (current-error-port)) - (if (and (not has-shown-debugger-hint?) - (not (memq 'backtrace - (debug-options-interface))) - (stack? the-last-stack)) - (begin - (newline (current-error-port)) - (display - "Type \"(backtrace)\" to get more information.\n" - (current-error-port)) - (set! has-shown-debugger-hint? #t))) + (if interactive + (if (and (not has-shown-debugger-hint?) + (not (memq 'backtrace + (debug-options-interface))) + (stack? (fluid-ref the-last-stack))) + (begin + (newline (current-error-port)) + (display + "Type \"(backtrace)\" to get more information.\n" + (current-error-port)) + (set! has-shown-debugger-hint? #t))) + (primitive-exit 1)) (set! stack-saved? #f))) (else @@ -2224,49 +2552,50 @@ (if next (loop next) status))) (loop (lambda () #t)))) -;;(define the-last-stack #f) Defined by scm_init_backtrace () +;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace () (define stack-saved? #f) (define (save-stack . narrowing) (cond (stack-saved?) ((not (memq 'debug (debug-options-interface))) - (set! the-last-stack #f) + (fluid-set! the-last-stack #f) (set! stack-saved? #t)) (else - (set! the-last-stack - (case (stack-id #t) - ((repl-stack) - (apply make-stack #t save-stack eval narrowing)) - ((load-stack) - (apply make-stack #t save-stack gsubr-apply narrowing)) - ((tk-stack) - (apply make-stack #t save-stack tk-stack-mark narrowing)) - ((#t) - (apply make-stack #t save-stack 0 1 narrowing)) - (else (let ((id (stack-id #t))) - (and (procedure? id) - (apply make-stack #t save-stack id narrowing)))))) + (fluid-set! + the-last-stack + (case (stack-id #t) + ((repl-stack) + (apply make-stack #t save-stack eval narrowing)) + ((load-stack) + (apply make-stack #t save-stack 0 narrowing)) + ((tk-stack) + (apply make-stack #t save-stack tk-stack-mark narrowing)) + ((#t) + (apply make-stack #t save-stack 0 1 narrowing)) + (else (let ((id (stack-id #t))) + (and (procedure? id) + (apply make-stack #t save-stack id narrowing)))))) (set! stack-saved? #t)))) -(define before-error-hook '()) -(define after-error-hook '()) -(define before-backtrace-hook '()) -(define after-backtrace-hook '()) +(define before-error-hook (make-hook)) +(define after-error-hook (make-hook)) +(define before-backtrace-hook (make-hook)) +(define after-backtrace-hook (make-hook)) (define has-shown-debugger-hint? #f) (define (handle-system-error key . args) (let ((cep (current-error-port))) - (cond ((not (stack? the-last-stack))) + (cond ((not (stack? (fluid-ref the-last-stack)))) ((memq 'backtrace (debug-options-interface)) - (run-hooks before-backtrace-hook) + (run-hook before-backtrace-hook) (newline cep) - (display-backtrace the-last-stack cep) + (display-backtrace (fluid-ref the-last-stack) cep) (newline cep) - (run-hooks after-backtrace-hook))) - (run-hooks before-error-hook) - (apply display-error the-last-stack cep args) - (run-hooks after-error-hook) + (run-hook after-backtrace-hook))) + (run-hook before-error-hook) + (apply display-error (fluid-ref the-last-stack) cep args) + (run-hook after-error-hook) (force-output cep) (throw 'abort key))) @@ -2279,10 +2608,10 @@ ;; Replaced by C code: ;;(define (backtrace) -;; (if the-last-stack +;; (if (fluid-ref the-last-stack) ;; (begin ;; (newline) -;; (display-backtrace the-last-stack (current-output-port)) +;; (display-backtrace (fluid-ref the-last-stack) (current-output-port)) ;; (newline) ;; (if (and (not has-shown-backtrace-hint?) ;; (not (memq 'backtrace (debug-options-interface)))) @@ -2299,14 +2628,22 @@ (define (gc-run-time) (cdr (assq 'gc-time-taken (gc-stats)))) -(define before-read-hook '()) -(define after-read-hook '()) +(define before-read-hook (make-hook)) +(define after-read-hook (make-hook)) + +;;; The default repl-reader function. We may override this if we've +;;; the readline library. +(define repl-reader + (lambda (prompt) + (display prompt) + (force-output) + (run-hook before-read-hook) + (read (current-input-port)))) (define (scm-style-repl) (letrec ( (start-gc-rt #f) (start-rt #f) - (repl-report-reset (lambda () #f)) (repl-report-start-timing (lambda () (set! start-gc-rt (gc-run-time)) (set! start-rt (get-internal-run-time)))) @@ -2320,19 +2657,39 @@ (* 1000 (/ (- (gc-run-time) start-gc-rt) internal-time-units-per-second)))) (display " msec in gc)\n"))) + + (consume-trailing-whitespace + (lambda () + (let ((ch (peek-char))) + (cond + ((eof-object? ch)) + ((or (char=? ch #\space) (char=? ch #\tab)) + (read-char) + (consume-trailing-whitespace)) + ((char=? ch #\newline) + (read-char)))))) (-read (lambda () - (if scm-repl-prompt - (begin - (display (cond ((string? scm-repl-prompt) - scm-repl-prompt) - ((thunk? scm-repl-prompt) - (scm-repl-prompt)) - (else "> "))) - (force-output) - (repl-report-reset))) - (run-hooks before-read-hook) - (let ((val (read (current-input-port)))) - (run-hooks after-read-hook) + (let ((val + (let ((prompt (cond ((string? scm-repl-prompt) + scm-repl-prompt) + ((thunk? scm-repl-prompt) + (scm-repl-prompt)) + (scm-repl-prompt "> ") + (else "")))) + (repl-reader prompt)))) + + ;; As described in R4RS, the READ procedure updates the + ;; port to point to the first characetr past the end of + ;; the external representation of the object. This + ;; means that it doesn't consume the newline typically + ;; found after an expression. This means that, when + ;; debugging Guile with GDB, GDB gets the newline, which + ;; it often interprets as a "continue" command, making + ;; breakpoints kind of useless. So, consume any + ;; trailing newline here, as well as any whitespace + ;; before it. + (consume-trailing-whitespace) + (run-hook after-read-hook) (if (eof-object? val) (begin (repl-report-start-timing) @@ -2382,18 +2739,11 @@ (-quit status)))) -;(define (stand-alone-repl) -; (let ((oport (current-input-port))) -; (set-current-input-port *stdin*) -; (scm-style-repl) -; (set-current-input-port oport))) - - ;;; {IOTA functions: generating lists of numbers} (define (reverse-iota n) (if (> n 0) (cons (1- n) (reverse-iota (1- n))) '())) -(define (iota n) (list-reverse! (reverse-iota n))) +(define (iota n) (reverse! (reverse-iota n))) ;;; {While} @@ -2408,6 +2758,35 @@ (lambda () (continue)) (lambda v (cadr v))))) +;;; {collect} +;;; +;;; Similar to `begin' but returns a list of the results of all constituent +;;; forms instead of the result of the last form. +;;; (The definition relies on the current left-to-right +;;; order of evaluation of operands in applications.) + +(defmacro collect forms + (cons 'list forms)) + +;;; {with-fluids} + +;; with-fluids is a convenience wrapper for the builtin procedure +;; `with-fluids*'. The syntax is just like `let': +;; +;; (with-fluids ((fluid val) +;; ...) +;; body) + +(defmacro with-fluids (bindings . body) + `(with-fluids* (list ,@(map car bindings)) (list ,@(map cadr bindings)) + (lambda () ,@body))) + +;;; Environments + +(define the-environment + (procedure->syntax + (lambda (x e) + e))) @@ -2445,11 +2824,25 @@ (set-current-module module) module)) +;; the guts of the use-modules macro. add the interfaces of the named +;; modules to the use-list of the current module, in order +(define (process-use-modules module-names) + (for-each (lambda (module-name) + (let ((mod-iface (resolve-interface module-name))) + (or mod-iface + (error "no such module" module-name)) + (module-use! (current-module) mod-iface))) + (reverse module-names))) + (defmacro use-modules modules - `(for-each (lambda (module) - (module-use! (current-module) - (resolve-interface module))) - (reverse ',modules))) + `(process-use-modules ',modules)) + +(defmacro use-syntax (spec) + (if (pair? spec) + `(begin + (process-use-modules ',(list spec)) + (internal-use-syntax ,(car (last-pair spec)))) + `(internal-use-syntax ,spec))) (define define-private define) @@ -2458,28 +2851,31 @@ (error "bad syntax" (list 'define-public args))) (define (defined-name n) (cond - ((symbol? n) n) - ((pair? n) (defined-name (car n))) - (else (syntax)))) + ((symbol? n) n) + ((pair? n) (defined-name (car n))) + (else (syntax)))) (cond - ((null? args) (syntax)) - - (#t (let ((name (defined-name (car args)))) - `(begin - (let ((public-i (module-public-interface (current-module)))) - ;; Make sure there is a local variable: - ;; - (module-define! (current-module) - ',name - (module-ref (current-module) ',name #f)) + ((null? args) (syntax)) + + (#t (let ((name (defined-name (car args)))) + `(begin + (let ((public-i (module-public-interface (current-module)))) + ;; Make sure there is a local variable: + ;; + (module-define! (current-module) + ',name + (module-ref (current-module) ',name #f)) - ;; Make sure that local is exported: - ;; - (module-add! public-i ',name (module-variable (current-module) ',name))) + ;; Make sure that local is exported: + ;; + (module-add! public-i ',name + (module-variable (current-module) ',name))) - ;; Now (re)define the var normally. - ;; - (define-private ,@ args)))))) + ;; Now (re)define the var normally. Bernard URBAN + ;; suggests we use eval here to accomodate Hobbit; it lets + ;; the interpreter handle the define-private form, which + ;; Hobbit can't digest. + (eval '(define-private ,@ args))))))) @@ -2511,14 +2907,33 @@ (defmacro ,@ args)))))) +(defmacro export names + `(let* ((m (current-module)) + (public-i (module-public-interface m))) + (for-each (lambda (name) + ;; Make sure there is a local variable: + (module-define! m name (module-ref m name #f)) + ;; Make sure that local is exported: + (module-add! public-i name (module-variable m name))) + ',names))) + +(define export-syntax export) + + (define load load-module) -;(define (load . args) -; (start-stack 'load-stack (apply load-module args))) +;;; {Load emacs interface support if emacs option is given.} + +(define (load-emacs-interface) + (if (memq 'debug-extensions *features*) + (debug-enable 'backtrace)) + (define-module (guile-user) :use-module (ice-9 emacs))) + + ;;; {I/O functions for Tcl channels (disabled)} ;; (define in-ch (get-standard-channel TCL_STDIN)) @@ -2554,1232 +2969,156 @@ ;; (set-current-output-port outp) ;; (set-current-error-port errp) +;; this is just (scm-style-repl) with a wrapper to install and remove +;; signal handlers. (define (top-repl) - (scm-style-repl)) + + ;; Load emacs interface support if emacs option is given. + (if (and (module-defined? the-root-module 'use-emacs-interface) + use-emacs-interface) + (load-emacs-interface)) + + ;; Place the user in the guile-user module. + (define-module (guile-user)) + + (let ((old-handlers #f) + (signals `((,SIGINT . "User interrupt") + (,SIGFPE . "Arithmetic error") + (,SIGBUS . "Bad memory access (bus error)") + (,SIGSEGV . "Bad memory access (Segmentation violation)")))) + + (dynamic-wind + + ;; call at entry + (lambda () + (let ((make-handler (lambda (msg) + (lambda (sig) + (save-stack %deliver-signals) + (scm-error 'signal + #f + msg + #f + (list sig)))))) + (set! old-handlers + (map (lambda (sig-msg) + (sigaction (car sig-msg) + (make-handler (cdr sig-msg)))) + signals)))) + + ;; the protected thunk. + (lambda () + + ;; If we've got readline, use it to prompt the user. This is a + ;; kludge, but we'll fix it soon. At least we only get + ;; readline involved when we're actually running the repl. + (if (and (memq 'readline *features*) + (isatty? (current-input-port)) + (not (and (module-defined? the-root-module + 'use-emacs-interface) + use-emacs-interface))) + (let ((read-hook (lambda () (run-hook before-read-hook)))) + (set-current-input-port (readline-port)) + (set! repl-reader + (lambda (prompt) + (dynamic-wind + (lambda () + (set-readline-prompt! prompt) + (set-readline-read-hook! read-hook)) + (lambda () (read)) + (lambda () + (set-readline-prompt! "") + (set-readline-read-hook! #f))))))) + (let ((status (scm-style-repl))) + (run-hook exit-hook) + status)) + + ;; call at exit. + (lambda () + (map (lambda (sig-msg old-handler) + (if (not (car old-handler)) + ;; restore original C handler. + (sigaction (car sig-msg) #f) + ;; restore Scheme handler, SIG_IGN or SIG_DFL. + (sigaction (car sig-msg) + (car old-handler) + (cdr old-handler)))) + signals old-handlers))))) (defmacro false-if-exception (expr) `(catch #t (lambda () ,expr) (lambda args #f))) - -;;; {Calling Conventions} -(define-module (ice-9 calling)) - -;;;; -;;; -;;; This file contains a number of macros that support -;;; common calling conventions. - -;;; -;;; with-excursion-function proc -;;; is an unevaluated list of names that are bound in the caller. -;;; proc is a procedure, called: -;;; (proc excursion) -;;; -;;; excursion is a procedure isolates all changes to -;;; in the dynamic scope of the call to proc. In other words, -;;; the values of are saved when proc is entered, and when -;;; proc returns, those values are restored. Values are also restored -;;; entering and leaving the call to proc non-locally, such as using -;;; call-with-current-continuation, error, or throw. -;;; -(defmacro-public with-excursion-function (vars proc) - `(,proc ,(excursion-function-syntax vars))) - - - -;;; with-getter-and-setter proc -;;; is an unevaluated list of names that are bound in the caller. -;;; proc is a procedure, called: -;;; (proc getter setter) -;;; -;;; getter and setter are procedures used to access -;;; or modify . -;;; -;;; setter, called with keywords arguments, modifies the named -;;; values. If "foo" and "bar" are among , then: -;;; -;;; (setter :foo 1 :bar 2) -;;; == (set! foo 1 bar 2) -;;; -;;; getter, called with just keywords, returns -;;; a list of the corresponding values. For example, -;;; if "foo" and "bar" are among the , then -;;; -;;; (getter :foo :bar) -;;; => ( ) -;;; -;;; getter, called with no arguments, returns a list of all accepted -;;; keywords and the corresponding values. If "foo" and "bar" are -;;; the *only* , then: -;;; -;;; (getter) -;;; => (:foo :bar ) -;;; -;;; The unusual calling sequence of a getter supports too handy -;;; idioms: -;;; -;;; (apply setter (getter)) ;; save and restore -;;; -;;; (apply-to-args (getter :foo :bar) ;; fetch and bind -;;; (lambda (foo bar) ....)) -;;; -;;; ;; [ "apply-to-args" is just like two-argument "apply" except that it -;;; ;; takes its arguments in a different order. -;;; -;;; -(defmacro-public with-getter-and-setter (vars proc) - `(,proc ,@ (getter-and-setter-syntax vars))) - -;;; with-getter vars proc -;;; A short-hand for a call to with-getter-and-setter. -;;; The procedure is called: -;;; (proc getter) -;;; -(defmacro-public with-getter (vars proc) - `(,proc ,(car (getter-and-setter-syntax vars)))) - - -;;; with-delegating-getter-and-setter get-delegate set-delegate proc -;;; Compose getters and setters. -;;; -;;; is an unevaluated list of names that are bound in the caller. -;;; -;;; get-delegate is called by the new getter to extend the set of -;;; gettable variables beyond just -;;; set-delegate is called by the new setter to extend the set of -;;; gettable variables beyond just -;;; -;;; proc is a procedure that is called -;;; (proc getter setter) -;;; -(defmacro-public with-delegating-getter-and-setter (vars get-delegate set-delegate proc) - `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate))) - - -;;; with-delegating-getter-and-setter get-delegate set-delegate proc -;;; is an unevaluated list of names that are bound in the caller. -;;; proc is called: -;;; -;;; (proc excursion getter setter) -;;; -;;; See also: -;;; with-getter-and-setter -;;; with-excursion-function -;;; -(defmacro-public with-excursion-getter-and-setter (vars proc) - `(,proc ,(excursion-function-syntax vars) - ,@ (getter-and-setter-syntax vars))) - - -(define (excursion-function-syntax vars) - (let ((saved-value-names (map gensym vars)) - (tmp-var-name (gensym 'temp)) - (swap-fn-name (gensym 'swap)) - (thunk-name (gensym 'thunk))) - `(lambda (,thunk-name) - (letrec ((,tmp-var-name #f) - (,swap-fn-name - (lambda () ,@ (map (lambda (n sn) `(set! ,tmp-var-name ,n ,n ,sn ,sn ,tmp-var-name)) - vars saved-value-names))) - ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars)) - (dynamic-wind - ,swap-fn-name - ,thunk-name - ,swap-fn-name))))) - - -(define (getter-and-setter-syntax vars) - (let ((args-name (gensym 'args)) - (an-arg-name (gensym 'an-arg)) - (new-val-name (gensym 'new-value)) - (loop-name (gensym 'loop)) - (kws (map symbol->keyword vars))) - (list `(lambda ,args-name - (let ,loop-name ((,args-name ,args-name)) - (if (null? ,args-name) - ,(if (null? kws) - ''() - `(let ((all-vals (,loop-name ',kws))) - (let ,loop-name ((vals all-vals) - (kws ',kws)) - (if (null? vals) - '() - `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws))))))) - (map (lambda (,an-arg-name) - (case ,an-arg-name - ,@ (append - (map (lambda (kw v) `((,kw) ,v)) kws vars) - `((else (throw 'bad-get-option ,an-arg-name)))))) - ,args-name)))) - - `(lambda ,args-name - (let ,loop-name ((,args-name ,args-name)) - (or (null? ,args-name) - (null? (cdr ,args-name)) - (let ((,an-arg-name (car ,args-name)) - (,new-val-name (cadr ,args-name))) - (case ,an-arg-name - ,@ (append - (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars) - `((else (throw 'bad-set-option ,an-arg-name))))) - (,loop-name (cddr ,args-name))))))))) - -(define (delegating-getter-and-setter-syntax vars get-delegate set-delegate) - (let ((args-name (gensym 'args)) - (an-arg-name (gensym 'an-arg)) - (new-val-name (gensym 'new-value)) - (loop-name (gensym 'loop)) - (kws (map symbol->keyword vars))) - (list `(lambda ,args-name - (let ,loop-name ((,args-name ,args-name)) - (if (null? ,args-name) - (append! - ,(if (null? kws) - ''() - `(let ((all-vals (,loop-name ',kws))) - (let ,loop-name ((vals all-vals) - (kws ',kws)) - (if (null? vals) - '() - `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws))))))) - (,get-delegate)) - (map (lambda (,an-arg-name) - (case ,an-arg-name - ,@ (append - (map (lambda (kw v) `((,kw) ,v)) kws vars) - `((else (car (,get-delegate ,an-arg-name))))))) - ,args-name)))) - - `(lambda ,args-name - (let ,loop-name ((,args-name ,args-name)) - (or (null? ,args-name) - (null? (cdr ,args-name)) - (let ((,an-arg-name (car ,args-name)) - (,new-val-name (cadr ,args-name))) - (case ,an-arg-name - ,@ (append - (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars) - `((else (,set-delegate ,an-arg-name ,new-val-name))))) - (,loop-name (cddr ,args-name))))))))) - - - - -;;; with-configuration-getter-and-setter proc -;;; -;;; Create a getter and setter that can trigger arbitrary computation. -;;; -;;; is a list of variable specifiers, explained below. -;;; proc is called: -;;; -;;; (proc getter setter) -;;; -;;; Each element of the list is of the form: -;;; -;;; ( getter-hook setter-hook) -;;; -;;; Both hook elements are evaluated; the variable name is not. -;;; Either hook may be #f or procedure. -;;; -;;; A getter hook is a thunk that returns a value for the corresponding -;;; variable. If omitted (#f is passed), the binding of is -;;; returned. -;;; -;;; A setter hook is a procedure of one argument that accepts a new value -;;; for the corresponding variable. If omitted, the binding of -;;; is simply set using set!. -;;; -(defmacro-public with-configuration-getter-and-setter (vars-etc proc) - `((lambda (simpler-get simpler-set body-proc) - (with-delegating-getter-and-setter () - simpler-get simpler-set body-proc)) - - (lambda (kw) - (case kw - ,@(map (lambda (v) `((,(symbol->keyword (car v))) - ,(cond - ((cadr v) => list) - (else `(list ,(car v)))))) - vars-etc))) - - (lambda (kw new-val) - (case kw - ,@(map (lambda (v) `((,(symbol->keyword (car v))) - ,(cond - ((caddr v) => (lambda (proc) `(,proc new-val))) - (else `(set! ,(car v) new-val))))) - vars-etc))) - - ,proc)) - -(defmacro-public with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc) - `((lambda (simpler-get simpler-set body-proc) - (with-delegating-getter-and-setter () - simpler-get simpler-set body-proc)) - - (lambda (kw) - (case kw - ,@(append! (map (lambda (v) `((,(symbol->keyword (car v))) - ,(cond - ((cadr v) => list) - (else `(list ,(car v)))))) - vars-etc) - `((else (,delegate-get kw)))))) - - (lambda (kw new-val) - (case kw - ,@(append! (map (lambda (v) `((,(symbol->keyword (car v))) - ,(cond - ((caddr v) => (lambda (proc) `(,proc new-val))) - (else `(set! ,(car v) new-val))))) - vars-etc) - `((else (,delegate-set kw new-val)))))) - - ,proc)) - - -;;; let-configuration-getter-and-setter proc -;;; -;;; This procedure is like with-configuration-getter-and-setter (q.v.) -;;; except that each element of is: +;;; This hook is run at the very end of an interactive session. ;;; -;;; ( initial-value getter-hook setter-hook) -;;; -;;; Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter -;;; introduces bindings for the variables named in . -;;; It is short-hand for: -;;; -;;; (let (( initial-value-1) -;;; ( initial-value-2) -;;; ...) -;;; (with-configuration-getter-and-setter (( v1-get v1-set) ...) proc)) -;;; -(defmacro-public let-with-configuration-getter-and-setter (vars-etc proc) - `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc) - (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc) - ,proc))) - - - - -;;; {Implementation of COMMON LISP list functions for Scheme} - -(define-module (ice-9 common-list)) - -;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme -; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer. -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) -(define-public (make-list k . init) - (set! init (if (pair? init) (car init))) - (do ((k k (+ -1 k)) - (result '() (cons init result))) - ((<= k 0) result))) - -(define-public (adjoin e l) (if (memq e l) l (cons e l))) - -(define-public (union l1 l2) - (cond ((null? l1) l2) - ((null? l2) l1) - (else (union (cdr l1) (adjoin (car l1) l2))))) - -(define-public (intersection l1 l2) - (cond ((null? l1) l1) - ((null? l2) l2) - ((memv (car l1) l2) (cons (car l1) (intersection (cdr l1) l2))) - (else (intersection (cdr l1) l2)))) - -(define-public (set-difference l1 l2) - (cond ((null? l1) l1) - ((memv (car l1) l2) (set-difference (cdr l1) l2)) - (else (cons (car l1) (set-difference (cdr l1) l2))))) - -(define-public (reduce-init p init l) - (if (null? l) - init - (reduce-init p (p init (car l)) (cdr l)))) - -(define-public (reduce p l) - (cond ((null? l) l) - ((null? (cdr l)) (car l)) - (else (reduce-init p (car l) (cdr l))))) - -(define-public (some pred l . rest) - (cond ((null? rest) - (let mapf ((l l)) - (and (not (null? l)) - (or (pred (car l)) (mapf (cdr l)))))) - (else (let mapf ((l l) (rest rest)) - (and (not (null? l)) - (or (apply pred (car l) (map car rest)) - (mapf (cdr l) (map cdr rest)))))))) - -(define-public (every pred l . rest) - (cond ((null? rest) - (let mapf ((l l)) - (or (null? l) - (and (pred (car l)) (mapf (cdr l)))))) - (else (let mapf ((l l) (rest rest)) - (or (null? l) - (and (apply pred (car l) (map car rest)) - (mapf (cdr l) (map cdr rest)))))))) - -(define-public (notany pred . ls) (not (apply some pred ls))) - -(define-public (notevery pred . ls) (not (apply every pred ls))) - -(define-public (find-if t l) - (cond ((null? l) #f) - ((t (car l)) (car l)) - (else (find-if t (cdr l))))) - -(define-public (member-if t l) - (cond ((null? l) #f) - ((t (car l)) l) - (else (member-if t (cdr l))))) - -(define-public (remove-if p l) - (cond ((null? l) '()) - ((p (car l)) (remove-if p (cdr l))) - (else (cons (car l) (remove-if p (cdr l)))))) - -(define-public (delete-if! pred list) - (let delete-if ((list list)) - (cond ((null? list) '()) - ((pred (car list)) (delete-if (cdr list))) - (else - (set-cdr! list (delete-if (cdr list))) - list)))) - -(define-public (delete-if-not! pred list) - (let delete-if ((list list)) - (cond ((null? list) '()) - ((not (pred (car list))) (delete-if (cdr list))) - (else - (set-cdr! list (delete-if (cdr list))) - list)))) - -(define-public (butlast lst n) - (letrec ((l (- (length lst) n)) - (bl (lambda (lst n) - (cond ((null? lst) lst) - ((positive? n) - (cons (car lst) (bl (cdr lst) (+ -1 n)))) - (else '()))))) - (bl lst (if (negative? n) - (slib:error "negative argument to butlast" n) - l)))) - -(define-public (and? . args) - (cond ((null? args) #t) - ((car args) (apply and? (cdr args))) - (else #f))) - -(define-public (or? . args) - (cond ((null? args) #f) - ((car args) #t) - (else (apply or? (cdr args))))) - -(define-public (has-duplicates? lst) - (cond ((null? lst) #f) - ((member (car lst) (cdr lst)) #t) - (else (has-duplicates? (cdr lst))))) - -(define-public (list* x . y) - (define (list*1 x) - (if (null? (cdr x)) - (car x) - (cons (car x) (list*1 (cdr x))))) - (if (null? y) - x - (cons x (list*1 y)))) - -;; pick p l -;; Apply P to each element of L, returning a list of elts -;; for which P returns a non-#f value. -;; -(define-public (pick p l) - (let loop ((s '()) - (l l)) - (cond - ((null? l) s) - ((p (car l)) (loop (cons (car l) s) (cdr l))) - (else (loop s (cdr l)))))) - -;; pick p l -;; Apply P to each element of L, returning a list of the -;; non-#f return values of P. -;; -(define-public (pick-mappings p l) - (let loop ((s '()) - (l l)) - (cond - ((null? l) s) - ((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l)))) - (else (loop s (cdr l)))))) - -(define-public (uniq l) - (if (null? l) - '() - (let ((u (uniq (cdr l)))) - (if (memq (car l) u) - u - (cons (car l) u))))) - - -;;; {Functions for browsing modules} - -(define-module (ice-9 ls) - :use-module (ice-9 common-list)) - -;;;; -;;; local-definitions-in root name -;;; Returns a list of names defined locally in the named -;;; subdirectory of root. -;;; definitions-in root name -;;; Returns a list of all names defined in the named -;;; subdirectory of root. The list includes alll locally -;;; defined names as well as all names inherited from a -;;; member of a use-list. -;;; -;;; A convenient interface for examining the nature of things: -;;; -;;; ls . various-names -;;; -;;; With just one argument, interpret that argument as the -;;; name of a subdirectory of the current module and -;;; return a list of names defined there. -;;; -;;; With more than one argument, still compute -;;; subdirectory lists, but return a list: -;;; (( . ) -;;; ( . ) -;;; ...) -;;; - -(define-public (local-definitions-in root names) - (let ((m (nested-ref root names)) - (answer '())) - (if (not (module? m)) - (set! answer m) - (module-for-each (lambda (k v) (set! answer (cons k answer))) m)) - answer)) - -(define-public (definitions-in root names) - (let ((m (nested-ref root names))) - (if (not (module? m)) - m - (reduce union - (cons (local-definitions-in m '()) - (map (lambda (m2) (definitions-in m2 '())) - (module-uses m))))))) - -(define-public (ls . various-refs) - (and various-refs - (if (cdr various-refs) - (map (lambda (ref) - (cons ref (definitions-in (current-module) ref))) - various-refs) - (definitions-in (current-module) (car various-refs))))) - -(define-public (lls . various-refs) - (and various-refs - (if (cdr various-refs) - (map (lambda (ref) - (cons ref (local-definitions-in (current-module) ref))) - various-refs) - (local-definitions-in (current-module) (car various-refs))))) - -(define-public (recursive-local-define name value) - (let ((parent (reverse! (cdr (reverse name))))) - (and parent (make-modules-in (current-module) parent)) - (local-define name value))) - -;;; {Queues} +(define exit-hook (make-hook)) -(define-module (ice-9 q)) - -;;;; Copyright (C) 1995 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; - -;;;; -;;; Q: Based on the interface to -;;; -;;; "queue.scm" Queues/Stacks for Scheme -;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. -;;; - -;;;; -;;; {Q} +;;; Load readline code into root module if readline primitives are available. ;;; -;;; A list is just a bunch of cons pairs that follows some constrains, right? -;;; Association lists are the same. Hash tables are just vectors and association -;;; lists. You can print them, read them, write them as constants, pun them off as other data -;;; structures etc. This is good. This is lisp. These structures are fast and compact -;;; and easy to manipulate arbitrarily because of their simple, regular structure and -;;; non-disjointedness (associations being lists and so forth). -;;; -;;; So I figured, queues should be the same -- just a "subtype" of cons-pair -;;; structures in general. -;;; -;;; A queue is a cons pair: -;;; ( . ) -;;; -;;; is a list of things in the q. New elements go at the end of that list. -;;; -;;; is #f if the q is empty, and otherwise is the last pair of . -;;; -;;; q's print nicely, but alas, they do not read well because the eq?-ness of -;;; and (last-pair ) is lost by read. The procedure -;;; -;;; (sync-q! q) -;;; -;;; recomputes and resets the component of a queue. -;;; - -(define-public (sync-q! obj) (set-cdr! obj (and (car obj) (last-pair (car obj))))) - -;;; make-q -;;; return a new q. -;;; -(define-public (make-q) (cons '() '())) - -;;; q? obj -;;; Return true if obj is a Q. -;;; An object is a queue if it is equal? to '(#f . #f) or -;;; if it is a pair P with (list? (car P)) and (eq? (cdr P) (last-pair P)). -;;; -(define-public (q? obj) (and (pair? obj) - (or (and (null? (car obj)) - (null? (cdr obj))) - (and - (list? (car obj)) - (eq? (cdr obj) (last-pair (car obj))))))) - -;;; q-empty? obj -;;; -(define-public (q-empty? obj) (null? (car obj))) - -;;; q-empty-check q -;;; Throw a q-empty exception if Q is empty. -(define-public (q-empty-check q) (if (q-empty? q) (throw 'q-empty q))) - - -;;; q-front q -;;; Return the first element of Q. -(define-public (q-front q) (q-empty-check q) (caar q)) - -;;; q-front q -;;; Return the last element of Q. -(define-public (q-rear q) (q-empty-check q) (cadr q)) - -;;; q-remove! q obj -;;; Remove all occurences of obj from Q. -(define-public (q-remove! q obj) - (while (memq obj (car q)) - (set-car! q (delq! obj (car q)))) - (set-cdr! q (last-pair (car q)))) - -;;; q-push! q obj -;;; Add obj to the front of Q -(define-public (q-push! q d) - (let ((h (cons d (car q)))) - (set-car! q h) - (if (null? (cdr q)) - (set-cdr! q h)))) - -;;; enq! q obj -;;; Add obj to the rear of Q -(define-public (enq! q d) - (let ((h (cons d '()))) - (if (not (null? (cdr q))) - (set-cdr! (cdr q) h) - (set-car! q h)) - (set-cdr! q h))) - -;;; q-pop! q -;;; Take the front of Q and return it. -(define-public (q-pop! q) - (q-empty-check q) - (let ((it (caar q)) - (next (cdar q))) - (if (not next) - (set-cdr! q #f)) - (set-car! q next) - it)) - -;;; deq! q -;;; Take the front of Q and return it. -(define-public deq! q-pop!) - -;;; q-length q -;;; Return the number of enqueued elements. -;;; -(define-public (q-length q) (length (car q))) - - - - -;;; {The runq data structure} - -(define-module (ice-9 runq) - :use-module (ice-9 q)) - -;;;; Copyright (C) 1996 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; - -;;;; -;;; -;;; One way to schedule parallel computations in a serial environment is -;;; to explicitly divide each task up into small, finite execution time, -;;; strips. Then you interleave the execution of strips from various -;;; tasks to achieve a kind of parallelism. Runqs are a handy data -;;; structure for this style of programming. -;;; -;;; We use thunks (nullary procedures) and lists of thunks to represent -;;; strips. By convention, the return value of a strip-thunk must either -;;; be another strip or the value #f. -;;; -;;; A runq is a procedure that manages a queue of strips. Called with no -;;; arguments, it processes one strip from the queue. Called with -;;; arguments, the arguments form a control message for the queue. The -;;; first argument is a symbol which is the message selector. -;;; -;;; A strip is processed this way: If the strip is a thunk, the thunk is -;;; called -- if it returns a strip, that strip is added back to the -;;; queue. To process a strip which is a list of thunks, the CAR of that -;;; list is called. After a call to that CAR, there are 0, 1, or 2 strips -;;; -- perhaps one returned by the thunk, and perhaps the CDR of the -;;; original strip if that CDR is not nil. The runq puts whichever of -;;; these strips exist back on the queue. (The exact order in which -;;; strips are put back on the queue determines the scheduling behavior of -;;; a particular queue -- it's a parameter.) -;;; -;;; - - - -;;;; -;;; (runq-control q msg . args) -;;; -;;; processes in the default way the control messages that -;;; can be sent to a runq. Q should be an ordinary -;;; Q (see utils/q.scm). -;;; -;;; The standard runq messages are: -;;; -;;; 'add! strip0 strip1... ;; to enqueue one or more strips -;;; 'enqueue! strip0 strip1... ;; to enqueue one or more strips -;;; 'push! strip0 ... ;; add strips to the front of the queue -;;; 'empty? ;; true if it is -;;; 'length ;; how many strips in the queue? -;;; 'kill! ;; empty the queue -;;; else ;; throw 'not-understood -;;; -(define-public (runq-control q msg . args) - (case msg - ((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*) - ((enque!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*) - ((push!) (for-each (lambda (t) (q-push! q t)) args) '*unspecified*) - ((empty?) (q-empty? q)) - ((length) (q-length q)) - ((kill!) (set! q (make-q))) - (else (throw 'not-understood msg args)))) - -(define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f))) - -;;;; -;;; make-void-runq -;;; -;;; Make a runq that discards all messages except "length", for which -;;; it returns 0. -;;; -(define-public (make-void-runq) - (lambda opts - (and opts - (apply-to-args opts - (lambda (msg . args) - (case msg - ((length) 0) - (else #f))))))) - -;;;; -;;; (make-fair-runq) -;;; -;;; Returns a runq procedure. -;;; Called with no arguments, the procedure processes one strip from the queue. -;;; Called with arguments, it uses runq-control. -;;; -;;; In a fair runq, if a strip returns a new strip X, X is added -;;; to the end of the queue, meaning it will be the last to execute -;;; of all the remaining procedures. -;;; -(define-public (make-fair-runq) - (letrec ((q (make-q)) - (self - (lambda ctl - (if ctl - (apply runq-control q ctl) - (and (not (q-empty? q)) - (let ((next-strip (deq! q))) - (cond - ((procedure? next-strip) (let ((k (run-strip next-strip))) - (and k (enq! q k)))) - ((pair? next-strip) (let ((k (run-strip (car next-strip)))) - (and k (enq! q k))) - (if (not (null? (cdr next-strip))) - (enq! q (cdr next-strip))))) - self)))))) - self)) - - -;;;; -;;; (make-exclusive-runq) -;;; -;;; Returns a runq procedure. -;;; Called with no arguments, the procedure processes one strip from the queue. -;;; Called with arguments, it uses runq-control. -;;; -;;; In an exclusive runq, if a strip W returns a new strip X, X is added -;;; to the front of the queue, meaning it will be the next to execute -;;; of all the remaining procedures. -;;; -;;; An exception to this occurs if W was the CAR of a list of strips. -;;; In that case, after the return value of W is pushed onto the front -;;; of the queue, the CDR of the list of strips is pushed in front -;;; of that (if the CDR is not nil). This way, the rest of the thunks -;;; in the list that contained W have priority over the return value of W. -;;; -(define-public (make-exclusive-runq) - (letrec ((q (make-q)) - (self - (lambda ctl - (if ctl - (apply runq-control q ctl) - (and (not (q-empty? q)) - (let ((next-strip (deq! q))) - (cond - ((procedure? next-strip) (let ((k (run-strip next-strip))) - (and k (q-push! q k)))) - ((pair? next-strip) (let ((k (run-strip (car next-strip)))) - (and k (q-push! q k))) - (if (not (null? (cdr next-strip))) - (q-push! q (cdr next-strip))))) - self)))))) - self)) - - -;;;; -;;; (make-subordinate-runq-to superior basic-inferior) -;;; -;;; Returns a runq proxy for the runq basic-inferior. -;;; -;;; The proxy watches for operations on the basic-inferior that cause -;;; a transition from a queue length of 0 to a non-zero length and -;;; vice versa. While the basic-inferior queue is not empty, -;;; the proxy installs a task on the superior runq. Each strip -;;; of that task processes N strips from the basic-inferior where -;;; N is the length of the basic-inferior queue when the proxy -;;; strip is entered. [Countless scheduling variations are possible.] -;;; -(define-public (make-subordinate-runq-to superior-runq basic-runq) - (let ((runq-task (cons #f #f))) - (set-car! runq-task - (lambda () - (if (basic-runq 'empty?) - (set-cdr! runq-task #f) - (do ((n (basic-runq 'length) (1- n))) - ((<= n 0) #f) - (basic-runq))))) - (letrec ((self - (lambda ctl - (if (not ctl) - (let ((answer (basic-runq))) - (self 'empty?) - answer) - (begin - (case (car ctl) - ((suspend) (set-cdr! runq-task #f)) - (else (let ((answer (apply basic-runq ctl))) - (if (and (not (cdr runq-task)) (not (basic-runq 'empty?))) - (begin - (set-cdr! runq-task runq-task) - (superior-runq 'add! runq-task))) - answer)))))))) - self))) - -;;;; -;;; (define fork-strips (lambda args args)) -;;; Return a strip that starts several strips in -;;; parallel. If this strip is enqueued on a fair -;;; runq, strips of the parallel subtasks will run -;;; round-robin style. -;;; -(define fork-strips (lambda args args)) - - -;;;; -;;; (strip-sequence . strips) -;;; -;;; Returns a new strip which is the concatenation of the argument strips. -;;; -(define-public ((strip-sequence . strips)) - (let loop ((st (let ((a strips)) (set! strips #f) a))) - (and (not (null? st)) - (let ((then ((car st)))) - (if then - (lambda () (loop (cons then (cdr st)))) - (lambda () (loop (cdr st)))))))) - - -;;;; -;;; (fair-strip-subtask . initial-strips) -;;; -;;; Returns a new strip which is the synchronos, fair, -;;; parallel execution of the argument strips. -;;; -;;; -;;; -(define-public (fair-strip-subtask . initial-strips) - (let ((st (make-fair-runq))) - (apply st 'add! initial-strips) - st)) - - -;;; {String Fun} - -(define-module (ice-9 string-fun)) - -;;;; -;;; -;;; Various string funcitons, particularly those that take -;;; advantage of the "shared substring" capability. -;;; - -;;; {String Fun: Dividing Strings Into Fields} -;;; -;;; The names of these functions are very regular. -;;; Here is a grammar of a call to one of these: -;;; -;;; -;;; := (-- ) -;;; -;;; = the string -;;; -;;; = The continuation. String functions generally return -;;; multiple values by passing them to this procedure. -;;; -;;; = split -;;; | separate-fields -;;; -;;; "split" means to divide a string into two parts. -;;; will be called with two arguments. -;;; -;;; "separate-fields" means to divide a string into as many -;;; parts as possible. will be called with -;;; however many fields are found. -;;; -;;; = before -;;; | after -;;; | discarding -;;; -;;; "before" means to leave the seperator attached to -;;; the beginning of the field to its right. -;;; "after" means to leave the seperator attached to -;;; the end of the field to its left. -;;; "discarding" means to discard seperators. -;;; -;;; Other dispositions might be handy. For example, "isolate" -;;; could mean to treat the separator as a field unto itself. -;;; -;;; = char -;;; | predicate -;;; -;;; "char" means to use a particular character as field seperator. -;;; "predicate" means to check each character using a particular predicate. -;;; -;;; Other determinations might be handy. For example, "character-set-member". -;;; -;;; = A parameter that completes the meaning of the determinations. -;;; For example, if the determination is "char", then this parameter -;;; says which character. If it is "predicate", the parameter is the -;;; predicate. -;;; -;;; -;;; For example: -;;; -;;; (separate-fields-discarding-char #\, "foo, bar, baz, , bat" list) -;;; => ("foo" " bar" " baz" " " " bat") -;;; -;;; (split-after-char #\- 'an-example-of-split list) -;;; => ("an-" "example-of-split") -;;; -;;; As an alternative to using a determination "predicate", or to trying to do anything -;;; complicated with these functions, consider using regular expressions. -;;; - -(define-public (split-after-char char str ret) - (let ((end (cond - ((string-index str char) => 1+) - (else (string-length str))))) - (ret (make-shared-substring str 0 end) - (make-shared-substring str end)))) - -(define-public (split-before-char char str ret) - (let ((end (or (string-index str char) - (string-length str)))) - (ret (make-shared-substring str 0 end) - (make-shared-substring str end)))) - -(define-public (split-discarding-char char str ret) - (let ((end (string-index str char))) - (if (not end) - (ret str "") - (ret (make-shared-substring str 0 end) - (make-shared-substring str (1+ end)))))) - -(define-public (split-after-char-last char str ret) - (let ((end (cond - ((string-rindex str char) => 1+) - (else 0)))) - (ret (make-shared-substring str 0 end) - (make-shared-substring str end)))) - -(define-public (split-before-char-last char str ret) - (let ((end (or (string-rindex str char) 0))) - (ret (make-shared-substring str 0 end) - (make-shared-substring str end)))) - -(define-public (split-discarding-char-last char str ret) - (let ((end (string-rindex str char))) - (if (not end) - (ret str "") - (ret (make-shared-substring str 0 end) - (make-shared-substring str (1+ end)))))) - -(define (split-before-predicate pred str ret) - (let loop ((n 0)) - (cond - ((= n (length str)) (ret str "")) - ((not (pred (string-ref str n))) (loop (1+ n))) - (else (ret (make-shared-substring str 0 n) - (make-shared-substring str n)))))) -(define (split-after-predicate pred str ret) - (let loop ((n 0)) - (cond - ((= n (length str)) (ret str "")) - ((not (pred (string-ref str n))) (loop (1+ n))) - (else (ret (make-shared-substring str 0 (1+ n)) - (make-shared-substring str (1+ n))))))) - -(define (split-discarding-predicate pred str ret) - (let loop ((n 0)) - (cond - ((= n (length str)) (ret str "")) - ((not (pred (string-ref str n))) (loop (1+ n))) - (else (ret (make-shared-substring str 0 n) - (make-shared-substring str (1+ n))))))) - -(define-public (separate-fields-discarding-char ch str ret) - (let loop ((fields '()) - (str str)) - (cond - ((string-rindex str ch) - => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 w)) fields) - (make-shared-substring str 0 w)))) - (else (ret (cons str fields)))))) - -(define-public (separate-fields-after-char ch str ret) - (let loop ((fields '()) - (str str)) - (cond - ((string-rindex str ch) - => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 w)) fields) - (make-shared-substring str 0 (+ 1 w))))) - (else (ret (cons str fields)))))) - -(define-public (separate-fields-before-char ch str ret) - (let loop ((fields '()) - (str str)) - (cond - ((string-rindex str ch) - => (lambda (pos) (loop (cons (make-shared-substring str w) fields) - (make-shared-substring str 0 w)))) - (else (ret (cons str fields)))))) - - -;;; {String Fun: String Prefix Predicates} -;;; -;;; Very simple: -;;; -;;; (define-public ((string-prefix-predicate pred?) prefix str) -;;; (and (<= (length prefix) (length str)) -;;; (pred? prefix (make-shared-substring str 0 (length prefix))))) -;;; -;;; (define-public string-prefix=? (string-prefix-predicate string=?)) -;;; - -(define-public ((string-prefix-predicate pred?) prefix str) - (and (<= (length prefix) (length str)) - (pred? prefix (make-shared-substring str 0 (length prefix))))) - -(define-public string-prefix=? (string-prefix-predicate string=?)) - - -;;; {String Fun: Strippers} -;;; -;;; = sans- -;;; -;;; = surrounding-whitespace -;;; | trailing-whitespace -;;; | leading-whitespace -;;; | final-newline -;;; - -(define-public (sans-surrounding-whitespace s) - (let ((st 0) - (end (string-length s))) - (while (and (< st (string-length s)) - (char-whitespace? (string-ref s st))) - (set! st (1+ st))) - (while (and (< 0 end) - (char-whitespace? (string-ref s (1- end)))) - (set! end (1- end))) - (if (< end st) - "" - (make-shared-substring s st end)))) - -(define-public (sans-trailing-whitespace s) - (let ((st 0) - (end (string-length s))) - (while (and (< 0 end) - (char-whitespace? (string-ref s (1- end)))) - (set! end (1- end))) - (if (< end st) - "" - (make-shared-substring s st end)))) - -(define-public (sans-leading-whitespace s) - (let ((st 0) - (end (string-length s))) - (while (and (< st (string-length s)) - (char-whitespace? (string-ref s st))) - (set! st (1+ st))) - (if (< end st) - "" - (make-shared-substring s st end)))) - -(define-public (sans-final-newline str) - (cond - ((= 0 (string-length str)) - str) - - ((char=? #\nl (string-ref str (1- (string-length str)))) - (make-shared-substring str 0 (1- (string-length str)))) - - (else str))) - -;;; {String Fun: has-trailing-newline?} -;;; - -(define-public (has-trailing-newline? str) - (and (< 0 (string-length str)) - (char=? #\nl (string-ref str (1- (string-length str)))))) - - - -;;; {String Fun: with-regexp-parts} - -(define-public (with-regexp-parts regexp fields str return fail) - (let ((parts (regexec regexp str fields))) - (if (number? parts) - (fail parts) - (apply return parts)))) +;;; Ideally, we wouldn't do this until we were sure we were actually +;;; going to enter the repl, but autoloading individual functions is +;;; clumsy at the moment. +(if (and (memq 'readline *features*) + (isatty? (current-input-port))) + (begin + (define-module (guile) :use-module (ice-9 readline)) + (define-module (guile-user) :use-module (ice-9 readline)))) -;;; {Load debug extension code if debug extensions present.} +;;; {Load debug extension code into user module if debug extensions present.} ;;; ;;; *fixme* This is a temporary solution. ;;; (if (memq 'debug-extensions *features*) - (define-module (guile) :use-module (ice-9 debug))) + (define-module (guile-user) :use-module (ice-9 debug))) -;;; {Load session support if present.} +;;; {Load session support into user module if present.} ;;; ;;; *fixme* This is a temporary solution. ;;; (if (%search-load-path "ice-9/session.scm") - (define-module (guile) :use-module (ice-9 session))) + (define-module (guile-user) :use-module (ice-9 session))) - -;;; {Load thread code if threads are present.} +;;; {Load thread code into user module if threads are present.} ;;; ;;; *fixme* This is a temporary solution. ;;; (if (memq 'threads *features*) - (define-module (guile) :use-module (ice-9 threads))) + (define-module (guile-user) :use-module (ice-9 threads))) -;;; {Load emacs interface support if emacs option is given.} -;;; -;;; *fixme* This is a temporary solution. -;;; +;;; {Load regexp code if regexp primitives are available.} -(if (and (module-defined? the-root-module 'use-emacs-interface) - use-emacs-interface) - (define-module (guile) :use-module (ice-9 emacs))) +(if (memq 'regex *features*) + (define-module (guile-user) :use-module (ice-9 regex))) - (define-module (guile)) +;;; {Check that the interpreter and scheme code match up.} + +(let ((show-line + (lambda args + (with-output-to-port (current-error-port) + (lambda () + (display (car (command-line))) + (display ": ") + (for-each (lambda (string) (display string)) + args) + (newline)))))) + + (load-from-path "ice-9/version.scm") + + (if (not (string=? + (libguile-config-stamp) ; from the interprpreter + (ice-9-config-stamp))) ; from the Scheme code + (begin + (show-line "warning: different versions of libguile and ice-9:") + (show-line "libguile: configured on " (libguile-config-stamp)) + (show-line "ice-9: configured on " (ice-9-config-stamp))))) + (append! %load-path (cons "." ())) +