[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Associate #:replace info with modules, not variab
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Associate #:replace info with modules, not variables |
|
Date: |
Fri, 29 Nov 2019 05:55:33 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit cf08dbdc189f0005cab6f2ec7b23ed9d150ec43d
Author: Andy Wingo <address@hidden>
Date: Fri Nov 29 11:51:29 2019 +0100
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.
---
doc/ref/api-modules.texi | 5 ++
module/ice-9/boot-9.scm | 120 +++++++++++++++++++++++++----------------------
module/srfi/srfi-18.scm | 4 +-
module/srfi/srfi-34.scm | 3 +-
4 files changed, 72 insertions(+), 60 deletions(-)
diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi
index d73df46..2334378 100644
--- a/doc/ref/api-modules.texi
+++ b/doc/ref/api-modules.texi
@@ -354,6 +354,11 @@ in the module body.
The @code{#:duplicates} (see below) provides fine-grain control about
duplicate binding handling on the module-user side.
+@item #:re-export-and-replace @var{list}
+@cindex re-export-and-replace
+Like @code{#:re-export}, but also marking the bindings as replacements
+in the sense of @code{#:replace}.
+
@item #:version @var{list}
@cindex module version
Specify a version for the module in the form of @var{list}, a list of
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index d893692..c3d0092 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 6decb8c..79aedb8 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 0e7ad99..4eb94b4 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))