New module language from S48 0.57.

This commit is contained in:
mainzelm 2002-04-03 12:17:19 +00:00
parent a5b0199999
commit 5aee745efb
9 changed files with 576 additions and 124 deletions

View File

@ -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 ; 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 (define-record-type interface :interface
(really-make-interface ref walk clients name) (really-make-interface ref walk clients name)
@ -12,23 +24,8 @@
(name interface-name set-interface-name!)) (name interface-name set-interface-name!))
(define-record-discloser :interface (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) (define (make-interface ref walk name)
(really-make-interface ref (really-make-interface ref
@ -36,16 +33,64 @@
(make-population) (make-population)
name)) 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) (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))) (let ((table (make-symbol-table)))
(for-each (lambda (item) (for-each (lambda (item)
(if (pair? item) (if (pair? item)
(let ((name (car item)) (let ((name (car item))
(type (cadr item))) (type (cadr item)))
(if (or (null? name) (pair? name)) (if (or (null? name)
;; Allow ((name1 name2 ...) type) (pair? name))
(for-each (lambda (name) (for-each (lambda (name)
(table-set! table name type)) (table-set! table name type))
name) name)
@ -53,35 +98,309 @@
(table-set! table item undeclared-type))) (table-set! table item undeclared-type)))
items) items)
(make-table-immutable! table) (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) (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) (for-each (lambda (i)
(note-reference-to-interface! i int)) (note-reference-to-interface! i int))
ints) ints)
int)) 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)))

View File

@ -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. ; The DEFINE-INTERFACE and DEFINE-STRUCTURE macros.
@ -50,7 +50,6 @@
((compound-interface ?int ...) ((compound-interface ?int ...)
(make-compound-interface #f ?int ...)))) (make-compound-interface #f ?int ...))))
; <item> ::= <name> | (<name> <type>) | ((<name> ...) <type>) ; <item> ::= <name> | (<name> <type>) | ((<name> ...) <type>)
(define-syntax export (define-syntax export
@ -105,6 +104,24 @@
(let ((p (a-package #f ?clause ...))) (let ((p (a-package #f ?clause ...)))
(values (make-structure p (lambda () ?int)) (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 ; Packages
(define-syntax a-package (define-syntax a-package

View File

@ -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. ; The entry point for all this.
@ -41,7 +41,7 @@
((variable-type? want-type) ((variable-type? want-type)
(get-location-for-unassignable cenv name)) (get-location-for-unassignable cenv name))
(else (else
(warn "invalid variable reference" name) (warn "invalid variable reference" name cenv)
(note-caching! cenv name place) (note-caching! cenv name place)
place))) place)))
(get-location-for-undefined cenv name))) (get-location-for-undefined cenv name)))
@ -79,12 +79,12 @@
(if (not (table-ref (package-definitions package) name)) (if (not (table-ref (package-definitions package) name))
(let loop ((opens (package-opens package))) (let loop ((opens (package-opens package)))
(if (not (null? opens)) (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) (begin (table-set! (package-cached package) name place)
(package-note-caching! (package-note-caching!
(structure-package (car opens)) (structure-package (car opens))
name place)) name place))
(loop (cdr opens)))))))) (loop (cdr opens))))))))
; Find the actual package providing PLACE and remember that it is being used. ; Find the actual package providing PLACE and remember that it is being used.
@ -147,8 +147,8 @@
(let loop ((opens (package-opens package))) (let loop ((opens (package-opens package)))
(if (null? opens) (if (null? opens)
(get-undefined package name) (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) (location-for-reference (structure-package (car opens)) name)
(loop (cdr opens)))))) (loop (cdr opens))))))
@ -190,18 +190,28 @@
(not (generic-lookup env name))) (not (generic-lookup env name)))
names))) names)))
(if (not (null? 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)))))

View File

@ -63,6 +63,18 @@
(add-to-population! struct (package-clients package)) (add-to-population! struct (package-clients package))
struct)) 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 ; STRUCT has name NAME. NAME can then also be used to refer to STRUCT's
; package. ; package.
@ -71,7 +83,7 @@
(begin (set-structure-name! struct name) (begin (set-structure-name! struct name)
(note-package-name! (structure-package 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. ; where new code may be added, possibly modifying the exported bindings.
(define (structure-unstable? struct) (define (structure-unstable? struct)
@ -82,8 +94,8 @@
(define (for-each-export proc struct) (define (for-each-export proc struct)
(let ((int (structure-interface struct))) (let ((int (structure-interface struct)))
(for-each-declaration (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 (proc name
(if (and (binding? binding) (if (and (binding? binding)
(eq? want-type undeclared-type)) (eq? want-type undeclared-type))
@ -256,8 +268,7 @@
; -------------------- ; --------------------
; The definitions table ; 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) (define (package-definition package name)
(initialize-package-if-necessary! package) (initialize-package-if-necessary! package)
@ -299,8 +310,7 @@
; -------------------- ; --------------------
; Lookup ; 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) (define (package-lookup package name)
(really-package-lookup package name (package-integrate? package))) (really-package-lookup package name (package-integrate? package)))
@ -328,10 +338,13 @@
(loop (cdr opens)))))) (loop (cdr opens))))))
(define (structure-lookup struct name integrate?) (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?) (define (real-structure-lookup struct name type integrate?)
(impose-type type (impose-type type
@ -348,8 +361,8 @@
name name
(package-integrate? (structure-package env))) (package-integrate? (structure-package env)))
(call-error "not exported" generic-lookup env name))) (call-error "not exported" generic-lookup env name)))
;((procedure? env) ((procedure? env)
; (lookup env name)) (lookup env name))
(else (else
(error "invalid environment" env name)))) (error "invalid environment" env name))))

View File

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

View File

@ -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 ; ,open interfaces packages meta-types sort syntactic
; ,config scheme ; ,config scheme
; Print out the names and types exported by THING, which is either a structure
; or an interface.
(define (list-interface thing) (define (list-interface thing)
(cond ((structure? thing) (cond ((structure? thing)
(list-interface-1 (structure-interface thing) (list-interface-1 (structure-interface thing)
(lambda (name) (lambda (name type)
(let ((x (structure-lookup thing name #t))) (let ((x (structure-lookup thing name #t)))
(if (binding? x) (if (binding? x)
(binding-type x) (binding-type x)
#f))))) #f)))))
((interface? thing) ((interface? thing)
(list-interface-1 thing (lambda (name) (list-interface-1 thing
(interface-ref thing name)))) (lambda (name type)
type)))
(else '?))) (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) (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) 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) (define (careful-type->sexp thing)
(cond ((not thing) 'undefined) (cond ((not thing) 'undefined)
((or (symbol? thing) (null? thing) (number? thing)) ((or (symbol? thing)
(null? thing)
(number? thing))
thing) ;? thing) ;?
((pair? thing) ;e.g. (variable #{Type :value}) ((pair? thing) ;e.g. (variable #{Type :value})
(cons (careful-type->sexp (car thing)) (cons (careful-type->sexp (car thing))
(careful-type->sexp (cdr thing)))) (careful-type->sexp (cdr thing))))
(else (type->sexp thing #t)))) (else
(type->sexp thing #t))))

34
scheme/env/pedit.scm vendored
View File

@ -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. ; Package / structure / interface mutation operations.
@ -79,18 +78,23 @@
(let recur ((q p)) (let recur ((q p))
(let loop ((opens (package-opens q))) (let loop ((opens (package-opens q)))
(if (not (null? opens)) (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)) loc))
; COPE-WITH-MUTATION: ; COPE-WITH-MUTATION:
@ -140,7 +144,7 @@
(begin (set! losers (cons package losers)) (begin (set! losers (cons package losers))
(walk-population (walk-population
(lambda (struct) (lambda (struct)
(if (interface-ref (structure-interface struct) name) (if (interface-member? (structure-interface struct) name)
(walk-population recur (structure-clients struct)))) (walk-population recur (structure-clients struct))))
(package-clients package))))) (package-clients package)))))
losers))) losers)))

View File

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

View File

@ -1,5 +1,5 @@
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*- ; -*- 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. ; This is file util.scm.
@ -97,3 +97,67 @@
(folder (car list) acc0 acc1 acc2)) (folder (car list) acc0 acc1 acc2))
(lambda (acc0 acc1 acc2) (lambda (acc0 acc1 acc2)
(loop (cdr list) 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 ...)))))