[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-10-45-gcb
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-10-45-gcb67c83 |
|
Date: |
Thu, 22 Apr 2010 13:48:12 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=cb67c838f5658a74793f593c342873d32e4a145c
The branch, master has been updated
via cb67c838f5658a74793f593c342873d32e4a145c (commit)
via bbd1d13333ad095cc7f0324a0dd3e9ee0d4703ad (commit)
via dbbbc2a1d07cff63e5f979a125ec6394c6833c07 (commit)
via c9904ab0406d0bf3415696f319760f67b218a638 (commit)
via 30ce621c5ac9b67420a9f159b2195f6cd682e237 (commit)
via 53ab624703ec6795a56c0f098a169117dd51bb66 (commit)
via 31ac29b621a7ab06076ffc8b756d2510ec95141b (commit)
via e31f22ebf0af5685636ec6a4416e3384bab740fd (commit)
via 51797cec094d642600e9f86c517eb5a6883f5358 (commit)
from 22457d5730b2d5302c55a8f1f4c07470be975021 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit cb67c838f5658a74793f593c342873d32e4a145c
Author: Andy Wingo <address@hidden>
Date: Thu Apr 22 15:25:09 2010 +0200
deprecate %app
* module/ice-9/boot-9.scm (module-name): Don't rely on (%app modules),
use other tricks to name anonymous modules.
(resolve-module): Instead of relying on %app, close over the root of
the module hierarchy -- the module that was '(%app modules).
* module/ice-9/deprecated.scm (%app): Provide a compatible %app shim.
commit bbd1d13333ad095cc7f0324a0dd3e9ee0d4703ad
Author: Andy Wingo <address@hidden>
Date: Tue Apr 20 14:53:38 2010 +0200
refactorings for the module boot process
* module/ice-9/boot-9.scm (%app): Bind %app and (%app modules) within
the nested hierarchy before making (guile).
(the-root-module): Define to '(%app modules guile) together with
the-root-module's definition.
(resolve-module): Define a "phase 2" resolve-module that only works on the
root module.
(try-module-autoload): No need for stub definition, as modules.c does
not reference this binding.
(resolve-module): Redefine, after modules have been loaded, to
actually do its job, without any hacks for the pre-boot phase.
Move up the boot code before the definition of resolve-module's
helpers.
commit dbbbc2a1d07cff63e5f979a125ec6394c6833c07
Author: Andy Wingo <address@hidden>
Date: Tue Apr 20 13:42:21 2010 +0200
add comments to resolve-module
* module/ice-9/boot-9.scm (resolve-module): Add comments.
commit c9904ab0406d0bf3415696f319760f67b218a638
Author: Andy Wingo <address@hidden>
Date: Tue Apr 20 13:41:41 2010 +0200
formally deprecate `app'
* module/ice-9/deprecated.scm (app): Deprecate.
* module/ice-9/boot-9.scm: Remove app definition.
commit 30ce621c5ac9b67420a9f159b2195f6cd682e237
Author: Andy Wingo <address@hidden>
Date: Thu Apr 22 15:08:13 2010 +0200
(app modules) -> (%app modules)
* module/ice-9/debugging/breakpoints.scm (module-if-already-loaded):
(all-loaded-modules):
* module/oop/goops/stklos.scm: Fix instances of (app modules) to be
(%app modules).
commit 53ab624703ec6795a56c0f098a169117dd51bb66
Author: Andy Wingo <address@hidden>
Date: Tue Apr 20 12:42:38 2010 +0200
fix comment about "local-define" and "local-remove".
* module/ice-9/boot-9.scm: Fix comment about "local-define!", whereas
it's "local-define". Same for "local-remove".
commit 31ac29b621a7ab06076ffc8b756d2510ec95141b
Author: Andy Wingo <address@hidden>
Date: Tue Apr 20 12:34:05 2010 +0200
module-type defined programmatically
* 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.
commit e31f22ebf0af5685636ec6a4416e3384bab740fd
Author: Andy Wingo <address@hidden>
Date: Mon Apr 19 20:19:24 2010 +0200
avoid primitive-eval in record-constructor
* module/ice-9/boot-9.scm (record-type-vtable): Add a third field, a
precomputed constructor. There is an unfortunate circularity here,
though.
(make-record-type): If the record has fewer than 20 fields,
return a constructor pre-generated to suit. Otherwise just check the
length, and dispatch to `apply' and not `primitive-eval'. FWIW the
current module record has something like 12 fields.
(record-constructor): If we're asking for the standard constructor,
return the precomputed constructor.
commit 51797cec094d642600e9f86c517eb5a6883f5358
Author: Andy Wingo <address@hidden>
Date: Mon Apr 19 19:33:57 2010 +0200
make-record-type slight refactor
* test-suite/tests/records.test ("records"): Add tests for printers.
* module/ice-9/boot-9.scm (make-record-type): Refactor the code that
makes the default printer.
-----------------------------------------------------------------------
Summary of changes:
libguile/modules.c | 10 +-
module/ice-9/boot-9.scm | 471 +++++++++++++++++++------------
module/ice-9/debugging/breakpoints.scm | 6 +-
module/ice-9/deprecated.scm | 12 +-
module/oop/goops/stklos.scm | 4 +-
test-suite/tests/records.test | 26 ++-
6 files changed, 334 insertions(+), 195 deletions(-)
diff --git a/libguile/modules.c b/libguile/modules.c
index fc6ff3b..ccb68b7 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 4beec1e..6a36ea4 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -634,9 +634,11 @@ If there is no handler at all, Guile prints an error and
then exits."
(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))
@@ -649,33 +651,72 @@ 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)
- (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)))
+ ;; 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 (and (pair? opt) (car opt))
+ 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)
@@ -688,14 +729,16 @@ If there is no handler at all, Guile prints an error and
then exits."
(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)))))))
+ (if (null? opt)
+ (struct-ref rtd (+ 2 vtable-offset-user))
+ (let ((field-names (car opt)))
+ (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)))))
@@ -1381,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)
@@ -1395,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
;;
@@ -1460,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)
- )))
@@ -1991,8 +2097,8 @@ If there is no handler at all, Guile prints an error and
then exits."
;;;
;;; 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-define name val == nested-define! (current-module) name
val
+;;; local-remove name == nested-remove! (current-module) name
;;;
@@ -2033,14 +2139,12 @@ If there is no handler at all, Guile prints an error
and then exits."
-;;; {The (%app) module}
+;;; {The (guile) module}
;;;
-;;; The root of conventionally named objects not directly in the top level.
-;;;
-;;; (%app modules)
-;;; (%app modules guile)
-;;;
-;;; The directory of all modules and the standard root module.
+;;; 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.
@@ -2057,8 +2161,47 @@ If there is no handler at all, Guile prints an error and
then exits."
(set-system-module! the-root-module #t)
(set-system-module! the-scm-module #t)
-;; NOTE: This binding is used in libguile/modules.c.
+
+
+
+;; 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)
+
+
+
+
+;; 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! (resolve-module '() #f) name mod)
+ (accessor mod))))))
+
(define (make-modules-in module name)
(if (null? name)
module
@@ -2194,70 +2337,34 @@ If there is no handler at all, Guile prints an error
and then exits."
;; 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)
-
-(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))))))
+ (let ((root (make-module)))
+ (set-module-name! root '())
+ ;; Define the-root-module as '(guile).
+ (module-define! root 'guile the-root-module)
+
+ (lambda (name . args) ;; #:optional (autoload #t) (version #f)
+ (let* ((already (nested-ref root 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 root name)))))))
-;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
(define (try-load-module name version)
(try-module-autoload name version))
diff --git a/module/ice-9/debugging/breakpoints.scm
b/module/ice-9/debugging/breakpoints.scm
index 0690699..7293c8e 100644
--- a/module/ice-9/debugging/breakpoints.scm
+++ b/module/ice-9/debugging/breakpoints.scm
@@ -1,6 +1,6 @@
;;;; (ice-9 debugging breakpoints) -- practical breakpoints
-;;; Copyright (C) 2005 Neil Jerram
+;;; Copyright (C) 2005, 2010 Neil Jerram
;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -253,7 +253,7 @@
;; If a module named MODULE-NAME has been loaded, return its module
;; object; otherwise return #f.
(define (module-if-already-loaded module-name)
- (nested-ref the-root-module (append '(app modules) module-name)))
+ (nested-ref the-root-module (append '(%app modules) module-name)))
;; Construct and return a list of all loaded modules.
(define (all-loaded-modules)
@@ -290,7 +290,7 @@
ds)))
;; Add submodules recursively, starting from the root of all
;; modules.
- (add-submodules-of '(app modules))
+ (add-submodules-of '(%app modules))
;; Return the result.
known-modules)
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 02ba537..5c43b2f 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -38,7 +38,9 @@
$tanh
closure?
%nil
- @bind))
+ @bind
+ %app
+ app))
;;;; Deprecated definitions.
@@ -296,3 +298,11 @@
(lambda () b0 b1 ...)
(lambda ()
(set! id old-v) ...)))))))))
+
+;; Define (%app modules)
+(define %app (make-module 31))
+(set-module-name! %app '(%app))
+(nested-define! %app '(modules) (resolve-module '() #f))
+
+;; app aliases %app
+(define app %app)
diff --git a/module/oop/goops/stklos.scm b/module/oop/goops/stklos.scm
index 835969f..718635e 100644
--- a/module/oop/goops/stklos.scm
+++ b/module/oop/goops/stklos.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 1999,2002, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999,2002, 2006, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -35,7 +35,7 @@
;; Export all bindings that are exported from (oop goops)...
(module-for-each (lambda (sym var)
(module-add! %module-public-interface sym var))
- (nested-ref the-root-module '(app modules oop goops
+ (nested-ref the-root-module '(%app modules oop goops
%module-public-interface)))
;; ...but replace the following bindings:
diff --git a/test-suite/tests/records.test b/test-suite/tests/records.test
index 7f8e636..c2ea06e 100644
--- a/test-suite/tests/records.test
+++ b/test-suite/tests/records.test
@@ -1,6 +1,6 @@
;;;; records.test --- Test suite for Guile's records. -*- mode: scheme;
coding: utf-8 -*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -17,10 +17,13 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-records)
+ #:use-module (ice-9 format)
#:use-module (test-suite lib))
-;; ascii names and symbols
-(define rtd-foo (make-record-type "foo" '(x y)))
+;; ascii names and symbols, custom printer
+(define rtd-foo (make-record-type "foo" '(x y)
+ (lambda (s p)
+ (display "#<it is a foo>" p))))
(define make-foo (record-constructor rtd-foo))
(define foo? (record-predicate rtd-foo))
(define get-foo-x (record-accessor rtd-foo 'x))
@@ -28,7 +31,7 @@
(define set-foo-x! (record-modifier rtd-foo 'x))
(define set-foo-y! (record-modifier rtd-foo 'y))
-;; non-Latin-1 names and symbols
+;; non-Latin-1 names and symbols, default printer
(define rtd-fÅÅ (make-record-type "fÅÅ" '(x ȳ)))
(define make-fÅÅ (record-constructor rtd-fÅÅ))
(define fÅÅ? (record-predicate rtd-fÅÅ))
@@ -71,4 +74,17 @@
(string=? "foo" (record-type-name rtd-foo)))
(pass-if "fÅÅ"
- (string=? "fÅÅ" (record-type-name rtd-fÅÅ)))))
+ (string=? "fÅÅ" (record-type-name rtd-fÅÅ))))
+
+ (with-test-prefix "printer"
+
+ (pass-if "foo"
+ (string=? "#<it is a foo>"
+ (with-output-to-string
+ (lambda () (display (make-foo 1 2))))))
+
+ (pass-if "fÅÅ"
+ (with-locale "en_US.utf8"
+ (string-prefix? "#<fÅÅ"
+ (with-output-to-string
+ (lambda () (display (make-fÅÅ 1 2)))))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-10-45-gcb67c83,
Andy Wingo <=