mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

module-type defined programmatically

Browse source 
* module/ice-9/boot-9.scm (make-record-type): Add an explanatory
  comment.
  (%print-module): Remove a hacky comment about redefinitions being
  difficult, because now the module-printer is called by name from
  module-type's printer.
  (module-type): Define the module type, its constructor, predicate, and
  accessors programmatically, at expansion time. Should reduce any
  errors in transcription, between adding fields and adding accessors.

* libguile/modules.c (scm_lookup_closure_module): Move an explanatory
  comment here from boot-9.scm.
This commit is contained in:
Andy Wingo 2010-04-20 12:34:05 +02:00
parent e31f22ebf0
commit 31ac29b621
2 changed files with 144 additions and 74 deletions
Download patch file Download diff file Expand all files Collapse all files

10
libguile/modules.c
View file

@ -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);

208
module/ice-9/boot-9.scm
View file

@ -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)
)))