diff options
Diffstat (limited to 'ice-9/boot-9.scm')
-rw-r--r-- | ice-9/boot-9.scm | 1983 |
1 files changed, 1069 insertions, 914 deletions
diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index fa55e9a1d..919b5d7ae 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. +;;;; Copyright (C) 1995, 1996, 1997 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 @@ -26,8 +26,20 @@ ;;; +;;; {Features} +;; + +(define (provide sym) + (if (not (memq sym *features*)) + (set! *features* (cons sym *features*)))) + + +;;; {R4RS compliance} -;; {Simple Debugging Tools} +(primitive-load-path "ice-9/r4rs.scm") + + +;;; {Simple Debugging Tools} ;; @@ -54,24 +66,22 @@ (lambda () (newline) (display ";;; WARNING ") - (print stuff) + (display stuff) (newline) (car (last-pair stuff))))) -;;; {apply and call-with-current-continuation} +;;; {Trivial Functions} ;;; -;;; These turn syntax, @apply and @call-with-current-continuation, -;;; into procedures. -;;; - -(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args)))) -(define (call-with-current-continuation proc) (@call-with-current-continuation proc)) +(define (id x) x) +(define (1+ n) (+ n 1)) +(define (-1+ n) (+ n -1)) +(define 1- -1+) +(define return-it noop) +(define (and=> value procedure) (and value (procedure value))) +(define (make-hash-table k) (make-vector k '())) - -;;; {apply-to-args} -;;; ;;; apply-to-args is functionally redunant with apply and, worse, ;;; is less general than apply since it only takes two arguments. ;;; @@ -87,28 +97,9 @@ (define (apply-to-args args fn) (apply fn args)) -;;; {Silly Naming Cleanups and Trivial Functions} -;;; - -(define %open-file open-file) -(define (id x) x) -(define < <?) -(define <= <=?) -(define = =?) -(define > >?) -(define >= >=?) -(define (1+ n) (+ n 1)) -(define (-1+ n) (+ n -1)) -(define 1- -1+) -(define return-it noop) -(define (and=> value thunk) (and value (thunk value))) -(define (make-hash-table k) (make-vector k '())) - ;;; {Integer Math} ;;; -(define (integer? x) (and (number? x) (= x (inexact->exact x)))) - (define (ipow-by-squaring x k acc proc) (cond ((zero? k) acc) ((= 1 k) (proc acc x)) @@ -131,102 +122,6 @@ (else (apply logior args)))) -;;; {Basic Port Code} -;;; -;;; Specificly, the parts of the low-level port code that are written in -;;; Scheme rather than C. -;;; -;;; WARNING: the parts of this interface that refer to file ports -;;; is going away. It would be gone already except that it is used -;;; "internally" in a few places. -;;; - - -;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper -;; mode to open files in. MSDOS does carraige return - newline -;; translation if not opened in `b' mode. -;; -(define OPEN_READ (case (software-type) - ((MS-DOS WINDOWS ATARIST) "rb") - (else "r"))) -(define OPEN_WRITE (case (software-type) - ((MS-DOS WINDOWS ATARIST) "wb") - (else "w"))) -(define OPEN_BOTH (case (software-type) - ((MS-DOS WINDOWS ATARIST) "r+b") - (else "r+"))) - -(define (open-input-file str) - (or (open-file str OPEN_READ) - (error "OPEN-INPUT-FILE couldn't find file " str))) - -(define (open-output-file str) - (or (open-file str OPEN_WRITE) - (error "OPEN-OUTPUT-FILE couldn't find file " str))) - -(define (open-io-file str) (open-file str OPEN_BOTH)) -(define close-input-port close-port) -(define close-output-port close-port) -(define close-io-port close-port) - -(define (call-with-input-file str proc) - (let* ((file (open-input-file str)) - (ans (proc file))) - (close-input-port file) - ans)) - -(define (call-with-output-file str proc) - (let* ((file (open-output-file str)) - (ans (proc file))) - (close-output-port file) - ans)) - -(define (with-input-from-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-input-port port))))) - (dynamic-wind swaports thunk swaports))) - -(define (with-output-to-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-output-port port))))) - (dynamic-wind swaports thunk swaports))) - -(define (with-error-to-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-error-port port))))) - (dynamic-wind swaports thunk swaports))) - -(define (with-input-from-file file thunk) - (let* ((nport (open-input-file file)) - (ans (with-input-from-port nport thunk))) - (close-port nport) - ans)) - -(define (with-output-to-file file thunk) - (let* ((nport (open-output-file file)) - (ans (with-output-to-port nport thunk))) - (close-port nport) - ans)) - -(define (with-error-to-file file thunk) - (let* ((nport (open-output-file file)) - (ans (with-error-to-port nport thunk))) - (close-port nport) - ans)) - -(define (with-input-from-string string thunk) - (call-with-input-string string - (lambda (p) (with-input-from-port p thunk)))) - -(define (with-output-to-string thunk) - (call-with-output-string - (lambda (p) (with-output-to-port p thunk)))) - -(define (with-error-to-string thunk) - (call-with-output-string - (lambda (p) (with-error-to-port p thunk)))) - -(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p)))) - - - ;;; {Symbol Properties} ;;; @@ -246,6 +141,122 @@ (symbol-pset! sym (delq! pair (symbol-pref sym)))))) + +;;; {Line and Delimited I/O} + +;;; corresponds to SCM_LINE_INCREMENTORS in libguile. +(define scm-line-incrementors "\n") + +(define (read-line! string . maybe-port) + (let* ((port (if (pair? maybe-port) + (car maybe-port) + (current-input-port)))) + (let* ((rv (%read-delimited! scm-line-incrementors + string + #t + port)) + (terminator (car rv)) + (nchars (cdr rv))) + (cond ((and (= nchars 0) + (eof-object? terminator)) + terminator) + ((not terminator) #f) + (else nchars))))) + +(define (read-delimited! delims buf . args) + (let* ((num-args (length args)) + (port (if (> num-args 0) + (car args) + (current-input-port))) + (handle-delim (if (> num-args 1) + (cadr args) + 'trim)) + (start (if (> num-args 2) + (caddr args) + 0)) + (end (if (> num-args 3) + (cadddr args) + (string-length buf)))) + (let* ((rv (%read-delimited! delims + buf + (not (eq? handle-delim 'peek)) + port + start + end)) + (terminator (car rv)) + (nchars (cdr rv))) + (cond ((or (not terminator) ; buffer filled + (eof-object? terminator)) + (if (zero? nchars) + (if (eq? handle-delim 'split) + (cons terminator terminator) + terminator) + (if (eq? handle-delim 'split) + (cons nchars terminator) + nchars))) + (else + (case handle-delim + ((trim peek) nchars) + ((concat) (string-set! buf nchars terminator) + (+ nchars 1)) + ((split) (cons nchars terminator)) + (else (error "unexpected handle-delim value: " + handle-delim)))))))) + +(define (read-delimited delims . args) + (let* ((port (if (pair? args) + (let ((pt (car args))) + (set! args (cdr args)) + pt) + (current-input-port))) + (handle-delim (if (pair? args) + (car args) + 'trim))) + (let loop ((substrings ()) + (total-chars 0) + (buf-size 100)) ; doubled each time through. + (let* ((buf (make-string buf-size)) + (rv (%read-delimited! delims + buf + (not (eq? handle-delim 'peek)) + port)) + (terminator (car rv)) + (nchars (cdr rv)) + (join-substrings + (lambda () + (apply string-append + (reverse + (cons (if (and (eq? handle-delim 'concat) + (not (eof-object? terminator))) + (string terminator) + "") + (cons (make-shared-substring buf 0 nchars) + substrings)))))) + (new-total (+ total-chars nchars))) + (cond ((not terminator) + ;; buffer filled. + (loop (cons (substring buf 0 nchars) substrings) + new-total + (* buf-size 2))) + ((eof-object? terminator) + (if (zero? new-total) + (if (eq? handle-delim 'split) + (cons terminator terminator) + terminator) + (if (eq? handle-delim 'split) + (cons (join-substrings) terminator) + (join-substrings)))) + (else + (case handle-delim + ((trim peek concat) (join-substrings)) + ((split) (cons (join-substrings) terminator)) + (else (error "unexpected handle-delim value: " + handle-delim))))))))) + +(define (read-line . args) + (apply read-delimited scm-line-incrementors args)) + + ;;; {Arrays} ;;; @@ -254,7 +265,7 @@ (define make-uniform-vector dimensions->uniform-array) ; (define uniform-vector-ref array-ref) (define (uniform-vector-set! u i o) - (uniform-vector-set1! u o i)) + (uniform-array-set1! u o i)) (define uniform-vector-fill! array-fill!) (define uniform-vector-read! uniform-array-read!) (define uniform-vector-write uniform-array-write) @@ -287,100 +298,6 @@ (and rem (pair? (cdr rem)) (cadr rem)))) - -;;; {Print} -;;; - -(define (print obj . args) - (let ((default-args (list (current-output-port) 0 0 default-print-style #f))) - (apply-to-args (append args (list-cdr-ref default-args (length args))) - (lambda (port depth length style table) - (cond - ((and table (print-table-ref table obj)) ((print-style-tag-hook style 'eq-val) - obj port depth length style table)) - (else - (and table (print-table-add! table obj)) - (cond - ((print-style-max-depth? style depth) ((print-style-excess-depth-hook style))) - ((print-style-max-length? style length) ((print-style-excess-length-hook style))) - (else ((print-style-hook style obj) - obj port depth length style table))))))))) - -(define (make-print-style) (make-vector 59)) - -(define (extend-print-style! style utag printer) (hashq-set! style utag printer)) - -(define (print-style-hook style obj) - (let ((type-tag (tag obj))) - (or (hashq-ref style type-tag) - (hashq-ref style (logand type-tag 255)) - print-obj))) - -(define (print-style-tag-hook style type-tag) - (or (hashq-ref style type-tag) - print-obj)) - -(define (print-style-max-depth? style d) #f) -(define (print-style-max-length? style l) #f) -(define (print-style-excess-length-hook style) (hashq-ref style 'excess-length-hook)) -(define (print-style-excess-depth-hook style) (hashq-ref style 'excess-depth-hook)) - -(define (make-print-table) (make-vector 59)) -(define (print-table-ref table obj) (hashq-ref table obj)) -(define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref))) - -(define (print-obj obj port depth length style table) (write obj port)) - -(define (print-pair pair port depth length style table) - (if (= 0 length) - (display #\( port)) - - (print (car pair) port (+ 1 depth) 0 style table) - - (cond - ((and (pair? (cdr pair)) - (or (not table) - (not (print-table-ref table (cdr pair))))) - - (display #\space port) - (print (cdr pair) port depth (+ 1 length) style table)) - - ((null? (cdr pair)) (display #\) port)) - - (else (display " . " port) - (print (cdr pair) port (+ 1 depth) 0 style table) - (display #\) port)))) - -(define (print-vector obj port depth length style table) - (if (= 0 length) - (cond - ((weak-hash-table? obj) (display "#wh(" port)) - ((weak-value-hash-table? obj) (display "#whv(" port)) - ((doubly-weak-hash-table? obj) (display "#whd(" port)) - (else (display "#(" port)))) - - (if (< length (vector-length obj)) - (print (vector-ref obj length) port (+ 1 depth) 0 style table)) - - (cond - ((>= (+ 1 length) (vector-length obj)) (display #\) port)) - (else (display #\space port) - (print obj port depth (+ 1 length) style table)))) - -(define default-print-style (make-print-style)) - -(extend-print-style! default-print-style utag_vector print-vector) -(extend-print-style! default-print-style utag_wvect print-vector) -(extend-print-style! default-print-style utag_pair print-pair) -(extend-print-style! default-print-style 'eq-val - (lambda (obj port depth length style table) - (if (symbol? obj) - (display obj) - (begin - (display "##" port) - (display (print-table-ref table obj)))))) - - ;;; {Records} ;;; @@ -390,16 +307,20 @@ (and (struct? obj) (eq? record-type-vtable (struct-vtable obj)))) (define (make-record-type type-name fields . opt) - (let ((printer-fn (and opt (car opt)))) + (let ((printer-fn (and (pair? opt) (car opt)))) (let ((struct (make-struct record-type-vtable 0 - (make-struct-layout (apply symbol-append (map (lambda (f) "pw") fields))) + (make-struct-layout + (apply symbol-append + (map (lambda (f) "pw") fields))) type-name (copy-tree fields)))) ;; !!! leaks printer functions - (if printer-fn - (extend-print-style! default-print-style - (logior utag_struct_base (ash (struct-vtable-tag struct) 8)) - printer-fn)) + ;; MDJ 960919 <djurfeldt@nada.kth.se>: *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) @@ -413,7 +334,7 @@ (error 'not-a-record-type obj))) (define (record-constructor rtd . opt) - (let ((field-names (if opt (car opt) (record-type-fields rtd)))) + (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd)))) (eval `(lambda ,field-names (make-struct ',rtd 0 ,@(map (lambda (f) (if (memq f field-names) @@ -449,6 +370,8 @@ (struct-vtable obj) (error 'not-a-record obj))) +(provide 'record) + ;;; {Booleans} ;;; @@ -548,19 +471,69 @@ (map-in-order fn (cdr l))))) +;;; {Hooks} +(define (run-hooks hook) + (for-each (lambda (thunk) (thunk)) hook)) + +(define add-hook! + (procedure->macro + (lambda (exp env) + `(let ((thunk ,(caddr exp))) + (if (not (memq thunk ,(cadr exp))) + (set! ,(cadr exp) + (cons thunk ,(cadr exp)))))))) + + ;;; {Files} ;;; !!!! these should be implemented using Tcl commands, not fports. ;;; -(define (file-exists? str) - (let ((port (open-file str OPEN_READ))) - (if port (begin (close-port port) #t) - #f))) - -(define (file-is-directory? str) - (let ((port (open-file (string-append str "/.") OPEN_READ))) - (if port (begin (close-port port) #t) - #f))) +(define (feature? feature) + (and (memq feature *features*) #t)) + +;; Using the vector returned by stat directly is probably not a good +;; idea (it could just as well be a record). Hence some accessors. +(define (stat:dev f) (vector-ref f 0)) +(define (stat:ino f) (vector-ref f 1)) +(define (stat:mode f) (vector-ref f 2)) +(define (stat:nlink f) (vector-ref f 3)) +(define (stat:uid f) (vector-ref f 4)) +(define (stat:gid f) (vector-ref f 5)) +(define (stat:rdev f) (vector-ref f 6)) +(define (stat:size f) (vector-ref f 7)) +(define (stat:atime f) (vector-ref f 8)) +(define (stat:mtime f) (vector-ref f 9)) +(define (stat:ctime f) (vector-ref f 10)) +(define (stat:blksize f) (vector-ref f 11)) +(define (stat:blocks f) (vector-ref f 12)) + +;; derived from stat mode. +(define (stat:type f) (vector-ref f 13)) +(define (stat:perms f) (vector-ref f 14)) + +(define file-exists? + (if (feature? 'posix) + (lambda (str) + (access? str F_OK)) + (lambda (str) + (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ)) + (lambda args #f)))) + (if port (begin (close-port port) #t) + #f))))) + +(define file-is-directory? + (if (feature? 'i/o-extensions) + (lambda (str) + (eq? (stat:type (stat str)) 'directory)) + (lambda (str) + (display str) + (newline) + (let ((port (catch 'system-error + (lambda () (open-file (string-append str "/.") + OPEN_READ)) + (lambda args #f)))) + (if port (begin (close-port port) #t) + #f))))) (define (has-suffix? str suffix) (let ((sufl (string-length suffix)) @@ -568,89 +541,61 @@ (and (> sl sufl) (string=? (substring str (- sl sufl) sl) suffix)))) - - ;;; {Error Handling} ;;; - -;; (error . args) is short for (throw (quote error) . args) -;; (define (error . args) - (apply throw 'error args)) - - - - -;; Error handling a la SCM. -;; -(define (%%default-error-handler tag . args) - (define cep (current-error-port)) - (perror "ERROR") - (errno 0) - (display "ERROR: " cep) - (if (not (null? args)) - (begin (display (car args) cep) - (for-each (lambda (x) (display #\ cep) (write x cep)) - (cdr args)))) - (newline cep) - (force-output cep) - (apply throw 'abort tag args)) - - - -;; Install SCM error handling as the default. -;; -(set-symbol-property! 'error - 'throw-handler-default - %%default-error-handler) - - - - - -;; %%bad-throw is the hook that is called upon a throw to a an unhandled -;; key. If the key has a default handler (a throw-handler-default property), + (save-stack) + (if (null? args) + (scm-error 'misc-error #f "?" #f #f) + (let loop ((msg "%s") + (rest (cdr args))) + (if (not (null? rest)) + (loop (string-append msg " %S") + (cdr rest)) + (scm-error 'misc-error #f msg args #f))))) + +;; bad-throw is the hook that is called upon a throw to a an unhandled +;; key (unless the throw has four arguments, in which case +;; it's usually interpreted as an error throw.) +;; If the key has a default handler (a throw-handler-default property), ;; it is applied to the throw. ;; -(define (%%bad-throw key . args) +(define (bad-throw key . args) (let ((default (symbol-property key 'throw-handler-default))) (or (and default (apply default key args)) - (throw 'error 'unhandled-exception key args)))) + (apply error "unhandled-exception:" key args)))) - - - - -;; A number of internally defined error types are represented +;; 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 %%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) @@ -658,333 +603,216 @@ (define (alarm-thunk) #t) (define (signal-handler n) - (cond - ((= n 21) (unmask-signals) (timer-thunk)) - ((= n 20) (unmask-signals) (gc-thunk)) - ((= n 19) (unmask-signals) (alarm-thunk)) - (else (unmask-signals) (throw '%%system-error n #f)))) - - -;; The default handler for built-in error types when -;; thrown by their symbolic name. The action is to -;; convert the error into a generic error, building -;; a descriptive message for the error. -;; -(define (%%handle-system-error ignored desc proc . args) - (let* ((b (assoc desc %%system-errors)) - (msghead (cond - (b (caddr b)) - ((or (symbol? desc) (string? desc)) - (string-append desc " ")) - (#t "Unknown error"))) - (msg (if (symbol? proc) - (string-append msghead proc ":") - msghead)) - (rest (if (and proc (not (symbol? proc))) - (cons proc args) - args)) - (fixed-args (cons msg rest))) - (apply error fixed-args))) - - -(set-symbol-property! '%%system-error - 'throw-handler-default - %%handle-system-error) - - -;; Install default handlers for built-in errors. -;; -(map (lambda (err) - (set-symbol-property! (cadr err) - 'throw-handler-default - %%handle-system-error)) - (cdr %%system-errors)) - - - - -(define ((make-simple-wrapper func) . args) - (or (apply func args) - (apply throw 'syserror func (errno) args))) - -(define ((make-eof-wrapper func) . args) - (let ((rv (apply func args))) - (if (eof-object? rv) - (apply throw 'syserror func (errno) args) - rv))) - -(define ((make-errno-wrapper func) . args) - (let ((rv (apply func args))) - (if (number? rv) - (apply throw 'syserror func rv args) - rv))) - -(define ((make-errpair-wrapper func) . args) - (let ((rv (apply func args))) - (if (and (pair? rv) - (number? (car rv)) - (null? (cdr rv))) - (apply throw 'syserror func (car rv) args) - rv))) - -(begin - (define (syserror key fn err . args) - (errno err) - (apply error (cons fn args))) - (set-symbol-property! 'syserror 'throw-handler-default syserror)) - - -(define (%getgrnam name) (%getgr name)) -(define (%getgrgid id) (%getgr id)) -(define (%gethostbyaddr addr) (%gethost addr)) -(define (%gethostbyname name) (%gethost name)) -(define (%getnetbyaddr addr) (%getnet addr)) -(define (%getnetbyname name) (%getnet name)) -(define (%getprotobyname name) (%getproto name)) -(define (%getprotobynumber addr) (%getproto addr)) -(define (%getpwnam name) (%getpw name)) -(define (%getpwuid uid) (%getpw uid)) -(define (%getservbyname name proto) (%getserv name proto)) -(define (%getservbyport port proto) (%getserv port proto)) + (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} + +(define (getgrnam name) (getgr name)) +(define (getgrgid id) (getgr id)) +(define (gethostbyaddr addr) (gethost addr)) +(define (gethostbyname name) (gethost name)) +(define (getnetbyaddr addr) (getnet addr)) +(define (getnetbyname name) (getnet name)) +(define (getprotobyname name) (getproto name)) +(define (getprotobynumber addr) (getproto addr)) +(define (getpwnam name) (getpw name)) +(define (getpwuid uid) (getpw uid)) +(define (getservbyname name proto) (getserv name proto)) +(define (getservbyport port proto) (getserv port proto)) (define (endgrent) (setgr)) (define (endhostent) (sethost)) (define (endnetent) (setnet)) (define (endprotoent) (setproto)) (define (endpwent) (setpw)) (define (endservent) (setserv)) +(define (getgrent) (getgr)) +(define (gethostent) (gethost)) +(define (getnetent) (getnet)) +(define (getprotoent) (getproto)) +(define (getpwent) (getpw)) +(define (getservent) (getserv)) +(define (reopen-file . args) (apply freopen args)) +(define (setgrent) (setgr #f)) +(define (sethostent) (sethost #t)) +(define (setnetent) (setnet #t)) +(define (setprotoent) (setproto #t)) +(define (setpwent) (setpw #t)) +(define (setservent) (setserv #t)) + +(define (passwd:name obj) (vector-ref obj 0)) +(define (passwd:passwd obj) (vector-ref obj 1)) +(define (passwd:uid obj) (vector-ref obj 2)) +(define (passwd:gid obj) (vector-ref obj 3)) +(define (passwd:gecos obj) (vector-ref obj 4)) +(define (passwd:dir obj) (vector-ref obj 5)) +(define (passwd:shell obj) (vector-ref obj 6)) + +(define (group:name obj) (vector-ref obj 0)) +(define (group:passwd obj) (vector-ref obj 1)) +(define (group:gid obj) (vector-ref obj 2)) +(define (group:mem obj) (vector-ref obj 3)) + +(define (hostent:name obj) (vector-ref obj 0)) +(define (hostent:aliases obj) (vector-ref obj 1)) +(define (hostent:addrtype obj) (vector-ref obj 2)) +(define (hostent:length obj) (vector-ref obj 3)) +(define (hostent:addr-list obj) (vector-ref obj 4)) + +(define (netent:name obj) (vector-ref obj 0)) +(define (netent:aliases obj) (vector-ref obj 1)) +(define (netent:addrtype obj) (vector-ref obj 2)) +(define (netent:net obj) (vector-ref obj 3)) + +(define (protoent:name obj) (vector-ref obj 0)) +(define (protoent:aliases obj) (vector-ref obj 1)) +(define (protoent:proto obj) (vector-ref obj 2)) + +(define (servent:name obj) (vector-ref obj 0)) +(define (servent:aliases obj) (vector-ref obj 1)) +(define (servent:port obj) (vector-ref obj 2)) +(define (servent:proto obj) (vector-ref obj 3)) + +(define (sockaddr:fam obj) (vector-ref obj 0)) +(define (sockaddr:path obj) (vector-ref obj 1)) +(define (sockaddr:addr obj) (vector-ref obj 1)) +(define (sockaddr:port obj) (vector-ref obj 2)) + +(define (utsname:sysname obj) (vector-ref obj 0)) +(define (utsname:nodename obj) (vector-ref obj 1)) +(define (utsname:release obj) (vector-ref obj 2)) +(define (utsname:version obj) (vector-ref obj 3)) +(define (utsname:machine obj) (vector-ref obj 4)) + +(define (tm:sec obj) (vector-ref obj 0)) +(define (tm:min obj) (vector-ref obj 1)) +(define (tm:hour obj) (vector-ref obj 2)) +(define (tm:mday obj) (vector-ref obj 3)) +(define (tm:mon obj) (vector-ref obj 4)) +(define (tm:year obj) (vector-ref obj 5)) +(define (tm:wday obj) (vector-ref obj 6)) +(define (tm:yday obj) (vector-ref obj 7)) +(define (tm:isdst obj) (vector-ref obj 8)) +(define (tm:gmtoff obj) (vector-ref obj 9)) +(define (tm:zone obj) (vector-ref obj 10)) + +(define (set-tm:sec obj val) (vector-set! obj 0 val)) +(define (set-tm:min obj val) (vector-set! obj 1 val)) +(define (set-tm:hour obj val) (vector-set! obj 2 val)) +(define (set-tm:mday obj val) (vector-set! obj 3 val)) +(define (set-tm:mon obj val) (vector-set! obj 4 val)) +(define (set-tm:year obj val) (vector-set! obj 5 val)) +(define (set-tm:wday obj val) (vector-set! obj 6 val)) +(define (set-tm:yday obj val) (vector-set! obj 7 val)) +(define (set-tm:isdst obj val) (vector-set! obj 8 val)) +(define (set-tm:gmtoff obj val) (vector-set! obj 9 val)) +(define (set-tm:zone obj val) (vector-set! obj 10 val)) + (define (file-position . args) (apply ftell args)) (define (file-set-position . args) (apply fseek args)) -(define (getgrent) (%getgr)) -(define (gethostent) (%gethost)) -(define (getnetent) (%getnet)) -(define (getprotoent) (%getproto)) -(define (getpwent) (%getpw)) -(define (getservent) (%getserv)) -(define (reopen-file . args) (apply freopen args)) -(define (setgrent arg) (setgr arg)) -(define (sethostent arg) (sethost arg)) -(define (setnetent arg) (setnet arg)) -(define (setprotoent arg) (setproto arg)) -(define (setpwent arg) (setpw arg)) -(define (setservent arg) (setserv arg)) -(define (%move->fdes port fd) - (if (= 1 (primitive-move->fdes port fd)) - (set-port-revealed! port 1) - #t)) - -(define accept (make-errno-wrapper %accept)) -(define bind (make-errno-wrapper %bind)) -(define chdir (make-errno-wrapper %chdir)) -(define chmod (make-errno-wrapper %chmod)) -(define chown (make-errno-wrapper %chown)) -(define close (make-errno-wrapper %close)) -(define closedir (make-errno-wrapper %closedir)) -(define connect (make-errno-wrapper %connect)) -(define copy-file (make-simple-wrapper %copy-file)) -(define ctermid (make-simple-wrapper %ctermid)) -(define delete-file (make-errno-wrapper %delete-file)) -(define duplicate-port (make-simple-wrapper %duplicate-port)) -(define execl (make-errno-wrapper %execl)) -(define execlp (make-errno-wrapper %execlp)) -(define fdopen (make-errno-wrapper %fdopen)) -(define fileno (make-simple-wrapper %fileno)) -(define fork (make-simple-wrapper %fork)) -(define freopen (make-errno-wrapper %freopen)) -(define fseek (make-errno-wrapper %fseek)) -(define ftell (make-errno-wrapper %ftell)) -(define getcwd (make-errno-wrapper %getcwd)) -(define getenv (make-simple-wrapper %getenv)) -(define getgrgid (make-errno-wrapper %getgrgid)) -(define getgrnam (make-errno-wrapper %getgrnam)) -(define getgroups (make-errno-wrapper %getgroups)) -(define gethostbyaddr (make-simple-wrapper %gethostbyaddr)) -(define gethost (make-simple-wrapper %gethost)) -(define gethostbyname (make-simple-wrapper %gethostbyname)) -(define getnetbyaddr (make-simple-wrapper %getnetbyaddr)) -(define getnetbyname (make-simple-wrapper %getnetbyname)) -(define getpeername (make-errno-wrapper %getpeername)) -(define getprotobyname (make-simple-wrapper %getprotobyname)) -(define getprotobynumber (make-simple-wrapper %getprotobynumber)) -(define getpwnam (make-simple-wrapper %getpwnam)) -(define getpwuid (make-simple-wrapper %getpwuid)) -(define getservbyname (make-simple-wrapper %getservbyname)) -(define getservbyport (make-simple-wrapper %getservbyport)) -(define getsockname (make-errno-wrapper %getsockname)) -(define getsockopt (make-errpair-wrapper %getsockopt)) -(define inet-aton (make-simple-wrapper %inet-aton)) -(define isatty? (make-errno-wrapper %isatty?)) -(define kill (make-errno-wrapper %kill)) -(define link (make-errno-wrapper %link)) -(define listen (make-errno-wrapper %listen)) -(define lstat (make-errno-wrapper %lstat)) -(define mkdir (make-errno-wrapper %mkdir)) -(define mknod (make-errno-wrapper %mknod)) -(define nice (make-errno-wrapper %nice)) -(define opendir (make-errno-wrapper %opendir)) -(define pipe (make-errno-wrapper %pipe)) -(define primitive-move->fdes (make-simple-wrapper %primitive-move->fdes)) -(define putenv (make-errno-wrapper %putenv)) -(define read-fd (make-errpair-wrapper %read-fd)) -(define readdir (make-errno-wrapper %readdir)) -(define readlink (make-errno-wrapper %readlink)) -(define recv (make-errno-wrapper %recv)) -(define recvfrom (make-errno-wrapper %recvfrom)) -(define redirect-port (make-errno-wrapper %redirect-port)) -(define rename-file (make-errno-wrapper %rename-file)) -(define rmdir (make-errno-wrapper %rmdir)) -(define select (make-errno-wrapper %select)) -(define send (make-errpair-wrapper %send)) -(define sendto (make-errpair-wrapper %sendto)) -(define setegid (make-errno-wrapper %setegid)) -(define seteuid (make-errno-wrapper %seteuid)) -(define setgid (make-errno-wrapper %setgid)) -(define setlocale (make-errno-wrapper %setlocale)) -(define setpgid (make-errno-wrapper %setpgid)) -(define setsid (make-simple-wrapper %setsid)) -(define setsockopt (make-errno-wrapper %setsockopt)) -(define setuid (make-errno-wrapper %setuid)) -(define shutdown (make-errno-wrapper %shutdown)) -(define socket (make-errno-wrapper %socket)) -(define socketpair (make-errno-wrapper %socketpair)) -(define stat (make-errno-wrapper %stat)) -(define strptime (make-simple-wrapper %strptime)) -(define symlink (make-simple-wrapper %symlink)) -(define tcgetpgrp (make-simple-wrapper %tcgetpgrp)) -(define tcsetpgrp (make-simple-wrapper %tcsetpgrp)) -(define ttyname (make-errno-wrapper %ttyname)) -(define uname (make-errno-wrapper %uname)) -(define utime (make-errno-wrapper %utime)) -(define waitpid (make-errno-wrapper %waitpid)) -(define write-fd (make-errpair-wrapper %write-fd)) -(define move->fdes (make-simple-wrapper %move->fdes)) + +(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 (release-port-handle port) + (let ((revealed (port-revealed port))) + (if (> revealed 0) + (set-port-revealed! port (- revealed 1))))) ;;; {Load Paths} ;;; -(define implementation-vicinity compiled-library-path) - ;;; Here for backward compatability ;; (define scheme-file-suffix (lambda () ".scm")) -(define in-vicinity string-append) - -(define (parse-path env_path) - (cond ((string? env_path) - (let loop ((curdir "") (env env_path) (path '())) - (cond ((= (string-length env) 0) - (if (> (string-length curdir) 0) - (append path (list curdir)) - path)) - ((char=? (string-ref env 0) #\:) - (loop "" - (substring env 1 (string-length env)) - (append path (list curdir)))) - (#t - (loop (string-append curdir (substring env 0 1)) - (substring env 1 (string-length env)) - path))))) - (#t '()))) - -(define %load-path (append (parse-path (%getenv "SCHEME_LOAD_PATH")) - (list "" - (in-vicinity (implementation-vicinity) "gls/guile/") - (in-vicinity (implementation-vicinity) "gls/") - (in-vicinity (implementation-vicinity) "slib/")))) +(define (in-vicinity vicinity file) + (let ((tail (let ((len (string-length vicinity))) + (if (zero? len) #f + (string-ref vicinity (- len 1)))))) + (string-append vicinity + (if (eq? tail #\/) "" "/") + file))) + -;;; {try-load} -;;; +;;; {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 (eval-string string) + (call-with-input-string + string + (lambda (port) + (let loop () + (let ((expr (read port))) + (if (eof-object? expr) #f + (begin (eval expr) (loop)))))))) + +(define (command-line) (program-arguments)) -(define (try-load-with-path file-name path) - (or-map (lambda (d) - (let ((f (in-vicinity d file-name))) - (and (not (file-is-directory? f)) - (%try-load f #t read-sharp)))) - path)) +(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? (getenv "HOME")) + (has-init? (passwd:dir (getpw (getuid))))))) + (if path (primitive-load path)))) -(define (try-load name) - (if (eval '(defined? %load-path)) - (try-load-with-path name (eval '%load-path)) - (%try-load name #t read-sharp))) -;;; {Load} -;;; - -(define %load-verbosely #t) -(define (assert-load-verbosity v) (set! %load-verbosely v)) -(define %load-indent -2) - -(define (%load f) - (current-module) - (or (and (not (file-is-directory? f)) - (%try-load f #t read-sharp)) - (and (not (has-suffix? f (scheme-file-suffix))) - (%try-load (string-append f (scheme-file-suffix)) #t read-sharp)))) - -(define (%load-announce file) - (if %load-verbosely - (with-output-to-port (current-error-port) - (lambda () - (display ";;; ") - (display (make-string %load-indent #\ )) - (display "loading ") - (display file) - (display "...") - (newline) - (force-output))))) - -(define (%load-announce-win file) - (if %load-verbosely - (with-output-to-port (current-error-port) - (lambda () - (display ";;; ") - (display (make-string %load-indent #\ )) - (display "...loaded ") - (display file) - (display ".") - (newline) - (force-output))))) - -(define (%load-announce-lossage file path) - (if %load-verbosely - (with-output-to-port (current-error-port) - (lambda () - (display ";;; ") - (display (make-string %load-indent #\ )) - (display "...COULD NOT LOAD ") - (display file) - (display " from ") - (write path) - (newline) - (force-output)))) - (throw 'could-not-load file path)) - - -(define (load-with-path name path) - (define (do-load) - (%load-announce name) - (if (not (or-map (lambda (d) - (if (%load (in-vicinity d name)) - (begin - (%load-announce-win (in-vicinity d name)) - #t) - #f)) - path)) - (%load-announce-lossage name path))) - - (let ((indent %load-indent)) - (dynamic-wind - (lambda () (set! %load-indent (modulo (+ indent 2) 16))) - do-load - (lambda () (set! %load-indent indent)))) - #t) - - -(define (load name) - (if (eval '(defined? %load-path)) - (load-with-path name (eval '%load-path)) - (load-with-path name '()))) +;;; {Loading by paths} + +;;; Load a Scheme source file named NAME, searching for it in the +;;; directories listed in %load-path, and applying each of the file +;;; name extensions listed in %load-extensions. +(define (load-from-path name) + (start-stack 'load-stack + (primitive-load-path name))) @@ -1086,6 +914,9 @@ (set! abs magnitude) +(define (log10 arg) + (/ (log arg) (log 10))) + ;;; {User Settable Hooks} ;;; @@ -1100,7 +931,6 @@ (define end-of-program #f) (define hang-up #f) (define arithmetic-error #f) -(define read-sharp #f) @@ -1111,7 +941,7 @@ ;;; (define (parse-path-symbol s) - (define (seperate-fields-discarding-char ch str ret) + (define (separate-fields-discarding-char ch str ret) (let loop ((fields '()) (str str)) (cond @@ -1119,41 +949,68 @@ => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 pos)) fields) (make-shared-substring str 0 pos)))) (else (ret (cons str fields)))))) - (seperate-fields-discarding-char #\/ + (separate-fields-discarding-char #\/ s (lambda (fields) (map string->symbol fields)))) -(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)) - ((#\!) (if (= 1 (line-number)) - (let skip () (if (eq? #\newline (peek-char port)) - (read port #t read-sharp) - (begin (read-char port) (skip)))) - (barf))) - (else (barf)))) +(read-hash-extend #\' (lambda (c port) + (read port))) +(read-hash-extend #\. (lambda (c port) + (eval (read port)))) + +(if (feature? 'array) + (begin + (let ((make-array-proc (lambda (template) + (lambda (c port) + (read:uniform-vector template port))))) + (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))) + (let ((array-proc (lambda (c port) + (read:array c port)))) + (for-each (lambda (char) (read-hash-extend char array-proc)) + '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))))) + +;; 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)))) (define (read:array digit port) (define chr0 (char->integer #\0)) @@ -1174,27 +1031,14 @@ ((#\c) 0+i) (else (error "read:array unknown option " c))))))) (if (eq? (peek-char port) #\() - (list->uniform-array rank prot (read port #t read-sharp)) + (list->uniform-array rank prot (read port)) (error "read:array list not found")))) (define (read:uniform-vector proto port) (if (eq? #\( (peek-char port)) - (list->uniform-array 1 proto (read port #t read-sharp)) + (list->uniform-array 1 proto (read port)) (error "read:uniform-vector list not found"))) - -(define read-sharp (lambda a (apply %read-sharp a))) - - - -;;; {Dynamic Roots} -;;; - -; mystery integers passed dynamic root error handlers -(define repl-quit -1) -(define repl-abort -2) - - ;;; {Command Line Options} ;;; @@ -1284,15 +1128,6 @@ -(define (delq-all! obj l) - (let ((answer (cons '() l))) - (let loop ((pos answer)) - (cond - ((null? (cdr pos)) (cdr answer)) - ((eq? (cadr pos) obj) (set-cdr! pos (cddr pos)) - (loop pos)) - (else (loop (cdr pos))))))) - (define (transform-usage-lambda cases) (let* ((raw-usage (delq! 'else (map car cases))) (usage-sans-specials (map (lambda (x) @@ -1301,7 +1136,7 @@ (and (boolean? (car x)) #t) x)) raw-usage)) - (usage-desc (delq-all! #t usage-sans-specials)) + (usage-desc (delq! #t usage-sans-specials)) (kw-desc (map car usage-desc)) (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc))) (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc))) @@ -1359,8 +1194,8 @@ ;;; -;; This is how modules are printed. -;; You can re-define it. +;;; {Printing Modules} +;; This is how modules are printed. You can re-define it. ;; (define (%print-module mod port depth length style table) (display "#<" port) @@ -1379,85 +1214,74 @@ ;; A module is characterized by an obarray in which local symbols ;; are interned, a list of modules, "uses", from which non-local ;; bindings can be inherited, and an optional lazy-binder which -;; is a (THUNK module symbol) which, as a last resort, can provide +;; is a (CLOSURE module symbol) which, as a last resort, can provide ;; bindings that would otherwise not be found locally in the module. ;; (define module-type - (make-record-type 'module '(obarray uses binder eval-thunk name kind) %print-module)) + (make-record-type 'module '(obarray uses binder eval-closure name kind) + %print-module)) -;; make-module &opt size uses +;; make-module &opt size uses binder ;; -;; Create a new module, perhaps with a particular size of obarray -;; or initial uses list. +;; Create a new module, perhaps with a particular size of obarray, +;; initial uses list, or binding procedure. ;; -(define module-constructor (record-constructor module-type)) - (define make-module (lambda args - (let* ((size 1021) - (uses '()) - (binder #f) - (answer #f) - (eval-thunk - (lambda (symbol define?) - (if define? - (module-make-local-var! answer symbol) - (module-variable answer symbol))))) - - (if (> (length args) 0) - (begin - (set! size (or (car args) size)) - (set! args (cdr args)))) - (if (> (length args) 0) - (begin - (set! uses (or (car args) uses)) - (set! args (cdr args)))) + (define (parse-arg index default) + (if (> (length args) index) + (list-ref args index) + default)) - (if (> (length args) 0) - (begin - (set! binder (or (car args) binder)) - (set! args (cdr args)))) + (if (> (length args) 3) + (error "Too many args to make-module." args)) - (if (not (null? args)) - (error "Too many args to make-module." args)) + (let ((size (parse-arg 0 1021)) + (uses (parse-arg 1 '())) + (binder (parse-arg 2 #f))) (if (not (integer? size)) (error "Illegal size to make-module." size)) - - (and (list? uses) - (or (and-map module? uses) - (error "Incorrect use list." uses))) - + (if (not (and (list? uses) + (and-map module? uses))) + (error "Incorrect use list." uses)) (if (and binder (not (procedure? binder))) (error "Lazy-binder expected to be a procedure or #f." binder)) - (set! answer - (module-constructor (make-vector size '()) - uses - binder - eval-thunk - #f - #f)) - answer))) + (let ((module (module-constructor (make-vector size '()) + uses binder #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 + ;; itself. + (set-module-eval-closure! module + (lambda (symbol define?) + (if define? + (module-make-local-var! module symbol) + (module-variable module symbol)))) + + module)))) + +(define module-constructor (record-constructor module-type)) (define module-obarray (record-accessor module-type 'obarray)) (define set-module-obarray! (record-modifier module-type 'obarray)) (define module-uses (record-accessor module-type 'uses)) (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)) -(define module-eval-thunk (record-accessor module-type 'eval-thunk)) -(define set-module-eval-thunk! (record-modifier module-type 'eval-thunk)) +(define module-eval-closure (record-accessor module-type 'eval-closure)) +(define set-module-eval-closure! (record-modifier module-type 'eval-closure)) (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)) (define set-module-kind! (record-modifier module-type 'kind)) (define module? (record-predicate module-type)) + (define (eval-in-module exp module) - (eval2 exp (module-eval-thunk module))) + (eval2 exp (module-eval-closure module))) ;;; {Module Searching in General} @@ -1581,12 +1405,13 @@ ;;; If the symbol is not found at all, return #f. ;;; (define (module-local-variable m v) - (caddr - (list m v +; (caddr +; (list m v (let ((b (module-obarray-ref (module-obarray m) v))) (or (and (variable? b) b) (and (module-binder m) - ((module-binder m) m v #f))))))) + ((module-binder m) m v #f))))) +;)) ;; module-variable module symbol ;; @@ -1711,13 +1536,13 @@ ;; make-root-module -:; A root module uses the symhash table (the system's privileged +;; A root module uses the symhash table (the system's privileged ;; obarray). Being inside a root module is like using SCM without ;; any module system. ;; -(define (root-module-thunk m s define?) +(define (root-module-closure m s define?) (let ((bi (and (symbol-interned? #f s) (builtin-variable s)))) (and bi @@ -1727,7 +1552,7 @@ bi)))) (define (make-root-module) - (make-module 1019 #f root-module-thunk)) + (make-module 1019 '() root-module-closure)) ;; make-scm-module @@ -1740,7 +1565,7 @@ ;; (define (make-scm-module) - (make-module 1019 #f + (make-module 1019 '() (lambda (m s define?) (let ((bi (and (symbol-interned? #f s) (builtin-variable s)))) @@ -1764,8 +1589,8 @@ (define (set-current-module m) (set! the-module m) (if m - (set! *top-level-lookup-thunk* (module-eval-thunk the-module)) - (set! *top-level-lookup-thunk* #f))) + (set! *top-level-lookup-closure* (module-eval-closure the-module)) + (set! *top-level-lookup-closure* #f))) ;; current-module @@ -1790,28 +1615,14 @@ (set-current-module outer-module) (set! outer-module #f))))) -(define basic-try-load-with-path try-load-with-path) -(define basic-try-load try-load) -(define basic-load-with-path load-with-path) (define basic-load load) - -(define (try-load-module-with-path . args) - (save-module-excursion (lambda () (apply basic-try-load-with-path args)))) - -(define (try-load-module . args) - (save-module-excursion (lambda () (apply basic-try-load args)))) - -(define (load-module-with-path . args) - (save-module-excursion (lambda () (apply basic-load-with-path args)))) - (define (load-module . args) (save-module-excursion (lambda () (apply basic-load args)))) - -;; MODULE-REF -- exported +;;; {MODULE-REF -- exported} ;; ;; Returns the value of a variable called NAME in MODULE or any of its ;; used modules. If there is no such variable, then if the optional third @@ -1848,6 +1659,15 @@ (variable-set! variable value) (module-add! module name (make-variable value name))))) +;; MODULE-DEFINED? -- exported +;; +;; Return #t iff NAME is defined in MODULE (or in a module that MODULE +;; uses) +;; +(define (module-defined? module name) + (let ((variable (module-variable module name))) + (and variable (variable-bound? variable)))) + ;; MODULE-USE! module interface ;; ;; Add INTERFACE to the list of interfaces used by MODULE. @@ -1857,9 +1677,6 @@ (cons interface (delq! interface (module-uses module))))) - - -;;;; ;;; {Recursive Namespaces} ;;; ;;; @@ -1870,7 +1687,7 @@ ;;; Each variable name is a list of elements, looked up in successively nested ;;; modules. ;;; -;;; (resolved-ref some-root-module '(foo bar baz)) +;;; (nested-ref some-root-module '(foo bar baz)) ;;; => <value of a variable named baz in the module bound to bar in ;;; the module bound to foo in some-root-module> ;;; @@ -1880,23 +1697,23 @@ ;;; ;; a-root is a module ;;; ;; name is a list of symbols ;;; -;;; resolved-ref a-root name -;;; resolved-set! a-root name val -;;; resolved-define! a-root name val -;;; resolved-remove! a-root name +;;; nested-ref a-root name +;;; nested-set! a-root name val +;;; nested-define! a-root name val +;;; nested-remove! a-root name ;;; ;;; ;;; (current-module) is a natural choice for a-root so for convenience there are ;;; also: ;;; -;;; value-ref name == resolved-ref (current-module) name -;;; value-set! name val == resolved-set! (current-module) name val -;;; value-define! name val == resolved-define! (current-module) name val -;;; value-remove! name == resolved-remove! (current-module) name +;;; local-ref name == nested-ref (current-module) name +;;; local-set! name val == nested-set! (current-module) name val +;;; local-define! name val == nested-define! (current-module) name val +;;; local-remove! name == nested-remove! (current-module) name ;;; -(define (resolved-ref root names) +(define (nested-ref root names) (let loop ((cur root) (elts names)) (cond @@ -1904,37 +1721,35 @@ ((not (module? cur)) #f) (else (loop (module-ref cur (car elts) #f) (cdr elts)))))) -(define (resolved-set! root names val) +(define (nested-set! root names val) (let loop ((cur root) (elts names)) (if (null? (cdr elts)) (module-set! cur (car elts) val) (loop (module-ref cur (car elts)) (cdr elts))))) -(define (resolved-define! root names val) +(define (nested-define! root names val) (let loop ((cur root) (elts names)) (if (null? (cdr elts)) (module-define! cur (car elts) val) (loop (module-ref cur (car elts)) (cdr elts))))) -(define (resolved-remove! root names) +(define (nested-remove! root names) (let loop ((cur root) (elts names)) (if (null? (cdr elts)) (module-remove! cur (car elts)) (loop (module-ref cur (car elts)) (cdr elts))))) -(define (value-ref names) (resolved-ref (current-module) names)) -(define (value-set! names val) (resolved-set! (current-module) names val)) -(define (value-define names val) (resolved-define! (current-module) names val)) -(define (value-remove names) (resolved-remove! (current-module) names)) +(define (local-ref names) (nested-ref (current-module) names)) +(define (local-set! names val) (nested-set! (current-module) names val)) +(define (local-define names val) (nested-define! (current-module) names val)) +(define (local-remove names) (nested-remove! (current-module) names)) - -;;;; -;;; #/app +;;; {#/app} ;;; ;;; The root of conventionally named objects not directly in the top level. ;;; @@ -1955,17 +1770,19 @@ (set-current-module the-root-module) (define app (make-module 31)) -(value-define '(app modules) (make-module 31)) -(value-define '(app modules guile) the-root-module) +(local-define '(app modules) (make-module 31)) +(local-define '(app modules guile) the-root-module) ;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module))) -(define (resolve-module name) +(define (resolve-module name . maybe-autoload) (let ((full-name (append '(app modules) name))) - (let ((already (value-ref full-name))) + (let ((already (local-ref full-name))) (or already (begin - (try-module-autoload name) + (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)))))) (define (beautify-user-module! module) @@ -1974,7 +1791,8 @@ (set-module-name! interface (module-name module)) (set-module-kind! interface 'interface) (set-module-public-interface! module interface))) - (if (not (memq the-scm-module (module-uses module))) + (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))))) (define (make-modules-in module name) @@ -1997,43 +1815,51 @@ (define (process-define-module args) (let* ((module-id (car args)) - (module (resolve-module module-id)) + (module (resolve-module module-id #f)) (kws (cdr args))) (beautify-user-module! module) - (let loop ((kws kws)) - (and (not (null? kws)) - (case (car kws) - ((: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" used-module) - (beautify-user-module! used-module))) - (let ((interface (module-ref used-module '%module-public-interface #f))) - (if (not interface) - (error "missing interface for use-module" used-module)) - (set-module-uses! module - (append! (delq! interface (module-uses module)) - (list interface))))) - (loop (cddr kws))) - - (else (error "unrecognized defmodule argument" kws))))) + (let loop ((kws kws) + (reversed-interfaces '())) + (if (null? kws) + (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))))) module)) +;;; {Autoloading modules} (define autoloads-in-progress '()) (define (try-module-autoload module-name) - + (define (sfx name) (string-append name (scheme-file-suffix))) (let* ((reverse-name (reverse module-name)) (name (car reverse-name)) (dir-hint-module-name (reverse (cdr reverse-name))) (dir-hint (apply symbol-append (map (lambda (elt) (symbol-append elt "/")) dir-hint-module-name)))) - (resolve-module dir-hint-module-name) + (resolve-module dir-hint-module-name #f) (and (not (autoload-done-or-in-progress? dir-hint name)) (let ((didit #f)) (dynamic-wind @@ -2051,13 +1877,13 @@ (and (or-map (lambda (f) (let ((full (in-vicinity d f))) full - (and (not (file-is-directory? full)) - (file-exists? full) + (and (file-exists? full) + (not (file-is-directory? full)) (begin (save-module-excursion (lambda () - (list f d) - (load-with-path f (list d)))) + (load (string-append + d "/" f)))) #t)))) trys) (begin @@ -2067,6 +1893,156 @@ (lambda () (set-autoloaded! dir-hint name didit))) didit)))) +;;; Dynamic linking of modules + +;; Initializing a module that is written in C is a two step process. +;; First the module's `module init' function is called. This function +;; is expected to call `scm_register_module_xxx' to register the `real +;; init' function. Later, when the module is referenced for the first +;; time, this real init function is called in the right context. See +;; gtcltk-lib/gtcltk-module.c for an example. +;; +;; The code for the module can be in a regular shared library (so that +;; the `module init' function will be called when libguile is +;; initialized). Or it can be dynamically linked. +;; +;; You can safely call `scm_register_module_xxx' before libguile +;; itself is initialized. You could call it from an C++ constructor +;; of a static object, for example. +;; +;; To make your Guile extension into a dynamic linkable module, follow +;; these easy steps: +;; +;; - Find a name for your module, like #/ice-9/gtcltk +;; - Write a function with a name like +;; +;; scm_init_ice_9_gtcltk_module +;; +;; This is your `module init' function. It should call +;; +;; scm_register_module_xxx ("ice-9 gtcltk", scm_init_gtcltk); +;; +;; "ice-9 gtcltk" is the C version of the module name. Slashes are +;; replaced by spaces, the rest is untouched. `scm_init_gtcltk' is +;; the real init function that executes the usual initializations +;; like making new smobs, etc. +;; +;; - Make a shared library with your code and a name like +;; +;; ice-9/libgtcltk.so +;; +;; and put it somewhere in %load-path. +;; +;; - Then you can simply write `:use-module #/ice-9/gtcltk' and it +;; will be linked automatically. +;; +;; This is all very experimental. + +(define (split-c-module-name str) + (let loop ((rev '()) + (start 0) + (pos 0) + (end (string-length str))) + (cond + ((= pos end) + (reverse (cons (string->symbol (substring str start pos)) rev))) + ((eq? (string-ref str pos) #\space) + (loop (cons (string->symbol (substring str start pos)) rev) + (+ pos 1) + (+ pos 1) + end)) + (else + (loop rev start (+ pos 1) end))))) + +(define (convert-c-registered-modules dynobj) + (let ((res (map (lambda (c) + (list (split-c-module-name (car c)) (cdr c) dynobj)) + (c-registered-modules)))) + (c-clear-registered-modules) + res)) + +(define registered-modules (convert-c-registered-modules #f)) + +(define (init-dynamic-module modname) + (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))) + (set! registered-modules (delq! modinfo registered-modules)) + #t) + #f)) + registered-modules)) + +(define (dynamic-maybe-call name dynobj) + (catch #t ; could use false-if-exception here + (lambda () + (dynamic-call name dynobj)) + (lambda args + #f))) + +(define (dynamic-maybe-link filename) + (catch #t ; could use false-if-exception here + (lambda () + (dynamic-link filename)) + (lambda args + #f))) + +(define (find-and-link-dynamic-module module-name) + (define (make-init-name mod-name) + (string-append 'scm_init + (list->string (map (lambda (c) + (if (or (char-alphabetic? c) + (char-numeric? c)) + c + #\_)) + (string->list mod-name))) + '_module)) + (let ((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)))))) + (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))) + +(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)))))) + +(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)))) + + + (define autoloads-done '((guile . guile))) (define (autoload-done-or-in-progress? p m) @@ -2101,8 +2077,8 @@ ;;; {Macros} ;;; -(define macro-table (make-weak-hash-table 523)) -(define xformer-table (make-weak-hash-table 523)) +(define macro-table (make-weak-key-hash-table 523)) +(define xformer-table (make-weak-key-hash-table 523)) (define (defmacro? m) (hashq-ref macro-table m)) (define (assert-defmacro?! m) (hashq-set! macro-table m #t)) @@ -2135,10 +2111,14 @@ (lambda (exp env) (copy-tree (apply f (cdr exp))))))) + +;; XXX - should the definition of the car really be looked up in the +;; current module? + (define (macroexpand-1 e) (cond ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (eval `(defined? ,a)) (eval a)))) + (val (and (symbol? a) (local-ref (list a))))) (if (defmacro? val) (apply (defmacro-transformer val) (cdr e)) e))) @@ -2147,7 +2127,7 @@ (define (macroexpand e) (cond ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (eval `(defined? ,a)) (eval a)))) + (val (and (symbol? a) (local-ref (list a))))) (if (defmacro? val) (macroexpand (apply (defmacro-transformer val) (cdr e))) e))) @@ -2167,72 +2147,194 @@ ;;; (define (repl read evaler print) - (let loop ((source (read (current-input-port) #t read-sharp))) + (let loop ((source (read (current-input-port)))) (print (evaler source)) - (loop (read (current-input-port) #t read-sharp)))) + (loop (read (current-input-port))))) ;; A provisional repl that acts like the SCM repl: ;; (define scm-repl-silent #f) (define (assert-repl-silence v) (set! scm-repl-silent v)) -(define scm-repl-verbose #t) +(define *unspecified* (if #f #f)) +(define (unspecified? v) (eq? v *unspecified*)) + +(define scm-repl-print-unspecified #f) +(define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v)) + +(define scm-repl-verbose #f) (define (assert-repl-verbosity v) (set! scm-repl-verbose v)) -(define scm-repl-prompt #t) -(define (assert-repl-prompt v) (set! scm-repl-prompt v)) +(define scm-repl-prompt "guile> ") + +(define (set-repl-prompt! v) (set! scm-repl-prompt v)) + +(define (default-lazy-handler key . args) + (save-stack lazy-handler-dispatch) + (apply throw key args)) + +(define apply-frame-handler default-lazy-handler) +(define exit-frame-handler default-lazy-handler) -(define the-prompt-string "guile> ") +(define (lazy-handler-dispatch key . args) + (case key + ((apply-frame) + (apply apply-frame-handler key args)) + ((exit-frame) + (apply exit-frame-handler key args)) + (else + (apply default-lazy-handler key args)))) + +(define abort-hook '()) (define (error-catching-loop thunk) - (define (loop first) - (let ((next - (catch #t - (lambda () - (dynamic-wind - (lambda () (unmask-signals)) - (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) - (lambda () (mask-signals)))) - - (lambda (key . args) - (case key - ((quit) (force-output) - (pk 'quit args) - #f) - - ((abort) ;; This is one of the closures that require (set! first #f) - ;; above - ;; - (lambda () - (force-output) - (display "ABORT: " (current-error-port)) - (write args (current-error-port)) - (newline (current-error-port)))) - - (else ;; This is the other cons-leak closure... - (lambda () - (apply %%bad-throw key args)))))))) - (and next (loop next)))) - (loop (lambda () #t))) + (let ((status #f)) + (define (loop first) + (let ((next + (catch #t + + (lambda () + (lazy-catch #t + (lambda () + (dynamic-wind + (lambda () (unmask-signals)) + (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) + (lambda () (mask-signals)))) + + lazy-handler-dispatch)) + + (lambda (key . args) + (case key + ((quit) + (read-line) ; discard trailing junk and linefeed. + (force-output) + (set! status args) + #f) + + ((switch-repl) + (apply throw 'switch-repl args)) + + ((abort) + ;; This is one of the closures that require + ;; (set! first #f) above + ;; + (lambda () + (run-hooks 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))) + (set! stack-saved? #f))) + + (else + ;; This is the other cons-leak closure... + (lambda () + (cond ((= (length args) 4) + (apply handle-system-error key args)) + (else + (apply bad-throw key args)))))))))) + (if next (loop next) status))) + (loop (lambda () #t)))) + +;;(define the-last-stack #f) 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) + (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)))))) + (set! stack-saved? #t)))) + +(define before-error-hook '()) +(define after-error-hook '()) +(define before-backtrace-hook '()) +(define after-backtrace-hook '()) + +(define has-shown-debugger-hint? #f) + +(define (handle-system-error key . args) + (let ((cep (current-error-port))) + (cond ((not (stack? the-last-stack))) + ((memq 'backtrace (debug-options-interface)) + (run-hooks before-backtrace-hook) + (newline cep) + (display-backtrace 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) + (force-output cep) + (throw 'abort key))) (define (quit . args) (apply throw 'quit args)) +(define exit quit) + +;;(define has-shown-backtrace-hint? #f) Defined by scm_init_backtrace () + +;; Replaced by C code: +;;(define (backtrace) +;; (if the-last-stack +;; (begin +;; (newline) +;; (display-backtrace the-last-stack (current-output-port)) +;; (newline) +;; (if (and (not has-shown-backtrace-hint?) +;; (not (memq 'backtrace (debug-options-interface)))) +;; (begin +;; (display +;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace +;;automatically if an error occurs in the future.\n") +;; (set! has-shown-backtrace-hint? #t)))) +;; (display "No backtrace available.\n"))) + (define (error-catching-repl r e p) (error-catching-loop (lambda () (p (e (r)))))) (define (gc-run-time) (cdr (assq 'gc-time-taken (gc-stats)))) +(define before-read-hook '()) +(define after-read-hook '()) + (define (scm-style-repl) (letrec ( (start-gc-rt #f) @@ -2254,12 +2356,19 @@ (-read (lambda () (if scm-repl-prompt (begin - (display the-prompt-string) + (display (cond ((string? scm-repl-prompt) + scm-repl-prompt) + ((thunk? scm-repl-prompt) + (scm-repl-prompt)) + (else "> "))) (force-output) (repl-report-reset))) - (let ((val (read (current-input-port) #t read-sharp))) + (run-hooks before-read-hook) + (let ((val (read (current-input-port)))) + (run-hooks after-read-hook) (if (eof-object? val) (begin + (repl-report-start-timing) (if scm-repl-verbose (begin (newline) @@ -2270,24 +2379,27 @@ (-eval (lambda (sourc) (repl-report-start-timing) - (eval sourc))) + (start-stack 'repl-stack (eval sourc)))) (-print (lambda (result) (if (not scm-repl-silent) (begin - (print result) - (newline) + (if (or scm-repl-print-unspecified + (not (unspecified? result))) + (begin + (write result) + (newline))) (if scm-repl-verbose (repl-report)) (force-output))))) - (-quit (lambda () + (-quit (lambda (args) (if scm-repl-verbose (begin (display ";;; QUIT executed, repl exitting") (newline) (repl-report))) - #t)) + args)) (-abort (lambda () (if scm-repl-verbose @@ -2297,19 +2409,21 @@ (repl-report))) (repl -read -eval -print)))) - (error-catching-repl -read - -eval - -print))) + (let ((status (error-catching-repl -read + -eval + -print))) + (-quit status)))) + -(define (stand-alone-repl) - (let ((oport (current-input-port))) - (set-current-input-port *stdin*) - (scm-style-repl) - (set-current-input-port oport))) +;(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))) @@ -2364,6 +2478,12 @@ (set-current-module module) module)) +(defmacro use-modules modules + `(for-each (lambda (module) + (module-use! (current-module) + (resolve-interface module))) + (reverse ',modules))) + (define define-private define) (defmacro define-public args @@ -2426,13 +2546,13 @@ -(define try-load-with-path try-load-module-with-path) -(define try-load try-load-module) -(define load-with-path load-module-with-path) (define load load-module) +;(define (load . args) +; (start-stack 'load-stack (apply load-module args))) +;;; {I/O functions for Tcl channels (disabled)} ;; (define in-ch (get-standard-channel TCL_STDIN)) ;; (define out-ch (get-standard-channel TCL_STDOUT)) @@ -2467,13 +2587,18 @@ ;; (set-current-output-port outp) ;; (set-current-error-port errp) -(define (top-repl) (scm-style-repl)) +(define (top-repl) + (scm-style-repl)) + +(defmacro false-if-exception (expr) + `(catch #t (lambda () ,expr) + (lambda args #f))) +;;; {Calling Conventions} (define-module (ice-9 calling)) ;;;; -;;; {Calling Conventions} ;;; ;;; This file contains a number of macros that support ;;; common calling conventions. @@ -2771,6 +2896,8 @@ +;;; {Implementation of COMMON LISP list functions for Scheme} + (define-module (ice-9 common-list)) ;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme @@ -2792,9 +2919,6 @@ ;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))) @@ -2953,35 +3077,38 @@ (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. +;;; 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. +;;; 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 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: +;;; With more than one argument, still compute +;;; subdirectory lists, but return a list: ;;; ((<subdir-name> . <names-defined-there>) ;;; (<subdir-name> . <names-defined-there>) ;;; ...) ;;; (define-public (local-definitions-in root names) - (let ((m (resolved-ref root names)) + (let ((m (nested-ref root names)) (answer '())) (if (not (module? m)) (set! answer m) @@ -2989,12 +3116,13 @@ answer)) (define-public (definitions-in root names) - (let ((m (resolved-ref 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))))))) + (map (lambda (m2) (definitions-in m2 '())) + (module-uses m))))))) (define-public (ls . various-refs) (and various-refs @@ -3012,11 +3140,13 @@ various-refs) (local-definitions-in (current-module) (car various-refs))))) -(define-public (recursive-value-define name value) +(define-public (recursive-local-define name value) (let ((parent (reverse! (cdr (reverse name))))) (and parent (make-modules-in (current-module) parent)) - (value-define name value))) + (local-define name value))) +;;; {Queues} + (define-module (ice-9 q)) ;;;; Copyright (C) 1995 Free Software Foundation, Inc. @@ -3036,7 +3166,6 @@ ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; - ;;;; ;;; Q: Based on the interface to ;;; @@ -3044,7 +3173,6 @@ ;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. ;;; - ;;;; ;;; {Q} ;;; @@ -3156,12 +3284,11 @@ -;;; installed-scm-file +;;; {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 @@ -3179,10 +3306,7 @@ ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; - - ;;;; -;;; {The runq data structure} ;;; ;;; One way to schedule parallel computations in a serial environment is ;;; to explicitly divide each task up into small, finite execution time, @@ -3400,21 +3524,17 @@ st)) +;;; {String Fun} -;;; installed-scm-file - (define-module (ice-9 string-fun)) - ;;;; -;;; {String Fun} ;;; ;;; Various string funcitons, particularly those that take ;;; advantage of the "shared substring" capability. ;;; -;;;; -;;; {Dividing Strings Into Fields} +;;; {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: @@ -3538,7 +3658,7 @@ (else (ret (make-shared-substring str 0 n) (make-shared-substring str (1+ n))))))) -(define-public (seperate-fields-discarding-char ch str ret) +(define-public (separate-fields-discarding-char ch str ret) (let loop ((fields '()) (str str)) (cond @@ -3547,7 +3667,7 @@ (make-shared-substring str 0 w)))) (else (ret (cons str fields)))))) -(define-public (seperate-fields-after-char ch str ret) +(define-public (separate-fields-after-char ch str ret) (let loop ((fields '()) (str str)) (cond @@ -3556,7 +3676,7 @@ (make-shared-substring str 0 (+ 1 w))))) (else (ret (cons str fields)))))) -(define-public (seperate-fields-before-char ch str ret) +(define-public (separate-fields-before-char ch str ret) (let loop ((fields '()) (str str)) (cond @@ -3566,12 +3686,11 @@ (else (ret (cons str fields)))))) -;;;; -;;; {String Prefix Predicates} +;;; {String Fun: String Prefix Predicates} ;;; ;;; Very simple: ;;; -:;; (define-public ((string-prefix-predicate pred?) prefix str) +;;; (define-public ((string-prefix-predicate pred?) prefix str) ;;; (and (<= (length prefix) (length str)) ;;; (pred? prefix (make-shared-substring str 0 (length prefix))))) ;;; @@ -3585,8 +3704,7 @@ (define-public string-prefix=? (string-prefix-predicate string=?)) -;;;; -;;; {Strippers} +;;; {String Fun: Strippers} ;;; ;;; <stripper> = sans-<removable-part> ;;; @@ -3639,8 +3757,7 @@ (else str))) -;;;; -;;; {has-trailing-newline?} +;;; {String Fun: has-trailing-newline?} ;;; (define-public (has-trailing-newline? str) @@ -3649,7 +3766,7 @@ - +;;; {String Fun: with-regexp-parts} (define-public (with-regexp-parts regexp fields str return fail) (let ((parts (regexec regexp str fields))) @@ -3658,6 +3775,44 @@ (apply return parts)))) +;;; {Load debug extension code if debug extensions present.} +;;; +;;; *fixme* This is a temporary solution. +;;; + +(if (memq 'debug-extensions *features*) + (define-module (guile) :use-module (ice-9 debug))) + + +;;; {Load session support if present.} +;;; +;;; *fixme* This is a temporary solution. +;;; + +(if (%search-load-path "ice-9/session.scm") + (define-module (guile) :use-module (ice-9 session))) + + +;;; {Load thread code if threads are present.} +;;; +;;; *fixme* This is a temporary solution. +;;; + +(if (memq 'threads *features*) + (define-module (guile) :use-module (ice-9 threads))) + + +;;; {Load emacs interface support if emacs option is given.} +;;; +;;; *fixme* This is a temporary solution. +;;; + +(if (and (module-defined? the-root-module 'use-emacs-interface) + use-emacs-interface) + (define-module (guile) :use-module (ice-9 emacs))) + + (define-module (guile)) +(append! %load-path (cons "." ())) |