New module language from S48 0.57.
This commit is contained in:
mainzelm
parent
a5b0199999
commit
5aee745efb
|
|
@ -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))))
|
||||
|
||||
(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.
|
||||
(lambda (int)
|
||||
(list 'interface (interface-name int))))
|
||||
|
||||
(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))
|
||||
;; Allow ((name1 name2 ...) type)
|
||||
(if (or (null? name)
|
||||
(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))
|
||||
(lambda (proc) (table-walk proc table))
|
||||
name))
|
||||
|
||||
|
||||
; Compoune interfaces
|
||||
;----------------
|
||||
; Compound interfaces
|
||||
;
|
||||
; 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.
|
||||
|
||||
(define (make-compound-interface name . ints)
|
||||
(let ((int
|
||||
(make-interface (lambda (name)
|
||||
(let loop ((ints ints))
|
||||
(if (null? ints)
|
||||
#f
|
||||
(or (interface-ref (car ints) name)
|
||||
(loop (cdr ints))))))
|
||||
(lambda (proc)
|
||||
(for-each (lambda (int)
|
||||
(for-each-declaration proc int))
|
||||
ints))
|
||||
name)))
|
||||
(let ((int (make-interface (lambda (name)
|
||||
(let loop ((ints ints))
|
||||
(if (null? ints)
|
||||
(values #f #f)
|
||||
(mvlet (((new-name type)
|
||||
(interface-ref (car ints) name)))
|
||||
(if new-name
|
||||
(values new-name type)
|
||||
(loop (cdr ints)))))))
|
||||
(lambda (proc)
|
||||
(for-each (lambda (int)
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
name)
|
||||
(if (interface-member? (structure-interface (car opens))
|
||||
name)
|
||||
(begin (table-set! (package-cached package) name place)
|
||||
(package-note-caching!
|
||||
(structure-package (car opens))
|
||||
name place))
|
||||
(structure-package (car opens))
|
||||
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))
|
||||
name)
|
||||
(if (interface-member? (structure-interface (car opens))
|
||||
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)))
|
||||
(newline out)
|
||||
(display "Undefined" out)
|
||||
(if (and current-package
|
||||
(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)))))
|
||||
(let ((names (map (lambda (name)
|
||||
(if (generated? name)
|
||||
(generated-name name)
|
||||
name))
|
||||
(reverse names))))
|
||||
(apply warn
|
||||
"undefined variables"
|
||||
env
|
||||
names)))))
|
||||
|
||||
; (let ((out (current-noise-port)))
|
||||
; (newline out)
|
||||
; (display "Undefined" out)
|
||||
; (if (and current-package
|
||||
; (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)))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(let ((binding (real-structure-lookup struct name want-type #t)))
|
||||
(lambda (name base-name want-type)
|
||||
(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
|
||||
; #(type place static).
|
||||
; Each entry in the package-definitions table is a binding.
|
||||
|
||||
(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
|
||||
; not. In the unbound case we return #f.
|
||||
; Look up a name in a package. Returns a binding if bound or #F if not.
|
||||
|
||||
(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)))
|
||||
(if type
|
||||
(real-structure-lookup struct name type integrate?)
|
||||
#f)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(interface-ref (structure-interface struct) name))
|
||||
(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)
|
||||
; (lookup env name))
|
||||
((procedure? env)
|
||||
(lookup env name))
|
||||
(else
|
||||
(error "invalid environment" env name))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(interface-ref thing name))))
|
||||
(list-interface-1 thing
|
||||
(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 '()))
|
||||
(for-each-declaration (lambda (name type)
|
||||
(if (not (memq name l)) ;compound signatures...
|
||||
(set! l (cons name l))))
|
||||
(let ((names '()))
|
||||
(for-each-declaration (lambda (name package-name type)
|
||||
(if (not (assq name names)) ;compound signatures...
|
||||
(set! names
|
||||
(cons (cons name
|
||||
(lookup package-name type))
|
||||
names))))
|
||||
int)
|
||||
(for-each (lambda (name)
|
||||
(write name)
|
||||
(display (make-string
|
||||
(max 0 (- 25 (string-length
|
||||
(symbol->string name))))
|
||||
#\space))
|
||||
(write-char #\space)
|
||||
(write (careful-type->sexp (lookup name))) ;( ...)
|
||||
(newline))
|
||||
(sort-list l (lambda (name1 name2)
|
||||
(string<? (symbol->string name1)
|
||||
(symbol->string name2)))))))
|
||||
(for-each (lambda (pair)
|
||||
(let ((name (car pair))
|
||||
(type (cdr pair)))
|
||||
(write name)
|
||||
(display (make-string
|
||||
(max 0 (- 25 (string-length
|
||||
(symbol->string name))))
|
||||
#\space))
|
||||
(write-char #\space)
|
||||
(write (careful-type->sexp type)) ;( ...)
|
||||
(newline)))
|
||||
(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))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
;; Shadowing
|
||||
(let* ((q (structure-package (car opens)))
|
||||
(probe (table-ref (package-undefineds q)
|
||||
name)))
|
||||
(if probe
|
||||
(begin (if *debug?*
|
||||
(note "undefined -> shadowed"
|
||||
name loc probe))
|
||||
(cope-with-mutation p name loc probe))
|
||||
(recur q)))
|
||||
(loop (cdr opens)))))))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(interface-ref (structure-interface (car opens))
|
||||
name))
|
||||
(lambda (base-name type)
|
||||
(if base-name
|
||||
;; Shadowing
|
||||
(let* ((q (structure-package (car opens)))
|
||||
(probe (table-ref (package-undefineds q)
|
||||
base-name)))
|
||||
(if probe
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
make-simple-interface
|
||||
(export 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
|
||||
|
|
|
|||
|
|
@ -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 ...)))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue