(eval-when (compile)
(set-current-module (resolve-module '(guile))))
+\f
+
+;;; {Error handling}
+;;;
+
+;; Define delimited continuation operators, and implement catch and throw in
+;; terms of them.
+
+(define make-prompt-tag
+ (lambda* (#:optional (stem "prompt"))
+ (gensym stem)))
+
+(define default-prompt-tag
+ ;; not sure if we should expose this to the user as a fluid
+ (let ((%default-prompt-tag (make-prompt-tag)))
+ (lambda ()
+ %default-prompt-tag)))
+
+(define (call-with-prompt tag thunk handler)
+ (@prompt tag (thunk) handler))
+(define (abort-to-prompt tag . args)
+ (@abort tag args))
+
+
+;; Define catch and with-throw-handler, using some common helper routines and a
+;; shared fluid. Hide the helpers in a lexical contour.
+
+(let ()
+ ;; Ideally we'd like to be able to give these default values for all threads,
+ ;; even threads not created by Guile; but alack, that does not currently seem
+ ;; possible. So wrap the getters in thunks.
+ (define %running-exception-handlers (make-fluid))
+ (define %exception-handler (make-fluid))
+
+ (define (running-exception-handlers)
+ (or (fluid-ref %running-exception-handlers)
+ (begin
+ (fluid-set! %running-exception-handlers '())
+ '())))
+ (define (exception-handler)
+ (or (fluid-ref %exception-handler)
+ (begin
+ (fluid-set! %exception-handler default-exception-handler)
+ default-exception-handler)))
+
+ (define (default-exception-handler k . args)
+ (cond
+ ((eq? k 'quit)
+ (primitive-exit (cond
+ ((not (pair? args)) 0)
+ ((integer? (car args)) (car args))
+ ((not (car args)) 1)
+ (else 0))))
+ (else
+ (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
+ (primitive-exit 1))))
+
+ (define (default-throw-handler prompt-tag catch-k)
+ (let ((prev (exception-handler)))
+ (lambda (thrown-k . args)
+ (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
+ (apply abort-to-prompt prompt-tag thrown-k args)
+ (apply prev thrown-k args)))))
+
+ (define (custom-throw-handler prompt-tag catch-k pre)
+ (let ((prev (exception-handler)))
+ (lambda (thrown-k . args)
+ (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
+ (let ((running (running-exception-handlers)))
+ (with-fluids ((%running-exception-handlers (cons pre running)))
+ (if (not (memq pre running))
+ (apply pre thrown-k args))
+ ;; fall through
+ (if prompt-tag
+ (apply abort-to-prompt prompt-tag thrown-k args)
+ (apply prev thrown-k args))))
+ (apply prev thrown-k args)))))
+
+ (define! 'catch
+ (lambda* (k thunk handler #:optional pre-unwind-handler)
+ "Invoke @var{thunk} in the dynamic context of @var{handler} for
+exceptions matching @var{key}. If thunk throws to the symbol
+@var{key}, then @var{handler} is invoked this way:
+@lisp
+ (handler key args ...)
+@end lisp
+
+@var{key} is a symbol or @code{#t}.
+
+@var{thunk} takes no arguments. If @var{thunk} returns
+normally, that is the return value of @code{catch}.
+
+Handler is invoked outside the scope of its own @code{catch}.
+If @var{handler} again throws to the same key, a new handler
+from further up the call chain is invoked.
+
+If the key is @code{#t}, then a throw to @emph{any} symbol will
+match this call to @code{catch}.
+
+If a @var{pre-unwind-handler} is given and @var{thunk} throws
+an exception that matches @var{key}, Guile calls the
+@var{pre-unwind-handler} before unwinding the dynamic state and
+invoking the main @var{handler}. @var{pre-unwind-handler} should
+be a procedure with the same signature as @var{handler}, that
+is @code{(lambda (key . args))}. It is typically used to save
+the stack at the point where the exception occurred, but can also
+query other parts of the dynamic state at that point, such as
+fluid values.
+
+A @var{pre-unwind-handler} can exit either normally or non-locally.
+If it exits normally, Guile unwinds the stack and dynamic context
+and then calls the normal (third argument) handler. If it exits
+non-locally, that exit determines the continuation."
+ (if (not (or (symbol? k) (eqv? k #t)))
+ (scm-error "catch" 'wrong-type-arg
+ "Wrong type argument in position ~a: ~a"
+ (list 1 k) (list k)))
+ (let ((tag (make-prompt-tag "catch")))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (with-fluids
+ ((%exception-handler
+ (if pre-unwind-handler
+ (custom-throw-handler tag k pre-unwind-handler)
+ (default-throw-handler tag k))))
+ (thunk)))
+ (lambda (cont k . args)
+ (apply handler k args))))))
+
+ (define! 'with-throw-handler
+ (lambda (k thunk pre-unwind-handler)
+ "Add @var{handler} to the dynamic context as a throw handler
+for key @var{key}, then invoke @var{thunk}."
+ (if (not (or (symbol? k) (eqv? k #t)))
+ (scm-error "with-throw-handler" 'wrong-type-arg
+ "Wrong type argument in position ~a: ~a"
+ (list 1 k) (list k)))
+ (with-fluids ((%exception-handler
+ (custom-throw-handler #f k pre-unwind-handler)))
+ (thunk))))
+
+ (define! 'throw
+ (lambda (key . args)
+ "Invoke the catch form matching @var{key}, passing @var{args} to the
+@var{handler}.
+
+@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
+
+If there is no handler at all, Guile prints an error and then exits."
+ (if (not (symbol? key))
+ ((exception-handler) 'wrong-type-arg "throw"
+ "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
+ (apply (exception-handler) key args)))))
+
+
+\f
+
;;; {R4RS compliance}
;;;
;; this is scheme wrapping the C code so the final pred call is a tail call,
;; per SRFI-13 spec
-(define (string-any char_pred s . rest)
- (let ((start (if (null? rest)
- 0 (car rest)))
- (end (if (or (null? rest) (null? (cdr rest)))
- (string-length s) (cadr rest))))
+(define string-any
+ (lambda* (char_pred s #:optional (start 0) (end (string-length s)))
(if (and (procedure? char_pred)
(> end start)
(<= end (string-length s))) ;; let c-code handle range error
;; this is scheme wrapping the C code so the final pred call is a tail call,
;; per SRFI-13 spec
-(define (string-every char_pred s . rest)
- (let ((start (if (null? rest)
- 0 (car rest)))
- (end (if (or (null? rest) (null? (cdr rest)))
- (string-length s) (cadr rest))))
+(define string-every
+ (lambda* (char_pred s #:optional (start 0) (end (string-length s)))
(if (and (procedure? char_pred)
(> end start)
(<= end (string-length s))) ;; let c-code handle range error
(define syntax-violation #f)
(define datum->syntax #f)
(define syntax->datum #f)
+(define syntax-source #f)
(define identifier? #f)
(define generate-temporaries #f)
(define bound-identifier=? #f)
(define free-identifier=? #f)
-(define sc-expand #f)
-;; $sc-expand is an implementation detail of psyntax. It is used by
+;; $sc-dispatch is an implementation detail of psyntax. It is used by
;; expanded macros, to dispatch an input against a set of patterns.
(define $sc-dispatch #f)
;; Load it up!
(primitive-load-path "ice-9/psyntax-pp")
-
-;; %pre-modules-transformer is the Scheme expander from now until the
-;; module system has booted up.
-(define %pre-modules-transformer sc-expand)
+;; The binding for `macroexpand' has now been overridden, making psyntax the
+;; expander now.
(define-syntax and
(syntax-rules ()
(include-from-path "ice-9/quasisyntax")
-;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
-;;; Please let the Guile developers know if you are using this macro.
-;;;
-(define-syntax @bind
+(define-syntax current-source-location
(lambda (x)
- (define (bound-member id ids)
- (cond ((null? ids) #f)
- ((bound-identifier=? id (car ids)) #t)
- ((bound-member (car ids) (cdr ids)))))
-
(syntax-case x ()
- ((_ () b0 b1 ...)
- #'(let () b0 b1 ...))
- ((_ ((id val) ...) b0 b1 ...)
- (and-map identifier? #'(id ...))
- (if (let lp ((ids #'(id ...)))
- (cond ((null? ids) #f)
- ((bound-member (car ids) (cdr ids)) #t)
- (else (lp (cdr ids)))))
- (syntax-violation '@bind "duplicate bound identifier" x)
- (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
- ((v ...) (generate-temporaries #'(id ...))))
- #'(let ((old-v id) ...
- (v val) ...)
- (dynamic-wind
- (lambda ()
- (set! id v) ...)
- (lambda () b0 b1 ...)
- (lambda ()
- (set! id old-v) ...)))))))))
+ ((_)
+ (with-syntax ((s (datum->syntax x (syntax-source x))))
+ #''s)))))
\f
#'(define-syntax macro
(lambda (y)
doc
+ #((macro-type . defmacro)
+ (defmacro-args args))
(syntax-case y ()
((_ . args)
(let ((v (syntax->datum #'args)))
(define (and=> value procedure) (and value (procedure value)))
(define call/cc call-with-current-continuation)
-;;; Delimited continuations
-(define (prompt tag thunk handler)
- (@prompt tag (thunk) handler))
-(define (abort tag . args)
- (@abort tag args))
-
;;; apply-to-args is functionally redundant with apply and, worse,
;;; is less general than apply since it only takes two arguments.
;;;
`(catch #t
(lambda ()
;; avoid saving backtraces inside false-if-exception
- (with-fluid* the-last-stack (fluid-ref the-last-stack)
- (lambda () ,expr)))
+ (with-fluids ((the-last-stack (fluid-ref the-last-stack)))
+ ,expr))
(lambda args #f)))
\f
(port-with-print-state new-port (get-print-state old-port))
new-port))
-;; 0: type-name, 1: fields
+;; 0: type-name, 1: fields, 2: constructor
(define record-type-vtable
- (make-vtable-vtable "prpr" 0
+ ;; FIXME: This should just call make-vtable, not make-vtable-vtable; but for
+ ;; that we need to expose the bare vtable-vtable to Scheme.
+ (make-vtable-vtable "prprpw" 0
(lambda (s p)
(cond ((eq? s record-type-vtable)
(display "#<record-type-vtable>" p))
(define (record-type? obj)
(and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
-(define (make-record-type type-name fields . opt)
- (let ((printer-fn (and (pair? opt) (car opt))))
- (let ((struct (make-struct record-type-vtable 0
- (make-struct-layout
- (apply string-append
- (map (lambda (f) "pw") fields)))
- (or printer-fn
- (lambda (s p)
- (display "#<" p)
- (display type-name p)
- (let loop ((fields fields)
- (off 0))
- (cond
- ((not (null? fields))
- (display " " p)
- (display (car fields) p)
- (display ": " p)
- (display (struct-ref s off) p)
- (loop (cdr fields) (+ 1 off)))))
- (display ">" p)))
- type-name
- (copy-tree fields))))
- ;; Temporary solution: Associate a name to the record type descriptor
- ;; so that the object system can create a wrapper class for it.
- (set-struct-vtable-name! struct (if (symbol? type-name)
- type-name
- (string->symbol type-name)))
- struct)))
+(define* (make-record-type type-name fields #:optional printer)
+ ;; Pre-generate constructors for nfields < 20.
+ (define-syntax make-constructor
+ (lambda (x)
+ (define *max-static-argument-count* 20)
+ (define (make-formals n)
+ (let lp ((i 0))
+ (if (< i n)
+ (cons (datum->syntax
+ x
+ (string->symbol
+ (string (integer->char (+ (char->integer #\a) i)))))
+ (lp (1+ i)))
+ '())))
+ (syntax-case x ()
+ ((_ rtd exp) (not (identifier? #'exp))
+ #'(let ((n exp))
+ (make-constructor rtd n)))
+ ((_ rtd nfields)
+ #`(case nfields
+ #,@(let lp ((n 0))
+ (if (< n *max-static-argument-count*)
+ (cons (with-syntax (((formal ...) (make-formals n))
+ (n n))
+ #'((n)
+ (lambda (formal ...)
+ (make-struct rtd 0 formal ...))))
+ (lp (1+ n)))
+ '()))
+ (else
+ (lambda args
+ (if (= (length args) nfields)
+ (apply make-struct rtd 0 args)
+ (scm-error 'wrong-number-of-args
+ (format #f "make-~a" type-name)
+ "Wrong number of arguments" '() #f)))))))))
+
+ (define (default-record-printer s p)
+ (display "#<" p)
+ (display (record-type-name (record-type-descriptor s)) p)
+ (let loop ((fields (record-type-fields (record-type-descriptor s)))
+ (off 0))
+ (cond
+ ((not (null? fields))
+ (display " " p)
+ (display (car fields) p)
+ (display ": " p)
+ (display (struct-ref s off) p)
+ (loop (cdr fields) (+ 1 off)))))
+ (display ">" p))
+
+ (let ((rtd (make-struct record-type-vtable 0
+ (make-struct-layout
+ (apply string-append
+ (map (lambda (f) "pw") fields)))
+ (or printer default-record-printer)
+ type-name
+ (copy-tree fields))))
+ (struct-set! rtd (+ vtable-offset-user 2)
+ (make-constructor rtd (length fields)))
+ ;; Temporary solution: Associate a name to the record type descriptor
+ ;; so that the object system can create a wrapper class for it.
+ (set-struct-vtable-name! rtd (if (symbol? type-name)
+ type-name
+ (string->symbol type-name)))
+ rtd))
(define (record-type-name obj)
(if (record-type? obj)
(struct-ref obj (+ 1 vtable-offset-user))
(error 'not-a-record-type obj)))
-(define (record-constructor rtd . opt)
- (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd))))
- (primitive-eval
- `(lambda ,field-names
- (make-struct ',rtd 0 ,@(map (lambda (f)
- (if (memq f field-names)
- f
- #f))
- (record-type-fields rtd)))))))
+(define* (record-constructor rtd #:optional field-names)
+ (if (not field-names)
+ (struct-ref rtd (+ 2 vtable-offset-user))
+ (primitive-eval
+ `(lambda ,field-names
+ (make-struct ',rtd 0 ,@(map (lambda (f)
+ (if (memq f field-names)
+ f
+ #f))
+ (record-type-fields rtd)))))))
(define (record-predicate rtd)
(lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
(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* (file-set-position port offset #:optional (whence SEEK_SET))
+ (seek port offset whence))
(define (move->fdes fd/port fd)
(cond ((integer? fd/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 dup->port
+ (case-lambda
+ ((port/fd mode)
+ (fdopen (dup->fdes port/fd) mode))
+ ((port/fd mode new-fd)
+ (let ((port (fdopen (dup->fdes port/fd new-fd) mode)))
+ (set-port-revealed! port 1)
+ port))))
+
+(define dup->inport
+ (case-lambda
+ ((port/fd)
+ (dup->port port/fd "r"))
+ ((port/fd new-fd)
+ (dup->port port/fd "r" new-fd))))
+
+(define dup->outport
+ (case-lambda
+ ((port/fd)
+ (dup->port port/fd "w"))
+ ((port/fd new-fd)
+ (dup->port port/fd "w" new-fd))))
+
+(define dup
+ (case-lambda
+ ((port/fd)
+ (if (integer? port/fd)
+ (dup->fdes port/fd)
+ (dup->port port/fd (port-mode port/fd))))
+ ((port/fd new-fd)
+ (if (integer? port/fd)
+ (dup->fdes port/fd new-fd)
+ (dup->port port/fd (port-mode port/fd) new-fd)))))
(define (duplicate-port port modes)
(dup->port port modes))
;;; {The interpreter stack}
;;;
-(defmacro start-stack (tag exp)
- `(%start-stack ,tag (lambda () ,exp)))
+;; %stacks defined in stacks.c
+(define (%start-stack tag thunk)
+ (let ((prompt-tag (make-prompt-tag "start-stack")))
+ (call-with-prompt
+ prompt-tag
+ (lambda ()
+ (with-fluids ((%stacks (acons tag prompt-tag
+ (or (fluid-ref %stacks) '()))))
+ (thunk)))
+ (lambda (k . args)
+ (%start-stack tag (lambda () (apply k args)))))))
+(define-syntax start-stack
+ (syntax-rules ()
+ ((_ tag exp)
+ (%start-stack tag (lambda () exp)))))
\f
(set! %load-hook %load-announce)
-(define (load name . reader)
+(define* (load name #:optional reader)
;; Returns the .go file corresponding to `name'. Does not search load
;; paths, only the fallback path. If the .go file is missing or out of
;; date, and autocompilation is enabled, will try autocompilation, just
(%load-should-autocompile
(%warn-autocompilation-enabled)
(format (current-error-port) ";;; compiling ~a\n" name)
+ ;; This use of @ is (ironically?) boot-safe, as modules have
+ ;; not been booted yet, so the resolve-module call in psyntax
+ ;; doesn't try to load a module, and compile-file will be
+ ;; treated as a function, not a macro.
(let ((cfn ((@ (system base compile) compile-file) name
#:env (current-module))))
(format (current-error-port) ";;; compiled ~a\n" cfn)
";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
name k args)
#f)))
- (with-fluid* current-reader (and (pair? reader) (car reader))
- (lambda ()
- (let ((cfn (and=> (and=> (false-if-exception (canonicalize-path name))
- compiled-file-name)
- fresh-compiled-file-name)))
- (if cfn
- (load-compiled cfn)
- (start-stack 'load-stack
- (primitive-load name)))))))
+ (with-fluids ((current-reader reader))
+ (let ((cfn (and=> (and=> (false-if-exception (canonicalize-path name))
+ compiled-file-name)
+ fresh-compiled-file-name)))
+ (if cfn
+ (load-compiled cfn)
+ (start-stack 'load-stack
+ (primitive-load name))))))
\f
;;;
;; 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)
+(define (%print-module mod port)
(display "#<" port)
(display (or (module-kind mod) "module") 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 import-obarray
- observers weak-observers version)
- %print-module))
+(letrec-syntax
+ ;; Locally extend the syntax to allow record accessors to be defined at
+ ;; compile-time. Cache the rtd locally to the constructor, the getters and
+ ;; the setters, in order to allow for redefinition of the record type; not
+ ;; relevant in the case of modules, but perhaps if we make this public, it
+ ;; could matter.
+
+ ((define-record-type
+ (lambda (x)
+ (define (make-id scope . fragments)
+ (datum->syntax #'scope
+ (apply symbol-append
+ (map (lambda (x)
+ (if (symbol? x) x (syntax->datum x)))
+ fragments))))
+
+ (define (getter rtd type-name field slot)
+ #`(define #,(make-id rtd type-name '- field)
+ (let ((rtd #,rtd))
+ (lambda (#,type-name)
+ (if (eq? (struct-vtable #,type-name) rtd)
+ (struct-ref #,type-name #,slot)
+ (%record-type-error rtd #,type-name))))))
+
+ (define (setter rtd type-name field slot)
+ #`(define #,(make-id rtd 'set- type-name '- field '!)
+ (let ((rtd #,rtd))
+ (lambda (#,type-name val)
+ (if (eq? (struct-vtable #,type-name) rtd)
+ (struct-set! #,type-name #,slot val)
+ (%record-type-error rtd #,type-name))))))
+
+ (define (accessors rtd type-name fields n exp)
+ (syntax-case fields ()
+ (() exp)
+ (((field #:no-accessors) field* ...) (identifier? #'field)
+ (accessors rtd type-name #'(field* ...) (1+ n)
+ exp))
+ (((field #:no-setter) field* ...) (identifier? #'field)
+ (accessors rtd type-name #'(field* ...) (1+ n)
+ #`(begin #,exp
+ #,(getter rtd type-name #'field n))))
+ (((field #:no-getter) field* ...) (identifier? #'field)
+ (accessors rtd type-name #'(field* ...) (1+ n)
+ #`(begin #,exp
+ #,(setter rtd type-name #'field n))))
+ ((field field* ...) (identifier? #'field)
+ (accessors rtd type-name #'(field* ...) (1+ n)
+ #`(begin #,exp
+ #,(getter rtd type-name #'field n)
+ #,(setter rtd type-name #'field n))))))
+
+ (define (predicate rtd type-name fields exp)
+ (accessors
+ rtd type-name fields 0
+ #`(begin
+ #,exp
+ (define (#,(make-id rtd type-name '?) obj)
+ (and (struct? obj) (eq? (struct-vtable obj) #,rtd))))))
+
+ (define (field-list fields)
+ (syntax-case fields ()
+ (() '())
+ (((f . opts) . rest) (identifier? #'f)
+ (cons #'f (field-list #'rest)))
+ ((f . rest) (identifier? #'f)
+ (cons #'f (field-list #'rest)))))
+
+ (define (constructor rtd type-name fields exp)
+ (let ((ctor (make-id rtd type-name '-constructor))
+ (args (field-list fields)))
+ (predicate rtd type-name fields
+ #`(begin #,exp
+ (define #,ctor
+ (let ((rtd #,rtd))
+ (lambda #,args
+ (make-struct rtd 0 #,@args))))
+ (struct-set! #,rtd (+ vtable-offset-user 2)
+ #,ctor)))))
+
+ (define (type type-name printer fields)
+ (define (make-layout)
+ (let lp ((fields fields) (slots '()))
+ (syntax-case fields ()
+ (() (datum->syntax #'here
+ (make-struct-layout
+ (apply string-append slots))))
+ ((_ . rest) (lp #'rest (cons "pw" slots))))))
+
+ (let ((rtd (make-id type-name type-name '-type)))
+ (constructor rtd type-name fields
+ #`(begin
+ (define #,rtd
+ (make-struct record-type-vtable 0
+ '#,(make-layout)
+ #,printer
+ '#,type-name
+ '#,(field-list fields)))
+ (set-struct-vtable-name! #,rtd '#,type-name)))))
+
+ (syntax-case x ()
+ ((_ type-name printer (field ...))
+ (type #'type-name #'printer #'(field ...)))))))
+
+ ;; 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 the set of fields or their order, you also need to
+ ;; change the constants in libguile/modules.h.
+ ;;
+ ;; NOTE: The getter `module-eval-closure' is used in libguile/modules.c.
+ ;; NOTE: The getter `module-transfomer' is defined libguile/modules.c.
+ ;; NOTE: The getter `module-name' is defined later, due to boot reasons.
+ ;; NOTE: The getter `module-public-interface' is used in libguile/modules.c.
+ ;;
+ (define-record-type module
+ (lambda (obj port) (%print-module obj port))
+ (obarray
+ uses
+ binder
+ eval-closure
+ (transformer #:no-getter)
+ (name #:no-getter)
+ kind
+ duplicates-handlers
+ (import-obarray #:no-setter)
+ observers
+ (weak-observers #:no-setter)
+ version
+ submodules
+ submodule-binder
+ public-interface
+ filename)))
+
;; make-module &opt size uses binder
;;
"Lazy-binder expected to be a procedure or #f." binder))
(let ((module (module-constructor (make-hash-table size)
- uses binder #f %pre-modules-transformer
+ uses binder #f macroexpand
#f #f #f
(make-hash-table %default-import-size)
'()
- (make-weak-key-hash-table 31) #f)))
+ (make-weak-key-hash-table 31) #f
+ (make-hash-table 7) #f #f #f)))
;; We can't pass this as an argument to module-constructor,
;; because we need it to close over a pointer to the module
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-version (record-accessor module-type 'version))
-(define set-module-version! (record-modifier module-type 'version))
-;; (define module-name (record-accessor module-type 'name)) wait until mods are booted
-(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-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? (record-predicate module-type))
-
-(define module-import-obarray (record-accessor module-type 'import-obarray))
-
-(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.
-
- ;; XXX: The following line introduces a circular reference that
- ;; precludes garbage collection of modules with the current weak hash
- ;; table semantics (see
- ;; http://lists.gnu.org/archive/html/guile-devel/2009-01/msg00102.html and
- ;; http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2465
- ;; for details). Since it doesn't appear to be used (only in
- ;; `scm_lookup_closure_module ()', which has 1 caller), we just comment
- ;; it out.
-
- ;(set-procedure-property! closure 'module module)
- )))
\f
(set-module-observers! module (cons proc (module-observers module)))
(cons module proc))
-(define (module-observe-weak module observer-id . proc)
+(define* (module-observe-weak module observer-id #:optional (proc observer-id))
;; Register PROC as an observer of MODULE under name OBSERVER-ID (which can
;; be any Scheme object). PROC is invoked and passed MODULE any time
;; MODULE is modified. PROC gets unregistered when OBSERVER-ID gets GC'd
;; The two-argument version is kept for backward compatibility: when called
;; with two arguments, the observer gets unregistered when closure PROC
;; gets GC'd (making it impossible to use an anonymous lambda for PROC).
-
- (let ((proc (if (null? proc) observer-id (car proc))))
- (hashq-set! (module-weak-observers module) observer-id proc)))
+ (hashq-set! (module-weak-observers module) observer-id proc))
(define (module-unobserve token)
(let ((module (car token))
(define (module-map proc module)
(hash-map->list proc (module-obarray module)))
+;; Submodules
+;;
+;; Modules exist in a separate namespace from values, because you generally do
+;; not want the name of a submodule, which you might not even use, to collide
+;; with local variables that happen to be named the same as the submodule.
+;;
+(define (module-ref-submodule module name)
+ (or (hashq-ref (module-submodules module) name)
+ (and (module-submodule-binder module)
+ ((module-submodule-binder module) module name))))
+
+(define (module-define-submodule! module name submodule)
+ (hashq-set! (module-submodules module) name submodule))
+
\f
;;; {Low Level Bootstrapping}
(define basic-load load)
-(define (load-module filename . reader)
+(define* (load-module filename #:optional 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)))))
+ (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)))))
\f
(module-name interface))))
(module-uses module))
(list interface)))
-
+ (hash-clear! (module-import-obarray module))
(module-modified module))))
;; MODULE-USE-INTERFACES! module interfaces
(define (module-use-interfaces! module interfaces)
(set-module-uses! module
(append (module-uses module) interfaces))
+ (hash-clear! (module-import-obarray module))
(module-modified module))
\f
;;; {Recursive Namespaces}
;;;
;;; A hierarchical namespace emerges if we consider some module to be
-;;; root, and variables bound to modules as nested namespaces.
+;;; root, and submodules of that module to be nested namespaces.
;;;
-;;; The routines in this file manage variable names in hierarchical namespace.
+;;; The routines here 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>
+;;; => <value of a variable named baz in the submodule bar of
+;;; the submodule foo of some-root-module>
;;;
;;;
;;; There are:
;;; nested-define! a-root name val
;;; nested-remove! a-root name
;;;
+;;; These functions manipulate values in namespaces. For referencing the
+;;; namespaces themselves, use the following:
;;;
-;;; (current-module) is a natural choice for a-root so for convenience there are
+;;; nested-ref-module a-root name
+;;; nested-define-module! a-root name mod
+;;;
+;;; (current-module) is a natural choice for a root so for convenience there are
;;; also:
;;;
-;;; local-ref name == nested-ref (current-module) name
-;;; local-set! name val == nested-set! (current-module) name val
-;;; local-define! name val == nested-define! (current-module) name val
-;;; local-remove! name == nested-remove! (current-module) name
+;;; local-ref name == nested-ref (current-module) name
+;;; local-set! name val == nested-set! (current-module) name val
+;;; local-define name val == nested-define! (current-module) name val
+;;; local-remove name == nested-remove! (current-module) name
+;;; local-ref-module name == nested-ref-module (current-module) name
+;;; local-define-module! name m == nested-define-module! (current-module) name m
;;;
(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))))))
+ (if (null? names)
+ root
+ (let loop ((cur root)
+ (head (car names))
+ (tail (cdr names)))
+ (if (null? tail)
+ (module-ref cur head #f)
+ (let ((cur (module-ref-submodule cur head)))
+ (and cur
+ (loop cur (car tail) (cdr tail))))))))
(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)))))
+ (head (car names))
+ (tail (cdr names)))
+ (if (null? tail)
+ (module-set! cur head val)
+ (let ((cur (module-ref-submodule cur head)))
+ (if (not cur)
+ (error "failed to resolve module" names)
+ (loop cur (car tail) (cdr tail)))))))
(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)))))
+ (head (car names))
+ (tail (cdr names)))
+ (if (null? tail)
+ (module-define! cur head val)
+ (let ((cur (module-ref-submodule cur head)))
+ (if (not cur)
+ (error "failed to resolve module" names)
+ (loop cur (car tail) (cdr tail)))))))
(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)))))
+ (head (car names))
+ (tail (cdr names)))
+ (if (null? tail)
+ (module-remove! cur head)
+ (let ((cur (module-ref-submodule cur head)))
+ (if (not cur)
+ (error "failed to resolve module" names)
+ (loop cur (car tail) (cdr tail)))))))
+
+
+(define (nested-ref-module root names)
+ (let loop ((cur root)
+ (names names))
+ (if (null? names)
+ cur
+ (let ((cur (module-ref-submodule cur (car names))))
+ (and cur
+ (loop cur (cdr names)))))))
+
+(define (nested-define-module! root names module)
+ (if (null? names)
+ (error "can't redefine root module" root module)
+ (let loop ((cur root)
+ (head (car names))
+ (tail (cdr names)))
+ (if (null? tail)
+ (module-define-submodule! cur head module)
+ (let ((cur (or (module-ref-submodule cur head)
+ (let ((m (make-module 31)))
+ (set-module-kind! m 'directory)
+ (set-module-name! m (append (module-name cur)
+ (list head)))
+ (module-define-submodule! cur head m)
+ m))))
+ (loop cur (car tail) (cdr tail)))))))
+
(define (local-ref names) (nested-ref (current-module) names))
(define (local-set! names val) (nested-set! (current-module) names val))
(define (local-define names val) (nested-define! (current-module) names val))
(define (local-remove names) (nested-remove! (current-module) names))
+(define (local-ref-module names) (nested-ref-module (current-module) names))
+(define (local-define-module names mod) (nested-define-module! (current-module) names mod))
+
\f
-;;; {The (%app) module}
-;;;
-;;; The root of conventionally named objects not directly in the top level.
-;;;
-;;; (%app modules)
-;;; (%app modules guile)
+;;; {The (guile) module}
;;;
-;;; The directory of all modules and the standard root module.
+;;; The standard module, which has the core Guile bindings. Also called the
+;;; "root module", as it is imported by many other modules, but it is not
+;;; necessarily the root of anything; and indeed, the module named '() might be
+;;; better thought of as a root.
;;;
-;; module-public-interface is defined in C.
-(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))
(set-system-module! the-root-module #t)
(set-system-module! the-scm-module #t)
-;; NOTE: This binding is used in libguile/modules.c.
+
+\f
+
+;; Now that we have a root module, even though modules aren't fully booted,
+;; expand the definition of resolve-module.
+;;
+(define (resolve-module name . args)
+ (if (equal? name '(guile))
+ the-root-module
+ (error "unexpected module to resolve during module boot" 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 process-define-module #f)
+(define process-use-modules #f)
+(define module-export! #f)
+(define default-duplicate-binding-procedures #f)
+
+;; This boots the module system. All bindings needed by modules.c
+;; must have been defined by now.
+;;
+(set-current-module the-root-module)
+
+
+\f
+
+;; Now that modules are booted, give module-name its final definition.
;;
+(define module-name
+ (let ((accessor (record-accessor module-type 'name)))
+ (lambda (mod)
+ (or (accessor mod)
+ (let ((name (list (gensym))))
+ ;; Name MOD and bind it in the module root so that it's visible to
+ ;; `resolve-module'. This is important as `psyntax' stores module
+ ;; names and relies on being able to `resolve-module' them.
+ (set-module-name! mod name)
+ (nested-define-module! (resolve-module '() #f) name mod)
+ (accessor mod))))))
+
(define (make-modules-in module name)
- (if (null? name)
- module
- (make-modules-in
- (let* ((var (module-local-variable module (car name)))
- (val (and var (variable-bound? var) (variable-ref var))))
- (if (module? val)
- val
- (let ((m (make-module 31)))
- (set-module-kind! m 'directory)
- (set-module-name! m (append (module-name module)
- (list (car name))))
- (module-define! module (car name) m)
- m)))
- (cdr name))))
+ (or (nested-ref-module module name)
+ (let ((m (make-module 31)))
+ (set-module-kind! m 'directory)
+ (set-module-name! m (append (module-name module) name))
+ (nested-define-module! module name m)
+ m)))
(define (beautify-user-module! module)
(let ((interface (module-public-interface module)))
(cond ((> (car lst1) (car lst2)) #t)
((< (car lst1) (car lst2)) #f)
(else (numlist-less (cdr lst1) (cdr lst2)))))))
- (numlist-less (car pair1) (car pair2)))
+ (not (numlist-less (car pair2) (car pair1))))
(define (match-version-and-file pair)
(and (version-matches? version-ref (car pair))
(let ((filenames
(let ((s (false-if-exception (stat file))))
(and s (eq? (stat:type s) 'regular))))
(map (lambda (ext)
- (string-append (cdr pair) "/" name ext))
+ (string-append (cdr pair) name ext))
%load-extensions))))
(and (not (null? filenames))
(cons (car pair) (car filenames))))))
(let ((entry (readdir dstrm)))
(if (eof-object? entry)
subdir-pairs
- (let* ((subdir (string-append (cdr root-pair) "/" entry))
+ (let* ((subdir (string-append (cdr root-pair) entry))
(num (string->number entry))
- (num (and num (append (car root-pair) (list num)))))
+ (num (and num (exact? num) (append (car root-pair)
+ (list num)))))
(if (and num (eq? (stat:type (stat subdir)) 'directory))
- (filter-subdir
- root-pair dstrm (cons (cons num subdir) subdir-pairs))
+ (filter-subdir
+ root-pair dstrm (cons (cons num (string-append subdir "/"))
+ subdir-pairs))
(filter-subdir root-pair dstrm subdir-pairs))))))
(or (and (null? root-pairs) ret)
;; NOTE: This binding is used in libguile/modules.c.
;;
(define resolve-module
- (let ((the-root-module the-root-module))
- (lambda (name . args)
- (if (equal? name '(guile))
- the-root-module
- (let ((full-name (append '(%app modules) name)))
- (let* ((already (nested-ref the-root-module full-name))
- (numargs (length args))
- (autoload (or (= numargs 0) (car args)))
- (version (and (> numargs 1) (cadr args))))
- (cond
- ((and already (module? already)
- (or (not autoload) (module-public-interface already)))
- ;; A hit, a palpable hit.
- (if (and version
- (not (version-matches? version (module-version already))))
- (error "incompatible module version already loaded" name))
- already)
- (autoload
- ;; Try to autoload the module, and recurse.
- (try-load-module name version)
- (resolve-module name #f))
- (else
- ;; A module is not bound (but maybe something else is),
- ;; we're not autoloading -- here's the weird semantics,
- ;; we create an empty module.
- (make-modules-in the-root-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)
-(define default-duplicate-binding-procedures #f)
+ (let ((root (make-module)))
+ (set-module-name! root '())
+ ;; Define the-root-module as '(guile).
+ (module-define-submodule! root 'guile the-root-module)
-(define %app (make-module 31))
-(set-module-name! %app '(%app))
-(define app %app) ;; for backwards compatability
-
-(let ((m (make-module 31)))
- (set-module-name! m '())
- (local-define '(%app modules) m))
-(local-define '(%app modules guile) the-root-module)
-
-;; This boots the module system. All bindings needed by modules.c
-;; must have been defined by now.
-;;
-(set-current-module the-root-module)
-;; definition deferred for syncase's benefit.
-(define module-name
- (let ((accessor (record-accessor module-type 'name)))
- (lambda (mod)
- (or (accessor mod)
- (let ((name (list (gensym))))
- ;; Name MOD and bind it in THE-ROOT-MODULE so that it's visible
- ;; to `resolve-module'. This is important as `psyntax' stores
- ;; module names and relies on being able to `resolve-module'
- ;; them.
- (set-module-name! mod name)
- (nested-define! the-root-module `(%app modules ,@name) mod)
- (accessor mod))))))
+ (lambda* (name #:optional (autoload #t) (version #f) #:key (ensure #t))
+ (let ((already (nested-ref-module root name)))
+ (cond
+ ((and already
+ (or (not autoload) (module-public-interface already)))
+ ;; A hit, a palpable hit.
+ (if (and version
+ (not (version-matches? version (module-version already))))
+ (error "incompatible module version already loaded" name))
+ already)
+ (autoload
+ ;; Try to autoload the module, and recurse.
+ (try-load-module name version)
+ (resolve-module name #f #:ensure ensure))
+ (else
+ ;; No module found (or if one was, it had no public interface), and
+ ;; we're not autoloading. Make an empty module if #:ensure is true.
+ (or already
+ (and ensure
+ (make-modules-in root name)))))))))
-;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
(define (try-load-module name version)
(try-module-autoload name version))
;; 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))
- (version (get-keyword-arg args #:version #f))
- (module (resolve-module name #t version))
+(define* (resolve-interface name #:key
+ (select #f)
+ (hide '())
+ (prefix #f)
+ (renamer (if prefix
+ (symbol-prefix-proc prefix)
+ identity))
+ version)
+ (let* ((module (resolve-module name #t version))
(public-i (and module (module-public-interface module))))
(and (or (not module) (not public-i))
(error "no code for module" name))
re-exports
(append (cadr kws) replacements)
autoloads))
+ ((#:filename)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (set-module-filename! module (cadr kws))
+ (loop (cddr kws)
+ reversed-interfaces
+ exports
+ re-exports
+ replacements
+ autoloads))
(else
(unrecognized kws)))))
(run-hook module-defined-hook module)
(set-car! autoload i)))
(module-local-variable i sym))))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
- (make-hash-table 0) '() (make-weak-value-hash-table 31) #f)))
+ (make-hash-table 0) '() (make-weak-value-hash-table 31) #f
+ (make-hash-table 0) #f #f #f)))
(define (module-autoload! module . args)
"Have @var{module} automatically load the module named @var{name} when one
;; 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 . args)
+(define* (try-module-autoload module-name #:optional version)
(let* ((reverse-name (reverse module-name))
(name (symbol->string (car reverse-name)))
- (version (and (not (null? args)) (car args)))
(dir-hint-module-name (reverse (cdr reverse-name)))
(dir-hint (apply string-append
(map (lambda (elt)
(dynamic-wind
(lambda () (autoload-in-progress! dir-hint name))
(lambda ()
- (with-fluid* current-reader #f
- (lambda ()
- (save-module-excursion
- (lambda ()
- (if version
- (load (find-versioned-module
- dir-hint name version %load-path))
- (primitive-load-path (in-vicinity dir-hint name) #f))
- (set! didit #t))))))
+ (with-fluids ((current-reader #f))
+ (save-module-excursion
+ (lambda ()
+ (if version
+ (load (find-versioned-module
+ dir-hint name version %load-path))
+ (primitive-load-path (in-vicinity dir-hint name) #f))
+ (set! didit #t)))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
(define (set-repl-prompt! v) (set! scm-repl-prompt v))
(define (default-pre-unwind-handler key . args)
- (save-stack 1)
+ ;; Narrow by two more frames: this one, and the throw handler.
+ (save-stack 2)
(apply throw key args))
(begin-deprecated
(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)))))))
-
- default-pre-unwind-handler)))
-
- (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))
+;; FIXME: stack-saved? is broken in the presence of threads.
(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))
- ((#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)))))
+ (if (not stack-saved?)
+ (begin
+ (let ((stacks (fluid-ref %stacks)))
+ (fluid-set! the-last-stack
+ ;; (make-stack obj inner outer inner outer ...)
+ ;;
+ ;; In this case, cut away the make-stack frame, the
+ ;; save-stack frame, and then narrow as specified by the
+ ;; user, delimited by the nearest start-stack invocation,
+ ;; if any.
+ (apply make-stack #t
+ 2
+ (if (pair? stacks) (cdar stacks) 0)
+ narrowing)))
+ (set! stack-saved? #t))))
(define before-error-hook (make-hook))
(define after-error-hook (make-hook))
(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))))
;;; The default repl-reader function. We may override this if we've
;;; the readline library.
(define repl-reader
- (lambda (prompt . reader)
- (display (if (string? prompt) prompt (prompt)))
+ (lambda* (prompt #:optional (reader (fluid-ref current-reader)))
+ (if (not (char-ready?))
+ (display (if (string? prompt) prompt (prompt))))
(force-output)
(run-hook before-read-hook)
- ((or (and (pair? reader) (car reader))
- (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)))
-
- (let ((status (error-catching-repl -read
- -eval
- -print)))
- (-quit status))))
+ ((or reader read) (current-input-port))))
\f
(if (memq 'prefix (read-options))
(error "boot-9 must be compiled with #:kw, not :kw")))
-(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)
- (:version #:version #t)))
- (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))))))
-
-(defmacro define-module args
- `(eval-when
- (eval load compile)
- (let ((m (process-define-module
- (list ,@(compile-define-module-args args)))))
- (set-current-module m)
- m)))
+;; FIXME: we really need to clean up the guts of the module system.
+;; We can compile to something better than process-define-module.
+(define-syntax define-module
+ (lambda (x)
+ (define (keyword-like? stx)
+ (let ((dat (syntax->datum stx)))
+ (and (symbol? dat)
+ (eqv? (string-ref (symbol->string dat) 0) #\:))))
+ (define (->keyword sym)
+ (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
+
+ (define (quotify-iface args)
+ (let loop ((in args) (out '()))
+ (syntax-case in ()
+ (() (reverse! out))
+ ;; The user wanted #:foo, but wrote :foo. Fix it.
+ ((sym . in) (keyword-like? #'sym)
+ (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
+ ((kw . in) (not (keyword? (syntax->datum #'kw)))
+ (syntax-violation 'define-module "expected keyword arg" x #'kw))
+ ((#:renamer renamer . in)
+ (loop #'in (cons* #'renamer #:renamer out)))
+ ((kw val . in)
+ (loop #'in (cons* #''val #'kw out))))))
+
+ (define (quotify 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 ((in args) (out '()))
+ (syntax-case in ()
+ (() (reverse! out))
+ ;; The user wanted #:foo, but wrote :foo. Fix it.
+ ((sym . in) (keyword-like? #'sym)
+ (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
+ ((kw . in) (not (keyword? (syntax->datum #'kw)))
+ (syntax-violation 'define-module "expected keyword arg" x #'kw))
+ ((#:no-backtrace . in)
+ (loop #'in (cons #:no-backtrace out)))
+ ((#:pure . in)
+ (loop #'in (cons #:pure out)))
+ ((kw)
+ (syntax-violation 'define-module "keyword arg without value" x #'kw))
+ ((use-module (name name* ...) . in)
+ (and (memq (syntax->datum #'use-module) '(#:use-module #:use-syntax))
+ (and-map symbol? (syntax->datum #'(name name* ...))))
+ (loop #'in
+ (cons* #''((name name* ...))
+ #'use-module
+ out)))
+ ((use-module ((name name* ...) arg ...) . in)
+ (and (memq (syntax->datum #'use-module) '(#:use-module #:use-syntax))
+ (and-map symbol? (syntax->datum #'(name name* ...))))
+ (loop #'in
+ (cons* #`(list '(name name* ...) #,@(quotify-iface #'(arg ...)))
+ #'use-module
+ out)))
+ ((#:autoload name bindings . in)
+ (loop #'in (cons* #''bindings #''name #:autoload out)))
+ ((kw val . in)
+ (loop #'in (cons* #''val #'kw out))))))
+
+ (syntax-case x ()
+ ((_ (name name* ...) arg ...)
+ (with-syntax (((quoted-arg ...) (quotify #'(arg ...))))
+ #'(eval-when (eval load compile expand)
+ (let ((m (process-define-module
+ (list '(name name* ...)
+ #:filename (assq-ref
+ (or (current-source-location) '())
+ 'filename)
+ quoted-arg ...))))
+ (set-current-module m)
+ 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.
(lambda ()
(module-use-interfaces! (current-module) interfaces)))))
-(defmacro use-modules modules
- `(eval-when
- (eval load compile)
- (process-use-modules
- (list ,@(map (lambda (m)
- `(list ,@(compile-interface-spec m)))
- modules)))
- *unspecified*))
-
-(defmacro use-syntax (spec)
- `(eval-when
- (eval load compile)
- (issue-deprecation-warning
- "`use-syntax' is deprecated. Please contact guile-devel for more info.")
- (process-use-modules (list (list ,@(compile-interface-spec spec))))
- *unspecified*))
+(define-syntax use-modules
+ (lambda (x)
+ (define (keyword-like? stx)
+ (let ((dat (syntax->datum stx)))
+ (and (symbol? dat)
+ (eqv? (string-ref (symbol->string dat) 0) #\:))))
+ (define (->keyword sym)
+ (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
+
+ (define (quotify-iface args)
+ (let loop ((in args) (out '()))
+ (syntax-case in ()
+ (() (reverse! out))
+ ;; The user wanted #:foo, but wrote :foo. Fix it.
+ ((sym . in) (keyword-like? #'sym)
+ (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
+ ((kw . in) (not (keyword? (syntax->datum #'kw)))
+ (syntax-violation 'define-module "expected keyword arg" x #'kw))
+ ((#:renamer renamer . in)
+ (loop #'in (cons* #'renamer #:renamer out)))
+ ((kw val . in)
+ (loop #'in (cons* #''val #'kw out))))))
+
+ (define (quotify specs)
+ (let lp ((in specs) (out '()))
+ (syntax-case in ()
+ (() (reverse out))
+ (((name name* ...) . in)
+ (and-map symbol? (syntax->datum #'(name name* ...)))
+ (lp #'in (cons #''((name name* ...)) out)))
+ ((((name name* ...) arg ...) . in)
+ (and-map symbol? (syntax->datum #'(name name* ...)))
+ (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...))))
+ (lp #'in (cons #`(list '(name name* ...) quoted-arg ...)
+ out)))))))
+
+ (syntax-case x ()
+ ((_ spec ...)
+ (with-syntax (((quoted-args ...) (quotify #'(spec ...))))
+ #'(eval-when (eval load compile expand)
+ (process-use-modules (list quoted-args ...))
+ *unspecified*))))))
+
+(define-syntax use-syntax
+ (syntax-rules ()
+ ((_ spec ...)
+ (begin
+ (eval-when (eval load compile expand)
+ (issue-deprecation-warning
+ "`use-syntax' is deprecated. Please contact guile-devel for more info."))
+ (use-modules spec ...)))))
+
+(include-from-path "ice-9/r6rs-libraries")
(define-syntax define-private
(syntax-rules ()
(module-add! public-i external-name var)))
names)))
+;; Export all local variables from a module
+;;
+(define (module-export-all! mod)
+ (define (fresh-interface!)
+ (let ((iface (make-module)))
+ (set-module-name! iface (module-name mod))
+ ;; for guile 2: (set-module-version! iface (module-version mod))
+ (set-module-kind! iface 'interface)
+ (set-module-public-interface! mod iface)
+ iface))
+ (let ((iface (or (module-public-interface mod)
+ (fresh-interface!))))
+ (set-module-obarray! iface (module-obarray mod))))
+
;; Re-export a imported variable
;;
(define (module-re-export! m names)
(module-add! public-i external-name var)))))
names)))
-(defmacro export names
- `(eval-when (eval load compile)
- (call-with-deferred-observers
- (lambda ()
- (module-export! (current-module) ',names)))))
+(define-syntax export
+ (syntax-rules ()
+ ((_ name ...)
+ (eval-when (eval load compile expand)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-export! (current-module) '(name ...))))))))
-(defmacro re-export names
- `(eval-when (eval load compile)
- (call-with-deferred-observers
- (lambda ()
- (module-re-export! (current-module) ',names)))))
+(define-syntax re-export
+ (syntax-rules ()
+ ((_ name ...)
+ (eval-when (eval load compile expand)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-re-export! (current-module) '(name ...))))))))
-(defmacro export-syntax names
- `(export ,@names))
+(define-syntax export-syntax
+ (syntax-rules ()
+ ((_ name ...)
+ (export name ...))))
-(defmacro re-export-syntax names
- `(re-export ,@names))
+(define-syntax re-export-syntax
+ (syntax-rules ()
+ ((_ name ...)
+ (re-export name ...))))
(define load load-module)
(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))))
+ (lambda* (init #:optional (converter identity))
+ (let ((fluid (make-fluid)))
(fluid-set! fluid (converter init))
(make fluid converter)))))
'(((ice-9 threads)))
'())))
;; load debugger on demand
- (module-autoload! guile-user-module '(ice-9 debugger) '(debug))
+ (module-autoload! guile-user-module '(system vm debug) '(debug))
;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see
;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have
;; no effect.
(let ((old-handlers #f)
- (start-repl (module-ref (resolve-interface '(system repl repl))
+ ;; We can't use @ here, as modules have been booted, but in Guile's
+ ;; build the srfi-1 helper lib hasn't been built yet, which will
+ ;; result in an error when (system repl repl) is loaded at compile
+ ;; time (to see if it is a macro or not).
+ (start-repl (module-ref (resolve-module '(system repl repl))
'start-repl))
(signals (if (provided? 'posix)
`((,SIGINT . "User interrupt")
;;; Place the user in the guile-user module.
;;;
-;;; FIXME: annotate ?
-;; (define (syncase exp)
-;; (with-fluids ((expansion-eval-closure
-;; (module-eval-closure (current-module))))
-;; (deannotate/source-properties (sc-expand (annotate exp)))))
-
;; FIXME:
(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
HCoop / bpt / guile.git / blobdiff