summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>2003-03-10 23:18:05 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>2003-03-10 23:18:05 +0000
commitf595ccfefc8461eb49e1a02c8974bc4e2575a502 (patch)
tree63f1263164db911da30f9a70f708bb3948e7dfcc
parentdbd6bd2910d5f49f97c0b53ce681b9fc448171b5 (diff)
downloadguile-f595ccfefc8461eb49e1a02c8974bc4e2575a502.tar.gz
* srfi-1.scm (iota map for-each map-in-order list-index member
delete delete! assoc): Marked as replacements. * goops.scm (define-extended-generics): New syntax. (<class> <operator-class> <entity-class> <entity>): Marked as replacements. * boot-9.scm (module-override!, make-mutable-parameter, lookup-duplicates-handlers, default-module-duplicates-handler): New functions. (process-duplicates): Don't call duplicates handlers for duplicate bindings of the same variable. (process-define-module): Process #:replace. (compile-interface-spec, resolve-interface): Process #:prefix. * format.scm (format): Marked as replacement. * threads.scm (future, future-ref): Marked as replacements.
-rw-r--r--NEWS78
-rw-r--r--ice-9/ChangeLog14
-rw-r--r--ice-9/boot-9.scm223
-rw-r--r--ice-9/format.scm11
-rw-r--r--ice-9/threads.scm8
-rw-r--r--oop/ChangeLog6
-rw-r--r--oop/goops.scm17
-rw-r--r--srfi/ChangeLog5
-rw-r--r--srfi/srfi-1.scm28
9 files changed, 285 insertions, 105 deletions
diff --git a/NEWS b/NEWS
index 67b7b6f54..0d1bd795e 100644
--- a/NEWS
+++ b/NEWS
@@ -63,31 +63,54 @@ debugging evaluator gives better error messages.
** Checking for duplicate bindings in module system
-The module system now can check for duplicate imported bindings.
-The syntax to enable this feature is:
+The module system now checks for duplicate imported bindings.
+
+The behavior can be controlled by specifying one or more duplicates
+handlers. For example, to get back the old behavior (which was to use
+the last imported binding of a certain name), write:
(define-module (foo)
:use-module (bar)
:use-module (baz)
- :duplicates check)
+ :duplicates last)
+
+If you want the old behavior without changing your module headers, put
+the line:
+
+ (default-module-duplicates-handler 'last)
-This will report an error if both (bar) and (baz) exports a binding
-with the same name.
+in your .guile init file.
The syntax for the :duplicates option is:
:duplicates HANDLER-NAME | (HANDLER1-NAME HANDLER2-NAME ...)
Specifying multiple handlers is useful since some handlers (such as
-merge-generics) can defer conflict resolution to others.
+replace) can defer conflict resolution to others. Each handler is
+tried until a binding is selected.
Currently available duplicates handlers are:
- check report an error for bindings with a common name
- first select the first encountered binding (override)
- last select the last encountered binding (override)
- merge-generics merge generic functions with a common name
- into an <extended-generic>
+ check report an error for bindings with a common name
+ warn issue a warning for bindings with a common name
+ replace replace bindings which have an imported replacement
+ warn-override-core issue a warning for imports which override core bindings
+ first select the first encountered binding (override)
+ last select the last encountered binding (override)
+ merge-generics merge generic functions with a common name
+ into an <extended-generic>
+
+The default duplicates handler is:
+
+ (replace warn-override-core check)
+
+** New define-module option: :replace
+
+:replace works as :export, but, in addition, marks the binding as a
+replacement.
+
+A typical example is `format' in (ice-9 format) which is a replacement
+for the core binding `format'.
** Merging generic functions
@@ -99,8 +122,9 @@ Assume that we work with a graphical package which needs to use two
independent vector packages for 2D and 3D vectors respectively. If
both packages export `x' we will encounter a name collision.
-This can now be resolved with the duplicates handler `merge-generics'
-which merges all generic functions with a common name:
+This can now be resolved automagically with the duplicates handler
+`merge-generics' which gives the module system license to merge all
+generic functions sharing a common name:
(define-module (math 2D-vectors)
:use-module (oop goops)
@@ -118,17 +142,27 @@ which merges all generic functions with a common name:
x in (my-module) will now share methods with x in both imported
modules.
-The detailed rule for method visibility is this:
+There will, in fact, now be three distinct generic functions named
+`x': x in (2D-vectors), x in (3D-vectors), and x in (my-module). The
+last function will be an <extended-generic>, extending the previous
+two functions.
+
+Let's call the imported generic functions the "ancestor functions". x
+in (my-module) is, in turn, a "descendant function" of the imported
+functions, extending its ancestors.
+
+For any generic function G, the applicable methods are selected from
+the union of the methods of the descendant functions, the methods of G
+itself and the methods of the ancestor functions.
-Let's call the imported generic functions the "ancestor functions".
-x in (my-module) is, in turn, a "descendant function" of the imported
-functions. For any generic function gf, the applicable methods are
-selected from the union of the methods of the descendant functions,
-the methods of gf and the methods of the ancestor functions.
+This, ancestor functions share methods with their descendants and vice
+versa. This implies that x in (math 2D-vectors) can will share the
+methods of x in (my-module) and vice versa, while x in (math 2D-vectors)
+doesn't share the methods of x in (math 3D-vectors), thus preserving
+modularity.
-This implies that x in (math 2D-vectors) can see the methods of x in
-(my-module) and vice versa, while x in (math 2D-vectors) doesn't see
-the methods of x in (math 3D-vectors), thus preserving modularity.
+Sharing is dynamic, so that adding new methods to a descendant implies
+adding it to the ancestor.
If duplicates checking is desired in the above example, the following
form of the :duplicates option can be used instead:
diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
index e91f82ce6..96eba46f9 100644
--- a/ice-9/ChangeLog
+++ b/ice-9/ChangeLog
@@ -1,3 +1,17 @@
+2003-03-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * boot-9.scm (module-override!, make-mutable-parameter,
+ lookup-duplicates-handlers, default-module-duplicates-handler):
+ New functions.
+ (process-duplicates): Don't call duplicates handlers for duplicate
+ bindings of the same variable.
+ (process-define-module): Process #:replace.
+ (compile-interface-spec, resolve-interface): Process #:prefix.
+
+ * format.scm (format): Marked as replacement.
+
+ * threads.scm (future, future-ref): Marked as replacements.
+
2003-03-07 Mikael Djurfeldt <djurfeldt@nada.kth.se>
These changes enables checking for duplicate imported bindings.
diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index daa9bf9ca..93b55d14b 100644
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -1601,7 +1601,9 @@
(set-module-name! interface (module-name module))
(set-module-kind! interface 'interface)
(set-module-public-interface! module interface)
- (set-module-duplicates-info! module (cons #f #f)))))
+ (set-module-duplicates-info!
+ module
+ (cons (default-module-duplicates-handler) #f)))))
(if (and (not (memq the-scm-module (module-uses module)))
(not (eq? module the-root-module)))
(set-module-uses! module
@@ -1677,7 +1679,13 @@
;; #:renamer RENAMER
;;
;; RENAMER is a procedure that takes a symbol and returns its new
-;; name. The default is to not perform any renaming.
+;; name. The default is to append a specified prefix (see below) or
+;; not perform any renaming.
+;;
+;; #:prefix PREFIX
+;;
+;; PREFIX is a symbol that will be appended to each exported name.
+;; The default is to not perform any renaming.
;;
;; Signal "no code for module" error if module name is not resolvable
;; or its public interface is not available. Signal "no binding"
@@ -1695,7 +1703,10 @@
def)))
(let* ((select (get-keyword-arg args #:select #f))
- (renamer (get-keyword-arg args #:renamer identity))
+ (renamer (or (get-keyword-arg args #:renamer #f)
+ (let ((prefix (get-keyword-arg args #:prefix #f)))
+ (and prefix (symbol-prefix-proc prefix)))
+ identity))
(module (resolve-module name))
(public-i (and module (module-public-interface module))))
(and (or (not module) (not public-i))
@@ -1740,11 +1751,13 @@
(let loop ((kws kws)
(reversed-interfaces '())
(exports '())
- (re-exports '()))
+ (re-exports '())
+ (replacements '()))
(if (null? kws)
(begin
(module-use-interfaces! module (reverse reversed-interfaces))
(module-export! module exports)
+ (module-replace! module replacements)
(module-re-export! module re-exports))
(case (car kws)
((#:use-module #:use-syntax)
@@ -1764,7 +1777,8 @@
(loop (cddr kws)
(cons interface reversed-interfaces)
exports
- re-exports)))
+ re-exports
+ replacements)))
((#:autoload)
(or (and (pair? (cdr kws)) (pair? (cddr kws)))
(unrecognized kws))
@@ -1774,40 +1788,44 @@
(caddr kws))
reversed-interfaces)
exports
- re-exports))
+ re-exports
+ replacements))
((#:no-backtrace)
(set-system-module! module #t)
- (loop (cdr kws) reversed-interfaces exports re-exports))
+ (loop (cdr kws) reversed-interfaces exports re-exports replacements))
((#:pure)
(purify-module! module)
- (loop (cdr kws) reversed-interfaces exports re-exports))
+ (loop (cdr kws) reversed-interfaces exports re-exports replacements))
((#:duplicates)
(if (not (pair? (cdr kws)))
(unrecognized kws))
(set-car! (module-duplicates-info module)
- (map (lambda (handler-name)
- (or (module-symbol-local-binding
- duplicate-handlers handler-name #f)
- (error "invalid duplicate handler name:"
- handler-name)))
- (if (list? (cadr kws))
- (cadr kws)
- (list (cadr kws)))))
- (loop (cddr kws) reversed-interfaces exports re-exports))
+ (lookup-duplicates-handlers (cadr kws)))
+ (loop (cddr kws) reversed-interfaces exports re-exports replacements))
((#:export #:export-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
(loop (cddr kws)
reversed-interfaces
(append (cadr kws) exports)
- re-exports))
+ re-exports
+ replacements))
((#:re-export #:re-export-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
(loop (cddr kws)
reversed-interfaces
exports
- (append (cadr kws) re-exports)))
+ (append (cadr kws) re-exports)
+ replacements))
+ ((#:replace #:replace-syntax)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (loop (cddr kws)
+ reversed-interfaces
+ exports
+ re-exports
+ (append (cadr kws) replacements)))
(else
(unrecognized kws)))))
(run-hook module-defined-hook module)
@@ -2533,6 +2551,7 @@
(define keys
;; sym key quote?
'((:select #:select #t)
+ (:prefix #:prefix #t)
(:renamer #:renamer #f)))
(if (not (pair? (car spec)))
`(',spec)
@@ -2674,6 +2693,14 @@
(module-add! public-i name var)))
names)))
+(define (module-replace! m names)
+ (let ((public-i (module-public-interface m)))
+ (for-each (lambda (name)
+ (let ((var (module-ensure-local-variable! m name)))
+ (set-object-property! var 'replace #t)
+ (module-add! public-i name var)))
+ names)))
+
;; Re-export a imported variable
;;
(define (module-re-export! m names)
@@ -2711,6 +2738,24 @@
(define load load-module)
+;;; {Parameters}
+;;;
+
+(define make-mutable-parameter
+ (let ((make (lambda (fluid converter)
+ (lambda args
+ (if (null? args)
+ (fluid-ref fluid)
+ (fluid-set! fluid (converter (car args))))))))
+ (lambda (init . converter)
+ (let ((fluid (make-fluid))
+ (converter (if (null? converter)
+ identity
+ (car converter))))
+ (fluid-set! fluid (converter init))
+ (make fluid converter)))))
+
+
;;; {Handling of duplicate imported bindings}
;;;
@@ -2734,26 +2779,77 @@
(define duplicate-handlers
(let ((m (make-module 7)))
+
+ (define (check module name int1 val1 int2 val2 var val)
+ (scm-error 'misc-error
+ #f
+ "~A: ~A imported from ~A and ~A"
+ (list (module-name module)
+ name
+ (module-name int1)
+ (module-name int2))
+ #f))
+
+ (define (warn module name int1 val1 int2 val2 var val)
+ (format #t
+ "~A: ~A imported from ~A and ~A\n"
+ (module-name module)
+ name
+ (module-name int1)
+ (module-name int2))
+ #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)))
+ old)
+ (and (object-property new 'replace)
+ new))))
+
+ (define (warn-override-core module name int1 val1 int2 val2 var val)
+ (and (eq? int1 the-scm-module)
+ (begin
+ (format #t
+ "WARNING: ~A: imported module ~A overrides core binding ~A\n"
+ (module-name module)
+ (module-name int2)
+ name)
+ (module-local-variable int2 name))))
+
+ (define (first module name int1 val1 int2 val2 var val)
+ (or var (module-local-variable int1 name)))
+
+ (define (last module name int1 val1 int2 val2 var val)
+ (module-local-variable int2 name))
+
(set-module-name! m 'duplicate-handlers)
(set-module-kind! m 'interface)
- (module-define! m 'check
- (lambda (module name int1 val1 int2 val2 var val)
- (scm-error 'misc-error
- #f
- "module ~A: duplicate binding ~A imported from ~A and ~A"
- (list (module-name module)
- name
- (module-name int1)
- (module-name int2))
- #f)))
- (module-define! m 'first
- (lambda (module name int1 val1 int2 val2 var val)
- (or var (module-local-variable int1 name))))
- (module-define! m 'last
- (lambda (module name int1 val1 int2 val2 var val)
- (module-local-variable int2 name)))
+ (module-define! m 'check check)
+ (module-define! m 'warn warn)
+ (module-define! m 'replace replace)
+ (module-define! m 'warn-override-core warn-override-core)
+ (module-define! m 'first first)
+ (module-define! m 'last last)
m))
+(define (lookup-duplicates-handlers handler-names)
+ (map (lambda (handler-name)
+ (or (module-symbol-local-binding
+ duplicate-handlers handler-name #f)
+ (error "invalid duplicate handler name:"
+ handler-name)))
+ (if (list? handler-names)
+ handler-names
+ (list handler-names))))
+
+(define default-module-duplicates-handler
+ (make-mutable-parameter '(replace warn-override-core check)
+ lookup-duplicates-handlers))
+
(define (make-duplicates-interface)
(let ((m (make-module)))
(set-module-kind! m 'interface)
@@ -2771,35 +2867,44 @@
(define (process-duplicates module interface)
(let* ((duplicates-info (module-duplicates-info module))
- (handlers (car duplicates-info))
- (d-interface (cdr duplicates-info)))
+ (duplicates-handlers (car duplicates-info))
+ (duplicates-interface (cdr duplicates-info)))
(module-for-each
(lambda (name var)
(let ((prev-interface (module-symbol-interface module name)))
(if prev-interface
- (begin
- (if (not d-interface)
+ (let ((var1 (module-local-variable prev-interface name))
+ (var2 (module-local-variable interface name)))
+ (if (not (eq? var1 var2))
(begin
- (set! d-interface (make-duplicates-interface))
- (set-cdr! duplicates-info d-interface)))
- (let* ((var (module-local-variable d-interface name))
- (val (and var (variable-bound? var) (variable-ref var))))
- (let loop ((handlers handlers))
- (cond ((null? handlers))
- (((car handlers)
- module
- name
- prev-interface
- (module-symbol-local-binding prev-interface name #f)
- interface
- (module-symbol-local-binding interface name #f)
- var
- val)
- =>
- (lambda (var)
- (module-add! d-interface name var)))
- (else
- (loop (cdr handlers))))))))))
+ (if (not duplicates-interface)
+ (begin
+ (set! duplicates-interface
+ (make-duplicates-interface))
+ (set-cdr! duplicates-info duplicates-interface)))
+ (let* ((var (module-local-variable duplicates-interface
+ name))
+ (val (and var
+ (variable-bound? var)
+ (variable-ref var))))
+ (let loop ((duplicates-handlers duplicates-handlers))
+ (cond ((null? duplicates-handlers))
+ (((car duplicates-handlers)
+ module
+ name
+ prev-interface
+ (and (variable-bound? var1)
+ (variable-ref var1))
+ interface
+ (and (variable-bound? var2)
+ (variable-ref var2))
+ var
+ val)
+ =>
+ (lambda (var)
+ (module-add! duplicates-interface name var)))
+ (else
+ (loop (cdr duplicates-handlers))))))))))))
interface)))
diff --git a/ice-9/format.scm b/ice-9/format.scm
index e84c2f6d4..efb7c16a5 100644
--- a/ice-9/format.scm
+++ b/ice-9/format.scm
@@ -14,12 +14,11 @@
(define-module (ice-9 format)
:use-module (ice-9 and-let-star)
:use-module (ice-9 threads)
- :autoload (ice-9 pretty-print) (pretty-print))
-
-(export format
- format:symbol-case-conv
- format:iobj-case-conv
- format:expch)
+ :autoload (ice-9 pretty-print) (pretty-print)
+ :replace (format)
+ :export (format:symbol-case-conv
+ format:iobj-case-conv
+ format:expch))
;;; Configuration ------------------------------------------------------------
diff --git a/ice-9/threads.scm b/ice-9/threads.scm
index 32c5a153d..74cd6e4ed 100644
--- a/ice-9/threads.scm
+++ b/ice-9/threads.scm
@@ -57,18 +57,18 @@
;;; Code:
(define-module (ice-9 threads)
- :export (future-ref
- par-map
+ :export (par-map
par-for-each
n-par-map
n-par-for-each)
+ :re-export (future-ref)
:export-syntax (begin-thread
- future
parallel
letpar
make-thread
with-mutex
- monitor))
+ monitor)
+ :re-export-syntax (future))
diff --git a/oop/ChangeLog b/oop/ChangeLog
index 04275d90f..e7aaa9673 100644
--- a/oop/ChangeLog
+++ b/oop/ChangeLog
@@ -1,3 +1,9 @@
+2003-03-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.scm (define-extended-generics): New syntax.
+ (<class> <operator-class> <entity-class> <entity>): Marked as
+ replacements.
+
2003-03-07 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops.scm (equal?): Define default method.
diff --git a/oop/goops.scm b/oop/goops.scm
index 71f0dae33..a840eb699 100644
--- a/oop/goops.scm
+++ b/oop/goops.scm
@@ -53,7 +53,7 @@
(define-module (oop goops)
:export-syntax (define-class class
define-generic define-accessor define-method
- define-extended-generic
+ define-extended-generic define-extended-generics
method)
:export (goops-version is-a?
ensure-metaclass ensure-metaclass-with-supers
@@ -97,6 +97,7 @@
primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition
slot-exists? make find-method get-keyword)
+ :replace (<class> <operator-class> <entity-class> <entity>)
:re-export (class-of) ;; from (guile)
:no-backtrace)
@@ -383,6 +384,20 @@
(goops-error "missing expression"))
(else
`(define ,name (make-extended-generic ,(caddr exp) ',name))))))))
+(define define-extended-generics
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((names (cadr exp))
+ (prefixes (get-keyword #:prefix (cddr exp) #f)))
+ (if prefixes
+ `(begin
+ ,@(map (lambda (name)
+ `(define-extended-generic ,name
+ (list ,@(map (lambda (prefix)
+ (symbol-append prefix name))
+ prefixes))))
+ names))
+ (goops-error "no prefixes supplied"))))))
(define (make-generic . name)
(let ((name (and (pair? name) (car name))))
diff --git a/srfi/ChangeLog b/srfi/ChangeLog
index 97401db1c..638bd828e 100644
--- a/srfi/ChangeLog
+++ b/srfi/ChangeLog
@@ -1,3 +1,8 @@
+2003-03-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * srfi-1.scm (iota map for-each map-in-order list-index member
+ delete delete! assoc): Marked as replacements.
+
2003-03-06 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* srfi-1.c (scm_init_srfi_1): Extend root module map and for-each
diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm
index fe6e7abe9..98ffeb46f 100644
--- a/srfi/srfi-1.scm
+++ b/srfi/srfi-1.scm
@@ -1,6 +1,6 @@
;;; srfi-1.scm --- List Library
-;; Copyright (C) 2001, 2002 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@@ -59,9 +59,8 @@
(define-module (srfi srfi-1)
:use-module (ice-9 session)
- :use-module (ice-9 receive))
-
-(export
+ :use-module (ice-9 receive)
+ :export (
;;; Constructors
;; cons <= in the core
;; list <= in the core
@@ -71,7 +70,7 @@
list-tabulate
;; list-copy <= in the core
circular-list
- iota ; Extended.
+ ;; iota ; Extended.
;;; Predicates
proper-list?
@@ -165,12 +164,12 @@
reduce-right
unfold
unfold-right
- map ; Extended.
- for-each ; Extended.
+ ;; map ; Extended.
+ ;; for-each ; Extended.
append-map
append-map!
map!
- map-in-order ; Extended.
+ ;; map-in-order ; Extended.
pair-for-each
filter-map
@@ -194,19 +193,19 @@
break!
any
every
- list-index ; Extended.
- member ; Extended.
+ ;; list-index ; Extended.
+ ;; member ; Extended.
;; memq <= in the core
;; memv <= in the core
;;; Deletion
- delete ; Extended.
- delete! ; Extended.
+ ;; delete ; Extended.
+ ;; delete! ; Extended.
delete-duplicates
delete-duplicates!
;;; Association lists
- assoc ; Extended.
+ ;; assoc ; Extended.
;; assq <= in the core
;; assv <= in the core
alist-cons
@@ -233,6 +232,9 @@
;; set-car! <= in the core
;; set-cdr! <= in the core
)
+ :replace (iota map for-each map-in-order list-index member
+ delete delete! assoc)
+ )
(cond-expand-provide (current-module) '(srfi-1))