2740 lines
84 KiB
Scheme
2740 lines
84 KiB
Scheme
;;; -*-scheme-*-
|
||
|
||
;;; GNU Mes --- Maxwell Equations of Software
|
||
;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007
|
||
;;; Free Software Foundation, Inc.
|
||
;;; Copyright © 2019,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||
;;;
|
||
;;; This file is part of GNU Mes.
|
||
;;;
|
||
;;; GNU Mes 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 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Mes 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 GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
|
||
;;; Commentary:
|
||
|
||
;;; guile/module.mes taken from GNU Guile 1.8 boot-9.scm
|
||
;;; This is experimental code for proper Guile module load support.
|
||
|
||
;;; This file is the first thing loaded into Guile. It adds many mundane
|
||
;;; definitions and a few that are interesting.
|
||
;;;
|
||
;;; The module system (hence the hierarchical namespace) are defined in this
|
||
;;; file.
|
||
|
||
;;; Code:
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;; EARLY!
|
||
(define (pke . stuff)
|
||
(display "\n" (current-error-port))
|
||
(newline (current-error-port))
|
||
(display ";;; " (current-error-port))
|
||
(write stuff (current-error-port))
|
||
(display "\n" (current-error-port))
|
||
(car (last-pair stuff)))
|
||
|
||
(define warn pke)
|
||
|
||
;;;;;;;;;;;;;;;;;;; GUILE
|
||
|
||
;; FIXME: move *features* to core, make dynamic
|
||
(define *core-features* '(current-time fork popen
|
||
;;posix
|
||
system))
|
||
|
||
(define *features* (cons* 'defmacro 'record 'define-macro
|
||
*core-features*))
|
||
|
||
(define (include-deprecated-features) #f)
|
||
|
||
(define make-weak-value-hash-table make-hash-table)
|
||
(define (%get-pre-modules-obarray)
|
||
(initial-module))
|
||
|
||
(define (make-mutex)
|
||
'*mutex*)
|
||
(define (lock-mutex m)
|
||
#t)
|
||
(define (unlock-mutex m)
|
||
#t)
|
||
|
||
;;;;;;;;;;;;;;;;;;; MODULE-DEPS
|
||
(define %debug (and=> (or (getenv "MES_DEBUG") "0") string->number))
|
||
|
||
(define core:module-define! module-define!)
|
||
(define (standard-eval-closure module)
|
||
(module-eval-closure module))
|
||
(define (standard-interface-eval-closure module)
|
||
(module-eval-closure module))
|
||
|
||
;; (define (make-undefined-variable)
|
||
;; (make-variable *undefined*))
|
||
|
||
(define (hash-fold proc init table)
|
||
(fold proc init (hash-map->list cons table)))
|
||
|
||
|
||
(define current-reader (make-fluid))
|
||
|
||
(define and-map
|
||
(lambda (f . lists)
|
||
(if (null? (car lists)) (and)
|
||
(if (null? (cdr (car lists))) (apply f (map car lists))
|
||
(and (apply f (map car lists))
|
||
(apply and-map f (map cdr lists)))))))
|
||
|
||
|
||
(define (hash-for-each proc table)
|
||
(hash-map->list proc table)
|
||
*unspecified*)
|
||
|
||
(define (filter pred lst)
|
||
(let loop ((lst lst))
|
||
(if (null? lst) '()
|
||
(if (pred (car lst))
|
||
(cons (car lst) (loop (cdr lst)))
|
||
(loop (cdr lst))))))
|
||
|
||
(define (delete! n lst)
|
||
(let loop ((lst lst) (prev lst))
|
||
(if (null? lst) '()
|
||
(let ((i (car lst)))
|
||
(if (equal? i n) (begin (set-cdr! prev (cdr lst))
|
||
(loop (cdr lst) prev))
|
||
(cons n (loop (cdr lst) lst)))))))
|
||
|
||
(define (delq! n lst)
|
||
(let loop ((lst lst) (prev lst))
|
||
(if (null? lst) '()
|
||
(let ((i (car lst)))
|
||
(if (eq? i n) (begin (set-cdr! prev (cdr lst))
|
||
(loop (cdr lst) prev))
|
||
(cons n (loop (cdr lst) lst)))))))
|
||
|
||
|
||
|
||
;;;;;;;;;;; ************************************************************
|
||
|
||
(define guile:current-module (make-fluid #f))
|
||
|
||
(define module-system-booted? #f)
|
||
(define *current-module* #f)
|
||
|
||
(define (set-current-module m)
|
||
(when (> %debug 2)
|
||
(format (current-error-port) "set-current-module: name=~a\n" (module-name m)))
|
||
(let ((o (guile:current-module)))
|
||
(guile:current-module m)
|
||
(set! *current-module* m)
|
||
(unless o
|
||
(set! module-system-booted? #t))
|
||
o))
|
||
|
||
(define (make-hook . n)
|
||
'())
|
||
|
||
(define (run-hook hook . args)
|
||
#t)
|
||
|
||
;; (define-macro (begin-deprecated . args)
|
||
;; #f)
|
||
|
||
(define (dynamic-wind in thunk out)
|
||
(catch #t
|
||
(lambda _
|
||
(in)
|
||
(let ((r (thunk)))
|
||
(out)
|
||
r))
|
||
(lambda (key . args)
|
||
(format (current-error-port) "ERROR: dynamic-wind: ~a ~s\n" key args)
|
||
(out))))
|
||
|
||
|
||
|
||
|
||
;;; {Features}
|
||
;;;
|
||
|
||
(define (provide sym)
|
||
(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))
|
||
|
||
;; let format alias simple-format until the more complete version is loaded
|
||
|
||
(define format simple-format)
|
||
|
||
|
||
|
||
;;; {Deprecation}
|
||
;;;
|
||
;;; Depends on: defmacro
|
||
;;;
|
||
|
||
(defmacro begin-deprecated forms
|
||
(if (include-deprecated-features)
|
||
(cons begin forms)
|
||
#f))
|
||
|
||
|
||
|
||
;;; {EVAL-CASE}
|
||
;;;
|
||
|
||
;; (eval-case ((situation*) forms)* (else forms)?)
|
||
;;
|
||
;; Evaluate certain code based on the situation that eval-case is used
|
||
;; in. The only defined situation right now is `load-toplevel' which
|
||
;; triggers for code evaluated at the top-level, for example from the
|
||
;; REPL or when loading a file.
|
||
|
||
(define-macro (eval-case . exp)
|
||
(let ((env #t)) ; XXX TODO: get current-env from eval-apply
|
||
`(begin
|
||
(define (toplevel-env? env)
|
||
(or (not (pair? env)) (not (pair? (car env)))))
|
||
(define (syntax)
|
||
(error "syntax error in eval-case"))
|
||
(let loop ((clauses ',exp))
|
||
(cond
|
||
((null? clauses)
|
||
#f)
|
||
((not (list? (car clauses)))
|
||
(syntax))
|
||
((eq? 'else (caar clauses))
|
||
(or (null? (cdr clauses))
|
||
(syntax))
|
||
(cons 'begin (cdar clauses)))
|
||
((not (list? (caar clauses)))
|
||
(syntax))
|
||
((and (toplevel-env? ,env)
|
||
(memq 'load-toplevel (caar clauses)))
|
||
(cons 'begin (cdar clauses)))
|
||
(else
|
||
(loop (cdr clauses))))))))
|
||
|
||
|
||
|
||
;;; {Booleans}
|
||
;;;
|
||
|
||
(define (->bool x) (not (not x)))
|
||
|
||
|
||
|
||
;;; {Symbols}
|
||
;;;
|
||
|
||
(define (symbol-append . args)
|
||
(string->symbol (apply string-append (map symbol->string args))))
|
||
|
||
(define (list->symbol . args)
|
||
(string->symbol (apply list->string args)))
|
||
|
||
(define (symbol . args)
|
||
(string->symbol (apply string args)))
|
||
|
||
|
||
|
||
;;; {Lists}
|
||
;;;
|
||
|
||
(define (filter pred lst)
|
||
(let loop ((lst lst))
|
||
(if (null? lst) '()
|
||
(if (pred (car lst))
|
||
(cons (car lst) (loop (cdr lst)))
|
||
(loop (cdr lst))))))
|
||
|
||
(define (delete! n lst)
|
||
(let loop ((lst lst) (prev lst))
|
||
(if (null? lst) '()
|
||
(let ((i (car lst)))
|
||
(if (equal? i n) (begin (set-cdr! prev (cdr lst))
|
||
(loop (cdr lst) prev))
|
||
(cons n (loop (cdr lst) lst)))))))
|
||
|
||
(define (delq! n lst)
|
||
(let loop ((lst lst) (prev lst))
|
||
(if (null? lst) '()
|
||
(let ((i (car lst)))
|
||
(if (eq? i n) (begin (set-cdr! prev (cdr lst))
|
||
(loop (cdr lst) prev))
|
||
(cons n (loop (cdr lst) lst)))))))
|
||
|
||
|
||
|
||
;;; {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-map f l
|
||
;;
|
||
;; Apply f to successive elements of l until exhaustion or f returns #f.
|
||
;; If returning early, return #f. Otherwise, return the last value returned
|
||
;; by f. If f has never been called because l is empty, return #t.
|
||
;;
|
||
(define (and-map f lst)
|
||
(let loop ((result #t)
|
||
(l lst))
|
||
(and result
|
||
(or (and (null? l)
|
||
result)
|
||
(loop (f (car l)) (cdr l))))))
|
||
|
||
;; or-map f l
|
||
;;
|
||
;; Apply f to successive elements of l until exhaustion or while f returns #f.
|
||
;; If returning early, return the return value of f.
|
||
;;
|
||
(define (or-map f lst)
|
||
(let loop ((result #f)
|
||
(l lst))
|
||
(or result
|
||
(and (not (null? l))
|
||
(loop (f (car l)) (cdr l))))))
|
||
|
||
|
||
|
||
(if (provided? 'posix)
|
||
(primitive-load-path "ice-9/posix.scm"))
|
||
|
||
(if (provided? 'socket)
|
||
(primitive-load-path "ice-9/networking.scm"))
|
||
|
||
;; For reference, Emacs file-exists-p uses stat in this same way.
|
||
;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in
|
||
;; C where all that's needed is to inspect the return from stat().
|
||
(define file-exists?
|
||
(if (provided? 'posix)
|
||
(lambda (str)
|
||
(->bool (false-if-exception (stat str))))
|
||
(lambda (str)
|
||
(let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
|
||
(lambda args #f))))
|
||
(if port (begin (close-port port) #t)
|
||
#f)))))
|
||
|
||
(define file-is-directory?
|
||
(if (provided? 'posix)
|
||
(lambda (str)
|
||
(eq? (stat:type (stat str)) 'directory))
|
||
(lambda (str)
|
||
(let ((port (catch 'system-error
|
||
(lambda () (open-file (string-append str "/.")
|
||
OPEN_READ))
|
||
(lambda args #f))))
|
||
(if port (begin (close-port port) #t)
|
||
#f)))))
|
||
|
||
(define (has-suffix? str suffix)
|
||
(let ((sufl (string-length suffix))
|
||
(sl (string-length str)))
|
||
(and (> sl sufl)
|
||
(string=? (substring str (- sl sufl) sl) suffix))))
|
||
|
||
(define (system-error-errno args)
|
||
(if (eq? (car args) 'system-error)
|
||
(car (list-ref args 4))
|
||
#f))
|
||
|
||
|
||
|
||
;;; {Error Handling}
|
||
;;;
|
||
|
||
(define (Xerror . args)
|
||
(save-stack)
|
||
(if (null? args)
|
||
(scm-error 'misc-error #f "?" #f #f)
|
||
(let loop ((msg "~A")
|
||
(rest (cdr args)))
|
||
(if (not (null? rest))
|
||
(loop (string-append msg " ~S")
|
||
(cdr rest))
|
||
(scm-error 'misc-error #f msg args #f)))))
|
||
|
||
;; bad-throw is the hook that is called upon a throw to a an unhandled
|
||
;; key (unless the throw has four arguments, in which case
|
||
;; it's usually interpreted as an error throw.)
|
||
;; If the key has a default handler (a throw-handler-default property),
|
||
;; it is applied to the throw.
|
||
;;
|
||
(define (bad-throw key . args)
|
||
(let ((default (symbol-property key 'throw-handler-default)))
|
||
(or (and default (apply default key args))
|
||
(apply error "unhandled-exception:" key args))))
|
||
|
||
|
||
|
||
(define (tm:sec obj) (vector-ref obj 0))
|
||
(define (tm:min obj) (vector-ref obj 1))
|
||
(define (tm:hour obj) (vector-ref obj 2))
|
||
(define (tm:mday obj) (vector-ref obj 3))
|
||
(define (tm:mon obj) (vector-ref obj 4))
|
||
(define (tm:year obj) (vector-ref obj 5))
|
||
(define (tm:wday obj) (vector-ref obj 6))
|
||
(define (tm:yday obj) (vector-ref obj 7))
|
||
(define (tm:isdst obj) (vector-ref obj 8))
|
||
(define (tm:gmtoff obj) (vector-ref obj 9))
|
||
(define (tm:zone obj) (vector-ref obj 10))
|
||
|
||
(define (set-tm:sec obj val) (vector-set! obj 0 val))
|
||
(define (set-tm:min obj val) (vector-set! obj 1 val))
|
||
(define (set-tm:hour obj val) (vector-set! obj 2 val))
|
||
(define (set-tm:mday obj val) (vector-set! obj 3 val))
|
||
(define (set-tm:mon obj val) (vector-set! obj 4 val))
|
||
(define (set-tm:year obj val) (vector-set! obj 5 val))
|
||
(define (set-tm:wday obj val) (vector-set! obj 6 val))
|
||
(define (set-tm:yday obj val) (vector-set! obj 7 val))
|
||
(define (set-tm:isdst obj val) (vector-set! obj 8 val))
|
||
(define (set-tm:gmtoff obj val) (vector-set! obj 9 val))
|
||
(define (set-tm:zone obj val) (vector-set! obj 10 val))
|
||
|
||
(define (tms:clock obj) (vector-ref obj 0))
|
||
(define (tms:utime obj) (vector-ref obj 1))
|
||
(define (tms:stime obj) (vector-ref obj 2))
|
||
(define (tms:cutime obj) (vector-ref obj 3))
|
||
(define (tms:cstime obj) (vector-ref obj 4))
|
||
|
||
(define file-position ftell)
|
||
(define (file-set-position port offset . whence)
|
||
(let ((whence (if (eq? whence '()) SEEK_SET (car whence))))
|
||
(seek port offset whence)))
|
||
|
||
(define (move->fdes fd/port fd)
|
||
(cond ((integer? fd/port)
|
||
(dup->fdes fd/port fd)
|
||
(close fd/port)
|
||
fd)
|
||
(else
|
||
(primitive-move->fdes fd/port fd)
|
||
(set-port-revealed! fd/port 1)
|
||
fd/port)))
|
||
|
||
(define (release-port-handle port)
|
||
(let ((revealed (port-revealed port)))
|
||
(if (> revealed 0)
|
||
(set-port-revealed! port (- revealed 1)))))
|
||
|
||
(define (dup->port port/fd mode . maybe-fd)
|
||
(let ((port (fdopen (apply dup->fdes port/fd maybe-fd)
|
||
mode)))
|
||
(if (pair? maybe-fd)
|
||
(set-port-revealed! port 1))
|
||
port))
|
||
|
||
(define (dup->inport port/fd . maybe-fd)
|
||
(apply dup->port port/fd "r" maybe-fd))
|
||
|
||
(define (dup->outport port/fd . maybe-fd)
|
||
(apply dup->port port/fd "w" maybe-fd))
|
||
|
||
(define (dup port/fd . maybe-fd)
|
||
(if (integer? port/fd)
|
||
(apply dup->fdes port/fd maybe-fd)
|
||
(apply dup->port port/fd (port-mode port/fd) maybe-fd)))
|
||
|
||
(define (duplicate-port port modes)
|
||
(dup->port port modes))
|
||
|
||
(define (fdes->inport fdes)
|
||
(let loop ((rest-ports (fdes->ports fdes)))
|
||
(cond ((null? rest-ports)
|
||
(let ((result (fdopen fdes "r")))
|
||
(set-port-revealed! result 1)
|
||
result))
|
||
((input-port? (car rest-ports))
|
||
(set-port-revealed! (car rest-ports)
|
||
(+ (port-revealed (car rest-ports)) 1))
|
||
(car rest-ports))
|
||
(else
|
||
(loop (cdr rest-ports))))))
|
||
|
||
(define (fdes->outport fdes)
|
||
(let loop ((rest-ports (fdes->ports fdes)))
|
||
(cond ((null? rest-ports)
|
||
(let ((result (fdopen fdes "w")))
|
||
(set-port-revealed! result 1)
|
||
result))
|
||
((output-port? (car rest-ports))
|
||
(set-port-revealed! (car rest-ports)
|
||
(+ (port-revealed (car rest-ports)) 1))
|
||
(car rest-ports))
|
||
(else
|
||
(loop (cdr rest-ports))))))
|
||
|
||
(define (port->fdes port)
|
||
(set-port-revealed! port (+ (port-revealed port) 1))
|
||
(fileno port))
|
||
|
||
;; (define (setenv name value)
|
||
;; (if value
|
||
;; (putenv (string-append name "=" value))
|
||
;; (putenv name)))
|
||
|
||
;; (define (unsetenv name)
|
||
;; "Remove the entry for NAME from the environment."
|
||
;; (putenv name))
|
||
|
||
|
||
|
||
;;; {Load Paths}
|
||
;;;
|
||
|
||
(define (in-vicinity vicinity file)
|
||
(let ((tail (let ((len (string-length vicinity)))
|
||
(if (zero? len)
|
||
#f
|
||
(string-ref vicinity (- len 1))))))
|
||
(string-append vicinity
|
||
(if (or (not tail)
|
||
(eq? tail #\/))
|
||
""
|
||
"/")
|
||
file)))
|
||
|
||
(define %load-path
|
||
(let ((path (cons* %moduledir "module" (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:))))
|
||
path))
|
||
|
||
(define (%search-load-path file-name)
|
||
(when (> %debug 2)
|
||
(format (current-error-port) "%search-load-path ~s\n" file-name))
|
||
(let ((file (or (search-path %load-path (string-append file-name ".mes"))
|
||
(search-path %load-path (string-append file-name ".scm")))))
|
||
(when (> %debug 1)
|
||
(format (current-error-port) " *file-name => ~s\n" file))
|
||
file))
|
||
|
||
|
||
|
||
;;; {Help for scm_shell}
|
||
;;;
|
||
;;; The argument-processing code used by Guile-based shells generates
|
||
;;; Scheme code based on the argument list. This page contains help
|
||
;;; functions for the code it generates.
|
||
;;;
|
||
|
||
(define (command-line) (program-arguments))
|
||
|
||
;; This is mostly for the internal use of the code generated by
|
||
;; scm_compile_shell_switches.
|
||
|
||
(define (turn-on-debugging)
|
||
(debug-enable 'debug)
|
||
(debug-enable 'backtrace)
|
||
(read-enable 'positions))
|
||
|
||
(define (load-user-init)
|
||
(let* ((home (or (getenv "HOME")
|
||
(false-if-exception (passwd:dir (getpwuid (getuid))))
|
||
"/")) ;; fallback for cygwin etc.
|
||
(init-file (in-vicinity home ".guile")))
|
||
(if (file-exists? init-file)
|
||
(primitive-load init-file))))
|
||
|
||
|
||
|
||
;;; {Loading by paths}
|
||
;;;
|
||
|
||
;;; Load a Scheme source file named NAME, searching for it in the
|
||
;;; directories listed in %load-path, and applying each of the file
|
||
;;; name extensions listed in %load-extensions.
|
||
(define (load-from-path name)
|
||
(start-stack 'load-stack
|
||
(primitive-load-path name)))
|
||
|
||
|
||
|
||
;;; {Low Level Modules}
|
||
;;;
|
||
;;; These are the low level data structures for modules.
|
||
;;;
|
||
;;; Every module object is of the type 'module-type', which is a record
|
||
;;; consisting of the following members:
|
||
;;;
|
||
;;; - eval-closure: the function that defines for its module the strategy that
|
||
;;; shall be followed when looking up symbols in the module.
|
||
;;;
|
||
;;; An eval-closure is a function taking two arguments: the symbol to be
|
||
;;; looked up and a boolean value telling whether a binding for the symbol
|
||
;;; should be created if it does not exist yet. If the symbol lookup
|
||
;;; succeeded (either because an existing binding was found or because a new
|
||
;;; binding was created), a variable object representing the binding is
|
||
;;; returned. Otherwise, the value #f is returned. Note that the eval
|
||
;;; closure does not take the module to be searched as an argument: During
|
||
;;; construction of the eval-closure, the eval-closure has to store the
|
||
;;; module it belongs to in its environment. This means, that any
|
||
;;; eval-closure can belong to only one module.
|
||
;;;
|
||
;;; The eval-closure of a module can be defined arbitrarily. However, three
|
||
;;; special cases of eval-closures are to be distinguished: During startup
|
||
;;; the module system is not yet activated. In this phase, no modules are
|
||
;;; defined and all bindings are automatically stored by the system in the
|
||
;;; pre-modules-obarray. Since no eval-closures exist at this time, the
|
||
;;; functions which require an eval-closure as their argument need to be
|
||
;;; passed the value #f.
|
||
;;;
|
||
;;; The other two special cases of eval-closures are the
|
||
;;; standard-eval-closure and the standard-interface-eval-closure. Both
|
||
;;; behave equally for the case that no new binding is to be created. The
|
||
;;; difference between the two comes in, when the boolean argument to the
|
||
;;; eval-closure indicates that a new binding shall be created if it is not
|
||
;;; found.
|
||
;;;
|
||
;;; Given that no new binding shall be created, both standard eval-closures
|
||
;;; define the following standard strategy of searching bindings in the
|
||
;;; module: First, the module's obarray is searched for the symbol. Second,
|
||
;;; if no binding for the symbol was found in the module's obarray, the
|
||
;;; module's binder procedure is exececuted. If this procedure did not
|
||
;;; return a binding for the symbol, the modules referenced in the module's
|
||
;;; uses list are recursively searched for a binding of the symbol. If the
|
||
;;; binding can not be found in these modules also, the symbol lookup has
|
||
;;; failed.
|
||
;;;
|
||
;;; If a new binding shall be created, the standard-interface-eval-closure
|
||
;;; immediately returns indicating failure. That is, it does not even try
|
||
;;; to look up the symbol. In contrast, the standard-eval-closure would
|
||
;;; first search the obarray, and if no binding was found there, would
|
||
;;; create a new binding in the obarray, therefore not calling the binder
|
||
;;; procedure or searching the modules in the uses list.
|
||
;;;
|
||
;;; The explanation of the following members obarray, binder and uses
|
||
;;; assumes that the symbol lookup follows the strategy that is defined in
|
||
;;; the standard-eval-closure and the standard-interface-eval-closure.
|
||
;;;
|
||
;;; - obarray: a hash table that maps symbols to variable objects. In this
|
||
;;; hash table, the definitions are found that are local to the module (that
|
||
;;; is, not imported from other modules). When looking up bindings in the
|
||
;;; module, this hash table is searched first.
|
||
;;;
|
||
;;; - binder: either #f or a function taking a module and a symbol argument.
|
||
;;; If it is a function it is called after the obarray has been
|
||
;;; unsuccessfully searched for a binding. It then can provide bindings
|
||
;;; that would otherwise not be found locally in the module.
|
||
;;;
|
||
;;; - uses: a list of modules from which non-local bindings can be inherited.
|
||
;;; These modules are the third place queried for bindings after the obarray
|
||
;;; has been unsuccessfully searched and the binder function did not deliver
|
||
;;; a result either.
|
||
;;;
|
||
;;; - transformer: either #f or a function taking a scheme expression as
|
||
;;; delivered by read. If it is a function, it will be called to perform
|
||
;;; syntax transformations (e. g. makro expansion) on the given scheme
|
||
;;; expression. The output of the transformer function will then be passed
|
||
;;; to Guile's internal memoizer. This means that the output must be valid
|
||
;;; scheme code. The only exception is, that the output may make use of the
|
||
;;; syntax extensions provided to identify the modules that a binding
|
||
;;; belongs to.
|
||
;;;
|
||
;;; - name: the name of the module. This is used for all kinds of printing
|
||
;;; outputs. In certain places the module name also serves as a way of
|
||
;;; identification. When adding a module to the uses list of another
|
||
;;; module, it is made sure that the new uses list will not contain two
|
||
;;; modules of the same name.
|
||
;;;
|
||
;;; - kind: classification of the kind of module. The value is (currently?)
|
||
;;; only used for printing. It has no influence on how a module is treated.
|
||
;;; Currently the following values are used when setting the module kind:
|
||
;;; 'module, 'directory, 'interface, 'custom-interface. If no explicit kind
|
||
;;; is set, it defaults to 'module.
|
||
;;;
|
||
;;; - duplicates-handlers
|
||
;;;
|
||
;;; - duplicates-interface
|
||
;;;
|
||
;;; - observers
|
||
;;;
|
||
;;; - weak-observers
|
||
;;;
|
||
;;; - observer-id
|
||
;;;
|
||
;;; In addition, the module may (must?) contain a binding for
|
||
;;; %module-public-interface... More explanations here...
|
||
;;;
|
||
;;; !!! warning: The interface to lazy binder procedures is going
|
||
;;; to be changed in an incompatible way to permit all the basic
|
||
;;; module ops to be virtualized.
|
||
;;;
|
||
;;; (make-module size use-list lazy-binding-proc) => module
|
||
;;; module-{obarray,uses,binder}[|-set!]
|
||
;;; (module? obj) => [#t|#f]
|
||
;;; (module-locally-bound? module symbol) => [#t|#f]
|
||
;;; (module-bound? module symbol) => [#t|#f]
|
||
;;; (module-symbol-locally-interned? module symbol) => [#t|#f]
|
||
;;; (module-symbol-interned? module symbol) => [#t|#f]
|
||
;;; (module-local-variable module symbol) => [#<variable ...> | #f]
|
||
;;; (module-variable module symbol) => [#<variable ...> | #f]
|
||
;;; (module-symbol-binding module symbol opt-value)
|
||
;;; => [ <obj> | opt-value | an error occurs ]
|
||
;;; (module-make-local-var! module symbol) => #<variable...>
|
||
;;; (module-add! module symbol var) => unspecified
|
||
;;; (module-remove! module symbol) => unspecified
|
||
;;; (module-for-each proc module) => unspecified
|
||
;;; (make-scm-module) => module ; a lazy copy of the symhash module
|
||
;;; (set-current-module module) => unspecified
|
||
;;; (current-module) => #<module...>
|
||
;;;
|
||
;;;
|
||
|
||
|
||
|
||
;;; {Printing Modules}
|
||
;;;
|
||
|
||
;; This is how modules are printed. You can re-define it.
|
||
;; (Redefining is actually more complicated than simply redefining
|
||
;; %print-module because that would only change the binding and not
|
||
;; the value stored in the vtable that determines how record are
|
||
;; printed. Sigh.)
|
||
|
||
(define (%print-module mod . port) ; unused args: depth length style table)
|
||
(display "#<" port)
|
||
(display (or (module-kind mod) "module") port)
|
||
(let ((name (module-name mod)))
|
||
(if name
|
||
(begin
|
||
(display " " port)
|
||
(display name port))))
|
||
(display " " port)
|
||
(display (number->string (object-address mod) 16) port)
|
||
(display ">" port))
|
||
|
||
(define (%print-module mod . port) ; unused args: depth length style table)
|
||
;; (unless (module? mod)
|
||
;; (error "Bad module to %print-module" mod))
|
||
(let ((port (if (pair? port) (car port) (current-error-port))))
|
||
(display "#<" port)
|
||
(display (or (module-kind mod) "module") port)
|
||
(let ((name (module-name mod)))
|
||
(if name
|
||
(begin
|
||
(display " " port)
|
||
(display name port))))
|
||
(display " " port)
|
||
(display (number->string (object-address mod) 16) port)
|
||
(display ">" port)))
|
||
|
||
;; module-type
|
||
;;
|
||
;; A module is characterized by an obarray in which local symbols
|
||
;; are interned, a list of modules, "uses", from which non-local
|
||
;; bindings can be inherited, and an optional lazy-binder which
|
||
;; is a (CLOSURE module symbol) which, as a last resort, can provide
|
||
;; bindings that would otherwise not be found locally in the module.
|
||
;;
|
||
;; NOTE: If you change anything here, you also need to change
|
||
;; libguile/modules.h.
|
||
;;
|
||
(define module-type
|
||
(make-record-type 'module
|
||
'(obarray uses binder eval-closure transformer name kind
|
||
duplicates-handlers duplicates-interface
|
||
observers weak-observers observer-id)
|
||
%print-module))
|
||
|
||
;; make-module &opt size uses binder
|
||
;;
|
||
;; Create a new module, perhaps with a particular size of obarray,
|
||
;; initial uses list, or binding procedure.
|
||
;;
|
||
(define make-module
|
||
(lambda args
|
||
|
||
(define (parse-arg index default)
|
||
(if (> (length args) index)
|
||
(list-ref args index)
|
||
default))
|
||
|
||
(if (> (length args) 3)
|
||
(error "Too many args to make-module." args))
|
||
|
||
(let ((size (or 1 (parse-arg 0 31)))
|
||
(uses (parse-arg 1 '()))
|
||
(binder (parse-arg 2 #f)))
|
||
|
||
(if (not (integer? size))
|
||
(error "Illegal size to make-module." size))
|
||
(if (not (and (list? uses)
|
||
(and-map module? uses)))
|
||
(error "Incorrect use list." uses))
|
||
(if (and binder (not (procedure? binder)))
|
||
(error
|
||
"Lazy-binder expected to be a procedure or #f." binder))
|
||
|
||
(let ((module (module-constructor (make-hash-table size)
|
||
uses binder #f #f #f #f #f #f
|
||
'()
|
||
(make-weak-value-hash-table (or 1 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
|
||
;; itself.
|
||
(set-module-eval-closure! module (standard-eval-closure module))
|
||
|
||
module))))
|
||
|
||
(define module-constructor (record-constructor module-type))
|
||
(define module-obarray (record-accessor module-type 'obarray))
|
||
(define set-module-obarray! (record-modifier module-type 'obarray))
|
||
(define module-uses (record-accessor module-type 'uses))
|
||
(define set-module-uses! (record-modifier module-type 'uses))
|
||
(define module-binder (record-accessor module-type 'binder))
|
||
(define set-module-binder! (record-modifier module-type 'binder))
|
||
|
||
;; NOTE: This binding is used in libguile/modules.c.
|
||
(define module-eval-closure (record-accessor 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-duplicates-handlers
|
||
(record-accessor module-type 'duplicates-handlers))
|
||
(define set-module-duplicates-handlers!
|
||
(record-modifier module-type 'duplicates-handlers))
|
||
(define module-duplicates-interface
|
||
(record-accessor module-type 'duplicates-interface))
|
||
(define set-module-duplicates-interface!
|
||
(record-modifier module-type 'duplicates-interface))
|
||
(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 (module? x)
|
||
;; (display "module? ")
|
||
;; (display x)
|
||
;; (let ((r ((record-predicate module-type) x)))
|
||
;; (display r)
|
||
;; (display "\n")
|
||
;; r))
|
||
|
||
(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))))
|
||
|
||
|
||
|
||
;;; {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-defer-observers #f)
|
||
(define module-defer-observers-mutex (make-mutex))
|
||
(define module-defer-observers-table (make-hash-table))
|
||
|
||
(define (module-modified m)
|
||
(if module-defer-observers
|
||
(hash-set! module-defer-observers-table m #t)
|
||
(module-call-observers m)))
|
||
|
||
;;; This function can be used to delay calls to observers so that they
|
||
;;; can be called once only in the face of massive updating of modules.
|
||
;;;
|
||
(define (call-with-deferred-observers thunk)
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(lock-mutex module-defer-observers-mutex)
|
||
(set! module-defer-observers #t))
|
||
thunk
|
||
(lambda ()
|
||
(set! module-defer-observers #f)
|
||
(hash-for-each (lambda (m dummy)
|
||
(module-call-observers m))
|
||
module-defer-observers-table)
|
||
(hash-clear! module-defer-observers-table)
|
||
(unlock-mutex module-defer-observers-mutex))))
|
||
|
||
(define (module-call-observers m)
|
||
(for-each (lambda (proc) (proc m)) (module-observers m))
|
||
(hash-fold (lambda (id proc res) (proc m)) #f (module-weak-observers m)))
|
||
|
||
|
||
|
||
;;; {Module Searching in General}
|
||
;;;
|
||
;;; We sometimes want to look for properties of a symbol
|
||
;;; just within the obarray of one module. If the property
|
||
;;; holds, then it is said to hold ``locally'' as in, ``The symbol
|
||
;;; DISPLAY is locally rebound in the module `safe-guile'.''
|
||
;;;
|
||
;;;
|
||
;;; Other times, we want to test for a symbol property in the obarray
|
||
;;; of M and, if it is not found there, try each of the modules in the
|
||
;;; uses list of M. This is the normal way of testing for some
|
||
;;; property, so we state these properties without qualification as
|
||
;;; in: ``The symbol 'fnord is interned in module M because it is
|
||
;;; interned locally in module M2 which is a member of the uses list
|
||
;;; of M.''
|
||
;;;
|
||
|
||
;; module-search fn m
|
||
;;
|
||
;; return the first non-#f result of FN applied to M and then to
|
||
;; the modules in the uses of m, and so on recursively. If all applications
|
||
;; return #f, then so does this function.
|
||
;;
|
||
(define (module-search fn m v)
|
||
(define (loop pos)
|
||
(and (pair? pos)
|
||
(or (module-search fn (car pos) v)
|
||
(loop (cdr pos)))))
|
||
(or (fn m v)
|
||
(loop (module-uses m))))
|
||
|
||
|
||
;;; {Is a symbol bound in a module?}
|
||
;;;
|
||
;;; Symbol S in Module M is bound if S is interned in M and if the binding
|
||
;;; of S in M has been set to some well-defined value.
|
||
;;;
|
||
|
||
;; module-locally-bound? module symbol
|
||
;;
|
||
;; Is a symbol bound (interned and defined) locally in a given module?
|
||
;;
|
||
(define (module-locally-bound? m v)
|
||
(let ((var (module-local-variable m v)))
|
||
(and var
|
||
(variable-bound? var))))
|
||
|
||
;; module-bound? module symbol
|
||
;;
|
||
;; Is a symbol bound (interned and defined) anywhere in a given module
|
||
;; or its uses?
|
||
;;
|
||
(define (module-bound? m v)
|
||
(module-search module-locally-bound? m v))
|
||
|
||
;;; {Is a symbol interned in a module?}
|
||
;;;
|
||
;;; Symbol S in Module M is interned if S occurs in
|
||
;;; of S in M has been set to some well-defined value.
|
||
;;;
|
||
;;; It is possible to intern a symbol in a module without providing
|
||
;;; an initial binding for the corresponding variable. This is done
|
||
;;; with:
|
||
;;; (module-add! module symbol (make-undefined-variable))
|
||
;;;
|
||
;;; In that case, the symbol is interned in the module, but not
|
||
;;; bound there. The unbound symbol shadows any binding for that
|
||
;;; symbol that might otherwise be inherited from a member of the uses list.
|
||
;;;
|
||
|
||
(define (module-obarray-get-handle ob key)
|
||
((if (symbol? key) hashq-get-handle hash-get-handle) ob key))
|
||
|
||
(define (module-obarray-ref ob key)
|
||
((if (symbol? key) hashq-ref hash-ref) ob key))
|
||
|
||
(define (module-obarray-set! ob key val)
|
||
((if (symbol? key) hashq-set! hash-set!) ob key val))
|
||
|
||
(define (module-obarray-remove! ob key)
|
||
((if (symbol? key) hashq-remove! hash-remove!) ob key))
|
||
|
||
;; module-symbol-locally-interned? module symbol
|
||
;;
|
||
;; is a symbol interned (not neccessarily defined) locally in a given module
|
||
;; or its uses? Interned symbols shadow inherited bindings even if
|
||
;; they are not themselves bound to a defined value.
|
||
;;
|
||
(define (module-symbol-locally-interned? m v)
|
||
(display "module-symbol-locally-interned? \n")
|
||
(not (not (module-obarray-get-handle (module-obarray m) v))))
|
||
|
||
;; module-symbol-interned? module symbol
|
||
;;
|
||
;; is a symbol interned (not neccessarily defined) anywhere in a given module
|
||
;; or its uses? Interned symbols shadow inherited bindings even if
|
||
;; they are not themselves bound to a defined value.
|
||
;;
|
||
(define (module-symbol-interned? m v)
|
||
(module-search module-symbol-locally-interned? m v))
|
||
|
||
|
||
;;; {Mapping modules x symbols --> variables}
|
||
;;;
|
||
|
||
;; module-local-variable module symbol
|
||
;; return the local variable associated with a MODULE and SYMBOL.
|
||
;;
|
||
;;; This function is very important. It is the only function that can
|
||
;;; return a variable from a module other than the mutators that store
|
||
;;; new variables in modules. Therefore, this function is the location
|
||
;;; of the "lazy binder" hack.
|
||
;;;
|
||
;;; If symbol is defined in MODULE, and if the definition binds symbol
|
||
;;; to a variable, return that variable object.
|
||
;;;
|
||
;;; If the symbols is not found at first, but the module has a lazy binder,
|
||
;;; then try the binder.
|
||
;;;
|
||
;;; If the symbol is not found at all, return #f.
|
||
;;;
|
||
(define (module-local-variable m v)
|
||
; (caddr
|
||
; (list m v
|
||
(let ((b (module-obarray-ref (module-obarray m) v)))
|
||
(or (and (variable? b) b)
|
||
(and (module-binder m)
|
||
((module-binder m) m v #f)))))
|
||
;))
|
||
|
||
;; module-variable module symbol
|
||
;;
|
||
;; like module-local-variable, except search the uses in the
|
||
;; case V is not found in M.
|
||
;;
|
||
;; NOTE: This function is superseded with C code (see modules.c)
|
||
;;; when using the standard eval closure.
|
||
;;
|
||
(define (module-variable m v)
|
||
(module-search module-local-variable m v))
|
||
|
||
|
||
;;; {Mapping modules x symbols --> bindings}
|
||
;;;
|
||
;;; These are similar to the mapping to variables, except that the
|
||
;;; variable is dereferenced.
|
||
;;;
|
||
|
||
;; module-symbol-binding module symbol opt-value
|
||
;;
|
||
;; return the binding of a variable specified by name within
|
||
;; a given module, signalling an error if the variable is unbound.
|
||
;; If the OPT-VALUE is passed, then instead of signalling an error,
|
||
;; return OPT-VALUE.
|
||
;;
|
||
(define (module-symbol-local-binding m v . opt-val)
|
||
(let ((var (module-local-variable m v)))
|
||
(if (and var (variable-bound? var))
|
||
(variable-ref var)
|
||
(if (not (null? opt-val))
|
||
(car opt-val)
|
||
(error "Locally unbound variable." v)))))
|
||
|
||
;; module-symbol-binding module symbol opt-value
|
||
;;
|
||
;; return the binding of a variable specified by name within
|
||
;; a given module, signalling an error if the variable is unbound.
|
||
;; If the OPT-VALUE is passed, then instead of signalling an error,
|
||
;; return OPT-VALUE.
|
||
;;
|
||
(define (module-symbol-binding m v . opt-val)
|
||
(let ((var (module-variable m v)))
|
||
(if (and var (variable-bound? var))
|
||
(variable-ref var)
|
||
(if (not (null? opt-val))
|
||
(car opt-val)
|
||
(error "Unbound variable." v)))))
|
||
|
||
|
||
|
||
|
||
;;; {Adding Variables to Modules}
|
||
;;;
|
||
|
||
;; module-make-local-var! module symbol
|
||
;;
|
||
;; ensure a variable for V in the local namespace of M.
|
||
;; If no variable was already there, then create a new and uninitialzied
|
||
;; variable.
|
||
;;
|
||
;; This function is used in modules.c.
|
||
;;
|
||
(define (module-make-local-var! m v)
|
||
(or (let ((b (module-obarray-ref (module-obarray m) v)))
|
||
(and (variable? b)
|
||
(begin
|
||
;; Mark as modified since this function is called when
|
||
;; the standard eval closure defines a binding
|
||
(module-modified m)
|
||
b)))
|
||
|
||
;; Create a new local variable.
|
||
(let ((local-var (make-undefined-variable)))
|
||
(module-add! m v local-var)
|
||
local-var)))
|
||
|
||
;; module-ensure-local-variable! module symbol
|
||
;;
|
||
;; Ensure that there is a local variable in MODULE for SYMBOL. If
|
||
;; there is no binding for SYMBOL, create a new uninitialized
|
||
;; variable. Return the local variable.
|
||
;;
|
||
(define (module-ensure-local-variable! module symbol)
|
||
(or (module-local-variable module symbol)
|
||
(let ((var (make-undefined-variable)))
|
||
(module-add! module symbol var)
|
||
var)))
|
||
|
||
;; module-add! module symbol var
|
||
;;
|
||
;; ensure a particular variable for V in the local namespace of M.
|
||
;;
|
||
(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-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-modified m))
|
||
|
||
(define (module-clear! m)
|
||
(hash-clear! (module-obarray m))
|
||
(module-modified m))
|
||
|
||
;; MODULE-FOR-EACH -- exported
|
||
;;
|
||
;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
|
||
;;
|
||
(define (module-for-each proc module)
|
||
(hash-for-each proc (module-obarray module)))
|
||
|
||
(define (module-map proc module)
|
||
(hash-map->list proc (module-obarray module)))
|
||
|
||
|
||
|
||
;;; {Low Level Bootstrapping}
|
||
;;;
|
||
|
||
;; make-root-module
|
||
|
||
;; A root module uses the pre-modules-obarray as its obarray. This
|
||
;; special obarray accumulates all bindings that have been established
|
||
;; before the module system is fully booted.
|
||
;;
|
||
;; (The obarray continues to be used by code that has been closed over
|
||
;; before the module system has been booted.)
|
||
|
||
(define (make-root-module)
|
||
(let ((m (make-module 0)))
|
||
(set-module-obarray! m (%get-pre-modules-obarray))
|
||
m))
|
||
|
||
;; make-scm-module
|
||
|
||
;; The root interface is a module that uses the same obarray as the
|
||
;; root module. It does not allow new definitions, tho.
|
||
|
||
(define (make-scm-module)
|
||
(let ((m (make-module 0)))
|
||
(set-module-obarray! m (%get-pre-modules-obarray))
|
||
(set-module-eval-closure! m (standard-interface-eval-closure m))
|
||
m))
|
||
|
||
|
||
|
||
|
||
;;; {Module-based Loading}
|
||
;;;
|
||
|
||
(define (save-module-excursion thunk)
|
||
(let ((inner-module (guile:current-module))
|
||
(outer-module #f))
|
||
(dynamic-wind (lambda ()
|
||
(set! outer-module (guile:current-module))
|
||
(set-current-module inner-module)
|
||
(set! inner-module #f))
|
||
thunk
|
||
(lambda ()
|
||
(set! inner-module (guile:current-module))
|
||
(set-current-module outer-module)
|
||
(set! outer-module #f)))))
|
||
|
||
(define (basic-load file-name reader)
|
||
(load file-name))
|
||
|
||
(define (load-module filename . reader)
|
||
(save-module-excursion
|
||
(lambda ()
|
||
(let ((oldname (and (current-load-port)
|
||
(port-filename (current-load-port)))))
|
||
(apply 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)
|
||
reader)))))
|
||
|
||
|
||
|
||
|
||
;;; {MODULE-REF -- exported}
|
||
;;;
|
||
|
||
;; Returns the value of a variable called NAME in MODULE or any of its
|
||
;; used modules. If there is no such variable, then if the optional third
|
||
;; argument DEFAULT is present, it is returned; otherwise an error is signaled.
|
||
;;
|
||
(define (module-ref module name . rest)
|
||
(let ((variable (module-variable module name)))
|
||
(if (and variable (variable-bound? variable))
|
||
(variable-ref variable)
|
||
(if (null? rest)
|
||
(begin
|
||
(when variable
|
||
(display "Variable's value is undefined: " (current-error-port))
|
||
(display name (current-error-port))
|
||
(display ": " (current-error-port))
|
||
(write variable (current-error-port))
|
||
(display "\n" (current-error-port)))
|
||
(error "No variable named" name 'in module))
|
||
(car rest) ; default value
|
||
))))
|
||
|
||
;; MODULE-SET! -- exported
|
||
;;
|
||
;; Sets the variable called NAME in MODULE (or in a module that MODULE uses)
|
||
;; to VALUE; if there is no such variable, an error is signaled.
|
||
;;
|
||
(define (module-set! module name value)
|
||
(let ((variable (module-variable module name)))
|
||
(if variable
|
||
(variable-set! variable value)
|
||
(error "No variable named" name 'in module))))
|
||
|
||
;; MODULE-DEFINE! -- exported
|
||
;;
|
||
;; Sets the variable called NAME in MODULE to VALUE; if there is no such
|
||
;; variable, it is added first.
|
||
;;
|
||
(define (module-define! module name value)
|
||
(let ((variable (module-local-variable module name)))
|
||
(if variable
|
||
(begin
|
||
(variable-set! variable value)
|
||
(module-modified module))
|
||
(let ((variable (make-variable value)))
|
||
(module-add! module name variable)))))
|
||
|
||
(define (module-define! module name value)
|
||
(if (hash-table? module) (let ((h (hashq-ref module name)))
|
||
(when (> %debug 2)
|
||
(format (current-error-port) "core:module-define! ~a\n" name))
|
||
(core:module-define! module name value))
|
||
(let ((variable (module-local-variable module name)))
|
||
(if variable
|
||
(begin
|
||
(variable-set! variable value)
|
||
(module-modified module))
|
||
(let ((variable (make-variable value)))
|
||
(module-add! module name variable))))))
|
||
|
||
;; MODULE-DEFINED? -- exported
|
||
;;
|
||
;; Return #t iff NAME is defined in MODULE (or in a module that MODULE
|
||
;; uses)
|
||
;;
|
||
(define (module-defined? module name)
|
||
(let ((variable (module-variable module name)))
|
||
(and variable (variable-bound? variable))))
|
||
|
||
;; MODULE-USE! module interface
|
||
;;
|
||
;; Add INTERFACE to the list of interfaces used by MODULE.
|
||
;;
|
||
(define (module-use! module interface)
|
||
(set-module-uses! module
|
||
(cons interface
|
||
(filter (lambda (m)
|
||
(not (equal? (module-name m)
|
||
(module-name interface))))
|
||
(module-uses module))))
|
||
(module-modified module))
|
||
|
||
;; MODULE-USE-INTERFACES! module interfaces
|
||
;;
|
||
;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
|
||
;;
|
||
(define (module-use-interfaces! module interfaces)
|
||
(let* ((duplicates-handlers? (or (module-duplicates-handlers module)
|
||
(default-duplicate-binding-procedures)))
|
||
(uses (module-uses module)))
|
||
;; remove duplicates-interface
|
||
(set! uses (delq! (module-duplicates-interface module) uses))
|
||
;; FIXME:
|
||
(set! uses (filter identity uses))
|
||
;; remove interfaces to be added
|
||
(for-each (lambda (interface)
|
||
(set! uses
|
||
(filter (lambda (m)
|
||
(not (equal? (module-name m)
|
||
(module-name interface))))
|
||
uses)))
|
||
interfaces)
|
||
;; add interfaces to use list
|
||
(set-module-uses! module uses)
|
||
;; FIXME:
|
||
;;(set! uses (filter identity uses))
|
||
(for-each (lambda (interface)
|
||
(and duplicates-handlers?
|
||
;; perform duplicate checking
|
||
(and #f 'FIXME (process-duplicates module interface)))
|
||
(set! uses (cons interface uses))
|
||
(set-module-uses! module uses))
|
||
interfaces)
|
||
;; add duplicates interface
|
||
(if (module-duplicates-interface module)
|
||
(set-module-uses! module
|
||
(cons (module-duplicates-interface module) uses)))
|
||
(module-modified module)))
|
||
|
||
|
||
|
||
;;; {Recursive Namespaces}
|
||
;;;
|
||
;;; A hierarchical namespace emerges if we consider some module to be
|
||
;;; root, and variables bound to modules as nested namespaces.
|
||
;;;
|
||
;;; The routines in this file manage variable names in hierarchical namespace.
|
||
;;; Each variable name is a list of elements, looked up in successively nested
|
||
;;; modules.
|
||
;;;
|
||
;;; (nested-ref some-root-module '(foo bar baz))
|
||
;;; => <value of a variable named baz in the module bound to bar in
|
||
;;; the module bound to foo in some-root-module>
|
||
;;;
|
||
;;;
|
||
;;; There are:
|
||
;;;
|
||
;;; ;; a-root is a module
|
||
;;; ;; name is a list of symbols
|
||
;;;
|
||
;;; nested-ref a-root name
|
||
;;; nested-set! a-root name val
|
||
;;; nested-define! a-root name val
|
||
;;; nested-remove! a-root name
|
||
;;;
|
||
;;;
|
||
;;; (guile:current-module) is a natural choice for a-root so for convenience there are
|
||
;;; also:
|
||
;;;
|
||
;;; local-ref name == nested-ref (guile:current-module) name
|
||
;;; local-set! name val == nested-set! (guile:current-module) name val
|
||
;;; local-define! name val == nested-define! (guile:current-module) name val
|
||
;;; local-remove! name == nested-remove! (guile:current-module) name
|
||
;;;
|
||
|
||
|
||
(define (nested-ref root names)
|
||
(let loop ((cur root)
|
||
(elts names))
|
||
(cond
|
||
((null? elts) cur)
|
||
((not (module? cur)) #f)
|
||
(else (loop (module-ref cur (car elts) #f) (cdr elts))))))
|
||
|
||
(define (nested-set! root names val)
|
||
(let loop ((cur root)
|
||
(elts names))
|
||
(if (null? (cdr elts))
|
||
(module-set! cur (car elts) val)
|
||
(loop (module-ref cur (car elts)) (cdr elts)))))
|
||
|
||
(define (nested-define! root names val)
|
||
(let loop ((cur root)
|
||
(elts names))
|
||
(if (null? (cdr elts))
|
||
(module-define! cur (car elts) val)
|
||
(loop (module-ref cur (car elts)) (cdr elts)))))
|
||
|
||
(define (nested-remove! root names)
|
||
(let loop ((cur root)
|
||
(elts names))
|
||
(if (null? (cdr elts))
|
||
(module-remove! cur (car elts))
|
||
(loop (module-ref cur (car elts)) (cdr elts)))))
|
||
|
||
(define (local-ref names) (nested-ref (guile:current-module) names))
|
||
(define (local-set! names val) (nested-set! (guile:current-module) names val))
|
||
(define (local-define names val) (nested-define! (guile:current-module) names val))
|
||
(define (local-remove names) (nested-remove! (guile:current-module) names))
|
||
|
||
|
||
|
||
|
||
;;; {The (%app) module}
|
||
;;;
|
||
;;; The root of conventionally named objects not directly in the top level.
|
||
;;;
|
||
;;; (%app modules)
|
||
;;; (%app modules guile)
|
||
;;;
|
||
;;; 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 (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 '(guile))
|
||
(set-module-name! the-scm-module '(guile))
|
||
(set-module-kind! the-scm-module 'interface)
|
||
(for-each set-system-module! (list the-root-module the-scm-module) '(#t #t))
|
||
|
||
;; 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))))
|
||
(else (let ((m (make-module 31)))
|
||
(set-module-kind! m 'directory)
|
||
(set-module-name! m (append (or (module-name module)
|
||
'())
|
||
(list (car name))))
|
||
(module-define! module (car name) m)
|
||
(make-modules-in m (cdr name)))))))
|
||
|
||
(define (beautify-user-module! module)
|
||
(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 (resolve-module name . maybe-autoload)
|
||
(let ((full-name (append '(%app modules) name)))
|
||
(let ((already (nested-ref the-root-module full-name)))
|
||
(if already
|
||
;; The module already exists...
|
||
(if (and (or (null? maybe-autoload) (car maybe-autoload))
|
||
(not (module-public-interface already)))
|
||
;; ...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 (guile:current-module) full-name))))))
|
||
|
||
;; Cheat. These bindings are needed by modules.c, but we don't want
|
||
;; to move their real definition here because that would be unnatural.
|
||
;;
|
||
(define try-module-autoload #f)
|
||
(define process-define-module #f)
|
||
(define process-use-modules #f)
|
||
(define module-export! #f)
|
||
|
||
;; This boots the module system. All bindings needed by modules.c
|
||
;; must have been defined by now.
|
||
;;
|
||
(set-current-module the-root-module)
|
||
|
||
(define %app (make-module 31))
|
||
(define app %app) ;; for backwards compatability
|
||
|
||
;; FIXME: MES
|
||
(module-add! the-root-module '%app (make-variable %app))
|
||
|
||
(local-define '(%app modules) (make-module 31))
|
||
(local-define '(%app modules guile) the-root-module)
|
||
|
||
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
|
||
|
||
(define (try-load-module name)
|
||
(or (begin-deprecated (try-module-linked name))
|
||
(try-module-autoload name)
|
||
(begin-deprecated (try-module-dynamic-link name))))
|
||
|
||
(define (purify-module! module)
|
||
"Removes bindings in MODULE which are inherited from the (guile) module."
|
||
(let ((use-list (module-uses module)))
|
||
(if (and (pair? use-list)
|
||
(eq? (car (last-pair use-list)) the-scm-module))
|
||
(set-module-uses! module (reverse (cdr (reverse use-list)))))))
|
||
|
||
;; Return a module that is an interface to the module designated by
|
||
;; NAME.
|
||
;;
|
||
;; `resolve-interface' takes four keyword arguments:
|
||
;;
|
||
;; #:select SELECTION
|
||
;;
|
||
;; SELECTION is a list of binding-specs to be imported; A binding-spec
|
||
;; is either a symbol or a pair of symbols (ORIG . SEEN), where ORIG
|
||
;; is the name in the used module and SEEN is the name in the using
|
||
;; module. Note that SEEN is also passed through RENAMER, below. The
|
||
;; default is to select all bindings. If you specify no selection but
|
||
;; a renamer, only the bindings that already exist in the used module
|
||
;; are made available in the interface. Bindings that are added later
|
||
;; are not picked up.
|
||
;;
|
||
;; #:hide BINDINGS
|
||
;;
|
||
;; BINDINGS is a list of bindings which should not be imported.
|
||
;;
|
||
;; #:prefix PREFIX
|
||
;;
|
||
;; PREFIX is a symbol that will be appended to each exported name.
|
||
;; The default is to not perform any renaming.
|
||
;;
|
||
;; #:renamer RENAMER
|
||
;;
|
||
;; RENAMER is a procedure that takes a symbol and returns its new
|
||
;; name. The default is not perform any renaming.
|
||
;;
|
||
;; Signal "no code for module" error if module name is not resolvable
|
||
;; or its public interface is not available. Signal "no binding"
|
||
;; error if selected binding does not exist in the used module.
|
||
;;
|
||
(define (resolve-interface name . args)
|
||
|
||
(define (get-keyword-arg args kw def)
|
||
(cond ((memq kw args)
|
||
=> (lambda (kw-arg)
|
||
(if (null? (cdr kw-arg))
|
||
(error "keyword without value: " kw))
|
||
(cadr kw-arg)))
|
||
(else
|
||
def)))
|
||
|
||
(let* ((select (get-keyword-arg args #:select #f))
|
||
(hide (get-keyword-arg args #:hide '()))
|
||
(renamer (or (get-keyword-arg args #:renamer #f)
|
||
(let ((prefix (get-keyword-arg args #:prefix #f)))
|
||
(and prefix (symbol-prefix-proc prefix)))
|
||
identity))
|
||
(module (resolve-module name))
|
||
(public-i (and module (module-public-interface module))))
|
||
(and (not module)
|
||
(error "no such module" name))
|
||
(and (not public-i)
|
||
(error "module has no public-i" name))
|
||
(and (or (not module) (not public-i))
|
||
(error "no code for module" name))
|
||
(if (and (not select) (null? hide) (eq? renamer identity))
|
||
public-i
|
||
(let ((selection (or select (module-map (lambda (sym var) sym)
|
||
public-i)))
|
||
(custom-i (make-module 31)))
|
||
(set-module-kind! custom-i 'custom-interface)
|
||
(set-module-name! custom-i name)
|
||
;; XXX - should use a lazy binder so that changes to the
|
||
;; used module are picked up automatically.
|
||
(for-each (lambda (bspec)
|
||
(let* ((direct? (symbol? bspec))
|
||
(orig (if direct? bspec (car bspec)))
|
||
(seen (if direct? bspec (cdr bspec)))
|
||
(var (or (module-local-variable public-i orig)
|
||
(module-local-variable module orig)
|
||
(error
|
||
;; fixme: format manually for now
|
||
(simple-format
|
||
#f "no binding `~A' in module ~A"
|
||
orig name)))))
|
||
(if (memq orig hide)
|
||
(set! hide (delq! orig hide))
|
||
(module-add! custom-i
|
||
(renamer seen)
|
||
var))))
|
||
selection)
|
||
;; Check that we are not hiding bindings which don't exist
|
||
(for-each (lambda (binding)
|
||
(if (not (module-local-variable public-i binding))
|
||
(error
|
||
(simple-format
|
||
#f "no binding `~A' to hide in module ~A"
|
||
binding name))))
|
||
hide)
|
||
custom-i))))
|
||
|
||
(define (symbol-prefix-proc prefix)
|
||
(lambda (symbol)
|
||
(symbol-append prefix symbol)))
|
||
|
||
;; This function is called from "modules.c". If you change it, be
|
||
;; sure to update "modules.c" as well.
|
||
|
||
(define (process-define-module args)
|
||
(let* ((module-id (car args))
|
||
(module (resolve-module module-id #f))
|
||
(kws (cdr args))
|
||
(unrecognized (lambda (arg)
|
||
(error "unrecognized define-module argument" arg))))
|
||
(beautify-user-module! module)
|
||
(let loop ((kws kws)
|
||
(reversed-interfaces '())
|
||
(exports '())
|
||
(re-exports '())
|
||
(replacements '()))
|
||
(if (null? kws)
|
||
(call-with-deferred-observers
|
||
(lambda ()
|
||
(module-use-interfaces! module (reverse reversed-interfaces))
|
||
(module-export! module exports)
|
||
(module-replace! module replacements)
|
||
(module-re-export! module re-exports)))
|
||
(begin
|
||
(case (car kws)
|
||
((#:use-module #:use-syntax)
|
||
(or (pair? (cdr kws))
|
||
(unrecognized kws))
|
||
(let* ((interface-args (cadr kws))
|
||
(interface (apply resolve-interface interface-args)))
|
||
(and (eq? (car kws) #:use-syntax)
|
||
(or (symbol? (caar interface-args))
|
||
(error "invalid module name for use-syntax"
|
||
(car interface-args)))
|
||
(set-module-transformer!
|
||
module
|
||
(module-ref interface
|
||
(car (last-pair (car interface-args)))
|
||
#f)))
|
||
(loop (cddr kws)
|
||
(cons interface reversed-interfaces)
|
||
exports
|
||
re-exports
|
||
replacements)))
|
||
((#:autoload)
|
||
(or (and (pair? (cdr kws)) (pair? (cddr kws)))
|
||
(unrecognized kws))
|
||
(loop (cdddr kws)
|
||
(cons (make-autoload-interface module
|
||
(cadr kws)
|
||
(caddr kws))
|
||
reversed-interfaces)
|
||
exports
|
||
re-exports
|
||
replacements))
|
||
((#:no-backtrace)
|
||
(set-system-module! module #t)
|
||
(loop (cdr kws) reversed-interfaces exports re-exports replacements))
|
||
((#:pure)
|
||
(purify-module! module)
|
||
(loop (cdr kws) reversed-interfaces exports re-exports replacements))
|
||
((#:duplicates)
|
||
(if (not (pair? (cdr kws)))
|
||
(unrecognized kws))
|
||
(set-module-duplicates-handlers!
|
||
module
|
||
(lookup-duplicates-handlers (cadr kws)))
|
||
(loop (cddr kws) reversed-interfaces exports re-exports replacements))
|
||
((#:export #:export-syntax)
|
||
(or (pair? (cdr kws))
|
||
(unrecognized kws))
|
||
(loop (cddr kws)
|
||
reversed-interfaces
|
||
(append (cadr kws) exports)
|
||
re-exports
|
||
replacements))
|
||
((#:re-export #:re-export-syntax)
|
||
(or (pair? (cdr kws))
|
||
(unrecognized kws))
|
||
(loop (cddr kws)
|
||
reversed-interfaces
|
||
exports
|
||
(append (cadr kws) re-exports)
|
||
replacements))
|
||
((#:replace #:replace-syntax)
|
||
(or (pair? (cdr kws))
|
||
(unrecognized kws))
|
||
(loop (cddr kws)
|
||
reversed-interfaces
|
||
exports
|
||
re-exports
|
||
(append (cadr kws) replacements)))
|
||
(else
|
||
(unrecognized kws))))))
|
||
(run-hook module-defined-hook module)
|
||
module))
|
||
|
||
;; `module-defined-hook' is a hook that is run whenever a new module
|
||
;; is defined. Its members are called with one argument, the new
|
||
;; module.
|
||
(define module-defined-hook (make-hook 1))
|
||
|
||
|
||
|
||
;;; {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))
|
||
(let ((autoload (memq a (module-uses module))))
|
||
;; Replace autoload-interface with actual interface if
|
||
;; that has not happened yet.
|
||
(if (pair? autoload)
|
||
(set-car! autoload i)))
|
||
(module-local-variable i sym))))))
|
||
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f #f
|
||
'() (make-weak-value-hash-table 31) 0)))
|
||
|
||
;;; {Compiled module}
|
||
|
||
(define load-compiled #f)
|
||
|
||
|
||
|
||
;;; {Autoloading modules}
|
||
;;;
|
||
|
||
(define autoloads-in-progress '())
|
||
|
||
;; This function is called from "modules.c". If you change it, be
|
||
;; sure to update "modules.c" as well.
|
||
|
||
(define (try-module-autoload module-name)
|
||
(let* ((reverse-name (reverse module-name))
|
||
(name (symbol->string (car reverse-name)))
|
||
(dir-hint-module-name (reverse (cdr reverse-name)))
|
||
(dir-hint (apply string-append
|
||
(map (lambda (elt)
|
||
(string-append (symbol->string elt) "/"))
|
||
dir-hint-module-name))))
|
||
(resolve-module dir-hint-module-name #f)
|
||
(and (not (autoload-done-or-in-progress? dir-hint name))
|
||
(let ((didit #f))
|
||
;; FIXME: *undefined* here is a terrible hack; it switches
|
||
;; toplevel for defines.
|
||
(define (load-file *undefined* file)
|
||
(save-module-excursion (lambda () (primitive-load file)))
|
||
(set! didit #t))
|
||
(dynamic-wind
|
||
(lambda () (autoload-in-progress! dir-hint name))
|
||
(lambda ()
|
||
(let ((file (in-vicinity dir-hint name)))
|
||
(cond ((and load-compiled
|
||
(%search-load-path (string-append file ".go")))
|
||
=> (lambda (full)
|
||
(load-file load-compiled full)))
|
||
((%search-load-path file)
|
||
=> (lambda (full)
|
||
(with-fluids ((current-reader #f))
|
||
(load-file 'primitive-load full)))))))
|
||
(lambda () (set-autoloaded! dir-hint name didit)))
|
||
didit))))
|
||
|
||
|
||
|
||
;;; {Dynamic linking of modules}
|
||
;;;
|
||
|
||
(define autoloads-done '((guile . guile)))
|
||
|
||
(define (autoload-done-or-in-progress? p m)
|
||
(let ((n (cons p m)))
|
||
(->bool (or (member n autoloads-done)
|
||
(member n autoloads-in-progress)))))
|
||
|
||
(define (autoload-done! p m)
|
||
(let ((n (cons p m)))
|
||
(set! autoloads-in-progress
|
||
(delete! n autoloads-in-progress))
|
||
(or (member n autoloads-done)
|
||
(set! autoloads-done (cons n autoloads-done)))))
|
||
|
||
(define (autoload-in-progress! p m)
|
||
(let ((n (cons p m)))
|
||
(set! autoloads-done
|
||
(delete! n autoloads-done))
|
||
(set! autoloads-in-progress (cons n autoloads-in-progress))))
|
||
|
||
(define (set-autoloaded! p m done?)
|
||
(if done?
|
||
(autoload-done! p m)
|
||
(let ((n (cons p m)))
|
||
(set! autoloads-done (delete! n autoloads-done))
|
||
(set! autoloads-in-progress (delete! n autoloads-in-progress)))))
|
||
|
||
|
||
|
||
;;; {Running Repls}
|
||
;;;
|
||
|
||
(define (repl read evaler print)
|
||
(let loop ((source (read (current-input-port))))
|
||
(print (evaler source))
|
||
(loop (read (current-input-port)))))
|
||
|
||
;; A provisional repl that acts like the SCM repl:
|
||
;;
|
||
(define scm-repl-silent #f)
|
||
(define (assert-repl-silence v) (set! scm-repl-silent v))
|
||
|
||
(define *unspecified* (if #f #f))
|
||
(define (unspecified? v) (eq? v *unspecified*))
|
||
|
||
(define scm-repl-print-unspecified #f)
|
||
(define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v))
|
||
|
||
(define scm-repl-verbose #f)
|
||
(define (assert-repl-verbosity v) (set! scm-repl-verbose v))
|
||
|
||
(define scm-repl-prompt "guile> ")
|
||
|
||
(define (set-repl-prompt! v) (set! scm-repl-prompt v))
|
||
|
||
(define (default-lazy-handler key . args)
|
||
(save-stack lazy-handler-dispatch)
|
||
(apply throw key args))
|
||
|
||
(define (lazy-handler-dispatch key . args)
|
||
(apply default-lazy-handler key args))
|
||
|
||
(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)
|
||
(interactive #t))
|
||
(define (loop first)
|
||
(let ((next
|
||
(catch #t
|
||
|
||
(lambda ()
|
||
(call-with-unblocked-asyncs
|
||
(lambda ()
|
||
(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)))))
|
||
|
||
(lambda (key . args)
|
||
(case key
|
||
((quit)
|
||
(set! status args)
|
||
#f)
|
||
|
||
((switch-repl)
|
||
(apply throw 'switch-repl args))
|
||
|
||
((abort)
|
||
;; This is one of the closures that require
|
||
;; (set! first #f) above
|
||
;;
|
||
(lambda ()
|
||
(run-hook abort-hook)
|
||
(force-output (current-output-port))
|
||
(display "ABORT: " (current-error-port))
|
||
(write args (current-error-port))
|
||
(newline (current-error-port))
|
||
(if interactive
|
||
(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 or \"(debug)\" to enter the debugger.\n"
|
||
(current-error-port))
|
||
(set! has-shown-debugger-hint? #t)))
|
||
(force-output (current-error-port)))
|
||
(begin
|
||
(primitive-exit 1)))
|
||
(set! stack-saved? #f)))
|
||
|
||
(else
|
||
;; This is the other cons-leak closure...
|
||
(lambda ()
|
||
(cond ((= (length args) 4)
|
||
(apply handle-system-error key args))
|
||
(else
|
||
(apply bad-throw key args)))))))
|
||
|
||
;; Note that having just `lazy-handler-dispatch'
|
||
;; here is connected with the mechanism that
|
||
;; produces a nice backtrace upon error. If, for
|
||
;; example, this is replaced with (lambda args
|
||
;; (apply lazy-handler-dispatch args)), the stack
|
||
;; cutting (in save-stack) goes wrong and ends up
|
||
;; saving no stack at all, so there is no
|
||
;; backtrace.
|
||
lazy-handler-dispatch)))
|
||
|
||
(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)))
|
||
(call-with-blocked-asyncs
|
||
(lambda () (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)
|
||
(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 primitive-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? (fluid-ref the-last-stack))))
|
||
((memq 'backtrace (debug-options-interface))
|
||
(let ((highlights (if (or (eq? key 'wrong-type-arg)
|
||
(eq? key 'out-of-range))
|
||
(list-ref args 3)
|
||
'())))
|
||
(run-hook before-backtrace-hook)
|
||
(newline cep)
|
||
(display "Backtrace:\n")
|
||
(display-backtrace (fluid-ref the-last-stack) cep
|
||
#f #f highlights)
|
||
(newline cep)
|
||
(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)))
|
||
|
||
(define core:exit exit)
|
||
(define (quit . args)
|
||
(apply throw 'quit args))
|
||
|
||
;; FIXME: how does Guile exit 0?
|
||
;; this gives
|
||
;; unhandled exception: error: (("option must be specified with argument:" "main"))
|
||
;;(define exit quit)
|
||
|
||
;;(define has-shown-backtrace-hint? #f) Defined by scm_init_backtrace ()
|
||
|
||
;; Replaced by C code:
|
||
;;(define (backtrace)
|
||
;; (if (fluid-ref the-last-stack)
|
||
;; (begin
|
||
;; (newline)
|
||
;; (display-backtrace (fluid-ref the-last-stack) (current-output-port))
|
||
;; (newline)
|
||
;; (if (and (not has-shown-backtrace-hint?)
|
||
;; (not (memq 'backtrace (debug-options-interface))))
|
||
;; (begin
|
||
;; (display
|
||
;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace
|
||
;;automatically if an error occurs in the future.\n")
|
||
;; (set! has-shown-backtrace-hint? #t))))
|
||
;; (display "No backtrace available.\n")))
|
||
|
||
(define (error-catching-repl r e p)
|
||
(error-catching-loop
|
||
(lambda ()
|
||
(call-with-values (lambda () (e (r)))
|
||
(lambda the-values (for-each p the-values))))))
|
||
|
||
(define (gc-run-time)
|
||
(cdr (assq 'gc-time-taken (gc-stats))))
|
||
|
||
(define before-read-hook (make-hook))
|
||
(define after-read-hook (make-hook))
|
||
(define before-eval-hook (make-hook 1))
|
||
(define after-eval-hook (make-hook 1))
|
||
(define before-print-hook (make-hook 1))
|
||
(define after-print-hook (make-hook 1))
|
||
|
||
;;; 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)
|
||
((or (fluid-ref current-reader) read) (current-input-port))))
|
||
|
||
(define (scm-style-repl)
|
||
|
||
(letrec (
|
||
(start-gc-rt #f)
|
||
(start-rt #f)
|
||
(repl-report-start-timing (lambda ()
|
||
(set! start-gc-rt (gc-run-time))
|
||
(set! start-rt (get-internal-run-time))))
|
||
(repl-report (lambda ()
|
||
(display ";;; ")
|
||
(display (inexact->exact
|
||
(* 1000 (/ (- (get-internal-run-time) start-rt)
|
||
internal-time-units-per-second))))
|
||
(display " msec (")
|
||
(display (inexact->exact
|
||
(* 1000 (/ (- (gc-run-time) start-gc-rt)
|
||
internal-time-units-per-second))))
|
||
(display " msec in gc)\n")))
|
||
|
||
(consume-trailing-whitespace
|
||
(lambda ()
|
||
(let ((ch (peek-char)))
|
||
(cond
|
||
((eof-object? ch))
|
||
((or (char=? ch #\space) (char=? ch #\tab))
|
||
(read-char)
|
||
(consume-trailing-whitespace))
|
||
((char=? ch #\newline)
|
||
(read-char))))))
|
||
(-read (lambda ()
|
||
(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 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
|
||
;; debugging Guile with GDB, GDB gets the newline, which
|
||
;; it often interprets as a "continue" command, making
|
||
;; breakpoints kind of useless. So, consume any
|
||
;; trailing newline here, as well as any whitespace
|
||
;; before it.
|
||
;; 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)
|
||
(if scm-repl-verbose
|
||
(begin
|
||
(newline)
|
||
(display ";;; EOF -- quitting")
|
||
(newline)))
|
||
(quit 0)))
|
||
val)))
|
||
|
||
(-eval (lambda (sourc)
|
||
(repl-report-start-timing)
|
||
(run-hook before-eval-hook sourc)
|
||
(let ((val (start-stack 'repl-stack
|
||
;; If you change this procedure
|
||
;; (primitive-eval), please also
|
||
;; modify the repl-stack case in
|
||
;; save-stack so that stack cutting
|
||
;; continues to work.
|
||
(primitive-eval sourc))))
|
||
(run-hook after-eval-hook sourc)
|
||
val)))
|
||
|
||
|
||
(-print (let ((maybe-print (lambda (result)
|
||
(if (or scm-repl-print-unspecified
|
||
(not (unspecified? result)))
|
||
(begin
|
||
(write result)
|
||
(newline))))))
|
||
(lambda (result)
|
||
(if (not scm-repl-silent)
|
||
(begin
|
||
(run-hook before-print-hook result)
|
||
(maybe-print result)
|
||
(run-hook after-print-hook result)
|
||
(if scm-repl-verbose
|
||
(repl-report))
|
||
(force-output))))))
|
||
|
||
(-quit (lambda (args)
|
||
(if scm-repl-verbose
|
||
(begin
|
||
(display ";;; QUIT executed, repl exitting")
|
||
(newline)
|
||
(repl-report)))
|
||
args))
|
||
|
||
(-abort (lambda ()
|
||
(if scm-repl-verbose
|
||
(begin
|
||
(display ";;; ABORT executed.")
|
||
(newline)
|
||
(repl-report)))
|
||
(repl -read -eval -print))))
|
||
|
||
(let ((status (error-catching-repl -read
|
||
-eval
|
||
-print)))
|
||
(-quit status))))
|
||
|
||
|
||
|
||
|
||
;;; {IOTA functions: generating lists of numbers}
|
||
;;;
|
||
|
||
(define (iota n)
|
||
(let loop ((count (1- n)) (result '()))
|
||
(if (< count 0) result
|
||
(loop (1- count) (cons count result)))))
|
||
|
||
|
||
|
||
;;; {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))
|
||
|
||
|
||
|
||
;;; {Module System Macros}
|
||
;;;
|
||
|
||
;; Return a list of expressions that evaluate to the appropriate
|
||
;; arguments for resolve-interface according to SPEC.
|
||
|
||
(define (compile-interface-spec spec)
|
||
(define (make-keyarg sym key quote?)
|
||
(cond ((or (memq sym spec)
|
||
(memq key spec))
|
||
=> (lambda (rest)
|
||
(if quote?
|
||
(list key (list 'quote (cadr rest)))
|
||
(list key (cadr rest)))))
|
||
(else
|
||
'())))
|
||
(define (map-apply func list)
|
||
(map (lambda (args) (apply func args)) list))
|
||
(define keys
|
||
;; sym key quote?
|
||
'((:select #:select #t)
|
||
(:hide #:hide #t)
|
||
(:prefix #:prefix #t)
|
||
(:renamer #:renamer #f)))
|
||
(if (not (pair? (car spec)))
|
||
`(',spec)
|
||
`(',(car spec)
|
||
,@(apply append (map-apply make-keyarg keys)))))
|
||
|
||
(define (keyword-like-symbol->keyword sym)
|
||
(symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
|
||
|
||
(define (compile-define-module-args args)
|
||
;; Just quote everything except #:use-module and #:use-syntax. We
|
||
;; need to know about all arguments regardless since we want to turn
|
||
;; symbols that look like keywords into real keywords, and the
|
||
;; keyword args in a define-module form are not regular
|
||
;; (i.e. no-backtrace doesn't take a value).
|
||
(let loop ((compiled-args `((quote ,(car args))))
|
||
(args (cdr args)))
|
||
(cond ((null? args)
|
||
(reverse! compiled-args))
|
||
;; symbol in keyword position
|
||
((symbol? (car args))
|
||
(loop compiled-args
|
||
(cons (keyword-like-symbol->keyword (car args)) (cdr args))))
|
||
((memq (car args) '(#:no-backtrace #:pure))
|
||
(loop (cons (car args) compiled-args)
|
||
(cdr args)))
|
||
((null? (cdr args))
|
||
(error "keyword without value:" (car args)))
|
||
((memq (car args) '(#:use-module #:use-syntax))
|
||
(loop (cons* `(list ,@(compile-interface-spec (cadr args)))
|
||
(car args)
|
||
compiled-args)
|
||
(cddr args)))
|
||
((eq? (car args) #:autoload)
|
||
(loop (cons* `(quote ,(caddr args))
|
||
`(quote ,(cadr args))
|
||
(car args)
|
||
compiled-args)
|
||
(cdddr args)))
|
||
(else
|
||
(loop (cons* `(quote ,(cadr args))
|
||
(car args)
|
||
compiled-args)
|
||
(cddr args))))))
|
||
|
||
;; (define-macro (define-module . args)
|
||
;; `(eval-case
|
||
;; ((load-toplevel)
|
||
;; (let ((m (process-define-module
|
||
;; (list ,@(compile-define-module-args args)))))
|
||
;; (when (> %debug 3)
|
||
;; (format (current-error-port) "define-module: name=~s\n" m))
|
||
;; (set-current-module m)
|
||
;; ;; XXX For Mes -- how/where does Guile define this 'module-procedure?
|
||
;; ,(let ((module (and (pair? args) (car args))))
|
||
;; `(when ,(and (pair? module)
|
||
;; (= 1 (length module))
|
||
;; (symbol? (car module)))
|
||
;; (define (,(car module) . arguments) (main (command-line)))))
|
||
;; m))
|
||
;; (else
|
||
;; (error "define-module can only be used at the top level"))))
|
||
|
||
(define-macro (define-module . args)
|
||
`(let ((m (process-define-module
|
||
(list ,@(compile-define-module-args args)))))
|
||
(when (> %debug 3)
|
||
(format (current-error-port) "define-module: name=~s\n" m))
|
||
(set-current-module m)
|
||
;; XXX For Mes -- how/where does Guile define this 'module-procedure?
|
||
,(let ((module (and (pair? args) (car args))))
|
||
`(when ,(and (pair? module)
|
||
(= 1 (length module))
|
||
(symbol? (car module)))
|
||
(define (,(car module) . arguments) (main (command-line)))))
|
||
m))
|
||
|
||
;; The guts of the use-modules macro. Add the interfaces of the named
|
||
;; modules to the use-list of the current module, in order.
|
||
|
||
;; This function is called by "modules.c". If you change it, be sure
|
||
;; to change scm_c_use_module as well.
|
||
|
||
(define (process-use-modules module-interface-args)
|
||
(let ((interfaces (map (lambda (mif-args)
|
||
(or (apply resolve-interface mif-args)
|
||
(error "no such module" mif-args)))
|
||
module-interface-args)))
|
||
(call-with-deferred-observers
|
||
(lambda ()
|
||
(module-use-interfaces! (guile:current-module) interfaces)))))
|
||
|
||
;; (defmacro use-modules modules
|
||
;; `(eval-case
|
||
;; ((load-toplevel)
|
||
;; (process-use-modules
|
||
;; (list ,@(map (lambda (m)
|
||
;; `(list ,@(compile-interface-spec m)))
|
||
;; modules)))
|
||
;; *unspecified*)
|
||
;; (else
|
||
;; (error "use-modules can only be used at the top level"))))
|
||
|
||
(define-macro (use-modules modules)
|
||
`(process-use-modules
|
||
(list ,@(map (lambda (m)
|
||
`(list ,@(compile-interface-spec m)))
|
||
modules))))
|
||
|
||
;; (defmacro use-syntax (spec)
|
||
;; `(eval-case
|
||
;; ((load-toplevel)
|
||
;; ,@(if (pair? spec)
|
||
;; `((process-use-modules (list
|
||
;; (list ,@(compile-interface-spec spec))))
|
||
;; (set-module-transformer! (guile:current-module)
|
||
;; ,(car (last-pair spec))))
|
||
;; `((set-module-transformer! (guile:current-module) ,spec)))
|
||
;; *unspecified*)
|
||
;; (else
|
||
;; (error "use-syntax can only be used at the top level"))))
|
||
|
||
;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed
|
||
;; as soon as guile supports hygienic macros.
|
||
;;;;;;(define define-private define)
|
||
|
||
;; (defmacro define-public args
|
||
;; (define (syntax)
|
||
;; (error "bad syntax" (list 'define-public args)))
|
||
;; (define (defined-name n)
|
||
;; (cond
|
||
;; ((symbol? n) n)
|
||
;; ((pair? n) (defined-name (car n)))
|
||
;; (else (syntax))))
|
||
;; (cond
|
||
;; ((null? args)
|
||
;; (syntax))
|
||
;; (#t
|
||
;; (let ((name (defined-name (car args))))
|
||
;; `(begin
|
||
;; (define-private ,@args)
|
||
;; (eval-case ((load-toplevel) (export ,name))))))))
|
||
|
||
;; (defmacro defmacro-public args
|
||
;; (define (syntax)
|
||
;; (error "bad syntax" (list 'defmacro-public args)))
|
||
;; (define (defined-name n)
|
||
;; (cond
|
||
;; ((symbol? n) n)
|
||
;; (else (syntax))))
|
||
;; (cond
|
||
;; ((null? args)
|
||
;; (syntax))
|
||
;; (#t
|
||
;; (let ((name (defined-name (car args))))
|
||
;; `(begin
|
||
;; (eval-case ((load-toplevel) (export-syntax ,name)))
|
||
;; (defmacro ,@args))))))
|
||
|
||
(define-macro (define-public . args)
|
||
(define (syntax)
|
||
(error "bad syntax" (list 'define-public args)))
|
||
(define (defined-name n)
|
||
(define (syntax)
|
||
(error "bad syntax" (list 'define-public args)))
|
||
(cond
|
||
((symbol? n) n)
|
||
((pair? n) (defined-name (car n)))
|
||
(else (syntax))))
|
||
(cond
|
||
((null? args)
|
||
(syntax))
|
||
(#t
|
||
;;`(export ,(defined-name (car args)))
|
||
(module-export! (guile:current-module) (list (defined-name (car args))))
|
||
`(define ,@args))))
|
||
|
||
;; Export a local variable
|
||
|
||
;; This function is called from "modules.c". If you change it, be
|
||
;; sure to update "modules.c" as well.
|
||
|
||
(define (module-export! m names)
|
||
(let ((public-i (module-public-interface m)))
|
||
(for-each (lambda (name)
|
||
(let ((var (module-ensure-local-variable! m name)))
|
||
(module-add! public-i name var)))
|
||
names)))
|
||
|
||
(define (module-replace! m names)
|
||
(let ((public-i (module-public-interface m)))
|
||
(for-each (lambda (name)
|
||
(let ((var (module-ensure-local-variable! m name)))
|
||
(set-object-property! var 'replace #t)
|
||
(module-add! public-i name var)))
|
||
names)))
|
||
|
||
;; Re-export a imported variable
|
||
;;
|
||
(define (module-re-export! m names)
|
||
(let ((public-i (module-public-interface m)))
|
||
(for-each (lambda (name)
|
||
(let ((var (module-variable m name)))
|
||
(cond ((not var)
|
||
(error "Undefined variable:" name))
|
||
((eq? var (module-local-variable m name))
|
||
(error "re-exporting local variable:" name))
|
||
(else
|
||
(module-add! public-i name var)))))
|
||
names)))
|
||
|
||
;; (defmacro export names
|
||
;; `(eval-case
|
||
;; ((load-toplevel)
|
||
;; (call-with-deferred-observers
|
||
;; (lambda ()
|
||
;; (module-export! (guile:current-module) ',names))))
|
||
;; (else
|
||
;; (error "export can only be used at the top level"))))
|
||
|
||
(define-macro (export . names)
|
||
`(module-export! (guile:current-module) ',names))
|
||
|
||
;; (defmacro re-export names
|
||
;; `(eval-case
|
||
;; ((load-toplevel)
|
||
;; (call-with-deferred-observers
|
||
;; (lambda ()
|
||
;; (module-re-export! (guile:current-module) ',names))))
|
||
;; (else
|
||
;; (error "re-export can only be used at the top level"))))
|
||
|
||
(define-macro (re-export . names)
|
||
`(module-re-export! (guile:current-module) ',names))
|
||
|
||
;; (defmacro export-syntax names
|
||
;; `(export ,@names))
|
||
|
||
;; (defmacro re-export-syntax names
|
||
;; `(re-export ,@names))
|
||
|
||
(define load load-module)
|
||
|
||
;; The following macro allows one to write, for example,
|
||
;;
|
||
;; (@ (ice-9 pretty-print) pretty-print)
|
||
;;
|
||
;; to refer directly to the pretty-print variable in module (ice-9
|
||
;; pretty-print). It works by looking up the variable and inserting
|
||
;; it directly into the code. This is understood by the evaluator.
|
||
;; Indeed, all references to global variables are memoized into such
|
||
;; variable objects.
|
||
|
||
(define-macro (@ mod-name var-name)
|
||
(let ((var (module-variable (resolve-interface mod-name) var-name)))
|
||
(if (not var)
|
||
(error "no such public variable" (list '@ mod-name var-name)))
|
||
var))
|
||
|
||
;; The '@@' macro is like '@' but it can also access bindings that
|
||
;; have not been explicitely exported.
|
||
|
||
(define-macro (@@ mod-name var-name)
|
||
(let ((var (module-variable (resolve-module mod-name) var-name)))
|
||
(if (not var)
|
||
(error "no such variable" (list '@@ mod-name var-name)))
|
||
var))
|
||
|
||
|
||
|
||
;;; {Parameters}
|
||
;;;
|
||
|
||
(define make-mutable-parameter
|
||
(let ((make (lambda (fluid converter)
|
||
(lambda args
|
||
(if (null? args)
|
||
(fluid-ref fluid)
|
||
(fluid-set! fluid (converter (car args))))))))
|
||
(lambda (init . converter)
|
||
(let ((fluid (make-fluid))
|
||
(converter (if (null? converter)
|
||
identity
|
||
(car converter))))
|
||
(fluid-set! fluid (converter init))
|
||
(make fluid converter)))))
|
||
|
||
|
||
|
||
;;; {Handling of duplicate imported bindings}
|
||
;;;
|
||
|
||
;; Duplicate handlers take the following arguments:
|
||
;;
|
||
;; module importing module
|
||
;; name conflicting name
|
||
;; int1 old interface where name occurs
|
||
;; val1 value of binding in old interface
|
||
;; int2 new interface where name occurs
|
||
;; val2 value of binding in new interface
|
||
;; var previous resolution or #f
|
||
;; val value of previous resolution
|
||
;;
|
||
;; A duplicate handler can take three alternative actions:
|
||
;;
|
||
;; 1. return #f => leave responsibility to next handler
|
||
;; 2. exit with an error
|
||
;; 3. return a variable resolving the conflict
|
||
;;
|
||
|
||
(define duplicate-handlers
|
||
(let ((m (make-module 7)))
|
||
|
||
(define (check module name int1 val1 int2 val2 var val)
|
||
(scm-error 'misc-error
|
||
#f
|
||
"~A: `~A' imported from both ~A and ~A"
|
||
(list (module-name module)
|
||
name
|
||
(module-name int1)
|
||
(module-name int2))
|
||
#f))
|
||
|
||
(define (warn module name int1 val1 int2 val2 var val)
|
||
(format (current-error-port)
|
||
"WARNING: ~A: `~A' imported from both ~A and ~A\n"
|
||
(module-name module)
|
||
name
|
||
(module-name int1)
|
||
(module-name int2))
|
||
#f)
|
||
|
||
(define (replace module name int1 val1 int2 val2 var val)
|
||
(let ((old (or (and var (object-property var 'replace) var)
|
||
(module-variable int1 name)))
|
||
(new (module-variable int2 name)))
|
||
(if (object-property old 'replace)
|
||
(and (or (eq? old new)
|
||
(not (object-property new 'replace)))
|
||
old)
|
||
(and (object-property new 'replace)
|
||
new))))
|
||
|
||
(define (warn-override-core module name int1 val1 int2 val2 var val)
|
||
(and (eq? int1 the-scm-module)
|
||
(begin
|
||
(format (current-error-port)
|
||
"WARNING: ~A: imported module ~A overrides core binding `~A'\n"
|
||
(module-name module)
|
||
(module-name int2)
|
||
name)
|
||
(module-local-variable int2 name))))
|
||
|
||
(define (first module name int1 val1 int2 val2 var val)
|
||
(or var (module-local-variable int1 name)))
|
||
|
||
(define (last module name int1 val1 int2 val2 var val)
|
||
(module-local-variable int2 name))
|
||
|
||
(define (noop module name int1 val1 int2 val2 var val)
|
||
#f)
|
||
|
||
(set-module-name! m 'duplicate-handlers)
|
||
(set-module-kind! m 'interface)
|
||
(module-define! m 'check check)
|
||
(module-define! m 'warn warn)
|
||
(module-define! m 'replace replace)
|
||
(module-define! m 'warn-override-core warn-override-core)
|
||
(module-define! m 'first first)
|
||
(module-define! m 'last last)
|
||
(module-define! m 'merge-generics noop)
|
||
(module-define! m 'merge-accessors noop)
|
||
m))
|
||
|
||
(define (lookup-duplicates-handlers handler-names)
|
||
(and handler-names
|
||
(map (lambda (handler-name)
|
||
(or (module-symbol-local-binding
|
||
duplicate-handlers handler-name #f)
|
||
(error "invalid duplicate handler name:"
|
||
handler-name)))
|
||
(if (list? handler-names)
|
||
handler-names
|
||
(list handler-names)))))
|
||
|
||
(define default-duplicate-binding-procedures
|
||
(make-mutable-parameter #f))
|
||
|
||
(define default-duplicate-binding-handler
|
||
(make-mutable-parameter '(replace warn-override-core warn last)
|
||
(lambda (handler-names)
|
||
(default-duplicate-binding-procedures
|
||
(lookup-duplicates-handlers handler-names))
|
||
handler-names)))
|
||
|
||
(define (make-duplicates-interface)
|
||
(let ((m (make-module)))
|
||
(set-module-kind! m 'custom-interface)
|
||
(set-module-name! m 'duplicates)
|
||
m))
|
||
|
||
(define (process-duplicates module interface)
|
||
(let* ((duplicates-handlers (or (module-duplicates-handlers module)
|
||
(default-duplicate-binding-procedures)))
|
||
(duplicates-interface (module-duplicates-interface module)))
|
||
(module-for-each
|
||
(lambda (name var)
|
||
(cond ((module-import-interface module name)
|
||
=>
|
||
(lambda (prev-interface)
|
||
(let ((var1 (module-local-variable prev-interface name))
|
||
(var2 (module-local-variable interface name)))
|
||
(if (not (eq? var1 var2))
|
||
(begin
|
||
(if (not duplicates-interface)
|
||
(begin
|
||
(set! duplicates-interface
|
||
(make-duplicates-interface))
|
||
(set-module-duplicates-interface!
|
||
module
|
||
duplicates-interface)))
|
||
(let* ((var (module-local-variable duplicates-interface
|
||
name))
|
||
(val (and var
|
||
(variable-bound? var)
|
||
(variable-ref var))))
|
||
(let loop ((duplicates-handlers duplicates-handlers))
|
||
(cond ((null? duplicates-handlers))
|
||
(((car duplicates-handlers)
|
||
module
|
||
name
|
||
prev-interface
|
||
(and (variable-bound? var1)
|
||
(variable-ref var1))
|
||
interface
|
||
(and (variable-bound? var2)
|
||
(variable-ref var2))
|
||
var
|
||
val)
|
||
=>
|
||
(lambda (var)
|
||
(module-add! duplicates-interface name var)))
|
||
(else
|
||
(loop (cdr duplicates-handlers)))))))))))))
|
||
interface)))
|
||
|
||
|
||
|
||
;;; {`cond-expand' for SRFI-0 support.}
|
||
;;;
|
||
;;; This syntactic form expands into different commands or
|
||
;;; definitions, depending on the features provided by the Scheme
|
||
;;; implementation.
|
||
;;;
|
||
;;; Syntax:
|
||
;;;
|
||
;;; <cond-expand>
|
||
;;; --> (cond-expand <cond-expand-clause>+)
|
||
;;; | (cond-expand <cond-expand-clause>* (else <command-or-definition>))
|
||
;;; <cond-expand-clause>
|
||
;;; --> (<feature-requirement> <command-or-definition>*)
|
||
;;; <feature-requirement>
|
||
;;; --> <feature-identifier>
|
||
;;; | (and <feature-requirement>*)
|
||
;;; | (or <feature-requirement>*)
|
||
;;; | (not <feature-requirement>)
|
||
;;; <feature-identifier>
|
||
;;; --> <a symbol which is the name or alias of a SRFI>
|
||
;;;
|
||
;;; Additionally, this implementation provides the
|
||
;;; <feature-identifier>s `guile' and `r5rs', so that programs can
|
||
;;; determine the implementation type and the supported standard.
|
||
;;;
|
||
;;; Currently, the following feature identifiers are supported:
|
||
;;;
|
||
;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
|
||
;;;
|
||
;;; Remember to update the features list when adding more SRFIs.
|
||
;;;
|
||
|
||
(define %cond-expand-features
|
||
;; Adjust the above comment when changing this.
|
||
'(guile
|
||
r5rs
|
||
srfi-0 ;; cond-expand itself
|
||
srfi-4 ;; homogenous numeric vectors
|
||
srfi-6 ;; open-input-string etc, in the guile core
|
||
srfi-13 ;; string library
|
||
srfi-14 ;; character sets
|
||
srfi-55 ;; require-extension
|
||
srfi-61 ;; general cond clause
|
||
))
|
||
|
||
;; This table maps module public interfaces to the list of features.
|
||
;;
|
||
(define %cond-expand-table (make-hash-table 31))
|
||
|
||
;; Add one or more features to the `cond-expand' feature list of the
|
||
;; module `module'.
|
||
;;
|
||
(define (cond-expand-provide module features)
|
||
(let ((mod (module-public-interface module)))
|
||
(and mod
|
||
(hashq-set! %cond-expand-table mod
|
||
(append (hashq-ref %cond-expand-table mod '())
|
||
features)))))
|
||
|
||
|
||
|
||
;;; Place the user in the guile-user module.
|
||
;;;
|
||
|
||
(define-module (guile-user))
|
||
|
||
;;; boot-9.scm ends here
|