409 lines
14 KiB
Scheme
409 lines
14 KiB
Scheme
;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
|
|
;;;
|
|
;;; Port Author: Andrew Whatson
|
|
;;;
|
|
;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
|
|
;;;
|
|
;;; scheme48-1.9.2/scheme/bcomp/package.scm
|
|
|
|
(define-module (prescheme bcomp interface)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (prescheme scheme48)
|
|
#:use-module (prescheme record-discloser)
|
|
#:use-module (prescheme population)
|
|
#:use-module (prescheme bcomp mtype)
|
|
#:export (make-simple-interface
|
|
make-compound-interface
|
|
make-modified-interface-maker
|
|
note-reference-to-interface!
|
|
interface-ref
|
|
interface-member?
|
|
interface?
|
|
interface-clients
|
|
for-each-declaration
|
|
note-interface-name!))
|
|
|
|
;; 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
|
|
(really-make-interface ref walk clients name)
|
|
interface?
|
|
(ref ref-method)
|
|
(walk walk-method)
|
|
(clients interface-clients)
|
|
(name interface-name set-interface-name!))
|
|
|
|
(define-record-discloser :interface
|
|
(lambda (int)
|
|
(list 'interface (interface-name int))))
|
|
|
|
(define (make-interface ref walk name)
|
|
(really-make-interface ref
|
|
walk
|
|
(make-population)
|
|
name))
|
|
|
|
;; 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)
|
|
(receive (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))
|
|
(for-each (lambda (name)
|
|
(table-set! table name type))
|
|
name)
|
|
(table-set! table name type)))
|
|
(table-set! table item undeclared-type)))
|
|
items)
|
|
(make-table-immutable! table)
|
|
table))
|
|
|
|
;;----------------
|
|
;; 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)
|
|
(values #f #f)
|
|
(receive (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 procedure that uses COMMANDS to modify any interface it is
|
|
;; passed. We parse the commands first so that errors are detected before
|
|
;; the structure that exports the modified interace is installed anywhere.
|
|
;;
|
|
;; 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-maker commands)
|
|
(if (and (list? commands)
|
|
(every okay-command? commands))
|
|
(receive (alist hidden default)
|
|
(process-commands commands)
|
|
(lambda (interface)
|
|
(let ((lookup (make-lookup alist hidden default interface))
|
|
(walker (make-interface-walker alist hidden default interface)))
|
|
(let ((int (make-interface lookup walker #f)))
|
|
(note-reference-to-interface! interface int)
|
|
int))))
|
|
(assertion-violation 'make-modified-interface-maker
|
|
"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)
|
|
(receive (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 (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 (list? spec)
|
|
(= 2 (length spec))
|
|
(symbol? (car spec))
|
|
(symbol? (cadr spec))))
|
|
args))
|
|
(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)
|
|
(interface-lookup (car spec) alist hidden default)))
|
|
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)
|
|
(interface-lookup (car spec) alist hidden default)))
|
|
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 helpers, depending on whether names are passed on by default.
|
|
|
|
(define (make-interface-walker alist hidden default interface)
|
|
(lambda (proc)
|
|
(if default
|
|
(walk-default proc alist hidden default interface))
|
|
(walk-alist proc alist hidden interface)))
|
|
|
|
;; 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 (walk-default proc alist hidden default interface)
|
|
(for-each-declaration
|
|
(lambda (name base-name type)
|
|
(let ((new-name
|
|
(cond ((symbol? default)
|
|
(symbol-append default name))
|
|
(else name))))
|
|
(if (not (memq new-name hidden))
|
|
(proc new-name
|
|
base-name
|
|
type))))
|
|
interface))
|
|
|
|
;; 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 (walk-alist proc alist hidden interface)
|
|
(for-each (lambda (pair)
|
|
(receive (base-name type)
|
|
(interface-ref interface (cdr pair))
|
|
(let ((new-name (car pair)))
|
|
(if (and base-name (not (memq new-name hidden)))
|
|
(proc new-name
|
|
base-name
|
|
type)))))
|
|
alist))
|