;;; installed-scm-file
-;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 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
(and (memq feature *features*) #t))
(begin-deprecated
- (define feature? provided?))
+ (define (feature? sym)
+ (issue-deprecation-warning
+ "`feature?' is deprecated. Use `provided?' instead.")
+ (provided? sym)))
;;; let format alias simple-format until the more complete version is loaded
(define format simple-format)
(define (1+ n) (+ n 1))
(define (1- n) (+ n -1))
(define (and=> value procedure) (and value (procedure value)))
-(define (make-hash-table k) (make-vector k '()))
;;; apply-to-args is functionally redundant with apply and, worse,
;;; is less general than apply since it only takes two arguments.
(define (tms:cutime obj) (vector-ref obj 3))
(define (tms:cstime obj) (vector-ref obj 4))
-(define (file-position . args) (apply ftell args))
-(define (file-set-position . args) (apply fseek args))
+(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)
(putenv (string-append name "=" value))
(putenv name)))
+(define (unsetenv name)
+ "Remove the entry for NAME from the environment."
+ (putenv name))
+
\f
;;; {Load Paths}
;;;
;; 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))))
(define (sqrt z)
(if (real? z)
(if (negative? z) (make-rectangular 0 ($sqrt (- z)))
- ($sqrt z))
+ ($sqrt z))
(make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
(define expt
(let ((integer-expt integer-expt))
(lambda (z1 z2)
(cond ((integer? z2)
- (if (>= z2 0)
- (integer-expt z1 z2)
- (/ 1 (integer-expt z1 (- z2)))))
+ (if (negative? z2)
+ (/ 1 (integer-expt z1 (- z2)))
+ (integer-expt z1 z2)))
((and (real? z2) (real? z1) (>= z1 0))
($expt z1 z2))
(else
(if (> (length args) 3)
(error "Too many args to make-module." args))
- (let ((size (parse-arg 0 1021))
+ (let ((size (parse-arg 0 31))
(uses (parse-arg 1 '()))
(binder (parse-arg 2 #f)))
(error
"Lazy-binder expected to be a procedure or #f." binder))
- (let ((module (module-constructor (make-vector size '())
+ (let ((module (module-constructor (and (not (zero? size))
+ (make-hash-table size))
uses binder #f #f #f #f
'()
(make-weak-value-hash-table 31)
;;
(define (module-symbol-local-binding m v . opt-val)
(let ((var (module-local-variable m v)))
- (if var
+ (if (and var (variable-bound? var))
(variable-ref var)
(if (not (null? opt-val))
(car opt-val)
;;
(define (module-symbol-binding m v . opt-val)
(let ((var (module-variable m v)))
- (if var
+ (if (and var (variable-bound? var))
(variable-ref var)
(if (not (null? opt-val))
(car opt-val)
;; 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) '())
+ (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)
- (let ((obarray (module-obarray module)))
- (do ((index 0 (+ index 1))
- (end (vector-length obarray)))
- ((= index end))
- (for-each
- (lambda (bucket)
- (proc (car bucket) (cdr bucket)))
- (vector-ref obarray index)))))
-
+ (hash-for-each proc (module-obarray module)))
(define (module-map proc module)
- (let* ((obarray (module-obarray module))
- (end (vector-length obarray)))
-
- (let loop ((i 0)
- (answer '()))
- (if (= i end)
- answer
- (loop (+ 1 i)
- (append!
- (map (lambda (bucket)
- (proc (car bucket) (cdr bucket)))
- (vector-ref obarray i))
- answer))))))
+ (hash-map proc (module-obarray module)))
+
\f
;;; {Low Level Bootstrapping}
(cons interface (delq! 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-info (module-duplicates-info module))
+ (duplicates-handlers? (car duplicates-info))
+ (uses (module-uses module)))
+ ;; remove duplicates-interface
+ (set! uses (delq! (cdr duplicates-info) uses))
+ ;; remove interfaces to be added
+ (for-each (lambda (interface)
+ (set! uses (delq! interface uses)))
+ interfaces)
+ ;; add interfaces to use list
+ (set-module-uses! module uses)
+ (for-each (lambda (interface)
+ (and duplicates-handlers?
+ ;; perform duplicate checking
+ (process-duplicates module interface))
+ (set! uses (cons interface uses))
+ (set-module-uses! module uses))
+ interfaces)
+ ;; add duplicates interface
+ (if (cdr duplicates-info)
+ (set-module-uses! module (cons (cdr duplicates-info) uses)))
+ (module-modified module)))
+
\f
;;; {Recursive Namespaces}
;;;
(module-ref m '%module-public-interface #f))
(define (set-module-public-interface! m i)
(module-define! m '%module-public-interface i))
+(define (module-duplicates-info m)
+ (or (module-ref m '%module-duplicates-info #f) (cons #f #f)))
+(define (set-module-duplicates-info! m i)
+ (module-define! m '%module-duplicates-info 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-duplicates-info! the-root-module (cons #f #f))
(set-module-name! the-root-module '(guile))
(set-module-name! the-scm-module '(guile))
(set-module-kind! the-scm-module 'interface)
(let ((interface (make-module 31)))
(set-module-name! interface (module-name module))
(set-module-kind! interface 'interface)
- (set-module-public-interface! module interface))))
+ (set-module-public-interface! module interface)
+ (set-module-duplicates-info! module (cons #f #f)))))
(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)))))
+ (set-module-uses! module
+ (append (module-uses module) (list the-scm-module)))))
;; NOTE: This binding is used in libguile/modules.c.
;;
(eq? (car (last-pair use-list)) the-scm-module))
(set-module-uses! module (reverse (cdr (reverse use-list)))))))
-;; Return a module that is a interface to the module designated by
+;; Return a module that is an interface to the module designated by
;; NAME.
;;
;; `resolve-interface' takes two keyword arguments:
;; 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 exists in the used module
+;; 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.
;;
(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))
(re-exports '()))
(if (null? kws)
(begin
- (for-each (lambda (interface)
- (module-use! module interface))
- (reverse reversed-interfaces))
+ (module-use-interfaces! module (reverse reversed-interfaces))
(module-export! module exports)
(module-re-export! module re-exports))
(case (car kws)
((#:pure)
(purify-module! module)
(loop (cdr kws) reversed-interfaces exports re-exports))
- ((#:export)
+ ((#:duplicates)
+ (if (not (pair? (cdr kws)))
+ (unrecognized kws))
+ (set-car! (module-duplicates-info module)
+ (map (lambda (handler-name)
+ (or (module-symbol-local-binding
+ duplicate-handlers handler-name #f)
+ (error "invalid duplicate handler name:"
+ handler-name)))
+ (if (list? (cadr kws))
+ (cadr kws)
+ (list (cadr kws)))))
+ (loop (cddr kws) reversed-interfaces exports re-exports))
+ ((#:export #:export-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
(loop (cddr kws)
reversed-interfaces
(append (cadr kws) exports)
re-exports))
- ((#:re-export)
+ ((#:re-export #:re-export-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
(loop (cddr kws)
(append (cadr kws) re-exports)))
(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)
(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)))
;;; {Defmacros}
;;;
-(define macro-table (make-weak-key-hash-table 523))
-(define xformer-table (make-weak-key-hash-table 523))
+(define macro-table (make-weak-key-hash-table 61))
+(define xformer-table (make-weak-key-hash-table 61))
(define (defmacro? m) (hashq-ref macro-table m))
(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
(set! options (delq! flag options)))
flags)
(,interface options)
- (,interface)))))
-
- (make-set! (lambda (interface)
- `((name exp)
- (,'quasiquote
- (begin (,interface (append (,interface)
- (list '(,'unquote name)
- (,'unquote exp))))
- (,interface)))))))
- (procedure->macro
+ (,interface))))))
+ (procedure->memoizing-macro
(lambda (exp env)
- (cons 'begin
- (let* ((option-group (cadr exp))
- (interface (car option-group)))
- (append (map (lambda (name constructor)
- `(define ,name
- ,(constructor interface)))
- (cadr option-group)
- (list make-options
- make-enable
- make-disable))
- (map (lambda (name constructor)
- `(defmacro ,name
- ,@(constructor interface)))
- (caddr option-group)
- (list make-set!)))))))))
+ (let* ((option-group (cadr exp))
+ (interface (car option-group))
+ (options/enable/disable (cadr option-group)))
+ `(begin
+ (define ,(car options/enable/disable)
+ ,(make-options interface))
+ (define ,(cadr options/enable/disable)
+ ,(make-enable interface))
+ (define ,(caddr options/enable/disable)
+ ,(make-disable interface))
+ (defmacro ,(caaddr option-group) (opt val)
+ `(,,(car options/enable/disable)
+ (append (,,(car options/enable/disable))
+ (list ',opt ,val))))))))))
(define-option-interface
(eval-options-interface
(lambda ()
(lazy-catch #t
(lambda ()
- (dynamic-wind
- (lambda () (unmask-signals))
+ (call-with-unblocked-asyncs
(lambda ()
(with-traps
(lambda ()
(set! first #f)
(let loop ((v (thunk)))
(loop (thunk)))
- #f)))
- (lambda () (mask-signals))))
+ #f)))))
lazy-handler-dispatch))
(#t
(error "sorry, not implemented")))))
(set! batch-mode? (lambda () (not interactive)))
- (loop (lambda () #t))))
+ (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))
;; 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)
- (for-each (lambda (mif-args)
- (let ((mod-iface (apply resolve-interface mif-args)))
- (or mod-iface
- (error "no such module" mif-args))
- (module-use! (current-module) mod-iface)))
- module-interface-args))
+ (module-use-interfaces! (current-module)
+ (map (lambda (mif-args)
+ (or (apply resolve-interface mif-args)
+ (error "no such module" mif-args)))
+ module-interface-args)))
(defmacro use-modules modules
`(eval-case
(process-use-modules
(list ,@(map (lambda (m)
`(list ,@(compile-interface-spec m)))
- modules))))
+ modules)))
+ *unspecified*)
(else
(error "use-modules can only be used at the top level"))))
(list ,@(compile-interface-spec spec))))
(set-module-transformer! (current-module)
,(car (last-pair spec))))
- `((set-module-transformer! (current-module) ,spec))))
+ `((set-module-transformer! (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
(defmacro ,@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)
(else
(error "re-export can only be used at the top level"))))
-(define export-syntax export)
-(define re-export-syntax re-export)
+(defmacro export-syntax names
+ `(export ,@names))
+(defmacro re-export-syntax names
+ `(re-export ,@names))
(define load load-module)
\f
+;;; {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)))
+ (set-module-name! m 'duplicate-handlers)
+ (set-module-kind! m 'interface)
+ (module-define! m 'check
+ (lambda (module name int1 val1 int2 val2 var val)
+ (scm-error 'misc-error
+ #f
+ "module ~A: duplicate binding ~A imported from ~A and ~A"
+ (list (module-name module)
+ name
+ (module-name int1)
+ (module-name int2))
+ #f)))
+ (module-define! m 'first
+ (lambda (module name int1 val1 int2 val2 var val)
+ (or var (module-local-variable int1 name))))
+ (module-define! m 'last
+ (lambda (module name int1 val1 int2 val2 var val)
+ (module-local-variable int2 name)))
+ m))
+
+(define (make-duplicates-interface)
+ (let ((m (make-module)))
+ (set-module-kind! m 'interface)
+ (set-module-name! m 'duplicates)
+ m))
+
+(define (module-symbol-interface module sym)
+ (or-map (lambda (interface)
+ (module-search (lambda (interface sym)
+ (and (module-local-variable interface sym)
+ interface))
+ interface
+ sym))
+ (module-uses module)))
+
+(define (process-duplicates module interface)
+ (let* ((duplicates-info (module-duplicates-info module))
+ (handlers (car duplicates-info))
+ (d-interface (cdr duplicates-info)))
+ (module-for-each
+ (lambda (name var)
+ (let ((prev-interface (module-symbol-interface module name)))
+ (if prev-interface
+ (begin
+ (if (not d-interface)
+ (begin
+ (set! d-interface (make-duplicates-interface))
+ (set-cdr! duplicates-info d-interface)))
+ (let* ((var (module-local-variable d-interface name))
+ (val (and var (variable-bound? var) (variable-ref var))))
+ (let loop ((handlers handlers))
+ (cond ((null? handlers))
+ (((car handlers)
+ module
+ name
+ prev-interface
+ (module-symbol-local-binding prev-interface name #f)
+ interface
+ (module-symbol-local-binding interface name #f)
+ var
+ val)
+ =>
+ (lambda (var)
+ (module-add! d-interface name var)))
+ (else
+ (loop (cdr handlers))))))))))
+ interface)))
+
+\f
;;; {`cond-expand' for SRFI-0 support.}
;;;
(let ((guile-user-module (resolve-module '(guile-user))))
;; Load emacs interface support if emacs option is given.
- (if (and (module-defined? the-root-module 'use-emacs-interface)
- (module-ref the-root-module 'use-emacs-interface))
+ (if (and (module-defined? guile-user-module 'use-emacs-interface)
+ (module-ref guile-user-module 'use-emacs-interface))
(load-emacs-interface))
;; Use some convenient modules (in reverse order)
;; Make a backup copy of the stack
(fluid-set! before-signal-stack
(fluid-ref the-last-stack))
- (save-stack %deliver-signals)
+ (save-stack 2)
(scm-error 'signal
#f
msg
HCoop / bpt / guile.git / blobdiff