New module language from S48 0.57.

scheme/bcomp/interface.scm

@@ -1,7 +1,19 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
 
 ; Interfaces
+;
+; An interface has four fields:
+;   - A procedure for looking up names in the interface.  The procedure
+;     returns a base name and a type.  If the name is not exported the
+;     base name is #F.
+;   - A procedure for walking over the declarations in the interfaces.
+;     The name, base-name, and type of each exported name are passed
+;     to the action procedure.
+;   - A population containing the structures that export this interface and
+;     any compound or modified interfaces that build on it.  This population
+;     is used for propogating changes when an interface or structure is
+;     redefined.
+;   - A name for debugging.
 
 (define-record-type interface :interface
   (really-make-interface ref walk clients name)
@@ -12,23 +24,8 @@
   (name interface-name set-interface-name!))
 
 (define-record-discloser :interface
-  (lambda (int) (list 'interface (interface-name int))))
+  (lambda (int)
-
+    (list 'interface (interface-name int))))
-(define (interface-ref int name)
-  ((ref-method int) name))
-
-(define (for-each-declaration proc int)
-  ((walk-method int) proc))
-
-(define (note-reference-to-interface! int thing)
-  (let ((pop (interface-clients int)))
-    (if pop
-	(add-to-population! thing pop)
-	;; If it's compound, we really ought to descend into its components
-	)))
-
-; If name is #f, then the interface is anonymous, so we don't need to
-; make a population.
 
 (define (make-interface ref walk name)
   (really-make-interface ref
@@ -36,16 +33,64 @@
 			 (make-population)
 			 name))
 
-; Simple interfaces (export (name type) ...)
+; The generic lookup function, and a simplified version for use when the
+; base name and type are not needed.
+
+(define (interface-ref int name)
+  ((ref-method int) name))
+
+(define (interface-member? int name)
+  (mvlet (((base-name type)
+	     (interface-ref int name)))
+    base-name))
+
+; The generic walk function.
+
+(define (for-each-declaration proc int)
+  ((walk-method int) proc))
+
+; Adding to the client population.
+
+(define (note-reference-to-interface! int thing)
+  (let ((pop (interface-clients int)))
+    (if pop
+	(add-to-population! thing pop))))
+
+; Adding a late name.
+
+(define (note-interface-name! int name)
+  (if (and name (not (interface-name int)))
+      (set-interface-name! int name)))
+
+;----------------
+; Simple interfaces.  ITEMS is a list of items of the form:
+;  - <name>			; use the default type
+;  - (<name> <type>)		; use <type>
+;  - ((<name> ...) <type>)	; use <type> for each <name>
+;
+; We make a table of the names and use it appropriately.
 
 (define (make-simple-interface name items)
+  (let ((table (make-simple-interface-table items)))
+    (make-interface (lambda (name)
+		      (let ((type (table-ref table name)))
+			(if type
+			    (values name type)
+			    (values #f #f))))
+		    (lambda (proc)
+		      (table-walk (lambda (name type)
+				    (proc name name type))
+				  table))
+		    name)))
+
+(define (make-simple-interface-table items)
   (let ((table (make-symbol-table)))
     (for-each (lambda (item)
 		(if (pair? item)
 		    (let ((name (car item))
 			  (type (cadr item)))
-		      (if (or (null? name) (pair? name))
+		      (if (or (null? name)
-			  ;; Allow ((name1 name2 ...) type)
+			      (pair? name))
 			  (for-each (lambda (name)
 				      (table-set! table name type))
 				    name)
@@ -53,35 +98,309 @@
 		    (table-set! table item undeclared-type)))
 	      items)
     (make-table-immutable! table)
-    (really-make-simple-interface table name)))
+    table))
 
-(define (really-make-simple-interface table name)
+;----------------
-  (make-interface (lambda (name) (table-ref table name))
+; Compound interfaces
-		  (lambda (proc) (table-walk proc table))
+;
-		  name))
+; A compound interface is the union of a set of existing interfaces.
-
+; To do lookups or walks we walk down the list of included interfaces.
-
-; Compoune interfaces
 
 (define (make-compound-interface name . ints)
-  (let ((int
+  (let ((int (make-interface (lambda (name)
-	 (make-interface (lambda (name)
+			       (let loop ((ints ints))
-			   (let loop ((ints ints))
+				 (if (null? ints)
-			     (if (null? ints)
+				     (values #f #f)
-				 #f
+				     (mvlet (((new-name type)
-				 (or (interface-ref (car ints) name)
+					      (interface-ref (car ints) name)))
-				     (loop (cdr ints))))))
+					    (if new-name
-			 (lambda (proc)
+						(values new-name type)
-			   (for-each (lambda (int)
+						(loop (cdr ints)))))))
-				       (for-each-declaration proc int))
+			     (lambda (proc)
-				     ints))
+			       (for-each (lambda (int)
-			 name)))
+					   (for-each-declaration proc int))
+					 ints))
+			     name)))
     (for-each (lambda (i)
 		(note-reference-to-interface! i int))
 	      ints)
     int))
 
+;----------------
+; Modified interfaces.
+;
+; We return a new interface that is INTERFACE modified by COMMANDS.  Commands
+; are:
+;  (prefix <symbol>)
+;      Add <symbol> to the beginning of every name in INTERFACE.
+;  (expose <symbol> ...)
+;      Export only those names in INTERFACE that are listed.
+;  (hide <symbol> ...)
+;      Do not export any of the names listed.
+;  (alias (<old> <new>) ...)
+;      Make name <old> also visible as <new>.
+;  (rename (<old> <new>) ...)
+;      Make name <old> visible as <new> but not as <old>.
+; The commands are interpreted last-to-first.  Thus
+;  ((expose foo:bar) (prefix foo:))
+; and
+;  ((prefix foo:) (expose bar))
+; both make BAR visible as FOO:BAR but
+;  ((expose bar) (prefix foo:))
+; does not allow any names to be seen.
+
+(define (make-modified-interface interface commands)
+  (if (and (proper-list? commands)
+	   (every okay-command? commands))
+      (mvlet (((alist hidden default)
+	         (process-commands commands)))
+	(let ((lookup (make-lookup alist hidden default interface))
+	      (walker (if default
+			  (make-default-walker alist hidden default interface)
+			  (make-alist-walker alist interface))))
+	  (let ((int (make-interface lookup walker #f)))
+	    (note-reference-to-interface! interface int)
+	    int)))
+      (error "badly-formed structure modifiers" commands)))
+
+; We process COMMANDS and compute three values:
+;   - an alist mapping visible names to their real names in the package
+;   - a list of names that are hidden (these may also appear in the alist;
+;     the hiding overrides the alist).      
+;   - a default, which applies to all other names:
+;         = #f, there are no other visible names
+;         = #t, all other names are visible
+;         = <symbol>, names beginning with this prefix are visible
+;
+; We just loop over the commands, dispatching on the type of command.
+
+(define (process-commands commands)
+  (let loop ((alist '())
+	     (hidden '())
+	     (default #t)
+	     (commands (reverse commands)))
+    (if (null? commands)
+	(values (filter (lambda (pair)
+			  (not (memq (car pair) hidden)))
+			alist)
+		hidden
+		default)
+	(mvlet (((alist hidden default)
+		   (let ((proc (case (caar commands)
+				 ((prefix) process-prefix)
+				 ((expose) process-expose)
+				 ((hide)   process-hide)
+				 ((alias)  process-alias)
+				 ((rename) process-rename))))
+		     (proc (cdar commands) alist hidden default))))
+	  (loop alist hidden default (cdr commands))))))
+
+; Checks that COMMAND is properly formed.
+
+(define (okay-command? command)
+  (and (proper-list? command)
+       (pair? command)
+       (symbol? (car command))
+       (pair? (cdr command))
+       (let ((args (cdr command)))
+	 (case (car command)
+	   ((prefix)
+	    (and (symbol? (car args))
+		 (null? (cdr args))))
+	   ((expose hide)
+	    (every symbol? args))
+	   ((alias rename)
+	    (every (lambda (spec)
+		     (and (proper-list? spec)
+			  (= 2 (length spec))
+			  (symbol? (car spec))
+			  (symbol? (cadr spec))))
+		   args))
+	   (else
+	    #f)))))
+
+; Checks that L is a proper list.
+
+(define (proper-list? l)
+  (cond ((null? l)
+	 #t)
+	((pair? l)
+	 (proper-list? (cdr l)))
+	(else
+	 #f)))
+
+; We add the prefix to the names in ALIST and HIDDEN.  If DEFAULT is already
+; a prefix we add this one to it, otherwise the prefix is the new default.
+
+(define (process-prefix args alist hidden default)	     
+  (let ((prefix (car args)))
+    (values (map (lambda (pair)
+		   (cons (symbol-append prefix (car pair))
+			 (cdr pair)))
+		 alist)
+	    (map (lambda (name)
+		   (symbol-append prefix name))
+		 hidden)
+	    (cond ((symbol? default)
+		   (symbol-append default prefix))
+		  ((not default)
+		   #f)
+		  (else
+		   prefix)))))
+
+; We make a new ALIST with the exposed names and with package names are looked
+; up in the current state.  Then we start again with no hidden names and no
+; default.
+
+(define (process-expose args alist hidden default)	     
+  (values (let loop ((args args) (new-alist '()))
+	    (if (null? args)
+		(reverse new-alist)
+		(let* ((name (car args))
+		       (pname (interface-lookup name alist hidden default)))
+		  (loop (cdr args)
+			(if pname
+			    (cons (cons name pname)
+				  new-alist)
+			    new-alist)))))
+	  '()		    
+	  #f))
+
+; Just add the names to the hidden list.
+
+(define (process-hide args alist hidden default)
+  (values alist
+	  (append args hidden)
+	  default))
+
+; Add the new aliases to ALIST.
+
+(define (process-alias args alist hidden default)
+  (values (append (map (lambda (spec)
+			 (cons (cadr spec)
+			       (car spec)))
+		       args)
+		  alist)
+	  hidden
+	  default))
+
+; Add the new aliases to ALIST and add the old names to HIDDEN.
+
+(define (process-rename args alist hidden default)
+  (values (append (map (lambda (spec)
+			 (cons (cadr spec)
+			       (car spec)))
+		       args)
+		  alist)
+	  (append (map car args) hidden)
+	  default))
+
+;----------------
+; Look up a name, returning the name by which it is known in the base structure.
+;   - If it is in HIDDEN then it is not exported.
+;   - If there is an alias, then return the alias.
+;   - If there is no default the name is not exported.
+;   - A default of #T means every name is passed through.
+;   - Otherwise, check that NAME begins with the default and return the
+;     suffix after the default.
+
+(define (interface-lookup name alist hidden default)
+  (cond ((memq name hidden)
+	 #f)
+	((assq name alist)
+	 => cdr)
+	((not default)
+	 #f)
+	((eq? default #t)
+	 name)
+	((prefix-match? (symbol->string name)
+			(symbol->string default))
+	 (remove-prefix (symbol->string name)
+			(symbol->string default)))
+	(else
+	 #f)))
+
+; Curried version of MAKE-LOOKUP for making the INTERFACE-REF method for
+; modified structures.
+
+(define (make-lookup alist hidden default interface)
+  (lambda (name)
+    (let ((alias (interface-lookup name alist hidden default)))
+      (if alias
+	  (interface-ref interface alias)
+	  (values #f #f)))))
+
+; True if NAME begins with PREFIX (and is not just PREFIX).
+
+(define (prefix-match? name prefix)
+  (and (< (string-length prefix)
+	  (string-length name))
+       (let loop ((i 0))
+	 (cond ((= i (string-length prefix))
+		#t)
+	       ((char=? (string-ref name i)
+			(string-ref prefix i))
+		(loop (+ i 1)))
+	       (else
+		#f)))))
+
+; Return the portion of NAME that follows PREFIX.
+
+(define (remove-prefix name prefix)
+  (string->symbol (substring name
+			     (string-length prefix)
+			     (string-length name))))
+
+;----------------
+; Return a procedure for walking over the declarations in a modified interface.
+; There are two versions, depending on whether names are passed on by default.
+; If there is a default we need to walk over the declarations in the base
+; interface and pass on the ones that are not hidden.
+
+(define (make-default-walker alist hidden default interface)
+  (lambda (proc)
+    (for-each-declaration
+      (lambda (name base-name type)
+	(if (not (memq name hidden))
+	    (proc (cond ((cdr-assq name alist)
+			 => car)
+			((symbol? default)
+			 (symbol-append default name))
+			(else
+			 name))
+		  base-name
+		  type)))
+      interface)))
+
+; Same as ASSQ except we look for THING as the cdr instead of the car.
+
+(define (cdr-assq thing alist)
+  (let loop ((alist alist))
+    (cond ((null? alist)
+	   #f)
+	  ((eq? thing (cdar alist))
+	   (car alist))
+	  (else
+	   (loop (cdr alist))))))
+
+; With no default, all of the names are in the ALIST and we do not need to
+; walk over the declarations in the base interface.
+
+(define (make-alist-walker alist interface)
+  (lambda (proc)
+    (for-each (lambda (pair)
+		(mvlet (((base-name type)
+			  (interface-ref interface (cdr pair))))
+		  (if base-name
+		      (proc (car pair)
+			    base-name
+			    type))))
+	      alist)))
+	 
+;----------------
+; Random utility.
+			  
+(define (symbol-append a b)
+  (string->symbol (string-append (symbol->string a)
+				 (symbol->string b))))
 
-(define (note-interface-name! int name)
-  (if (and name (not (interface-name int)))
-      (set-interface-name! int name)))

scheme/bcomp/module-language.scm

@@ -1,4 +1,4 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
 
 
 ; The DEFINE-INTERFACE and DEFINE-STRUCTURE macros.
@@ -50,7 +50,6 @@
     ((compound-interface ?int ...)
      (make-compound-interface #f ?int ...))))
 
-
 ; <item> ::= <name> | (<name> <type>) | ((<name> ...) <type>)
 
 (define-syntax export
@@ -105,6 +104,24 @@
      (let ((p (a-package #f ?clause ...)))
        (values (make-structure p (lambda () ?int))
 	       ...)))))
+
+(define-syntax modify
+  (syntax-rules ()
+    ((modify ?struct ?command ...)
+     (make-modified-structure ?struct '(?command ...)))))
+
+; Two handy shorthands for MODIFY.
+
+(define-syntax subset
+  (syntax-rules ()
+    ((restrict struct (name ...))
+     (modify struct (expose name ...)))))
+
+(define-syntax with-prefix
+  (syntax-rules ()
+    ((with-prefix struct the-prefix)
+     (modify struct (prefix the-prefix)))))
+
 ; Packages
 
 (define-syntax a-package

scheme/bcomp/package-undef.scm

@@ -1,4 +1,4 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
 
 ; The entry point for all this.
 
@@ -41,7 +41,7 @@
 	      ((variable-type? want-type)
 	       (get-location-for-unassignable cenv name))
 	      (else
-	       (warn "invalid variable reference" name)
+	       (warn "invalid variable reference" name cenv)
 	       (note-caching! cenv name place)
 	       place)))
       (get-location-for-undefined cenv name)))
@@ -79,12 +79,12 @@
       (if (not (table-ref (package-definitions package) name))
 	  (let loop ((opens (package-opens package)))
 	    (if (not (null? opens))
-		(if (interface-ref (structure-interface (car opens))
+		(if (interface-member? (structure-interface (car opens))
-				   name)
+				       name)
 		    (begin (table-set! (package-cached package) name place)
 			   (package-note-caching!
-			       (structure-package (car opens))
+			    (structure-package (car opens))
-			       name place))
+			    name place))
 		    (loop (cdr opens))))))))
 
 ; Find the actual package providing PLACE and remember that it is being used.
@@ -147,8 +147,8 @@
   (let loop ((opens (package-opens package)))
     (if (null? opens)
 	(get-undefined package name)
-	(if (interface-ref (structure-interface (car opens))
+	(if (interface-member? (structure-interface (car opens))
-			   name)
+			       name)
 	    (location-for-reference (structure-package (car opens)) name)
 	    (loop (cdr opens))))))
 
@@ -190,18 +190,28 @@
 			 (not (generic-lookup env name)))
 		       names)))
     (if (not (null? names))
-	(let ((out (current-noise-port)))
+	(let ((names (map (lambda (name)
-	  (newline out)
+			    (if (generated? name)
-	  (display "Undefined" out)
+				(generated-name name)
-	  (if (and current-package
+				name))
-		   (not (eq? env current-package)))
+			  (reverse names))))
-	      (begin (display " in " out)
+	  (apply warn
-		     (write env out)))
+		 "undefined variables"
-	  (display ": " out)
+		 env
-	  (write (map (lambda (name)
+		 names)))))
-			(if (generated? name)
+	      
-			    (generated-name name)
+;        (let ((out (current-noise-port)))
-			    name))
+;          (newline out)
-		      (reverse names))
+;          (display "Undefined" out)
-		 out)
+;          (if (and current-package
-	  (newline out)))))
+;                   (not (eq? env current-package)))
+;              (begin (display " in " out)
+;                     (write env out)))
+;          (display ": " out)
+;          (write (map (lambda (name)
+;                        (if (generated? name)
+;                            (generated-name name)
+;                            name))
+;                      (reverse names))
+;                 out)
+;          (newline out)))))

scheme/bcomp/package.scm

@@ -63,6 +63,18 @@
     (add-to-population! struct (package-clients package))
     struct))
 
+; Make a structure by using COMMANDS to modify the STRUCTURE's interface.
+
+(define (make-modified-structure structure commands)
+  (let ((new-struct (make-structure (structure-package structure)
+				    (lambda ()
+				      (make-modified-interface
+				        (structure-interface structure)
+					commands)))))
+    (if (structure-unstable? structure)
+	(add-to-population! new-struct (structure-clients structure)))
+    new-struct))
+
 ; STRUCT has name NAME.  NAME can then also be used to refer to STRUCT's
 ; package.
 
@@ -71,7 +83,7 @@
       (begin (set-structure-name! struct name)
 	     (note-package-name! (structure-package struct) name))))
 
-; A structure is unstable if it's package is.  An unstable package is one
+; A structure is unstable if its package is.  An unstable package is one
 ; where new code may be added, possibly modifying the exported bindings.
 
 (define (structure-unstable? struct)
@@ -82,8 +94,8 @@
 (define (for-each-export proc struct)
   (let ((int (structure-interface struct)))
     (for-each-declaration
-        (lambda (name want-type)
+        (lambda (name base-name want-type)
-	  (let ((binding (real-structure-lookup struct name want-type #t)))
+	  (let ((binding (real-structure-lookup struct base-name want-type #t)))
 	    (proc name
 		  (if (and (binding? binding)
 			   (eq? want-type undeclared-type))
@@ -256,8 +268,7 @@
 ; --------------------
 ; The definitions table
 
-; Each entry in the package-definitions table is a binding
+; Each entry in the package-definitions table is a binding.
-; #(type place static).
 
 (define (package-definition package name)
   (initialize-package-if-necessary! package)
@@ -299,8 +310,7 @@
 ; --------------------
 ; Lookup
 
-; Look up a name in a package.  Returns a binding if bound, or a name if
+; Look up a name in a package.  Returns a binding if bound or #F if not.
-; not.  In the unbound case we return #f.
 
 (define (package-lookup package name)
   (really-package-lookup package name (package-integrate? package)))
@@ -328,10 +338,13 @@
 	    (loop (cdr opens))))))
 
 (define (structure-lookup struct name integrate?)
-  (let ((type (interface-ref (structure-interface struct) name)))
+  (call-with-values
-    (if type
+    (lambda ()
-	(real-structure-lookup struct name type integrate?)
+      (interface-ref (structure-interface struct) name))
-	#f)))
+    (lambda (base-name type)
+      (if type
+	  (real-structure-lookup struct base-name type integrate?)
+	  #f))))
 
 (define (real-structure-lookup struct name type integrate?)
   (impose-type type
@@ -348,8 +361,8 @@
 			       name
 			       (package-integrate? (structure-package env)))
 	     (call-error "not exported" generic-lookup env name)))
-	;((procedure? env)
+	((procedure? env)
-	; (lookup env name))
+	 (lookup env name))
 	(else
 	 (error "invalid environment" env name))))
 

scheme/comp-packages.scm

@@ -200,6 +200,8 @@
 (define-structure interfaces interfaces-interface
   (open scheme-level-2
 	define-record-types tables
+	util
+	signals
 	weak	; populations
 	meta-types)
   (files (bcomp interface))

scheme/env/list-interface.scm

@@ -1,46 +1,63 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
 
 
 ;  ,open interfaces packages meta-types sort syntactic
 ;  ,config scheme
 
+; Print out the names and types exported by THING, which is either a structure
+; or an interface.
+
 (define (list-interface thing)
   (cond ((structure? thing)
 	 (list-interface-1 (structure-interface thing)
-			   (lambda (name)
+			   (lambda (name type)
 			     (let ((x (structure-lookup thing name #t)))
 			       (if (binding? x)
 				   (binding-type x)
 				   #f)))))
 	((interface? thing)
-	 (list-interface-1 thing (lambda (name)
+	 (list-interface-1 thing
-				   (interface-ref thing name))))
+			   (lambda (name type)
+			     type)))
 	(else '?)))
 
+; LOOKUP is passed the package-name and the type from the interface and
+; returns a (possibly different) type.
+
 (define (list-interface-1 int lookup)
-  (let ((l '()))
+  (let ((names '()))
-    (for-each-declaration (lambda (name type)
+    (for-each-declaration (lambda (name package-name type)
-			    (if (not (memq name l))  ;compound signatures...
+			    (if (not (assq name names))  ;compound signatures...
-				(set! l (cons name l))))
+				(set! names
+				      (cons (cons name
+						  (lookup package-name type))
+					    names))))
 			  int)
-    (for-each (lambda (name)
+    (for-each (lambda (pair)
-		(write name)
+		(let ((name (car pair))
-		(display (make-string
+		      (type (cdr pair)))
-			  (max 0 (- 25 (string-length
+		  (write name)
-					(symbol->string name))))
+		  (display (make-string
-			  #\space))
+			    (max 0 (- 25 (string-length
-		(write-char #\space)
+					  (symbol->string name))))
-		(write (careful-type->sexp (lookup name)))    ;( ...)
+			    #\space))
-		(newline))
+		  (write-char #\space)
-	      (sort-list l (lambda (name1 name2)
+		  (write (careful-type->sexp type))    ;( ...)
-			     (string<? (symbol->string name1)
+		  (newline)))
-				       (symbol->string name2)))))))
+	      (sort-list names
+			 (lambda (pair1 pair2)
+			   (string<? (symbol->string (car pair1))
+				     (symbol->string (car pair2))))))))
 
 (define (careful-type->sexp thing)
   (cond ((not thing) 'undefined)
-	((or (symbol? thing) (null? thing) (number? thing))
+	((or (symbol? thing)
+	     (null? thing)
+	     (number? thing))
 	 thing)     ;?
 	((pair? thing)    ;e.g. (variable #{Type :value})
 	 (cons (careful-type->sexp (car thing))
 	       (careful-type->sexp (cdr thing))))
-	(else (type->sexp thing #t))))
+	(else
+	 (type->sexp thing #t))))
+

scheme/env/pedit.scm

@@ -1,5 +1,4 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
 
 ; Package / structure / interface mutation operations.
 
@@ -79,18 +78,23 @@
 	(let recur ((q p))
 	  (let loop ((opens (package-opens q)))
 	    (if (not (null? opens))
-		(if (interface-ref (structure-interface (car opens)) name)
+		(call-with-values
-		    ;; Shadowing
+		 (lambda ()
-		    (let* ((q (structure-package (car opens)))
+		   (interface-ref (structure-interface (car opens))
-			   (probe (table-ref (package-undefineds q)
+				  name))
-					    name)))
+		 (lambda (base-name type)
-		      (if probe
+		   (if base-name
-			  (begin (if *debug?*
+		       ;; Shadowing
-				     (note "undefined -> shadowed"
+		       (let* ((q (structure-package (car opens)))
-					   name loc probe))
+			      (probe (table-ref (package-undefineds q)
-				 (cope-with-mutation p name loc probe))
+						base-name)))
-			  (recur q)))
+			 (if probe
-		    (loop (cdr opens)))))))
+			     (begin (if *debug?*
+					(note "undefined -> shadowed"
+					      name loc probe))
+				    (cope-with-mutation p name loc probe))
+			     (recur q)))
+		       (loop (cdr opens)))))))))
     loc))
 
 ; COPE-WITH-MUTATION:
@@ -140,7 +144,7 @@
 	      (begin (set! losers (cons package losers))
 		     (walk-population
 		      (lambda (struct)
-			(if (interface-ref (structure-interface struct) name)
+			(if (interface-member? (structure-interface struct) name)
 			    (walk-population recur (structure-clients struct))))
 		      (package-clients package)))))
 	losers)))

scheme/interfaces.scm

@@ -299,7 +299,9 @@
 	  reduce
 	  sublist
 	  insert
-	  unspecific))
+	  unspecific
+	  
+	  (mvlet :syntax)))
 
 ; Level 2 consists of harder things built on level 1.
 
@@ -989,10 +991,12 @@
 ; Interfaces.
 
 (define-interface interfaces-interface
-  (export make-compound-interface
+  (export make-simple-interface
-	  make-simple-interface
+	  make-compound-interface
+	  make-modified-interface
 	  note-reference-to-interface!
 	  interface-ref
+	  interface-member?
 	  interface?
 	  interface-clients
 	  for-each-declaration
@@ -1004,6 +1008,7 @@
   (export make-package
 	  make-simple-package		;start.scm
 	  make-structure
+	  make-modified-structure
 	  package-define!
 	  package-lookup
 	  package?			;command.scm
@@ -1122,6 +1127,7 @@
 	    define-reflective-tower-maker
 	    export-reflective-tower-maker
 	    compound-interface
+	    modify subset with-prefix
 	    export
 	    structure structures let	; New
 	    begin			; mostly for macros

scheme/rts/util.scm

@@ -1,5 +1,5 @@
 ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
 
 
 ; This is file util.scm.
@@ -97,3 +97,67 @@
 	   (folder (car list) acc0 acc1 acc2))
 	 (lambda (acc0 acc1 acc2)
 	   (loop (cdr list) acc0 acc1 acc2))))))
+
+;----------------
+; A version of LET and LET* which allows clauses that return multiple values.
+;
+; There is another copy of this in big/mvlet.scm.
+;
+; MV = multiple-value
+;
+; (mvlet (<clause> ...) <body>)
+; (mvlet* (<clause> ...) <body>)
+;
+; <clause> ::= (<ids> <expression>)
+; <ids> ::= <id> | (<id> ...) | (<id> ... . <id>)
+;
+; A clause of the form (<id> <exp>) is like a normal LET clause.  There is no
+; clause equivalent to
+;   (call-with-values (lambda () <expression>)
+;                     (lambda <id> <body>))
+
+(define-syntax mvlet
+  (syntax-rules ()
+    ((mvlet () body ...)
+     (let () body ...))
+    ((mvlet (clause ...) body ...)
+     (mvlet-helper (clause ...) () (body ...)))))
+
+(define-syntax mvlet-helper
+  (syntax-rules ()
+    ((mvlet-helper () clauses (body ...))
+     (let clauses body ...))
+    ((mvlet-helper (((var . more-vars) val) more ...) clauses body)
+     (copy-vars (var . more-vars) () val (more ...) clauses body))
+    ((mvlet-helper ((var val) more ...) clauses body)
+     (mvlet-helper (more ...) ((var val) . clauses) body))))
+
+(define-syntax copy-vars
+  (syntax-rules ()
+    ((copy-vars (var . more-vars) (copies ...)
+		val more clauses body)
+     (copy-vars more-vars (copies ... x)
+		val more ((var x) . clauses) body))
+    ((copy-vars () copies val more clauses body)
+     (call-with-values
+       (lambda () val)
+       (lambda copies
+	 (mvlet-helper more clauses body))))
+    ((copy-vars last (copies ...) val more clauses body)
+     (call-with-values
+       (lambda () val)
+       (lambda (copies ... . lastx)
+	 (mvlet-helper more ((last lastx) . clauses) body))))))
+
+(define-syntax mvlet*
+  (syntax-rules ()
+    ((mvlet* () body ...)
+     (let () body ...))
+    ((mvlet* (((vars ...) val) clause ...) body ...)
+     (call-with-values
+       (lambda () val)
+       (lambda (vars ...)
+	 (mvlet (clause ...) body ...))))
+    ((mvlet* ((var val) clause ...) body ...)
+     (let ((var val)) (mvlet (clause ...) body ...)))))
+