;;; -*- Mode:LISP; Package:NC; Base:10; Readtable:CL -*-
;;; Copyright (c) 1985 Yale University
;;; Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
;;; This material was developed by the T Project at the Yale University Computer
;;; Science Department. Permission to copy this software, to redistribute it,
;;; and to use it for any purpose is granted, subject to the following restric-
;;; tions and understandings.
;;; 1. Any copy made of this software must include this copyright notice in full.
;;; 2. Users of this software agree to make their best efforts (a) to return
;;; to the T Project at Yale any improvements or extensions that they make,
;;; so that these may be included in future releases; and (b) to inform
;;; the T Project of noteworthy uses of this software.
;;; 3. All materials developed as a consequence of the use of this software
;;; shall duly acknowledge such use, in accordance with the usual standards
;;; of acknowledging credit in academic research.
;;; 4. Yale has made no warrantee or representation that the operation of
;;; this software will be error-free, and Yale is under no obligation to
;;; provide any services, by way of maintenance, update, or otherwise.
;;; 5. In conjunction with products arising from the use of this material,
;;; there shall be no use of the name of the Yale University nor of any
;;; adaptation thereof in any advertising, promotional, or sales literature
;;; without prior written consent from Yale in each case.
;;;
;;; Early binding database for ORBIT. DEFINE and its cousins generate early
;;; binding information, usually referred to as support, for the variable
;;; defined. Currently the only information generated, besides the fact that
;;; the variable have been defined, is an integrable value and then only if
;;; the defining special form is of the proper type.
;;; (MAKE-SUPPORT-TABLE id primop-table)
;;;============================================================================
;;; A support table contains the support information for a given locale.
;;; PRIMOP-TABLE is a table containing all of the primops defined in the
;;; locale.
;;;
;;; (
) => the support for in the locale. This
;;; is settable.
;;; (WALK-SUPPORT ) => ( ) for each
;;; in the table.
;;; (PRIMOP-SUPPORT ) => Returns a primop if there is one
;;; named in this table's primop table.
;(define (make-support-table id primop-table)
; (let ((table (make-table id)))
; (object (lambda (name)
; (table-entry table name))
; ((setter self)
; (lambda (name value)
; (set (table-entry table name) value)))
; ((primop-support self name)
; (primop-table name))
; ((walk-support self proc)
; (table-walk table proc))
; ((walk-primop-table self proc)
; (if primop-table
; (walk-primop-table primop-table proc)))
; ((support-table? self) t)
; ((identification self) id)
; ((print self stream)
; (format stream "#{Support-table ~D ~S}" (object-hash self) id)))))
(defstruct env-table
id
table)
(zl:defsubst identification (env-table)
(env-table-id env-table))
(defstruct (support-table (:include env-table)
(:constructor %make-support-table (id table primop-table))
(:print-function (lambda (struct stream depth)
depth
(format stream "#{Support-table ~D ~S}"
(support-table-id struct)
(object-hash struct)))))
primop-table)
(defun make-support-table (id primop-table)
(%make-support-table id (make-table id) primop-table))
(defun walk-support (support-table proc)
(table-walk (support-table-table support-table) proc))
(zl:defsubst support-table-lookup (table name)
(table-entry (support-table-table table) name))
(defun make-empty-support-table (id)
(make-support-table id (make-primop-table id)))
;;; (MAKE-PRIMOP-TABLE id)
;;;============================================================================
;;; The primops defined in a locale have a distinct name space. This allows
;;; primops to be anonymous in the regular name space and still be referred to
;;; by name by the support tables and files. Primop tables are essentially
;;; identical to support tables.
;(define (make-primop-table id)
; (let ((table (make-table id)))
; (object (lambda (name)
; (table-entry table name))
; ((setter self)
; (lambda (name value)
; (set (table-entry table name) value)))
; ((walk-primop-table self proc)
; (table-walk table proc))
; ((print self stream)
; (format stream "#{Primop-table ~D ~S}" (object-hash self) id)))))
(defstruct (primop-table (:include env-table)
(:constructor %make-primop-table (id table))
(:print-function (lambda (struct stream depth)
depth
(format stream "#{Primop-table ~D ~S}"
(primop-table-id struct)
(object-hash struct)))))
)
(zl:defsubst primop-table-lookup (table name)
(table-entry (primop-table-table table) name))
(defun make-primop-table (id)
(%make-primop-table id (make-table id)))
;;; (MAKE-SUPPORT-ENV id support-tables)
;;;============================================================================
;;; A support environment is made from a list of support tables. It responds
;;; to information requests by trying each support table in turn. The method
;;; for AUGMENT-CONTEXT is used by the HERALD special form.
;(define (make-support-env id support-tables)
; (object (lambda (name)
; (any (lambda (p)
; (p name))
; support-tables))
; ((identification self) id)
; ((primop-support self name)
; (any (lambda (p)
; (primop-support p name))
; support-tables))
; ((augment-context self . rest)
; (get-support-environment id support-tables rest))
; ((print self stream)
; (format stream "#{Support-env ~D ~S}" (object-hash self) id))))
;;; identification should not properly be applied to these...
(defstruct (support-env (:constructor make-support-env (id support-tables))
(:print-function (lambda (struct stream depth)
depth
(format stream "#{Support-env ~D ~S}"
(support-env-id struct)
(object-hash struct)))))
id
support-tables)
(defun argument-context (support-env &rest rest)
(error "mumble blugh"))
(defun make-empty-support-env (id)
(make-support-env id '()))
;;; (MAKE-FLAT-SUPPORT-ENV id support-tables)
;;;============================================================================
;;; Makes an environment that uses one table to hold all support definitions.
;;; Used for permanent environments.
;(define (make-flat-support-env id support-tables)
; (receive (support-table primop-table)
; (combine-tables id support-tables)
; (object (lambda (name)
; (table-entry support-table name))
; ((primop-support self name)
; (table-entry primop-table name))
; ((walk-support self proc)
; (table-walk support-table proc))
; ((walk-primop-table self proc)
; (table-walk primop-table proc))
; ((identification self) id)
; ((augment-context self . rest)
; (get-support-environment id `(,self) rest))
; ((print self stream)
; (format stream "#{Flat-support-env ~D ~S}" (object-hash self) id)))))
(defstruct (flat-support-env (:include support-table)
(:constructor %make-flat-support-env (id table primop-table))
(:print-function (lambda (struct stream depth)
depth
(format stream "#{Flat-support-env ~D ~S}"
(support-env-id struct)
(object-hash struct)))))
)
(defun make-flat-support-env (id support-tables)
(multiple-value-bind (support-table primop-table)
(combine-tables id support-tables)
(%make-flat-support-env id support-table primop-table)))
(defun combine-tables (id support-tables)
(let ((support-table (make-table id))
(primop-table (make-table id)))
(mapc #'(lambda (table)
(walk-support table
#'(lambda (name support)
(setf (table-entry support-table name)
support)))
(walk-primop-table table
#'(lambda (name primop)
(setf (table-entry primop-table name)
primop))))
(reverse support-tables))
(values support-table primop-table)))
(defun support-lookup (env-or-table name)
(if (typep env-or-table 'support-env)
(some #'(lambda (s) (support-lookup s name))
(support-env-support-tables env-or-table))
(support-table-lookup env-or-table name)))
; support-table
; ((primop-support self name)
; (primop-table name))
; flat-support-env
; ((primop-support self name)
; (table-entry primop-table name))
; support-env
; ((primop-support self name)
; (any (lambda (p)
; (primop-support p name))
; support-tables))
(defun primop-support (support-env-or-table name)
(ecase (type-of support-env-or-table)
(SUPPORT-TABLE
(primop-table-lookup (support-table-primop-table support-env-or-table) name))
(FLAT-SUPPORT-ENV
(table-entry (flat-support-env-primop-table support-env-or-table) name))
(SUPPORT-ENV
(some #'(lambda (p)
(primop-table-lookup (support-table-primop-table p) name))
(support-env-support-tables support-env-or-table)))))
;support-table
; ((walk-primop-table self proc)
; (if primop-table
; (walk-primop-table primop-table proc)))
;primop-table
; ((walk-primop-table self proc)
; (table-walk table proc))
;flat-support-env
; ((walk-primop-table self proc)
; (table-walk primop-table proc))
(defun walk-primop-table (table proc)
(ecase (type-of table)
(SUPPORT-TABLE
(if (support-table-primop-table table)
(table-walk (primop-table-table (support-table-primop-table table)) proc)))
(PRIMOP-TABLE
(table-walk (primop-table-table table) proc))
(FLAT-SUPPORT-ENV
(table-walk (flat-support-env-primop-table table) proc))))
;;; *PRIMITIVE-PRIMOP-TABLE*
;;; *PRIMITIVE-SUPPORT-TABLE*
;;; *PRIMITIVE-SUPPORT-ENV*
;;; *STANDARD-SUPPORT-ENV*
;;;===========================================================================
;;; A starter set of tables and environments.
(defvar *primitive-primop-table*
(make-primop-table '*primitive-primop-table*))
(defvar *primitive-support-table*
(make-support-table '*primitive-support-table* *primitive-primop-table*))
(defvar *primitive-support-env*
(make-support-env '*primitive-support-env* `(,*primitive-support-table*)))
(defvar *standard-support-env* (make-empty-support-env '*empty-env*)) ;lset
;;; SUPPORT
;;;============================================================================
;;; Structure to hold support information for a symbol in a particular
;;; environment.
(defstruct (support (:constructor make-support (variable table data variant value type))
(:print-function (lambda (struct stream depth)
depth
(format stream "#{Support ~S}" (object-hash struct)))))
variable ; The variable being supported.
table ; The support table this support is in.
variant ; What kind of support this is, one of 'DEFINE etc.
value ; The value VARIABLE is bound to if VARIABLE is integrable.
type ; The type of the value VARIABLE is bound to.
data ; Not currently used.
)
(defun make-support-entry (var table data variant value type)
(let ((s (make-support var table data variant value type)))
(setf (variable-support var) s)
(setf (support-table-lookup table (variable-name var)) s)
s))
;;; (CREATE-SUPPORT shape new-support support)
;;;============================================================================
;(define (create-support shape new-support support)
; (table-walk (shape-table shape)
; (lambda (key val)
; (ignore key)
; (if (or (cdr val)
; (variable-binder (car val)))
; (bug "lexical variable ~S still in shape ~S" val shape))))
; (walk (lambda (var)
; (find-var-support var
; (support (variable-name var))
; (new-support (variable-name var))
; new-support))
; (shape-defined shape))
; (shape-defined shape))
(defun get-variable-support (variable)
(let ((support (variable-support variable)))
(let ((value (and support
(eq 'constant (support-variant support))
(support-value support))))
(if (and value (variable-p value))
(get-variable-support value)
support))))
;;; (SUPPORTS-DEFINITION ref)
;;;============================================================================
;;; A predicate that determines if REF is the support value of some variable.
;;; Returns the support variant if it exists.
(defun supports-definition (ref)
(and (call-arg? (node-role ref))
(let ((proc (call-proc (node-parent ref))))
(if (and (eq (call-arg 2) (node-role ref))
(primop-node? proc)
(primop.defines-support? (primop-value proc)))
(primop.support-variant (primop-value proc))
nil))))
;;; (FIX-MULTIPLE-DEFINITIONS var)
;;;============================================================================
;;; Replace all more permanent definitions of VAR with DEFINE.
(defun fix-multiple-definitions (var)
(orbit-warning "~S is multiply defined" (variable-name var))
(dolist (ref (variable-refs var))
(let ((variant (supports-definition ref)))
(if (eq 'constant variant)
(setf (primop-value (call-proc (node-parent ref)))
primop/*define)))))
;;;
(defun weaken-support (table)
(walk-support table
#'(lambda (name support)
(ignore name)
(cond ((eq 'constant (support-variant support))
(setf (support-value support) nil)
(setf (support-variant support) 'define)))))
(values))