summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/modules.c10
-rw-r--r--module/ice-9/boot-9.scm208
2 files changed, 144 insertions, 74 deletions
diff --git a/libguile/modules.c b/libguile/modules.c
index fc6ff3b47..ccb68b709 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -242,8 +242,14 @@ scm_lookup_closure_module (SCM proc)
{
SCM mod;
- /* FIXME: The `module' property is no longer set. See
- `set-module-eval-closure!' in `boot-9.scm'. */
+ /* FIXME: The `module' property is no longer set on eval closures, as it
+ introduced 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 this
+ function, which has 1 caller), we no longer extend
+ `set-module-eval-closure!' to set the `module' property. */
abort ();
mod = scm_procedure_property (proc, sym_module);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 22ba8fbe0..3bc24f278 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -651,6 +651,7 @@ If there is no handler at all, Guile prints an error and then exits."
(and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
(define (make-record-type type-name fields . opt)
+ ;; Pre-generate constructors for nfields < 20.
(define-syntax make-constructor
(lambda (x)
(define *max-static-argument-count* 20)
@@ -1423,12 +1424,7 @@ If there is no handler at all, Guile prints an error and then exits."
;;;
;; 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)
@@ -1437,23 +1433,140 @@ If there is no handler at all, Guile prints an error and then exits."
(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.
+ ;;
+ (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)))
+
;; make-module &opt size uses binder
;;
@@ -1502,55 +1615,6 @@ If there is no handler at all, Guile prints an error and then exits."
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)
- )))