scsh-0.6/scheme/bcomp/interface.scm

; 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)
  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)
  (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))
			  (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)
				     (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))))