summaryrefslogtreecommitdiff
path: root/ice-9/boot-9.scm
diff options
context:
space:
mode:
Diffstat (limited to 'ice-9/boot-9.scm')
-rw-r--r--ice-9/boot-9.scm1983
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 "." ()))