diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2003-03-10 23:18:05 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2003-03-10 23:18:05 +0000 |
commit | f595ccfefc8461eb49e1a02c8974bc4e2575a502 (patch) | |
tree | 63f1263164db911da30f9a70f708bb3948e7dfcc | |
parent | dbd6bd2910d5f49f97c0b53ce681b9fc448171b5 (diff) | |
download | guile-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-- | NEWS | 78 | ||||
-rw-r--r-- | ice-9/ChangeLog | 14 | ||||
-rw-r--r-- | ice-9/boot-9.scm | 223 | ||||
-rw-r--r-- | ice-9/format.scm | 11 | ||||
-rw-r--r-- | ice-9/threads.scm | 8 | ||||
-rw-r--r-- | oop/ChangeLog | 6 | ||||
-rw-r--r-- | oop/goops.scm | 17 | ||||
-rw-r--r-- | srfi/ChangeLog | 5 | ||||
-rw-r--r-- | srfi/srfi-1.scm | 28 |
9 files changed, 285 insertions, 105 deletions
@@ -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)) |