diff options
author | Andy Wingo <wingo@pobox.com> | 2019-11-29 11:51:29 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-11-29 11:51:29 +0100 |
commit | cf08dbdc189f0005cab6f2ec7b23ed9d150ec43d (patch) | |
tree | 8e0fb3579bbf5bd496f5c7e10b770e6c4287c6db /module | |
parent | 8304b15807debfb1aba6ef6510e42d6174a92215 (diff) | |
download | guile-cf08dbdc189f0005cab6f2ec7b23ed9d150ec43d.tar.gz |
Associate #:replace info with modules, not variables
* doc/ref/api-modules.texi (Creating Guile Modules): Document
#:re-export-and-replace.
* module/ice-9/boot-9.scm (module-replacements): New module field.
(make-module, make-autoload-interface): Initialize replacements to an
empty hash table.
(resolve-interface): Propagate replacement info when making custom
interfaces.
(define-module): Parse a #:re-export-and-replace keyword arg.
(define-module*): Handle #:re-export-and-replace.
(module-export!, module-re-export!): Add a keyword arg to indicate
whether to replace or not.
(module-replace!): Call module-export! with #:replace? #t.
(duplicate-handlers): Update replace duplicate handler to look for
replacement info on the interfaces.
* module/srfi/srfi-18.scm (srfi):
* module/srfi/srfi-34.scm (srfi): Update to #:re-export-and-replace
raise-continuable as raise.
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/boot-9.scm | 120 | ||||
-rw-r--r-- | module/srfi/srfi-18.scm | 4 | ||||
-rw-r--r-- | module/srfi/srfi-34.scm | 3 |
3 files changed, 67 insertions, 60 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index d89369252..c3d009213 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2464,7 +2464,8 @@ name extensions listed in %load-extensions." submodule-binder public-interface filename - next-unique-id))) + next-unique-id + (replacements #:no-setter)))) ;; make-module &opt size uses binder @@ -2489,7 +2490,8 @@ initial uses list, or binding procedure." (make-hash-table) '() (make-weak-key-hash-table) #f - (make-hash-table) #f #f #f 0)) + (make-hash-table) #f #f #f 0 + (make-hash-table))) @@ -3294,7 +3296,10 @@ error if selected binding does not exist in the used module." hide) (define (maybe-export! src dst var) (unless (memq src hide) - (module-add! custom-i (renamer dst) var))) + (let ((name (renamer dst))) + (when (hashq-ref (module-replacements public-i) src) + (hashq-set! (module-replacements custom-i) name #t)) + (module-add! custom-i name var)))) (cond (select (for-each @@ -3326,8 +3331,8 @@ error if selected binding does not exist in the used module." (define* (define-module* name #:key filename pure version (imports '()) (exports '()) - (replacements '()) (re-exports '()) (autoloads '()) - (duplicates #f) transformer declarative?) + (replacements '()) (re-exports '()) (re-export-replacements '()) + (autoloads '()) (duplicates #f) transformer declarative?) (define (list-of pred l) (or (null? l) (and (pair? l) (pred (car l)) (list-of pred (cdr l))))) @@ -3371,6 +3376,7 @@ error if selected binding does not exist in the used module." imports))) (module-use-interfaces! module imports))) (module-re-export! module re-exports) + (module-re-export! module re-export-replacements #:replace? #t) ;; FIXME: Avoid use of `apply'. (apply module-autoload! module autoloads) (let ((duplicates (or duplicates @@ -3421,7 +3427,7 @@ error if selected binding does not exist in the used module." #:warning "Failed to autoload ~a in ~a:\n" sym name)))) (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f (make-hash-table 0) '() (make-weak-value-hash-table) #f - (make-hash-table 0) #f #f #f 0))) + (make-hash-table 0) #f #f #f 0 (make-hash-table 0)))) (define (module-autoload! module . args) "Have @var{module} automatically load the module named @var{name} when one @@ -3768,7 +3774,7 @@ but it fails to load." ((kw val . in) (loop #'in (cons* #'val #'kw out)))))) - (define (parse args imp exp rex rep aut dec) + (define (parse args imp exp rex rep rxp aut dec) ;; 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 @@ -3780,58 +3786,61 @@ but it fails to load." (exp (if (null? exp) '() #`(#:exports '#,exp))) (rex (if (null? rex) '() #`(#:re-exports '#,rex))) (rep (if (null? rep) '() #`(#:replacements '#,rep))) + (rxp (if (null? rxp) '() #`(#:re-export-replacements '#,rxp))) (aut (if (null? aut) '() #`(#:autoloads '#,aut))) (dec (if dec '() #`(#:declarative? #,(user-modules-declarative?))))) - #`(#,@imp #,@exp #,@rex #,@rep #,@aut #,@dec))) + #`(#,@imp #,@exp #,@rex #,@rep #,@rxp #,@aut #,@dec))) ;; The user wanted #:foo, but wrote :foo. Fix it. ((sym . args) (keyword-like? #'sym) (parse #`(#,(->keyword (syntax->datum #'sym)) . args) - imp exp rex rep aut dec)) + imp exp rex rep rxp aut dec)) ((kw . args) (not (keyword? (syntax->datum #'kw))) (syntax-violation 'define-module "expected keyword arg" x #'kw)) ((#:no-backtrace . args) ;; Ignore this one. - (parse #'args imp exp rex rep aut dec)) + (parse #'args imp exp rex rep rxp aut dec)) ((#:pure . args) - #`(#:pure #t . #,(parse #'args imp exp rex rep aut dec))) + #`(#:pure #t . #,(parse #'args imp exp rex rep rxp aut dec))) ((kw) (syntax-violation 'define-module "keyword arg without value" x #'kw)) ((#:version (v ...) . args) - #`(#:version '(v ...) . #,(parse #'args imp exp rex rep aut dec))) + #`(#:version '(v ...) . #,(parse #'args imp exp rex rep rxp aut dec))) ((#:duplicates (d ...) . args) - #`(#:duplicates '(d ...) . #,(parse #'args imp exp rex rep aut dec))) + #`(#:duplicates '(d ...) . #,(parse #'args imp exp rex rep rxp aut dec))) ((#:filename f . args) - #`(#:filename 'f . #,(parse #'args imp exp rex rep aut dec))) + #`(#:filename 'f . #,(parse #'args imp exp rex rep rxp aut dec))) ((#:declarative? d . args) - #`(#:declarative? 'd . #,(parse #'args imp exp rex rep aut #t))) + #`(#:declarative? 'd . #,(parse #'args imp exp rex rep rxp aut #t))) ((#:use-module (name name* ...) . args) (and (and-map symbol? (syntax->datum #'(name name* ...)))) - (parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut dec)) + (parse #'args #`(#,@imp ((name name* ...))) exp rex rep rxp aut dec)) ((#:use-syntax (name name* ...) . args) (and (and-map symbol? (syntax->datum #'(name name* ...)))) #`(#:transformer '(name name* ...) . #,(parse #'args #`(#,@imp ((name name* ...))) exp rex - rep aut dec))) + rep rxp aut dec))) ((#:use-module ((name name* ...) arg ...) . args) (and (and-map symbol? (syntax->datum #'(name name* ...)))) (parse #'args #`(#,@imp ((name name* ...) #,@(parse-iface #'(arg ...)))) - exp rex rep aut dec)) + exp rex rep rxp aut dec)) ((#:export (ex ...) . args) - (parse #'args imp #`(#,@exp ex ...) rex rep aut dec)) + (parse #'args imp #`(#,@exp ex ...) rex rep rxp aut dec)) ((#:export-syntax (ex ...) . args) - (parse #'args imp #`(#,@exp ex ...) rex rep aut dec)) + (parse #'args imp #`(#,@exp ex ...) rex rep rxp aut dec)) ((#:re-export (re ...) . args) - (parse #'args imp exp #`(#,@rex re ...) rep aut dec)) + (parse #'args imp exp #`(#,@rex re ...) rep rxp aut dec)) ((#:re-export-syntax (re ...) . args) - (parse #'args imp exp #`(#,@rex re ...) rep aut dec)) + (parse #'args imp exp #`(#,@rex re ...) rep rxp aut dec)) ((#:replace (r ...) . args) - (parse #'args imp exp rex #`(#,@rep r ...) aut dec)) + (parse #'args imp exp rex #`(#,@rep r ...) rxp aut dec)) ((#:replace-syntax (r ...) . args) - (parse #'args imp exp rex #`(#,@rep r ...) aut dec)) + (parse #'args imp exp rex #`(#,@rep r ...) rxp aut dec)) + ((#:re-export-and-replace (r ...) . args) + (parse #'args imp exp rex rep #`(#,@rxp r ...) aut dec)) ((#:autoload name bindings . args) - (parse #'args imp exp rex rep #`(#,@aut name bindings) dec)) + (parse #'args imp exp rex rep rxp #`(#,@aut name bindings) dec)) ((kw val . args) (syntax-violation 'define-module "unknown keyword or bad argument" #'kw #'val)))) @@ -3840,7 +3849,7 @@ but it fails to load." ((_ (name name* ...) arg ...) (and-map symbol? (syntax->datum #'(name name* ...))) (with-syntax (((quoted-arg ...) - (parse #'(arg ...) '() '() '() '() '() #f)) + (parse #'(arg ...) '() '() '() '() '() '() #f)) ;; Ideally the filename is either a string or #f; ;; this hack is to work around a case in which ;; port-filename returns a symbol (`socket') for @@ -3941,27 +3950,20 @@ but it fails to load." ;; This function is called from "modules.c". If you change it, be ;; sure to update "modules.c" as well. -(define (module-export! m names) +(define* (module-export! m names #:key replace?) "Export a local variable." (let ((public-i (module-public-interface m))) (for-each (lambda (name) (let* ((internal-name (if (pair? name) (car name) name)) (external-name (if (pair? name) (cdr name) name)) (var (module-ensure-local-variable! m internal-name))) + (when replace? + (hashq-set! (module-replacements public-i) external-name #t)) (module-add! public-i external-name var))) names))) (define (module-replace! m names) - (let ((public-i (module-public-interface m))) - (for-each (lambda (name) - (let* ((internal-name (if (pair? name) (car name) name)) - (external-name (if (pair? name) (cdr name) name)) - (var (module-ensure-local-variable! m internal-name))) - ;; FIXME: use a bit on variables instead of object - ;; properties. - (set-object-property! var 'replace #t) - (module-add! public-i external-name var))) - names))) + (module-export! m names #:replace? #t)) (define (module-export-all! mod) "Export all local variables from a module." @@ -3976,20 +3978,24 @@ but it fails to load." (fresh-interface!)))) (set-module-obarray! iface (module-obarray mod)))) -(define (module-re-export! m names) +(define* (module-re-export! m names #:key replace?) "Re-export an imported variable." (let ((public-i (module-public-interface m))) - (for-each (lambda (name) - (let* ((internal-name (if (pair? name) (car name) name)) - (external-name (if (pair? name) (cdr name) name)) - (var (module-variable m internal-name))) - (cond ((not var) - (error "Undefined variable:" internal-name)) - ((eq? var (module-local-variable m internal-name)) - (error "re-exporting local variable:" internal-name)) - (else - (module-add! public-i external-name var))))) - names))) + (for-each + (lambda (name) + (let* ((internal-name (if (pair? name) (car name) name)) + (external-name (if (pair? name) (cdr name) name)) + (var (module-variable m internal-name))) + (cond + ((not var) + (error "Undefined variable:" internal-name)) + ((eq? var (module-local-variable m internal-name)) + (error "re-exporting local variable:" internal-name)) + (else + (when replace? + (hashq-set! (module-replacements public-i) external-name #t)) + (module-add! public-i external-name var))))) + names))) (define-syntax-rule (export name ...) (eval-when (expand load eval) @@ -4073,15 +4079,15 @@ but it fails to load." #f) (define (replace module name int1 val1 int2 val2 var val) - (let ((old (or (and var (object-property var 'replace) var) - (module-variable int1 name))) - (new (module-variable int2 name))) - (if (object-property old 'replace) - (and (or (eq? old new) - (not (object-property new 'replace))) + (let* ((replace1 (hashq-ref (module-replacements int1) name)) + (replace2 (hashq-ref (module-replacements int2) name)) + (old (or (and replace1 var) + (module-variable int1 name))) + (new (module-variable int2 name))) + (if replace1 + (and (or (eq? old new) (not replace2)) old) - (and (object-property new 'replace) - new)))) + (and replace2 new)))) (define (warn-override-core module name int1 val1 int2 val2 var val) (and (eq? int1 the-scm-module) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 6decb8ca4..79aedb8d1 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -76,8 +76,8 @@ terminated-thread-exception? uncaught-exception? uncaught-exception-reason) - #:re-export ((raise-continuable . raise) - with-exception-handler) + #:re-export (with-exception-handler) + #:re-export-and-replace ((raise-continuable . raise)) #:replace (current-time current-thread thread? diff --git a/module/srfi/srfi-34.scm b/module/srfi/srfi-34.scm index 0e7ad995d..4eb94b443 100644 --- a/module/srfi/srfi-34.scm +++ b/module/srfi/srfi-34.scm @@ -1,6 +1,6 @@ ;;; srfi-34.scm --- Exception handling for programs -;; Copyright (C) 2003, 2006, 2008, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2003, 2006, 2008, 2010, 2019 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 @@ -29,6 +29,7 @@ (define-module (srfi srfi-34) #:re-export (with-exception-handler (raise-exception . raise)) + #:re-export-and-replace ((raise-exception . raise)) #:export-syntax (guard)) (cond-expand-provide (current-module) '(srfi-34)) |