;;; installed-scm-file
-;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
+;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999 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
(if (not (memq sym *features*))
(set! *features* (cons sym *features*))))
+;;; Return #t iff FEATURE is available to this Guile interpreter.
+;;; In SLIB, provided? also checks to see if the module is available.
+;;; We should do that too, but don't.
+(define (provided? feature)
+ (and (memq feature *features*) #t))
+
+;;; presumably deprecated.
+(define feature? provided?)
+
+;;; let format alias simple-format until the more complete version is loaded
+(define format simple-format)
+
\f
;;; {R4RS compliance}
(else
(case handle-delim
((trim peek) nchars)
- ((concat) (string-set! buf nchars terminator)
+ ((concat) (string-set! buf (+ nchars start) terminator)
(+ nchars 1))
((split) (cons nchars terminator))
(else (error "unexpected handle-delim value: "
(case handle-delim
((trim peek concat) (join-substrings))
((split) (cons (join-substrings) terminator))
+
+
(else (error "unexpected handle-delim value: "
handle-delim)))))))))
-
+
+;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string
+;;; from PORT. The return value depends on the value of HANDLE-DELIM,
+;;; which may be one of the symbols `trim', `concat', `peek' and
+;;; `split'. If it is `trim' (the default), the trailing newline is
+;;; removed and the string is returned. If `concat', the string is
+;;; returned with the trailing newline intact. If `peek', the newline
+;;; is left in the input port buffer and the string is returned. If
+;;; `split', the newline is split from the string and read-line
+;;; returns a pair consisting of the truncated string and the newline.
+
(define (read-line . args)
- (apply read-delimited scm-line-incrementors args))
+ (let* ((port (if (null? args)
+ (current-input-port)
+ (car args)))
+ (handle-delim (if (> (length args) 1)
+ (cadr args)
+ 'trim))
+ (line/delim (%read-line port))
+ (line (car line/delim))
+ (delim (cdr line/delim)))
+ (case handle-delim
+ ((trim) line)
+ ((split) line/delim)
+ ((concat) (if (and (string? line) (char? delim))
+ (string-append line (string delim))
+ line))
+ ((peek) (if (char? delim)
+ (unread-char delim port))
+ line)
+ (else
+ (error "unexpected handle-delim value: " handle-delim)))))
\f
;;; {Arrays}
;;;
-(begin
- (define uniform-vector? array?)
- (define make-uniform-vector dimensions->uniform-array)
- ; (define uniform-vector-ref array-ref)
- (define (uniform-vector-set! u i o)
- (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)
-
- (define (make-array fill . args)
- (dimensions->uniform-array args () fill))
- (define (make-uniform-array prot . args)
- (dimensions->uniform-array args prot))
- (define (list->array ndim lst)
- (list->uniform-array ndim '() lst))
- (define (list->uniform-vector prot lst)
- (list->uniform-array 1 prot lst))
- (define (array-shape a)
- (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
- (array-dimensions a))))
+(if (provided? 'array)
+ (primitive-load-path "ice-9/arrays.scm"))
\f
;;; {Keywords}
\f
-;;; Printing structs
-
-;; The printing of structures can be customized by setting the builtin
-;; variable *struct-printer* to a procedure. A second dispatching
-;; step is implemented here to allow for struct-type specific printing
-;; procedures.
-;;
-;; A particular type of structures is characterized by its vtable. In
-;; addition to some internal fields, such a vtable can contain
-;; arbitrary user-defined fields. We use the first of these fields to
-;; hold the specific printing procedure. To avoid breaking code that
-;; already uses this first extra-field for some other purposes, we use
-;; a unique tag to decide whether it really contains a structure
-;; printer or not.
-;;
-;; XXX - Printing structures is probably fundamental enough that we
-;; can simply hardcode the vtable slot convention and expect everyone
-;; to obey it.
-;;
-;; A structure-type specific printer follows the same calling
-;; convention as the builtin *struct-printer*.
-
-;; A shorthand for one already hardcoded vtable convention
+;;; {Structs}
(define (struct-layout s)
- (struct-ref (struct-vtable s) 0))
-
-;; This is our new convention for storing printing procedures
-
-(define %struct-printer-tag (cons '%struct-printer-tag #f))
-
-(define (struct-printer s)
- (let ((vtable (struct-vtable s)))
- (and (> (string-length (struct-layout vtable))
- (* 2 struct-vtable-offset))
- (let ((p (struct-ref vtable struct-vtable-offset)))
- (and (pair? p)
- (eq? (car p) %struct-printer-tag)
- (cdr p))))))
-
-(define (make-struct-printer printer)
- (cons %struct-printer-tag printer))
-
-;; Note: While the printer is extracted from a structure itself, it
-;; has to be set in the vtable of the structure.
-
-(define (set-struct-printer-in-vtable! vtable printer)
- (struct-set! vtable struct-vtable-offset (make-struct-printer printer)))
-
-;; The dispatcher
-
-(set! *struct-printer* (lambda (s p)
- (let ((printer (struct-printer s)))
- (and printer
- (printer s p)))))
+ (struct-ref (struct-vtable s) vtable-index-layout))
\f
;;; {Records}
;;
;; It should print OBJECT to PORT.
-;; 0: printer, 1: type-name, 2: fields
+(define (inherit-print-state old-port new-port)
+ (if (get-print-state old-port)
+ (port-with-print-state new-port (get-print-state old-port))
+ new-port))
+
+;; 0: type-name, 1: fields
(define record-type-vtable
- (make-vtable-vtable "prprpr" 0
- (make-struct-printer
- (lambda (s p)
- (cond ((eq? s record-type-vtable)
- (display "#<record-type-vtable>" p))
- (else
- (display "#<record-type " p)
- (display (record-type-name s) p)
- (display ">" p)))))))
+ (make-vtable-vtable "prpr" 0
+ (lambda (s p)
+ (cond ((eq? s record-type-vtable)
+ (display "#<record-type-vtable>" p))
+ (else
+ (display "#<record-type " p)
+ (display (record-type-name s) p)
+ (display ">" p))))))
(define (record-type? obj)
(and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
(make-struct-layout
(apply symbol-append
(map (lambda (f) "pw") fields)))
- (make-struct-printer
- (or printer-fn
- (lambda (s p)
- (display "#<" p)
- (display type-name p)
- (let loop ((fields fields)
- (off 0))
- (cond
- ((not (null? fields))
- (display " " p)
- (display (car fields) p)
- (display ": " p)
- (display (struct-ref s off) p)
- (loop (cdr fields) (+ 1 off)))))
- (display ">" p))))
+ (or printer-fn
+ (lambda (s p)
+ (display "#<" p)
+ (display type-name p)
+ (let loop ((fields fields)
+ (off 0))
+ (cond
+ ((not (null? fields))
+ (display " " p)
+ (display (car fields) p)
+ (display ": " p)
+ (display (struct-ref s off) p)
+ (loop (cdr fields) (+ 1 off)))))
+ (display ">" p)))
type-name
(copy-tree fields))))
+ ;; Temporary solution: Associate a name to the record type descriptor
+ ;; so that the object system can create a wrapper class for it.
+ (set-struct-vtable-name! struct (if (symbol? type-name)
+ type-name
+ (string->symbol type-name)))
struct)))
(define (record-type-name obj)
(if (record-type? obj)
- (struct-ref obj (+ 1 struct-vtable-offset))
+ (struct-ref obj vtable-offset-user)
(error 'not-a-record-type obj)))
(define (record-type-fields obj)
(if (record-type? obj)
- (struct-ref obj (+ 2 struct-vtable-offset))
+ (struct-ref obj (+ 1 vtable-offset-user))
(error 'not-a-record-type obj)))
(define (record-constructor rtd . opt)
\f
-;;; {and-map, or-map, and map-in-order}
+;;; {Multiple return values}
+
+(define *values-rtd*
+ (make-record-type "values"
+ '(values)))
+
+(define values
+ (let ((make-values (record-constructor *values-rtd*)))
+ (lambda x
+ (if (and (not (null? x))
+ (null? (cdr x)))
+ (car x)
+ (make-values x)))))
+
+(define call-with-values
+ (let ((access-values (record-accessor *values-rtd* 'values))
+ (values-predicate? (record-predicate *values-rtd*)))
+ (lambda (producer consumer)
+ (let ((result (producer)))
+ (if (values-predicate? result)
+ (apply consumer (access-values result))
+ (consumer result))))))
+
+(provide 'values)
+
+\f
+;;; {and-map and or-map}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
(and (not (null? l))
(loop (f (car l)) (cdr l))))))
-;; map-in-order
-;;
-;; Like map, but guaranteed to process the list in order.
-;;
-(define (map-in-order fn l)
- (if (null? l)
- '()
- (cons (fn (car l))
- (map-in-order fn (cdr l)))))
-
\f
-;;; {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))))))))
-\f
-;;; {Files}
-;;; !!!! these should be implemented using Tcl commands, not fports.
-;;;
+(if (provided? 'posix)
+ (primitive-load-path "ice-9/posix.scm"))
-(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))
+(if (provided? 'socket)
+ (primitive-load-path "ice-9/networking.scm"))
(define file-exists?
- (if (feature? 'posix)
+ (if (provided? 'posix)
(lambda (str)
(access? str F_OK))
(lambda (str)
#f)))))
(define file-is-directory?
- (if (feature? 'i/o-extensions)
+ (if (provided? 'posix)
(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))
(save-stack)
(if (null? args)
(scm-error 'misc-error #f "?" #f #f)
- (let loop ((msg "%s")
+ (let loop ((msg "~A")
(rest (cdr args)))
(if (not (null? rest))
- (loop (string-append msg " %S")
+ (loop (string-append msg " ~S")
(cdr rest))
(scm-error 'misc-error #f msg args #f)))))
(apply error "unhandled-exception:" key args))))
\f
-;;; {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 (file-position . args) (apply ftell args))
(define (file-set-position . args) (apply fseek args))
-(define (open-input-pipe command) (open-pipe command OPEN_READ))
-(define (open-output-pipe command) (open-pipe command OPEN_WRITE))
-
(define (move->fdes fd/port fd)
(cond ((integer? fd/port)
(dup->fdes fd/port fd)
;; This is mostly for the internal use of the code generated by
;; scm_compile_shell_switches.
(define (load-user-init)
- (define (has-init? dir)
+ (define (existing-file dir)
(let ((path (in-vicinity dir ".guile")))
- (catch 'system-error
- (lambda ()
- (let ((stats (stat path)))
- (if (not (eq? (stat:type stats) 'directory))
- path)))
- (lambda dummy #f))))
- (let ((path (or (has-init? (or (getenv "HOME") "/"))
- (has-init? (passwd:dir (getpw (getuid)))))))
+ (if (and (file-exists? path)
+ (not (file-is-directory? path)))
+ path
+ #f)))
+ (let ((path (or (existing-file (or (getenv "HOME") "/"))
+ (and (provided? 'posix)
+ (existing-file (passwd:dir (getpw (getuid))))))))
(if path (primitive-load path))))
\f
;;; {Transcendental Functions}
;;;
;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
-;;; Copyright (C) 1992, 1993 Jerry D. Hedden.
+;;; Written by Jerry D. Hedden, (C) FSF.
;;; See the file `COPYING' for terms applying to this program.
;;;
;;; Reader code for various "#c" forms.
;;;
-;;; Parse the portion of a #/ list that comes after the first slash.
-(define (read-path-list-notation slash port)
- (letrec
-
- ;; Is C a delimiter?
- ((delimiter? (lambda (c) (or (eof-object? c)
- (char-whitespace? c)
- (string-index "()\";" c))))
-
- ;; Read and return one component of a path list.
- (read-component
- (lambda ()
- (let loop ((reversed-chars '()))
- (let ((c (peek-char port)))
- (if (or (delimiter? c)
- (char=? c #\/))
- (string->symbol (list->string (reverse reversed-chars)))
- (loop (cons (read-char port) reversed-chars))))))))
-
- ;; Read and return a path list.
- (let loop ((reversed-path (list (read-component))))
- (let ((c (peek-char port)))
- (if (and (char? c) (char=? c #\/))
- (begin
- (read-char port)
- (loop (cons (read-component) reversed-path)))
- (reverse reversed-path))))))
-
(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 #\/ read-path-list-notation)
-
-(define (read:array digit port)
- (define chr0 (char->integer #\0))
- (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
- (if (char-numeric? (peek-char port))
- (readnum (+ (* 10 val)
- (- (char->integer (read-char port)) chr0)))
- val)))
- (prot (if (eq? #\( (peek-char port))
- '()
- (let ((c (read-char port)))
- (case c ((#\b) #t)
- ((#\a) #\a)
- ((#\u) 1)
- ((#\e) -1)
- ((#\s) 1.0)
- ((#\i) 1/3)
- ((#\c) 0+i)
- (else (error "read:array unknown option " c)))))))
- (if (eq? (peek-char port) #\()
- (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))
- (error "read:uniform-vector list not found")))
-
\f
;;; {Command Line Options}
;;;
;;
(define module-type
(make-record-type 'module
- '(obarray uses binder eval-closure transformer name kind)
+ '(obarray uses binder eval-closure transformer name kind
+ observers weak-observers observer-id)
%print-module))
;; make-module &opt size uses binder
"Lazy-binder expected to be a procedure or #f." binder))
(let ((module (module-constructor (make-vector size '())
- uses binder #f #f #f #f)))
+ uses binder #f #f #f #f
+ '()
+ (make-weak-value-hash-table 31)
+ 0)))
;; We can't pass this as an argument to module-constructor,
;; because we need it to close over a pointer to the module
(define set-module-uses! (record-modifier module-type 'uses))
(define module-binder (record-accessor module-type 'binder))
(define set-module-binder! (record-modifier module-type 'binder))
+
+;; NOTE: This binding is used in libguile/modules.c.
(define module-eval-closure (record-accessor module-type 'eval-closure))
-(define set-module-eval-closure! (record-modifier module-type 'eval-closure))
+
(define module-transformer (record-accessor module-type 'transformer))
(define set-module-transformer! (record-modifier module-type 'transformer))
(define module-name (record-accessor module-type 'name))
(define set-module-name! (record-modifier module-type 'name))
(define module-kind (record-accessor module-type 'kind))
(define set-module-kind! (record-modifier module-type 'kind))
+(define module-observers (record-accessor module-type 'observers))
+(define set-module-observers! (record-modifier module-type 'observers))
+(define module-weak-observers (record-accessor module-type 'weak-observers))
+(define module-observer-id (record-accessor module-type 'observer-id))
+(define set-module-observer-id! (record-modifier module-type 'observer-id))
(define module? (record-predicate module-type))
+(define set-module-eval-closure!
+ (let ((setter (record-modifier module-type 'eval-closure)))
+ (lambda (module closure)
+ (setter module closure)
+ ;; Make it possible to lookup the module from the environment.
+ ;; This implementation is correct since an eval closure can belong
+ ;; to maximally one module.
+ (set-procedure-property! closure 'module module))))
(define (eval-in-module exp module)
(eval2 exp (module-eval-closure module)))
\f
+;;; {Observer protocol}
+;;;
+
+(define (module-observe module proc)
+ (set-module-observers! module (cons proc (module-observers module)))
+ (cons module proc))
+
+(define (module-observe-weak module proc)
+ (let ((id (module-observer-id module)))
+ (hash-set! (module-weak-observers module) id proc)
+ (set-module-observer-id! module (+ 1 id))
+ (cons module id)))
+
+(define (module-unobserve token)
+ (let ((module (car token))
+ (id (cdr token)))
+ (if (integer? id)
+ (hash-remove! (module-weak-observers module) id)
+ (set-module-observers! module (delq1! id (module-observers module)))))
+ *unspecified*)
+
+(define (module-modified m)
+ (for-each (lambda (proc) (proc m)) (module-observers m))
+ (hash-fold (lambda (id proc res) (proc m)) #f (module-weak-observers m)))
+
+\f
;;; {Module Searching in General}
;;;
;;; We sometimes want to look for properties of a symbol
;;
(define (module-make-local-var! m v)
(or (let ((b (module-obarray-ref (module-obarray m) v)))
- (and (variable? b) b))
+ (and (variable? b)
+ (begin
+ (module-modified m)
+ b)))
(and (module-binder m)
((module-binder m) m v #t))
(begin
(let ((answer (make-undefined-variable v)))
(module-obarray-set! (module-obarray m) v answer)
+ (module-modified m)
answer))))
;; module-add! module symbol var
(define (module-add! m v var)
(if (not (variable? var))
(error "Bad variable to module-add!" var))
- (module-obarray-set! (module-obarray m) v var))
+ (module-obarray-set! (module-obarray m) v var)
+ (module-modified m))
;; module-remove!
;;
;; make sure that a symbol is undefined in the local namespace of M.
;;
(define (module-remove! m v)
- (module-obarray-remove! (module-obarray m) v))
+ (module-obarray-remove! (module-obarray m) v)
+ (module-modified m))
(define (module-clear! m)
- (vector-fill! (module-obarray m) '()))
+ (vector-fill! (module-obarray m) '())
+ (module-modified m))
;; MODULE-FOR-EACH -- exported
;;
;; the-module
-;;
+;;
+;; NOTE: This binding is used in libguile/modules.c.
+;;
(define the-module #f)
;; scm:eval-transformer
;;
;; set the current module as viewed by the normalizer.
;;
+;; NOTE: This binding is used in libguile/modules.c.
+;;
(define (set-current-module m)
(set! the-module m)
(if m
(define basic-load load)
-(define (load-module . args)
- (save-module-excursion (lambda () (apply basic-load args))))
+(define (load-module filename)
+ (save-module-excursion
+ (lambda ()
+ (let ((oldname (and (current-load-port)
+ (port-filename (current-load-port)))))
+ (basic-load (if (and oldname
+ (> (string-length filename) 0)
+ (not (char=? (string-ref filename 0) #\/))
+ (not (string=? (dirname oldname) ".")))
+ (string-append (dirname oldname) "/" filename)
+ filename))))))
\f
(define (module-define! module name value)
(let ((variable (module-local-variable module name)))
(if variable
- (variable-set! variable value)
+ (begin
+ (variable-set! variable value)
+ (module-modified module))
(module-add! module name (make-variable value name)))))
;; MODULE-DEFINED? -- exported
;;
(define (module-use! module interface)
(set-module-uses! module
- (cons interface (delq! interface (module-uses module)))))
+ (cons interface (delq! interface (module-uses module))))
+ (module-modified module))
\f
;;; {Recursive Namespaces}
;;; The directory of all modules and the standard root module.
;;;
-(define (module-public-interface m) (module-ref m '%module-public-interface #f))
-(define (set-module-public-interface! m i) (module-define! m '%module-public-interface i))
+(define (module-public-interface m)
+ (module-ref m '%module-public-interface #f))
+(define (set-module-public-interface! m i)
+ (module-define! m '%module-public-interface i))
+(define (set-system-module! m s)
+ (set-procedure-property! (module-eval-closure m) 'system-module s))
(define the-root-module (make-root-module))
(define the-scm-module (make-scm-module))
(set-module-public-interface! the-root-module the-scm-module)
(set-module-name! the-root-module 'the-root-module)
(set-module-name! the-scm-module 'the-scm-module)
+(for-each set-system-module! (list the-root-module the-scm-module) '(#t #t))
(set-current-module the-root-module)
;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module)))
+(define (try-load-module name)
+ (or (try-module-linked name)
+ (try-module-autoload name)
+ (try-module-dynamic-link name)))
+
+;; NOTE: This binding is used in libguile/modules.c.
+;;
(define (resolve-module name . maybe-autoload)
(let ((full-name (append '(app modules) name)))
(let ((already (local-ref full-name)))
- (or already
- (begin
- (if (or (null? maybe-autoload) (car maybe-autoload))
- (or (try-module-linked name)
- (try-module-autoload name)
- (try-module-dynamic-link name)))
- (make-modules-in (current-module) full-name))))))
+ (if already
+ ;; The module already exists...
+ (if (and (or (null? maybe-autoload) (car maybe-autoload))
+ (not (module-ref already '%module-public-interface #f)))
+ ;; ...but we are told to load and it doesn't contain source, so
+ (begin
+ (try-load-module name)
+ already)
+ ;; simply return it.
+ already)
+ (begin
+ ;; Try to autoload it if we are told so
+ (if (or (null? maybe-autoload) (car maybe-autoload))
+ (try-load-module name))
+ ;; Get/create it.
+ (make-modules-in (current-module) full-name))))))
(define (beautify-user-module! module)
- (if (not (module-public-interface module))
- (let ((interface (make-module 31)))
- (set-module-name! interface (module-name module))
- (set-module-kind! interface 'interface)
- (set-module-public-interface! module interface)))
+ (let ((interface (module-public-interface module)))
+ (if (or (not interface)
+ (eq? interface module))
+ (let ((interface (make-module 31)))
+ (set-module-name! interface (module-name module))
+ (set-module-kind! interface 'interface)
+ (set-module-public-interface! module interface))))
(if (and (not (memq the-scm-module (module-uses module)))
(not (eq? module the-root-module)))
(set-module-uses! module (append (module-uses module) (list the-scm-module)))))
+;; NOTE: This binding is used in libguile/modules.c.
+;;
(define (make-modules-in module name)
(if (null? name)
module
(cond
- ((module-ref module (car name) #f) => (lambda (m) (make-modules-in m (cdr name))))
+ ((module-ref module (car name) #f)
+ => (lambda (m) (make-modules-in m (cdr name))))
(else (let ((m (make-module 31)))
(set-module-kind! m 'directory)
(set-module-name! m (car name))
(for-each (lambda (interface)
(module-use! module interface))
reversed-interfaces)
- (case (cond ((keyword? (car kws))
- (keyword->symbol (car kws)))
- ((and (symbol? (car kws))
- (eq? (string-ref (car kws) 0) #\:))
- (string->symbol (substring (car kws) 1)))
- (else #f))
- ((use-module)
- (if (not (pair? (cdr kws)))
- (error "unrecognized defmodule argument" kws))
- (let* ((used-name (cadr kws))
- (used-module (resolve-module used-name)))
- (if (not (module-ref used-module '%module-public-interface #f))
- (begin
- ((if %autoloader-developer-mode warn error)
- "no code for module" (module-name used-module))
- (beautify-user-module! used-module)))
- (let ((interface (module-public-interface used-module)))
- (if (not interface)
- (error "missing interface for use-module" used-module))
- (loop (cddr kws) (cons interface reversed-interfaces)))))
- (else
- (error "unrecognized defmodule argument" kws)))))
+ (let ((keyword (cond ((keyword? (car kws))
+ (keyword->symbol (car kws)))
+ ((and (symbol? (car kws))
+ (eq? (string-ref (car kws) 0) #\:))
+ (string->symbol (substring (car kws) 1)))
+ (else #f))))
+ (case keyword
+ ((use-module use-syntax)
+ (if (not (pair? (cdr kws)))
+ (error "unrecognized defmodule argument" kws))
+ (let* ((used-name (cadr kws))
+ (used-module (resolve-module used-name)))
+ (if (not (module-ref used-module
+ '%module-public-interface
+ #f))
+ (begin
+ ((if %autoloader-developer-mode warn error)
+ "no code for module" (module-name used-module))
+ (beautify-user-module! used-module)))
+ (let ((interface (module-public-interface used-module)))
+ (if (not interface)
+ (error "missing interface for use-module"
+ used-module))
+ (if (eq? keyword 'use-syntax)
+ (set-module-transformer!
+ module
+ (module-ref interface (car (last-pair used-name))
+ #f)))
+ (loop (cddr kws)
+ (cons interface reversed-interfaces)))))
+ ((autoload)
+ (if (not (and (pair? (cdr kws)) (pair? (cddr kws))))
+ (error "unrecognized defmodule argument" kws))
+ (loop (cdddr kws)
+ (cons (make-autoload-interface module
+ (cadr kws)
+ (caddr kws))
+ reversed-interfaces)))
+ ((no-backtrace)
+ (set-system-module! module #t)
+ (loop (cdr kws) reversed-interfaces))
+ (else
+ (error "unrecognized defmodule argument" kws))))))
module))
+
+;;; {Autoload}
+
+(define (make-autoload-interface module name bindings)
+ (let ((b (lambda (a sym definep)
+ (and (memq sym bindings)
+ (let ((i (module-public-interface (resolve-module name))))
+ (if (not i)
+ (error "missing interface for module" name))
+ ;; Replace autoload-interface with interface
+ (set-car! (memq a (module-uses module)) i)
+ (module-local-variable i sym))))))
+ (module-constructor #() #f b #f #f name 'autoload
+ '() (make-weak-value-hash-table 31) 0)))
+
\f
;;; {Autoloading modules}
(let ((didit #f))
(dynamic-wind
(lambda () (autoload-in-progress! dir-hint name))
- (lambda ()
- (let loop ((dirs %load-path))
- (and (not (null? dirs))
- (or
- (let ((d (car dirs))
- (trys (list
- dir-hint
- (sfx dir-hint)
- (in-vicinity dir-hint name)
- (in-vicinity dir-hint (sfx name)))))
- (and (or-map (lambda (f)
- (let ((full (in-vicinity d f)))
- full
- (and (file-exists? full)
- (not (file-is-directory? full))
- (begin
- (save-module-excursion
- (lambda ()
- (load (string-append
- d "/" f))))
- #t))))
- trys)
- (begin
- (set! didit #t)
- #t)))
- (loop (cdr dirs))))))
+ (lambda ()
+ (let ((full (%search-load-path (in-vicinity dir-hint name))))
+ (if full
+ (begin
+ (save-module-excursion (lambda () (primitive-load full)))
+ (set! didit #t)))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
+\f
;;; Dynamic linking of modules
;; Initializing a module that is written in C is a two step process.
(c-clear-registered-modules)
res))
-(define registered-modules (convert-c-registered-modules #f))
-
+(define registered-modules '())
+
+(define (register-modules dynobj)
+ (set! registered-modules
+ (append! (convert-c-registered-modules dynobj)
+ registered-modules)))
+
(define (init-dynamic-module modname)
+ ;; Register any linked modules which has been registered on the C level
+ (register-modules #f)
(or-map (lambda (modinfo)
(if (equal? (car modinfo) modname)
- (let ((mod (resolve-module modname #f)))
- (save-module-excursion
- (lambda ()
- (set-current-module mod)
- (dynamic-call (cadr modinfo) (caddr modinfo))
- (set-module-public-interface! mod mod)))
+ (begin
(set! registered-modules (delq! modinfo registered-modules))
- #t)
+ (let ((mod (resolve-module modname #f)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module mod)
+ (set-module-public-interface! mod mod)
+ (dynamic-call (cadr modinfo) (caddr modinfo))
+ ))
+ #t))
#f))
registered-modules))
(define (find-and-link-dynamic-module module-name)
(define (make-init-name mod-name)
- (string-append 'scm_init
+ (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
+ "_module"))
+
+ ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
+ ;; and the `libname' (the name of the module prepended by `lib') in the cdr
+ ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then
+ ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
+ (let ((subdir-and-libname
(let loop ((dirs "")
(syms module-name))
- (cond
- ((null? (cdr syms))
- (string-append dirs "lib" (car syms) ".so"))
- (else
- (loop (string-append dirs (car syms) "/") (cdr syms))))))
+ (if (null? (cdr syms))
+ (cons dirs (string-append "lib" (car syms)))
+ (loop (string-append dirs (car syms) "/") (cdr syms)))))
(init (make-init-name (apply string-append
(map (lambda (s)
(string-append "_" s))
module-name)))))
- ;; (pk 'libname libname 'init init)
- (or-map
- (lambda (dir)
- (let ((full (in-vicinity dir libname)))
- ;; (pk 'trying full)
- (if (file-exists? full)
- (begin
- (link-dynamic-module full init)
- #t)
- #f)))
- %load-path)))
+ (let ((subdir (car subdir-and-libname))
+ (libname (cdr subdir-and-libname)))
+
+ ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that
+ ;; file exists, fetch the dlname from that file and attempt to link
+ ;; against it. If `subdir/libfoo.la' does not exist, or does not seem
+ ;; to name any shared library, look for `subdir/libfoo.so' instead and
+ ;; link against that.
+ (let check-dirs ((dir-list %load-path))
+ (if (null? dir-list)
+ #f
+ (let* ((dir (in-vicinity (car dir-list) subdir))
+ (sharlib-full
+ (or (try-using-libtool-name dir libname)
+ (try-using-sharlib-name dir libname))))
+ (if (and sharlib-full (file-exists? sharlib-full))
+ (link-dynamic-module sharlib-full init)
+ (check-dirs (cdr dir-list)))))))))
+
+(define (try-using-libtool-name libdir libname)
+ (let ((libtool-filename (in-vicinity libdir
+ (string-append libname ".la"))))
+ (and (file-exists? libtool-filename)
+ libtool-filename)))
+
+(define (try-using-sharlib-name libdir libname)
+ (in-vicinity libdir (string-append libname ".so")))
(define (link-dynamic-module filename initname)
+ ;; Register any linked modules which has been registered on the C level
+ (register-modules #f)
(let ((dynobj (dynamic-link filename)))
(dynamic-call initname dynobj)
- (set! registered-modules
- (append! (convert-c-registered-modules dynobj)
- registered-modules))))
+ (register-modules dynobj)))
(define (try-module-linked module-name)
(init-dynamic-module module-name))
;;; {Run-time options}
-((let* ((names '((debug-options-interface
+((let* ((names '((eval-options-interface
+ (eval-options eval-enable eval-disable)
+ (eval-set!))
+
+ (debug-options-interface
(debug-options debug-enable debug-disable)
(debug-set!))
(print-options-interface
(print-options print-enable print-disable)
(print-set!))
+
+ (readline-options-interface
+ (readline-options readline-enable readline-disable)
+ (readline-set!))
))
(option-name car)
(option-value cadr)
(make-options (lambda (interface)
`(lambda args
(cond ((null? args) (,interface))
- ((pair? (car args))
+ ((list? (car args))
(,interface (car args)) (,interface))
- (else (for-each print-option
+ (else (for-each ,print-option
(,interface #t)))))))
(make-enable (lambda (interface)
(save-stack lazy-handler-dispatch)
(apply throw key args))
+(define enter-frame-handler default-lazy-handler)
(define apply-frame-handler default-lazy-handler)
(define exit-frame-handler default-lazy-handler)
(apply apply-frame-handler key args))
((exit-frame)
(apply exit-frame-handler key args))
+ ((enter-frame)
+ (apply enter-frame-handler key args))
(else
(apply default-lazy-handler key args))))
-(define abort-hook '())
+(define abort-hook (make-hook))
+
+;; these definitions are used if running a script.
+;; otherwise redefined in error-catching-loop.
+(define (set-batch-mode?! arg) #t)
+(define (batch-mode?) #t)
(define (error-catching-loop thunk)
- (let ((status #f))
+ (let ((status #f)
+ (interactive #t))
(define (loop first)
(let ((next
(catch #t
(dynamic-wind
(lambda () (unmask-signals))
(lambda ()
- (first)
+ (with-traps
+ (lambda ()
+ (first)
- ;; This line is needed because mark
- ;; doesn't do closures quite right.
- ;; Unreferenced locals should be
- ;; collected.
- ;;
- (set! first #f)
- (let loop ((v (thunk)))
- (loop (thunk)))
- #f)
+ ;; This line is needed because mark
+ ;; doesn't do closures quite right.
+ ;; Unreferenced locals should be
+ ;; collected.
+ ;;
+ (set! first #f)
+ (let loop ((v (thunk)))
+ (loop (thunk)))
+ #f)))
(lambda () (mask-signals))))
lazy-handler-dispatch))
(lambda (key . args)
(case key
((quit)
- (force-output)
(set! status args)
#f)
;; (set! first #f) above
;;
(lambda ()
- (run-hooks abort-hook)
- (force-output)
+ (run-hook abort-hook)
+ (force-output (current-output-port))
(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))
+ (if interactive
(begin
- (newline (current-error-port))
- (display
- "Type \"(backtrace)\" to get more information.\n"
- (current-error-port))
- (set! has-shown-debugger-hint? #t)))
+ (if (and
+ (not has-shown-debugger-hint?)
+ (not (memq 'backtrace
+ (debug-options-interface)))
+ (stack? (fluid-ref the-last-stack)))
+ (begin
+ (newline (current-error-port))
+ (display
+ "Type \"(backtrace)\" to get more information.\n"
+ (current-error-port))
+ (set! has-shown-debugger-hint? #t)))
+ (force-output (current-error-port)))
+ (begin
+ (primitive-exit 1)))
(set! stack-saved? #f)))
(else
(else
(apply bad-throw key args))))))))))
(if next (loop next) status)))
+ (set! set-batch-mode?! (lambda (arg)
+ (cond (arg
+ (set! interactive #f)
+ (restore-signals))
+ (#t
+ (error "sorry, not implemented")))))
+ (set! batch-mode? (lambda () (not interactive)))
(loop (lambda () #t))))
-;;(define the-last-stack #f) Defined by scm_init_backtrace ()
+;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()
+(define before-signal-stack (make-fluid))
(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 0 narrowing))
- ((tk-stack)
- (apply make-stack #t save-stack tk-stack-mark narrowing))
- ((#t)
- (apply make-stack #t save-stack 0 1 narrowing))
- (else (let ((id (stack-id #t)))
- (and (procedure? id)
- (apply make-stack #t save-stack id narrowing))))))
- (set! stack-saved? #t))))
-
-(define before-error-hook '())
-(define after-error-hook '())
-(define before-backtrace-hook '())
-(define after-backtrace-hook '())
+ (or stack-saved?
+ (cond ((not (memq 'debug (debug-options-interface)))
+ (fluid-set! the-last-stack #f)
+ (set! stack-saved? #t))
+ (else
+ (fluid-set!
+ the-last-stack
+ (case (stack-id #t)
+ ((repl-stack)
+ (apply make-stack #t save-stack eval #t 0 narrowing))
+ ((load-stack)
+ (apply make-stack #t save-stack 0 #t 0 narrowing))
+ ((tk-stack)
+ (apply make-stack #t save-stack tk-stack-mark #t 0 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 #t 0 narrowing))))))
+ (set! stack-saved? #t)))))
+
+(define before-error-hook (make-hook))
+(define after-error-hook (make-hook))
+(define before-backtrace-hook (make-hook))
+(define after-backtrace-hook (make-hook))
(define has-shown-debugger-hint? #f)
(define (handle-system-error key . args)
(let ((cep (current-error-port)))
- (cond ((not (stack? the-last-stack)))
+ (cond ((not (stack? (fluid-ref the-last-stack))))
((memq 'backtrace (debug-options-interface))
- (run-hooks before-backtrace-hook)
+ (run-hook before-backtrace-hook)
(newline cep)
- (display-backtrace the-last-stack cep)
+ (display "Backtrace:\n")
+ (display-backtrace (fluid-ref the-last-stack) cep)
(newline cep)
- (run-hooks after-backtrace-hook)))
- (run-hooks before-error-hook)
- (apply display-error the-last-stack cep args)
- (run-hooks after-error-hook)
+ (run-hook after-backtrace-hook)))
+ (run-hook before-error-hook)
+ (apply display-error (fluid-ref the-last-stack) cep args)
+ (run-hook after-error-hook)
(force-output cep)
(throw 'abort key)))
;; Replaced by C code:
;;(define (backtrace)
-;; (if the-last-stack
+;; (if (fluid-ref the-last-stack)
;; (begin
;; (newline)
-;; (display-backtrace the-last-stack (current-output-port))
+;; (display-backtrace (fluid-ref the-last-stack) (current-output-port))
;; (newline)
;; (if (and (not has-shown-backtrace-hint?)
;; (not (memq 'backtrace (debug-options-interface))))
(define (gc-run-time)
(cdr (assq 'gc-time-taken (gc-stats))))
-(define before-read-hook '())
-(define after-read-hook '())
+(define before-read-hook (make-hook))
+(define after-read-hook (make-hook))
+
+;;; The default repl-reader function. We may override this if we've
+;;; the readline library.
+(define repl-reader
+ (lambda (prompt)
+ (display prompt)
+ (force-output)
+ (run-hook before-read-hook)
+ (read (current-input-port))))
(define (scm-style-repl)
(letrec (
(start-gc-rt #f)
(start-rt #f)
- (repl-report-reset (lambda () #f))
(repl-report-start-timing (lambda ()
(set! start-gc-rt (gc-run-time))
(set! start-rt (get-internal-run-time))))
((char=? ch #\newline)
(read-char))))))
(-read (lambda ()
- (if scm-repl-prompt
- (begin
- (display (cond ((string? scm-repl-prompt)
- scm-repl-prompt)
- ((thunk? scm-repl-prompt)
- (scm-repl-prompt))
- (else "> ")))
- (force-output)
- (repl-report-reset)))
- (run-hooks before-read-hook)
- (let ((val (read (current-input-port))))
+ (let ((val
+ (let ((prompt (cond ((string? scm-repl-prompt)
+ scm-repl-prompt)
+ ((thunk? scm-repl-prompt)
+ (scm-repl-prompt))
+ (scm-repl-prompt "> ")
+ (else ""))))
+ (repl-reader prompt))))
+
;; As described in R4RS, the READ procedure updates the
- ;; port to point to the first characetr past the end of
+ ;; port to point to the first character past the end of
;; the external representation of the object. This
;; means that it doesn't consume the newline typically
;; found after an expression. This means that, when
;; breakpoints kind of useless. So, consume any
;; trailing newline here, as well as any whitespace
;; before it.
- (consume-trailing-whitespace)
- (run-hooks after-read-hook)
+ ;; But not if EOF, for control-D.
+ (if (not (eof-object? val))
+ (consume-trailing-whitespace))
+ (run-hook after-read-hook)
(if (eof-object? val)
(begin
(repl-report-start-timing)
\f
;;; {IOTA functions: generating lists of numbers}
-(define (reverse-iota n) (if (> n 0) (cons (1- n) (reverse-iota (1- n))) '()))
-(define (iota n) (reverse! (reverse-iota n)))
+(define (iota n)
+ (let loop ((count (1- n)) (result '()))
+ (if (< count 0) result
+ (loop (1- count) (cons count result)))))
\f
;;; {While}
(lambda () (continue))
(lambda v (cadr v)))))
+;;; {collect}
+;;;
+;;; Similar to `begin' but returns a list of the results of all constituent
+;;; forms instead of the result of the last form.
+;;; (The definition relies on the current left-to-right
+;;; order of evaluation of operands in applications.)
+
+(defmacro collect forms
+ (cons 'list forms))
;;; {with-fluids}
`(with-fluids* (list ,@(map car bindings)) (list ,@(map cadr bindings))
(lambda () ,@body)))
+;;; Environments
+
+(define the-environment
+ (procedure->syntax
+ (lambda (x e)
+ e)))
+
+(define (environment-module env)
+ (let ((closure (and (pair? env) (car (last-pair env)))))
+ (and closure (procedure-property closure 'module))))
+
\f
;;; {Macros}
(defmacro use-modules modules
`(process-use-modules ',modules))
-(define (use-syntax transformer)
- (set-module-transformer! (current-module) transformer)
- (set! scm:eval-transformer transformer))
+(defmacro use-syntax (spec)
+ `(begin
+ ,@(if (pair? spec)
+ `((process-use-modules ',(list spec))
+ (set-module-transformer! (current-module)
+ ,(car (last-pair spec))))
+ `((set-module-transformer! (current-module) ,spec)))
+ (set! scm:eval-transformer (module-transformer (current-module)))))
(define define-private define)
(defmacro ,@ args))))))
+(defmacro export names
+ `(let* ((m (current-module))
+ (public-i (module-public-interface m)))
+ (for-each (lambda (name)
+ ;; Make sure there is a local variable:
+ (module-define! m name (module-ref m name #f))
+ ;; Make sure that local is exported:
+ (module-add! public-i name (module-variable m name)))
+ ',names)))
+
+(define export-syntax export)
+
+
(define load load-module)
-;(define (load . args)
-; (start-stack 'load-stack (apply load-module args)))
\f
-;;; {I/O functions for Tcl channels (disabled)}
+;;; {Load emacs interface support if emacs option is given.}
-;; (define in-ch (get-standard-channel TCL_STDIN))
-;; (define out-ch (get-standard-channel TCL_STDOUT))
-;; (define err-ch (get-standard-channel TCL_STDERR))
-;;
-;; (define inp (%make-channel-port in-ch "r"))
-;; (define outp (%make-channel-port out-ch "w"))
-;; (define errp (%make-channel-port err-ch "w"))
-;;
-;; (define %system-char-ready? char-ready?)
-;;
-;; (define (char-ready? p)
-;; (if (not (channel-port? p))
-;; (%system-char-ready? p)
-;; (let* ((channel (%channel-port-channel p))
-;; (old-blocking (channel-option-ref channel :blocking)))
-;; (dynamic-wind
-;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking "0"))
-;; (lambda () (not (eof-object? (peek-char p))))
-;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking old-blocking))))))
-;;
-;; (define (top-repl)
-;; (with-input-from-port inp
-;; (lambda ()
-;; (with-output-to-port outp
-;; (lambda ()
-;; (with-error-to-port errp
-;; (lambda ()
-;; (scm-style-repl))))))))
-;;
-;; (set-current-input-port inp)
-;; (set-current-output-port outp)
-;; (set-current-error-port errp)
+(define (load-emacs-interface)
+ (if (memq 'debug-extensions *features*)
+ (debug-enable 'backtrace))
+ (define-module (guile-user) :use-module (ice-9 emacs)))
+
+\f
+
+(define using-readline?
+ (let ((using-readline? (make-fluid)))
+ (make-procedure-with-setter
+ (lambda () (fluid-ref using-readline?))
+ (lambda (v) (fluid-set! using-readline? v)))))
;; this is just (scm-style-repl) with a wrapper to install and remove
;; signal handlers.
(define (top-repl)
+
+ ;; Load emacs interface support if emacs option is given.
+ (if (and (module-defined? the-root-module 'use-emacs-interface)
+ use-emacs-interface)
+ (load-emacs-interface))
+
+ ;; Place the user in the guile-user module.
+ (define-module (guile-user)
+ :use-module (guile) ;so that bindings will be checked here first
+ :use-module (ice-9 session)
+ :use-module (ice-9 debug)
+ :autoload (ice-9 debugger) (debug)) ;load debugger on demand
+ (if (memq 'threads *features*)
+ (define-module (guile-user) :use-module (ice-9 threads)))
+ (if (memq 'regex *features*)
+ (define-module (guile-user) :use-module (ice-9 regex)))
+
(let ((old-handlers #f)
- (signals `((,SIGINT . "User interrupt")
- (,SIGFPE . "Arithmetic error")
- (,SIGBUS . "Bad memory access (bus error)")
- (,SIGSEGV . "Bad memory access (Segmentation violation)"))))
+ (signals (if (provided? 'posix)
+ `((,SIGINT . "User interrupt")
+ (,SIGFPE . "Arithmetic error")
+ (,SIGBUS . "Bad memory access (bus error)")
+ (,SIGSEGV .
+ "Bad memory access (Segmentation violation)"))
+ '())))
(dynamic-wind
(lambda ()
(let ((make-handler (lambda (msg)
(lambda (sig)
+ ;; Make a backup copy of the stack
+ (fluid-set! before-signal-stack
+ (fluid-ref the-last-stack))
(save-stack %deliver-signals)
(scm-error 'signal
#f
;; the protected thunk.
(lambda ()
- (scm-style-repl))
+ (let ((status (scm-style-repl)))
+ (run-hook exit-hook)
+ status))
;; call at exit.
(lambda ()
(sigaction (car sig-msg)
(car old-handler)
(cdr old-handler))))
- signals old-handlers)))))
+ signals old-handlers)))))
(defmacro false-if-exception (expr)
`(catch #t (lambda () ,expr)
(lambda args #f)))
-\f
-;;; {Calling Conventions}
-(define-module (ice-9 calling))
-
-;;;;
-;;;
-;;; This file contains a number of macros that support
-;;; common calling conventions.
-
-;;;
-;;; with-excursion-function <vars> proc
-;;; <vars> is an unevaluated list of names that are bound in the caller.
-;;; proc is a procedure, called:
-;;; (proc excursion)
-;;;
-;;; excursion is a procedure isolates all changes to <vars>
-;;; in the dynamic scope of the call to proc. In other words,
-;;; the values of <vars> are saved when proc is entered, and when
-;;; proc returns, those values are restored. Values are also restored
-;;; entering and leaving the call to proc non-locally, such as using
-;;; call-with-current-continuation, error, or throw.
-;;;
-(defmacro-public with-excursion-function (vars proc)
- `(,proc ,(excursion-function-syntax vars)))
-
-
-
-;;; with-getter-and-setter <vars> proc
-;;; <vars> is an unevaluated list of names that are bound in the caller.
-;;; proc is a procedure, called:
-;;; (proc getter setter)
-;;;
-;;; getter and setter are procedures used to access
-;;; or modify <vars>.
-;;;
-;;; setter, called with keywords arguments, modifies the named
-;;; values. If "foo" and "bar" are among <vars>, then:
-;;;
-;;; (setter :foo 1 :bar 2)
-;;; == (set! foo 1 bar 2)
-;;;
-;;; getter, called with just keywords, returns
-;;; a list of the corresponding values. For example,
-;;; if "foo" and "bar" are among the <vars>, then
-;;;
-;;; (getter :foo :bar)
-;;; => (<value-of-foo> <value-of-bar>)
-;;;
-;;; getter, called with no arguments, returns a list of all accepted
-;;; keywords and the corresponding values. If "foo" and "bar" are
-;;; the *only* <vars>, then:
-;;;
-;;; (getter)
-;;; => (:foo <value-of-bar> :bar <value-of-foo>)
-;;;
-;;; The unusual calling sequence of a getter supports too handy
-;;; idioms:
-;;;
-;;; (apply setter (getter)) ;; save and restore
-;;;
-;;; (apply-to-args (getter :foo :bar) ;; fetch and bind
-;;; (lambda (foo bar) ....))
-;;;
-;;; ;; [ "apply-to-args" is just like two-argument "apply" except that it
-;;; ;; takes its arguments in a different order.
-;;;
-;;;
-(defmacro-public with-getter-and-setter (vars proc)
- `(,proc ,@ (getter-and-setter-syntax vars)))
-
-;;; with-getter vars proc
-;;; A short-hand for a call to with-getter-and-setter.
-;;; The procedure is called:
-;;; (proc getter)
-;;;
-(defmacro-public with-getter (vars proc)
- `(,proc ,(car (getter-and-setter-syntax vars))))
-
-
-;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
-;;; Compose getters and setters.
-;;;
-;;; <vars> is an unevaluated list of names that are bound in the caller.
-;;;
-;;; get-delegate is called by the new getter to extend the set of
-;;; gettable variables beyond just <vars>
-;;; set-delegate is called by the new setter to extend the set of
-;;; gettable variables beyond just <vars>
-;;;
-;;; proc is a procedure that is called
-;;; (proc getter setter)
-;;;
-(defmacro-public with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
- `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
-
-
-;;; with-excursion-getter-and-setter <vars> proc
-;;; <vars> is an unevaluated list of names that are bound in the caller.
-;;; proc is called:
-;;;
-;;; (proc excursion getter setter)
-;;;
-;;; See also:
-;;; with-getter-and-setter
-;;; with-excursion-function
-;;;
-(defmacro-public with-excursion-getter-and-setter (vars proc)
- `(,proc ,(excursion-function-syntax vars)
- ,@ (getter-and-setter-syntax vars)))
-
-
-(define (excursion-function-syntax vars)
- (let ((saved-value-names (map gensym vars))
- (tmp-var-name (gensym 'temp))
- (swap-fn-name (gensym 'swap))
- (thunk-name (gensym 'thunk)))
- `(lambda (,thunk-name)
- (letrec ((,tmp-var-name #f)
- (,swap-fn-name
- (lambda () ,@ (map (lambda (n sn) `(set! ,tmp-var-name ,n ,n ,sn ,sn ,tmp-var-name))
- vars saved-value-names)))
- ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
- (dynamic-wind
- ,swap-fn-name
- ,thunk-name
- ,swap-fn-name)))))
-
-
-(define (getter-and-setter-syntax vars)
- (let ((args-name (gensym 'args))
- (an-arg-name (gensym 'an-arg))
- (new-val-name (gensym 'new-value))
- (loop-name (gensym 'loop))
- (kws (map symbol->keyword vars)))
- (list `(lambda ,args-name
- (let ,loop-name ((,args-name ,args-name))
- (if (null? ,args-name)
- ,(if (null? kws)
- ''()
- `(let ((all-vals (,loop-name ',kws)))
- (let ,loop-name ((vals all-vals)
- (kws ',kws))
- (if (null? vals)
- '()
- `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
- (map (lambda (,an-arg-name)
- (case ,an-arg-name
- ,@ (append
- (map (lambda (kw v) `((,kw) ,v)) kws vars)
- `((else (throw 'bad-get-option ,an-arg-name))))))
- ,args-name))))
-
- `(lambda ,args-name
- (let ,loop-name ((,args-name ,args-name))
- (or (null? ,args-name)
- (null? (cdr ,args-name))
- (let ((,an-arg-name (car ,args-name))
- (,new-val-name (cadr ,args-name)))
- (case ,an-arg-name
- ,@ (append
- (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
- `((else (throw 'bad-set-option ,an-arg-name)))))
- (,loop-name (cddr ,args-name)))))))))
-
-(define (delegating-getter-and-setter-syntax vars get-delegate set-delegate)
- (let ((args-name (gensym 'args))
- (an-arg-name (gensym 'an-arg))
- (new-val-name (gensym 'new-value))
- (loop-name (gensym 'loop))
- (kws (map symbol->keyword vars)))
- (list `(lambda ,args-name
- (let ,loop-name ((,args-name ,args-name))
- (if (null? ,args-name)
- (append!
- ,(if (null? kws)
- ''()
- `(let ((all-vals (,loop-name ',kws)))
- (let ,loop-name ((vals all-vals)
- (kws ',kws))
- (if (null? vals)
- '()
- `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
- (,get-delegate))
- (map (lambda (,an-arg-name)
- (case ,an-arg-name
- ,@ (append
- (map (lambda (kw v) `((,kw) ,v)) kws vars)
- `((else (car (,get-delegate ,an-arg-name)))))))
- ,args-name))))
-
- `(lambda ,args-name
- (let ,loop-name ((,args-name ,args-name))
- (or (null? ,args-name)
- (null? (cdr ,args-name))
- (let ((,an-arg-name (car ,args-name))
- (,new-val-name (cadr ,args-name)))
- (case ,an-arg-name
- ,@ (append
- (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
- `((else (,set-delegate ,an-arg-name ,new-val-name)))))
- (,loop-name (cddr ,args-name)))))))))
-
-
-
-
-;;; with-configuration-getter-and-setter <vars-etc> proc
-;;;
-;;; Create a getter and setter that can trigger arbitrary computation.
-;;;
-;;; <vars-etc> is a list of variable specifiers, explained below.
-;;; proc is called:
-;;;
-;;; (proc getter setter)
-;;;
-;;; Each element of the <vars-etc> list is of the form:
-;;;
-;;; (<var> getter-hook setter-hook)
-;;;
-;;; Both hook elements are evaluated; the variable name is not.
-;;; Either hook may be #f or procedure.
-;;;
-;;; A getter hook is a thunk that returns a value for the corresponding
-;;; variable. If omitted (#f is passed), the binding of <var> is
-;;; returned.
-;;;
-;;; A setter hook is a procedure of one argument that accepts a new value
-;;; for the corresponding variable. If omitted, the binding of <var>
-;;; is simply set using set!.
-;;;
-(defmacro-public with-configuration-getter-and-setter (vars-etc proc)
- `((lambda (simpler-get simpler-set body-proc)
- (with-delegating-getter-and-setter ()
- simpler-get simpler-set body-proc))
-
- (lambda (kw)
- (case kw
- ,@(map (lambda (v) `((,(symbol->keyword (car v)))
- ,(cond
- ((cadr v) => list)
- (else `(list ,(car v))))))
- vars-etc)))
-
- (lambda (kw new-val)
- (case kw
- ,@(map (lambda (v) `((,(symbol->keyword (car v)))
- ,(cond
- ((caddr v) => (lambda (proc) `(,proc new-val)))
- (else `(set! ,(car v) new-val)))))
- vars-etc)))
-
- ,proc))
-
-(defmacro-public with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
- `((lambda (simpler-get simpler-set body-proc)
- (with-delegating-getter-and-setter ()
- simpler-get simpler-set body-proc))
-
- (lambda (kw)
- (case kw
- ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
- ,(cond
- ((cadr v) => list)
- (else `(list ,(car v))))))
- vars-etc)
- `((else (,delegate-get kw))))))
-
- (lambda (kw new-val)
- (case kw
- ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
- ,(cond
- ((caddr v) => (lambda (proc) `(,proc new-val)))
- (else `(set! ,(car v) new-val)))))
- vars-etc)
- `((else (,delegate-set kw new-val))))))
-
- ,proc))
-
-
-;;; let-configuration-getter-and-setter <vars-etc> proc
-;;;
-;;; This procedure is like with-configuration-getter-and-setter (q.v.)
-;;; except that each element of <vars-etc> is:
-;;;
-;;; (<var> initial-value getter-hook setter-hook)
-;;;
-;;; Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
-;;; introduces bindings for the variables named in <vars-etc>.
-;;; It is short-hand for:
-;;;
-;;; (let ((<var1> initial-value-1)
-;;; (<var2> initial-value-2)
-;;; ...)
-;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
-;;;
-(defmacro-public let-with-configuration-getter-and-setter (vars-etc proc)
- `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
- (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
- ,proc)))
-
-
-
-\f
-;;; {Implementation of COMMON LISP list functions for Scheme}
-
-(define-module (ice-9 common-list))
-
-;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
-; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
-;
-;Permission to copy this software, to redistribute it, and to use it
-;for any purpose is granted, subject to the following restrictions and
-;understandings.
-;
-;1. Any copy made of this software must include this copyright notice
-;in full.
-;
-;2. I have made no warrantee or representation that the operation of
-;this software will be error-free, and I am under no obligation to
-;provide any services, by way of maintenance, update, or otherwise.
-;
-;3. In conjunction with products arising from the use of this
-;material, there shall be no use of my name in any advertising,
-;promotional, or sales literature without prior written consent in
-;each case.
-
-(define-public (adjoin e l) (if (memq e l) l (cons e l)))
-
-(define-public (union l1 l2)
- (cond ((null? l1) l2)
- ((null? l2) l1)
- (else (union (cdr l1) (adjoin (car l1) l2)))))
-
-(define-public (intersection l1 l2)
- (cond ((null? l1) l1)
- ((null? l2) l2)
- ((memv (car l1) l2) (cons (car l1) (intersection (cdr l1) l2)))
- (else (intersection (cdr l1) l2))))
-
-(define-public (set-difference l1 l2)
- (cond ((null? l1) l1)
- ((memv (car l1) l2) (set-difference (cdr l1) l2))
- (else (cons (car l1) (set-difference (cdr l1) l2)))))
-
-(define-public (reduce-init p init l)
- (if (null? l)
- init
- (reduce-init p (p init (car l)) (cdr l))))
-
-(define-public (reduce p l)
- (cond ((null? l) l)
- ((null? (cdr l)) (car l))
- (else (reduce-init p (car l) (cdr l)))))
-
-(define-public (some pred l . rest)
- (cond ((null? rest)
- (let mapf ((l l))
- (and (not (null? l))
- (or (pred (car l)) (mapf (cdr l))))))
- (else (let mapf ((l l) (rest rest))
- (and (not (null? l))
- (or (apply pred (car l) (map car rest))
- (mapf (cdr l) (map cdr rest))))))))
-
-(define-public (every pred l . rest)
- (cond ((null? rest)
- (let mapf ((l l))
- (or (null? l)
- (and (pred (car l)) (mapf (cdr l))))))
- (else (let mapf ((l l) (rest rest))
- (or (null? l)
- (and (apply pred (car l) (map car rest))
- (mapf (cdr l) (map cdr rest))))))))
-
-(define-public (notany pred . ls) (not (apply some pred ls)))
-
-(define-public (notevery pred . ls) (not (apply every pred ls)))
-
-(define-public (find-if t l)
- (cond ((null? l) #f)
- ((t (car l)) (car l))
- (else (find-if t (cdr l)))))
-
-(define-public (member-if t l)
- (cond ((null? l) #f)
- ((t (car l)) l)
- (else (member-if t (cdr l)))))
-
-(define-public (remove-if p l)
- (cond ((null? l) '())
- ((p (car l)) (remove-if p (cdr l)))
- (else (cons (car l) (remove-if p (cdr l))))))
-
-(define-public (delete-if! pred list)
- (let delete-if ((list list))
- (cond ((null? list) '())
- ((pred (car list)) (delete-if (cdr list)))
- (else
- (set-cdr! list (delete-if (cdr list)))
- list))))
-
-(define-public (delete-if-not! pred list)
- (let delete-if ((list list))
- (cond ((null? list) '())
- ((not (pred (car list))) (delete-if (cdr list)))
- (else
- (set-cdr! list (delete-if (cdr list)))
- list))))
-
-(define-public (butlast lst n)
- (letrec ((l (- (length lst) n))
- (bl (lambda (lst n)
- (cond ((null? lst) lst)
- ((positive? n)
- (cons (car lst) (bl (cdr lst) (+ -1 n))))
- (else '())))))
- (bl lst (if (negative? n)
- (error "negative argument to butlast" n)
- l))))
-
-(define-public (and? . args)
- (cond ((null? args) #t)
- ((car args) (apply and? (cdr args)))
- (else #f)))
-
-(define-public (or? . args)
- (cond ((null? args) #f)
- ((car args) #t)
- (else (apply or? (cdr args)))))
-
-(define-public (has-duplicates? lst)
- (cond ((null? lst) #f)
- ((member (car lst) (cdr lst)) #t)
- (else (has-duplicates? (cdr lst)))))
-
-(define-public (list* x . y)
- (define (list*1 x)
- (if (null? (cdr x))
- (car x)
- (cons (car x) (list*1 (cdr x)))))
- (if (null? y)
- x
- (cons x (list*1 y))))
-
-;; pick p l
-;; Apply P to each element of L, returning a list of elts
-;; for which P returns a non-#f value.
-;;
-(define-public (pick p l)
- (let loop ((s '())
- (l l))
- (cond
- ((null? l) s)
- ((p (car l)) (loop (cons (car l) s) (cdr l)))
- (else (loop s (cdr l))))))
-
-;; pick p l
-;; Apply P to each element of L, returning a list of the
-;; non-#f return values of P.
-;;
-(define-public (pick-mappings p l)
- (let loop ((s '())
- (l l))
- (cond
- ((null? l) s)
- ((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l))))
- (else (loop s (cdr l))))))
-
-(define-public (uniq l)
- (if (null? l)
- '()
- (let ((u (uniq (cdr l))))
- (if (memq (car l) u)
- u
- (cons (car l) u)))))
-
-\f
-;;; {Functions for browsing modules}
-
-(define-module (ice-9 ls)
- :use-module (ice-9 common-list))
-
-;;;;
-;;; local-definitions-in root name
-;;; Returns a list of names defined locally in the named
-;;; subdirectory of root.
-;;; definitions-in root name
-;;; Returns a list of all names defined in the named
-;;; subdirectory of root. The list includes alll locally
-;;; defined names as well as all names inherited from a
-;;; member of a use-list.
-;;;
-;;; A convenient interface for examining the nature of things:
-;;;
-;;; ls . various-names
-;;;
-;;; With just one argument, interpret that argument as the
-;;; name of a subdirectory of the current module and
-;;; return a list of names defined there.
-;;;
-;;; With more than one argument, still compute
-;;; subdirectory lists, but return a list:
-;;; ((<subdir-name> . <names-defined-there>)
-;;; (<subdir-name> . <names-defined-there>)
-;;; ...)
-;;;
-
-(define-public (local-definitions-in root names)
- (let ((m (nested-ref root names))
- (answer '()))
- (if (not (module? m))
- (set! answer m)
- (module-for-each (lambda (k v) (set! answer (cons k answer))) m))
- answer))
-
-(define-public (definitions-in root names)
- (let ((m (nested-ref root names)))
- (if (not (module? m))
- m
- (reduce union
- (cons (local-definitions-in m '())
- (map (lambda (m2) (definitions-in m2 '()))
- (module-uses m)))))))
-
-(define-public (ls . various-refs)
- (and various-refs
- (if (cdr various-refs)
- (map (lambda (ref)
- (cons ref (definitions-in (current-module) ref)))
- various-refs)
- (definitions-in (current-module) (car various-refs)))))
-
-(define-public (lls . various-refs)
- (and various-refs
- (if (cdr various-refs)
- (map (lambda (ref)
- (cons ref (local-definitions-in (current-module) ref)))
- various-refs)
- (local-definitions-in (current-module) (car various-refs)))))
-
-(define-public (recursive-local-define name value)
- (let ((parent (reverse! (cdr (reverse name)))))
- (and parent (make-modules-in (current-module) parent))
- (local-define name value)))
-\f
-;;; {Queues}
-
-(define-module (ice-9 q))
-
-;;;; Copyright (C) 1995 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
-;;;;
-
-;;;;
-;;; Q: Based on the interface to
-;;;
-;;; "queue.scm" Queues/Stacks for Scheme
-;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
-;;;
-
-;;;;
-;;; {Q}
+;;; This hook is run at the very end of an interactive session.
;;;
-;;; A list is just a bunch of cons pairs that follows some constrains, right?
-;;; Association lists are the same. Hash tables are just vectors and association
-;;; lists. You can print them, read them, write them as constants, pun them off as other data
-;;; structures etc. This is good. This is lisp. These structures are fast and compact
-;;; and easy to manipulate arbitrarily because of their simple, regular structure and
-;;; non-disjointedness (associations being lists and so forth).
-;;;
-;;; So I figured, queues should be the same -- just a "subtype" of cons-pair
-;;; structures in general.
-;;;
-;;; A queue is a cons pair:
-;;; ( <the-q> . <last-pair> )
-;;;
-;;; <the-q> is a list of things in the q. New elements go at the end of that list.
-;;;
-;;; <last-pair> is #f if the q is empty, and otherwise is the last pair of <the-q>.
-;;;
-;;; q's print nicely, but alas, they do not read well because the eq?-ness of
-;;; <last-pair> and (last-pair <the-q>) is lost by read. The procedure
-;;;
-;;; (sync-q! q)
-;;;
-;;; recomputes and resets the <last-pair> component of a queue.
-;;;
-
-(define-public (sync-q! obj) (set-cdr! obj (and (car obj) (last-pair (car obj)))))
-
-;;; make-q
-;;; return a new q.
-;;;
-(define-public (make-q) (cons '() '()))
-
-;;; q? obj
-;;; Return true if obj is a Q.
-;;; An object is a queue if it is equal? to '(#f . #f) or
-;;; if it is a pair P with (list? (car P)) and (eq? (cdr P) (last-pair P)).
-;;;
-(define-public (q? obj) (and (pair? obj)
- (or (and (null? (car obj))
- (null? (cdr obj)))
- (and
- (list? (car obj))
- (eq? (cdr obj) (last-pair (car obj)))))))
-
-;;; q-empty? obj
-;;;
-(define-public (q-empty? obj) (null? (car obj)))
-
-;;; q-empty-check q
-;;; Throw a q-empty exception if Q is empty.
-(define-public (q-empty-check q) (if (q-empty? q) (throw 'q-empty q)))
-
-
-;;; q-front q
-;;; Return the first element of Q.
-(define-public (q-front q) (q-empty-check q) (caar q))
-
-;;; q-rear q
-;;; Return the last element of Q.
-(define-public (q-rear q) (q-empty-check q) (cadr q))
-
-;;; q-remove! q obj
-;;; Remove all occurences of obj from Q.
-(define-public (q-remove! q obj)
- (while (memq obj (car q))
- (set-car! q (delq! obj (car q))))
- (set-cdr! q (last-pair (car q))))
-
-;;; q-push! q obj
-;;; Add obj to the front of Q
-(define-public (q-push! q d)
- (let ((h (cons d (car q))))
- (set-car! q h)
- (if (null? (cdr q))
- (set-cdr! q h))))
-
-;;; enq! q obj
-;;; Add obj to the rear of Q
-(define-public (enq! q d)
- (let ((h (cons d '())))
- (if (not (null? (cdr q)))
- (set-cdr! (cdr q) h)
- (set-car! q h))
- (set-cdr! q h)))
-
-;;; q-pop! q
-;;; Take the front of Q and return it.
-(define-public (q-pop! q)
- (q-empty-check q)
- (let ((it (caar q))
- (next (cdar q)))
- (if (not next)
- (set-cdr! q #f))
- (set-car! q next)
- it))
-
-;;; deq! q
-;;; Take the front of Q and return it.
-(define-public deq! q-pop!)
-
-;;; q-length q
-;;; Return the number of enqueued elements.
-;;;
-(define-public (q-length q) (length (car q)))
-
-
-
-\f
-;;; {The runq data structure}
-
-(define-module (ice-9 runq)
- :use-module (ice-9 q))
-
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
-;;;;
-
-;;;;
-;;;
-;;; One way to schedule parallel computations in a serial environment is
-;;; to explicitly divide each task up into small, finite execution time,
-;;; strips. Then you interleave the execution of strips from various
-;;; tasks to achieve a kind of parallelism. Runqs are a handy data
-;;; structure for this style of programming.
-;;;
-;;; We use thunks (nullary procedures) and lists of thunks to represent
-;;; strips. By convention, the return value of a strip-thunk must either
-;;; be another strip or the value #f.
-;;;
-;;; A runq is a procedure that manages a queue of strips. Called with no
-;;; arguments, it processes one strip from the queue. Called with
-;;; arguments, the arguments form a control message for the queue. The
-;;; first argument is a symbol which is the message selector.
-;;;
-;;; A strip is processed this way: If the strip is a thunk, the thunk is
-;;; called -- if it returns a strip, that strip is added back to the
-;;; queue. To process a strip which is a list of thunks, the CAR of that
-;;; list is called. After a call to that CAR, there are 0, 1, or 2 strips
-;;; -- perhaps one returned by the thunk, and perhaps the CDR of the
-;;; original strip if that CDR is not nil. The runq puts whichever of
-;;; these strips exist back on the queue. (The exact order in which
-;;; strips are put back on the queue determines the scheduling behavior of
-;;; a particular queue -- it's a parameter.)
-;;;
-;;;
-
-
-
-;;;;
-;;; (runq-control q msg . args)
-;;;
-;;; processes in the default way the control messages that
-;;; can be sent to a runq. Q should be an ordinary
-;;; Q (see utils/q.scm).
-;;;
-;;; The standard runq messages are:
-;;;
-;;; 'add! strip0 strip1... ;; to enqueue one or more strips
-;;; 'enqueue! strip0 strip1... ;; to enqueue one or more strips
-;;; 'push! strip0 ... ;; add strips to the front of the queue
-;;; 'empty? ;; true if it is
-;;; 'length ;; how many strips in the queue?
-;;; 'kill! ;; empty the queue
-;;; else ;; throw 'not-understood
-;;;
-(define-public (runq-control q msg . args)
- (case msg
- ((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
- ((enque!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
- ((push!) (for-each (lambda (t) (q-push! q t)) args) '*unspecified*)
- ((empty?) (q-empty? q))
- ((length) (q-length q))
- ((kill!) (set! q (make-q)))
- (else (throw 'not-understood msg args))))
-
-(define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f)))
-
-;;;;
-;;; make-void-runq
-;;;
-;;; Make a runq that discards all messages except "length", for which
-;;; it returns 0.
-;;;
-(define-public (make-void-runq)
- (lambda opts
- (and opts
- (apply-to-args opts
- (lambda (msg . args)
- (case msg
- ((length) 0)
- (else #f)))))))
-
-;;;;
-;;; (make-fair-runq)
-;;;
-;;; Returns a runq procedure.
-;;; Called with no arguments, the procedure processes one strip from the queue.
-;;; Called with arguments, it uses runq-control.
-;;;
-;;; In a fair runq, if a strip returns a new strip X, X is added
-;;; to the end of the queue, meaning it will be the last to execute
-;;; of all the remaining procedures.
-;;;
-(define-public (make-fair-runq)
- (letrec ((q (make-q))
- (self
- (lambda ctl
- (if ctl
- (apply runq-control q ctl)
- (and (not (q-empty? q))
- (let ((next-strip (deq! q)))
- (cond
- ((procedure? next-strip) (let ((k (run-strip next-strip)))
- (and k (enq! q k))))
- ((pair? next-strip) (let ((k (run-strip (car next-strip))))
- (and k (enq! q k)))
- (if (not (null? (cdr next-strip)))
- (enq! q (cdr next-strip)))))
- self))))))
- self))
-
-
-;;;;
-;;; (make-exclusive-runq)
-;;;
-;;; Returns a runq procedure.
-;;; Called with no arguments, the procedure processes one strip from the queue.
-;;; Called with arguments, it uses runq-control.
-;;;
-;;; In an exclusive runq, if a strip W returns a new strip X, X is added
-;;; to the front of the queue, meaning it will be the next to execute
-;;; of all the remaining procedures.
-;;;
-;;; An exception to this occurs if W was the CAR of a list of strips.
-;;; In that case, after the return value of W is pushed onto the front
-;;; of the queue, the CDR of the list of strips is pushed in front
-;;; of that (if the CDR is not nil). This way, the rest of the thunks
-;;; in the list that contained W have priority over the return value of W.
-;;;
-(define-public (make-exclusive-runq)
- (letrec ((q (make-q))
- (self
- (lambda ctl
- (if ctl
- (apply runq-control q ctl)
- (and (not (q-empty? q))
- (let ((next-strip (deq! q)))
- (cond
- ((procedure? next-strip) (let ((k (run-strip next-strip)))
- (and k (q-push! q k))))
- ((pair? next-strip) (let ((k (run-strip (car next-strip))))
- (and k (q-push! q k)))
- (if (not (null? (cdr next-strip)))
- (q-push! q (cdr next-strip)))))
- self))))))
- self))
-
-
-;;;;
-;;; (make-subordinate-runq-to superior basic-inferior)
-;;;
-;;; Returns a runq proxy for the runq basic-inferior.
-;;;
-;;; The proxy watches for operations on the basic-inferior that cause
-;;; a transition from a queue length of 0 to a non-zero length and
-;;; vice versa. While the basic-inferior queue is not empty,
-;;; the proxy installs a task on the superior runq. Each strip
-;;; of that task processes N strips from the basic-inferior where
-;;; N is the length of the basic-inferior queue when the proxy
-;;; strip is entered. [Countless scheduling variations are possible.]
-;;;
-(define-public (make-subordinate-runq-to superior-runq basic-runq)
- (let ((runq-task (cons #f #f)))
- (set-car! runq-task
- (lambda ()
- (if (basic-runq 'empty?)
- (set-cdr! runq-task #f)
- (do ((n (basic-runq 'length) (1- n)))
- ((<= n 0) #f)
- (basic-runq)))))
- (letrec ((self
- (lambda ctl
- (if (not ctl)
- (let ((answer (basic-runq)))
- (self 'empty?)
- answer)
- (begin
- (case (car ctl)
- ((suspend) (set-cdr! runq-task #f))
- (else (let ((answer (apply basic-runq ctl)))
- (if (and (not (cdr runq-task)) (not (basic-runq 'empty?)))
- (begin
- (set-cdr! runq-task runq-task)
- (superior-runq 'add! runq-task)))
- answer))))))))
- self)))
-
-;;;;
-;;; (define fork-strips (lambda args args))
-;;; Return a strip that starts several strips in
-;;; parallel. If this strip is enqueued on a fair
-;;; runq, strips of the parallel subtasks will run
-;;; round-robin style.
-;;;
-(define fork-strips (lambda args args))
-
-
-;;;;
-;;; (strip-sequence . strips)
-;;;
-;;; Returns a new strip which is the concatenation of the argument strips.
-;;;
-(define-public ((strip-sequence . strips))
- (let loop ((st (let ((a strips)) (set! strips #f) a)))
- (and (not (null? st))
- (let ((then ((car st))))
- (if then
- (lambda () (loop (cons then (cdr st))))
- (lambda () (loop (cdr st))))))))
-
-
-;;;;
-;;; (fair-strip-subtask . initial-strips)
-;;;
-;;; Returns a new strip which is the synchronos, fair,
-;;; parallel execution of the argument strips.
-;;;
-;;;
-;;;
-(define-public (fair-strip-subtask . initial-strips)
- (let ((st (make-fair-runq)))
- (apply st 'add! initial-strips)
- st))
-
-\f
-;;; {String Fun}
-
-(define-module (ice-9 string-fun))
-
-;;;;
-;;;
-;;; Various string funcitons, particularly those that take
-;;; advantage of the "shared substring" capability.
-;;;
-\f
-;;; {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:
-;;;
-;;; <string-function-invocation>
-;;; := (<action>-<seperator-disposition>-<seperator-determination> <seperator-param> <str> <ret>)
-;;;
-;;; <str> = the string
-;;;
-;;; <ret> = The continuation. String functions generally return
-;;; multiple values by passing them to this procedure.
-;;;
-;;; <action> = split
-;;; | separate-fields
-;;;
-;;; "split" means to divide a string into two parts.
-;;; <ret> will be called with two arguments.
-;;;
-;;; "separate-fields" means to divide a string into as many
-;;; parts as possible. <ret> will be called with
-;;; however many fields are found.
-;;;
-;;; <seperator-disposition> = before
-;;; | after
-;;; | discarding
-;;;
-;;; "before" means to leave the seperator attached to
-;;; the beginning of the field to its right.
-;;; "after" means to leave the seperator attached to
-;;; the end of the field to its left.
-;;; "discarding" means to discard seperators.
-;;;
-;;; Other dispositions might be handy. For example, "isolate"
-;;; could mean to treat the separator as a field unto itself.
-;;;
-;;; <seperator-determination> = char
-;;; | predicate
-;;;
-;;; "char" means to use a particular character as field seperator.
-;;; "predicate" means to check each character using a particular predicate.
-;;;
-;;; Other determinations might be handy. For example, "character-set-member".
-;;;
-;;; <seperator-param> = A parameter that completes the meaning of the determinations.
-;;; For example, if the determination is "char", then this parameter
-;;; says which character. If it is "predicate", the parameter is the
-;;; predicate.
-;;;
-;;;
-;;; For example:
-;;;
-;;; (separate-fields-discarding-char #\, "foo, bar, baz, , bat" list)
-;;; => ("foo" " bar" " baz" " " " bat")
-;;;
-;;; (split-after-char #\- 'an-example-of-split list)
-;;; => ("an-" "example-of-split")
-;;;
-;;; As an alternative to using a determination "predicate", or to trying to do anything
-;;; complicated with these functions, consider using regular expressions.
-;;;
-
-(define-public (split-after-char char str ret)
- (let ((end (cond
- ((string-index str char) => 1+)
- (else (string-length str)))))
- (ret (make-shared-substring str 0 end)
- (make-shared-substring str end))))
-
-(define-public (split-before-char char str ret)
- (let ((end (or (string-index str char)
- (string-length str))))
- (ret (make-shared-substring str 0 end)
- (make-shared-substring str end))))
-
-(define-public (split-discarding-char char str ret)
- (let ((end (string-index str char)))
- (if (not end)
- (ret str "")
- (ret (make-shared-substring str 0 end)
- (make-shared-substring str (1+ end))))))
-
-(define-public (split-after-char-last char str ret)
- (let ((end (cond
- ((string-rindex str char) => 1+)
- (else 0))))
- (ret (make-shared-substring str 0 end)
- (make-shared-substring str end))))
-
-(define-public (split-before-char-last char str ret)
- (let ((end (or (string-rindex str char) 0)))
- (ret (make-shared-substring str 0 end)
- (make-shared-substring str end))))
-
-(define-public (split-discarding-char-last char str ret)
- (let ((end (string-rindex str char)))
- (if (not end)
- (ret str "")
- (ret (make-shared-substring str 0 end)
- (make-shared-substring str (1+ end))))))
-
-(define (split-before-predicate pred str ret)
- (let loop ((n 0))
- (cond
- ((= n (string-length str)) (ret str ""))
- ((not (pred (string-ref str n))) (loop (1+ n)))
- (else (ret (make-shared-substring str 0 n)
- (make-shared-substring str n))))))
-(define (split-after-predicate pred str ret)
- (let loop ((n 0))
- (cond
- ((= n (string-length str)) (ret str ""))
- ((not (pred (string-ref str n))) (loop (1+ n)))
- (else (ret (make-shared-substring str 0 (1+ n))
- (make-shared-substring str (1+ n)))))))
-
-(define (split-discarding-predicate pred str ret)
- (let loop ((n 0))
- (cond
- ((= n (string-length str)) (ret str ""))
- ((not (pred (string-ref str n))) (loop (1+ n)))
- (else (ret (make-shared-substring str 0 n)
- (make-shared-substring str (1+ n)))))))
-
-(define-public (separate-fields-discarding-char ch str ret)
- (let loop ((fields '())
- (str str))
- (cond
- ((string-rindex str ch)
- => (lambda (w) (loop (cons (make-shared-substring str (+ 1 w)) fields)
- (make-shared-substring str 0 w))))
- (else (apply ret str fields)))))
-
-(define-public (separate-fields-after-char ch str ret)
- (reverse
- (let loop ((fields '())
- (str str))
- (cond
- ((string-index str ch)
- => (lambda (w) (loop (cons (make-shared-substring str 0 (+ 1 w)) fields)
- (make-shared-substring str (+ 1 w)))))
- (else (apply ret str fields))))))
-
-(define-public (separate-fields-before-char ch str ret)
- (let loop ((fields '())
- (str str))
- (cond
- ((string-rindex str ch)
- => (lambda (w) (loop (cons (make-shared-substring str w) fields)
- (make-shared-substring str 0 w))))
- (else (apply ret str fields)))))
-
-\f
-;;; {String Fun: String Prefix Predicates}
-;;;
-;;; Very simple:
-;;;
-;;; (define-public ((string-prefix-predicate pred?) prefix str)
-;;; (and (<= (string-length prefix) (string-length str))
-;;; (pred? prefix (make-shared-substring str 0 (string-length prefix)))))
-;;;
-;;; (define-public string-prefix=? (string-prefix-predicate string=?))
-;;;
-
-(define-public ((string-prefix-predicate pred?) prefix str)
- (and (<= (string-length prefix) (string-length str))
- (pred? prefix (make-shared-substring str 0 (string-length prefix)))))
-
-(define-public string-prefix=? (string-prefix-predicate string=?))
-
-\f
-;;; {String Fun: Strippers}
-;;;
-;;; <stripper> = sans-<removable-part>
-;;;
-;;; <removable-part> = surrounding-whitespace
-;;; | trailing-whitespace
-;;; | leading-whitespace
-;;; | final-newline
-;;;
-
-(define-public (sans-surrounding-whitespace s)
- (let ((st 0)
- (end (string-length s)))
- (while (and (< st (string-length s))
- (char-whitespace? (string-ref s st)))
- (set! st (1+ st)))
- (while (and (< 0 end)
- (char-whitespace? (string-ref s (1- end))))
- (set! end (1- end)))
- (if (< end st)
- ""
- (make-shared-substring s st end))))
-
-(define-public (sans-trailing-whitespace s)
- (let ((st 0)
- (end (string-length s)))
- (while (and (< 0 end)
- (char-whitespace? (string-ref s (1- end))))
- (set! end (1- end)))
- (if (< end st)
- ""
- (make-shared-substring s st end))))
-
-(define-public (sans-leading-whitespace s)
- (let ((st 0)
- (end (string-length s)))
- (while (and (< st (string-length s))
- (char-whitespace? (string-ref s st)))
- (set! st (1+ st)))
- (if (< end st)
- ""
- (make-shared-substring s st end))))
-
-(define-public (sans-final-newline str)
- (cond
- ((= 0 (string-length str))
- str)
-
- ((char=? #\nl (string-ref str (1- (string-length str))))
- (make-shared-substring str 0 (1- (string-length str))))
+(define exit-hook (make-hook))
- (else str)))
\f
-;;; {String Fun: has-trailing-newline?}
-;;;
-
-(define-public (has-trailing-newline? str)
- (and (< 0 (string-length str))
- (char=? #\nl (string-ref str (1- (string-length str))))))
-
-
-\f
-;;; {String Fun: with-regexp-parts}
-
-;;; This relies on the older, hairier regexp interface, which we don't
-;;; particularly want to implement, and it's not used anywhere, so
-;;; we're just going to drop it for now.
-;;; (define-public (with-regexp-parts regexp fields str return fail)
-;;; (let ((parts (regexec regexp str fields)))
-;;; (if (number? parts)
-;;; (fail parts)
-;;; (apply return parts))))
-
-\f
-;;; {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)))
-
-\f
-;;; {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)))
-
-\f
-;;; {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)))
-
-\f
-;;; {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)
- (begin
- (if (memq 'debug-extensions *features*)
- (debug-enable 'backtrace))
- (define-module (guile) :use-module (ice-9 emacs))))
-
-\f
-;;; {Load regexp code if regexp primitives are available.}
-
-(if (memq 'regex *features*)
- (define-module (guile) :use-module (ice-9 regex)))
-
-\f
-;;; {Check that the interpreter and scheme code match up.}
-
-(let ((show-line
- (lambda args
- (with-output-to-port (current-error-port)
- (lambda ()
- (display (car (command-line)))
- (display ": ")
- (for-each (lambda (string) (display string))
- args)
- (newline))))))
-
- (load-from-path "ice-9/version.scm")
-
- (if (not (string=?
- (libguile-config-stamp) ; from the interprpreter
- (ice-9-config-stamp))) ; from the Scheme code
- (begin
- (show-line "warning: different versions of libguile and ice-9:")
- (show-line "libguile: configured on " (libguile-config-stamp))
- (show-line "ice-9: configured on " (ice-9-config-stamp)))))
-
-\f
-
(define-module (guile))
(append! %load-path (cons "." ()))
HCoop / bpt / guile.git / blobdiff