mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 16:50:21 +02:00
Code Activity

* srfi-1.scm (iota map for-each map-in-order list-index member

Browse source 
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.
This commit is contained in:
Mikael Djurfeldt 2003-03-10 23:18:05 +00:00
parent dbd6bd2910
commit f595ccfefc
9 changed files with 285 additions and 105 deletions
Download patch file Download diff file Expand all files Collapse all files

78
NEWS
View file

@ -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)
This will report an error if both (bar) and (baz) exports a binding
with the same name.
If you want the old behavior without changing your module headers, put
the line:
(default-module-duplicates-handler 'last)
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. 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.
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.
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.
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.
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.
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:

14
ice-9/ChangeLog
View file

@ -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.

223
ice-9/boot-9.scm
View file

@ -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)
@ -2710,6 +2737,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)))

11
ice-9/format.scm
View file

@ -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 ------------------------------------------------------------

8
ice-9/threads.scm
View file

@ -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))

6
oop/ChangeLog
View file

@ -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.

17
oop/goops.scm
View file

@ -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))))

5
srfi/ChangeLog
View file

@ -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

28
srfi/srfi-1.scm
View file

@ -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))