;;; installed-scm-file
-;;;; Copyright (C) 1995, 1996, 1997, 1998 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: "
;;; {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}
;; It should print OBJECT to PORT.
(define (inherit-print-state old-port new-port)
- (if (pair? old-port)
- (cons (if (pair? new-port) (car new-port) new-port)
- (cdr old-port))
+ (if (get-print-state old-port)
+ (port-with-print-state new-port (get-print-state old-port))
new-port))
;; 0: type-name, 1: fields
(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)
(apply consumer (access-values result))
(consumer result))))))
+(provide 'values)
\f
-;;; {and-map, or-map, and map-in-order}
+;;; {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))))))))
-
-(define remove-hook!
- (procedure->macro
- (lambda (exp env)
- `(let ((thunk ,(caddr exp)))
- (if (memq thunk ,(cadr exp))
- (set! ,(cadr exp)
- (delq! thunk ,(cadr exp))))))))
-
\f
-;;; {Files}
-;;;
-;;; If no one can explain this comment to me by 31 Jan 1998, I will
-;;; assume it is meaningless and remove it. -twp
-;;; !!!! these should be implemented using Tcl commands, not fports.
-(define (feature? feature)
- (and (memq feature *features*) #t))
+(if (provided? 'posix)
+ (primitive-load-path "ice-9/posix.scm"))
-;; 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
;;; 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))))))
-
-(define (read-path-list-notation-warning slash port)
- (if (not (getenv "GUILE_HUSH"))
- (begin
- (display "warning: obsolete `#/' list notation read from "
- (current-error-port))
- (display (port-filename port) (current-error-port))
- (display "; see guile-core/NEWS." (current-error-port))
- (newline (current-error-port))
- (display " Set the GUILE_HUSH environment variable to disable this warning."
- (current-error-port))
- (newline (current-error-port))))
- (read-hash-extend #\/ read-path-list-notation)
- (read-path-list-notation slash port))
-
-
(read-hash-extend #\' (lambda (c port)
(read port)))
(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 #\y #\h)
- '(#t #\a 1 -1 1.0 1/3 0+i #\nul s)))
- (let ((array-proc (lambda (c port)
- (read:array c port))))
- (for-each (lambda (char) (read-hash-extend char array-proc))
- '(#\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-warning)
-
-(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 (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))
(define %autoloader-developer-mode #t)
-(define (internal-use-syntax transformer)
- (set-module-transformer! (current-module) transformer)
- (set! scm:eval-transformer transformer))
-
(define (process-define-module args)
(let* ((module-id (car args))
(module (resolve-module module-id #f))
(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))
+ (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))
+ (error "missing interface for use-module"
+ used-module))
(if (eq? keyword 'use-syntax)
- (internal-use-syntax
+ (set-module-transformer!
+ module
(module-ref interface (car (last-pair used-name))
#f)))
- (loop (cddr kws) (cons interface reversed-interfaces)))))
+ (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))
+ "_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
(let ((libtool-filename (in-vicinity libdir
(string-append libname ".la"))))
(and (file-exists? libtool-filename)
- (with-input-from-file libtool-filename
- (lambda ()
- (let loop ((ln (read-line)))
- (cond ((eof-object? ln) #f)
- ((and (>= (string-length ln) 8)
- (string=? "dlname='" (substring ln 0 8))
- (string-index ln #\' 8))
- =>
- (lambda (end)
- (in-vicinity libdir (substring ln 8 end))))
- (else (loop (read-line))))))))))
+ 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))
(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 (error-catching-loop thunk)
(let ((status #f)
(interactive #t))
- (set! set-batch-mode?! (lambda (arg)
- (cond (arg
- (set! interactive #f)
- (restore-signals))
- (#t
- (error "sorry, not implemented")))))
- (set! batch-mode? (lambda () (not interactive)))
(define (loop first)
(let ((next
(catch #t
(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 interactive
- (if (and (not has-shown-debugger-hint?)
- (not (memq 'backtrace
- (debug-options-interface)))
- (stack? (fluid-ref the-last-stack)))
- (begin
- (newline (current-error-port))
- (display
- "Type \"(backtrace)\" to get more information.\n"
- (current-error-port))
- (set! has-shown-debugger-hint? #t)))
- (primitive-exit 1))
+ (begin
+ (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 (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)))
- (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 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)
(let ((cep (current-error-port)))
(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:\n")
(display-backtrace (fluid-ref the-last-stack) cep)
(newline cep)
- (run-hooks after-backtrace-hook)))
- (run-hooks before-error-hook)
+ (run-hook after-backtrace-hook)))
+ (run-hook before-error-hook)
(apply display-error (fluid-ref the-last-stack) cep args)
- (run-hooks after-error-hook)
+ (run-hook after-error-hook)
(force-output cep)
(throw 'abort key)))
(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.
(lambda (prompt)
(display prompt)
(force-output)
- (run-hooks before-read-hook)
+ (run-hook before-read-hook)
(read (current-input-port))))
(define (scm-style-repl)
(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}
`(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}
`(process-use-modules ',modules))
(defmacro use-syntax (spec)
- (if (pair? spec)
- `(begin
- (process-use-modules ',(list spec))
- (internal-use-syntax ,(car (last-pair spec))))
- `(internal-use-syntax ,spec)))
+ `(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)
(define-module (guile-user) :use-module (ice-9 emacs)))
\f
-;;; {I/O functions for Tcl channels (disabled)}
-;; (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 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.
(load-emacs-interface))
;; Place the user in the guile-user module.
- (define-module (guile-user))
+ (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 ()
-
- ;; If we've got readline, use it to prompt the user. This is a
- ;; kludge, but we'll fix it soon. At least we only get
- ;; readline involved when we're actually running the repl.
- (if (and (memq 'readline *features*)
- (isatty? (current-input-port))
- (not (and (module-defined? the-root-module
- 'use-emacs-interface)
- use-emacs-interface)))
- (let ((read-hook (lambda () (run-hooks before-read-hook))))
- (set-current-input-port (readline-port))
- (set! repl-reader
- (lambda (prompt)
- (dynamic-wind
- (lambda ()
- (set-readline-prompt! prompt)
- (set-readline-read-hook! read-hook))
- (lambda () (read))
- (lambda ()
- (set-readline-prompt! "")
- (set-readline-read-hook! #f)))))))
(let ((status (scm-style-repl)))
- (run-hooks exit-hook)
+ (run-hook exit-hook)
status))
;; call at exit.
(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)
;;; This hook is run at the very end of an interactive session.
;;;
-(define exit-hook '())
-
-;;; Load readline code into root module if readline primitives are available.
-;;;
-;;; Ideally, we wouldn't do this until we were sure we were actually
-;;; going to enter the repl, but autoloading individual functions is
-;;; clumsy at the moment.
-(if (and (memq 'readline *features*)
- (isatty? (current-input-port)))
- (begin
- (define-module (guile) :use-module (ice-9 readline))
- (define-module (guile-user) :use-module (ice-9 readline))))
-
-\f
-;;; {Load debug extension code into user module if debug extensions present.}
-;;;
-;;; *fixme* This is a temporary solution.
-;;;
-
-(if (memq 'debug-extensions *features*)
- (define-module (guile-user) :use-module (ice-9 debug)))
-
-\f
-;;; {Load session support into user module if present.}
-;;;
-;;; *fixme* This is a temporary solution.
-;;;
-
-(if (%search-load-path "ice-9/session.scm")
- (define-module (guile-user) :use-module (ice-9 session)))
-
-;;; {Load thread code into user module if threads are present.}
-;;;
-;;; *fixme* This is a temporary solution.
-;;;
-
-(if (memq 'threads *features*)
- (define-module (guile-user) :use-module (ice-9 threads)))
-
-\f
-;;; {Load regexp code if regexp primitives are available.}
-
-(if (memq 'regex *features*)
- (define-module (guile-user) :use-module (ice-9 regex)))
+(define exit-hook (make-hook))
\f
(define-module (guile))
-;;; {Check that the interpreter and scheme code match up.}
-
-(let ((show-line
- (lambda args
- (with-output-to-port (current-error-port)
- (lambda ()
- (display (car (command-line)))
- (display ": ")
- (for-each (lambda (string) (display string))
- args)
- (newline))))))
-
- (load-from-path "ice-9/version.scm")
-
- (if (not (string=?
- (libguile-config-stamp) ; from the interprpreter
- (ice-9-config-stamp))) ; from the Scheme code
- (begin
- (show-line "warning: different versions of libguile and ice-9:")
- (show-line "libguile: configured on " (libguile-config-stamp))
- (show-line "ice-9: configured on " (ice-9-config-stamp)))))
-
(append! %load-path (cons "." ()))
-
HCoop / bpt / guile.git / blobdiff