;;; -*- mode:lisp;package:user;base:10.;fonts: cptfont -*- ;;; ;;; Hacked 15 August 1985 Richard Mark Soley for Lambda port ;;; ;;;$Header: /ct/interp/diana.l,v 1.36 84/06/22 15:37:43 bill Exp $ ;;; ;;;$Log: /ct/interp/diana.l,v $ ;;;Revision 1.36 84/06/22 15:37:43 bill ;;;Fixed bug in diana_children so that it will now discard threads and conts ;;;regardless of what form they may take. ;;; ;;;Revision 1.35 84/05/09 13:30:56 penny ;;;enforced the loading of all three diana files if either dianatts ;;;or dianonds needs loading. This would have crashed in other instances. ;;; ;;;Revision 1.34 84/05/08 20:01:06 penny ;;;forced the reloading of dianapos if either dianatts ot dianods reloaded ;;; ;;;Revision 1.33 84/05/07 18:33:55 penny ;;;stopped the pprint of ct_threadp if not verbose ;;; ;;;Revision 1.32 84/04/12 17:00:23 bill ;;;Changed diana_cons and diana_threadify_int so that ct_threadp now starts off ;;;as nil. ;;; ;;;Revision 1.31 84/04/11 17:26:57 bill ;;;Added the functions diana_late_put, diana_late_get, diana_late_rem. ;;;Changed the threadifier to make ct_threadp a list of all nodes which ;;;point to a given node. ;;; ;;;Revision 1.30 84/02/12 18:45:48 mark ;;;Fixed it to enable impure diana. Also brought back the ;;;pretty printer from dianaids. ;;; ;;;Revision 1.29 84/01/30 21:29:41 mark ;;;Fixed a bug in diana_children function in that it "tripped" ;;;over lists with dotted tails in the debugger. Now it is more ;;;careful, using a "do" instead of a "mapc". No other changes. ;;;This should not require recompiling anything (phew!!). ;;; ;;;Revision 1.28 84/01/13 06:29:33 mark ;;;This is Pass Five of the New Diana, which basically completes the ;;;project. What remains is to consider the impure slot idea, try to ;;;prune a few universal attributes away, and bring the documentation ;;;back up to speed with the code. This software should now be stable ;;;and in very good shape. Many bugs were fixed. It should be smaller ;;;and faster than Pass Four as well. ;;; ;;;Revision 1.27 84/01/04 19:25:21 mark ;;;Split it into three files, the other two are dianatts and ;;;diananods, and cleaned up a few things. ;;; ;;;Revision 1.26 83/12/29 19:25:05 mark ;;;Improved Pass Three with many of the missing node->att pairs used ;;;in CTAda now added. In particular, sm_value is now allowed on all ;;;dn_xxx_id nodes. All missing pairs discovered to date have been ;;;added. Also, adds missing functions and corrects code that was ;;;commented out. Debugging mode version with heavy error checking. ;;;Diana_test seems to work on both ".qb" and ".o" -- ready to try ;;;a build on either machine. Now 14 contingent slots, 11 universal. ;;; ;;;Revision 1.25 83/12/28 18:45:44 mark ;;;Re-compiled with a minor fix in order of compilation for diana_get. ;;; ;;;Revision 1.23 83/12/21 03:23:05 mark ;;;Same as 1.22, previous check-in was aborted due to Vax compilation ;;;problems. -- Somebody PLEASE change charmac to NOT load Diana!! ;;; ;;;Revision 1.22 83/12/21 02:42:46 mark ;;;Fixed bug of trying to mapc the macro sp_princ. Changed atom ;;;to ct_atomp and defined that. Fixed bug in atomic_listp. Added ;;;more checks to diana_test and diana_wffp. Found and fixed bug ;;;in diana_children of as_lists. Fixed diana_node_type_set typo. ;;;Added as_id, as_dscrmnt_var_s, sm_wegot, sm_decl_s, and perhaps ;;;one or two others. Cleaned up pretty printer slightly. A few ;;;other minor changes toward third pass. This is still a pass 2 ;;;version, 128 words per node. ;;; ;;;Revision 1.21 83/12/20 02:04:04 mark ;;;Improved error checking and macro expansions, fixed bug in ;;;diana_pprint for lists of nodes, various cleanups toward pass 3. ;;;This is still a pass 2 implementation, and very wasteful of space. ;;;Added diana_wffp {partial version} and diana_test. ;;; ;;; ;;;Revision 1.20 83/12/18 18:35:49 mark ;;;Fixed bugs in threadifier and diana_pprint. ;;; ;;;Revision 1.19 83/12/18 14:42:40 mark ;;;Pass Two release of new representation scheme. ;;; ;;;Revision 1.18 83/12/13 20:36:47 mark ;;;Corrected the bug that macros were not wrapped in suitable ;;;eval-when forms. ;;; ;;;Revision 1.17 83/12/12 18:17:15 mark ;;;Brought the old representation up to the new spec, as ;;;described in /ct/interp/diana.man1, in preparation for ;;;conversion to the new hunk-based representation. (Pass 1.) ;;; ;;;Revision 1.16 83/11/07 16:12:08 penny ;;;Re-instated the pure-space stuff. ;;; ;;;Revision 1.15 83/11/05 19:17:31 pozsvath ;;;Added definitions for dn_sons for each dn. ;;; ;;;Revision 1.14 83/10/29 22:27:30 pozsvath ;;;Defined arity for diana nodes and added some more nodes to the ;;;constant list (that were left out). ;;; ;;;Revision 1.13 83/10/29 19:42:44 penny ;;;Removed the pure space stuff, not working on franz. ;;; ;;;Revision 1.12 83/10/28 15:19:40 penny ;;;Changed diana_put and diana_threadify to use pure-space. ;;; ;;;Revision 1.11 83/10/14 14:24:34 penny ;;;Commented out the defvar on *diana_internp*, made it a special ;;;added the putprop on the intern'd gensym in diana_ct_id. ;;; ;;; ;;;Revision 1.10 83/10/12 03:19:24 penny ;;;Tried to make nodify work and broke it, commented it out. ;;; ;;;Revision 1.9 83/10/10 23:07:26 penny ;;;Added the node dn_already_in_there to ct_predefined nodes. ;;; ;;;Revision 1.8 83/09/29 15:17:13 bill ;;;Added a diana_rem function to remove diana node attributes. ;;; ;;;Revision 1.7 83/09/20 23:23:30 paul ;;;Convert to new filename convention. ;;; ;;;Revision 1.6 83/08/30 01:03:28 penny ;;;Global replaced io with ct_io. ;;; ;;;Revision 1.5 83/08/11 14:57:27 penny ;;;Added dn_character_literal. ;;; ;;;Revision 1.4 83/07/20 14:35:45 penny ;;;Placed defs of uplow lowup uplowlist lowuplist from ;;;stdenv in to resolve problem. ;;; ;;;Revision 1.3 83/07/06 09:34:06 penny ;;;Repositioned mode line. ;;; ;;;Revision 1.1 83/06/22 12:42:27 penny ;;;Initial revision. ;;; ;;;Edit History Prior to Revision Control: ;;;Edit by Mark, rename ct_package_mixin ct_named_context 26-May-83 ;;;Edit by Mark to add to list of "quiet" attributes. 22-May-83 ;;;Edit by Mark to force ct_id attributes to the front. 16-May-83 ;;;Edit by Mark Miller to flush fe_result, some *tst*'s. 9-May-83 ;;;Edits by Paul and Others to Improve PPRINT etc. Apr&May-83 ;;;Edit by Mark Miller 7-Apr-83 ;;;Edit by John Shelton, Mark Miller 25-Mar-83 ;;;Initial implementation by Mark M and Paul R 6-Feb-83 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; DIANA ;;; ;;; Mark Miller and Paul Robertson 6-Feb-83 ;;; ;;; ;;; ;;; This is the code implementing the CTADA DIANA USERS MANUAL. ;;; ;;; See the file /ct/interp/diana.man for details. ;;; ;;; ;;; ;;; Collection of utility routines for working with C*T Diana ;;; ;;; Structures. Since they are potentially circular and need to ;;; ;;; preserve EQ-ness across operations like File Write/Read, several ;;; ;;; such are needed. Also provides for GETting a field from a Diana ;;; ;;; node, PUTting a new value/field, and checking whether a given ;;; ;;; frob IS a legal Diana node. Finally there's a "threadifier" for ;;; ;;; installing sideways and upward threads into a structure for the ;;; ;;; benefit of the back end. The threadifier expects STANDARD Diana ;;; ;;; Structures as input, and provides LEGAL BUT AUGMENTED Diana ;;; ;;; Structures as output. All C*T-augmentation fields have names of ;;; ;;; the form "ct_xxxx". ;;; ;;; ;;; ;;; This file is part of a proprietary software project. Source ;;; ;;; code and documentation describing implementation details are ;;; ;;; available on a confidential, non-disclosure basis only. These ;;; ;;; materials, including this file in particular, are trade secrets ;;; ;;; of Computer * Thought Corporation. ;;; ;;; ;;; ;;; (c) Copyright 1982 and 1983, Computer * Thought Corporation. ;;; ;;; All Rights Reserved. ;;; ;;; ;;; ;;; Reference materials: ;;; ;;; Miller, December 1983. The CTAda Diana Users Manual (online). ;;; ;;; Ambler & Trawick, Chatin's Graph Coloring Algorithm as a ;;; ;;; Method for Assigning Positions to Diana Attributes. ;;; ;;; SIGPLAN NOTICES, V18, #2, February 1983. ;;; ;;; Robertson & Miller, 1982. The C*T Diana Virtual Machine. ;;; ;;; Foderaro and Sklower, The FRANZ LISP Manual, September 1981. ;;; ;;; Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981. ;;; ;;; Charniak et al., 1980. Artificial Intelligence Programming. ;;; ;;; Miller, 1982. The C*T Ada Tutor: Guide to the Implementation. ;;; ;;; Tartan Labs, 1982. The Diana Reference Manual. ;;; ;;; The following code assumes familiarity with these materials. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Please Note Well: THIS DOCUMENTATION IS OUT OF DATE ++PASS6 ;;; ;;; ;;; ;;; Notice that a number of items are read-time conditionalized so ;;; ;;; that they will only be seen when loading or compiling with ;;; ;;; (sstatus feature diana_debugging) in effect. These features ;;; ;;; are only needed for debugging the Diana package, and are not ;;; ;;; used sufficiently often to warrant using up extra space in the ;;; ;;; actual system. After setting this switch, it is necessary to ;;; ;;; re-compile or re-load this file in order to cause these ;;; ;;; features to become available. ;;; ;;; ;;; ;;; Some symbols defined here are for internal use only. The ;;; ;;; following are the SUPPORTED features defined in this file: ;;; ;;; See the self-contained Diana.Doc commentary for full details. ;;; ;;; ;;; ;;; diana_actual_attributes, diana_arity, diana_attributep, ;;; ;;; *diana_attributes* (debugging only), ;;; ;;; diana_children, diana_cons, diana_copy, ;;; ;;; diana_get, diana_impure_put, *diana_internp*, ;;; ;;; diana_legal_attributes, diana_mapc, diana_mapcar, ;;; ;;; *diana_node_counter*, diana_nodep, diana_nodetype_get, ;;; ;;; diana_nodetypep, *diana_nodetypes* (debugging-only), ;;; ;;; diana_pprint, diana_put, diana_rem, diana_nodetype_structural, ;;; ;;; diana_test diana_late_put, diana_late_get, diana_late_rem ;;; ;;; (debugging-only), diana_threadify, diana_wffp (debugging- ;;; ;;; only). ;;; ;;; ;;; ;;; All other symbols defined here are subject to change without ;;; ;;; notice. See Diana.Man for detailed specifications. ;;; ;;; ;;; ;;; Please do not rely on the internal representation of this ;;; ;;; abstract datatype. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ensure presence of needed files. (comment Assumes the presence of ctload and a suitable database) (declare (ct_includef 'intrpdcl)) ;;; Uses several special variables named *diana_xxx* from ;;; the global interpreter declarations file. (eval-when (compile load eval) (ct_load 'charmac)) #$. (ct_load 'aip) ;AIP Macros pkg. #$. (ct_load 'compat) ;Compatibility Pkg. #$. (ct_load 'ctio) ;Input-Output. #$. (ct_load 'polly) ;Pure space stuff. #$. (ct_load 'chunks) ;Hunk-like datatype. ;;; Since the attributes or nodetypes files might have been previously ;;; loaded but without full complr data, it may be necessary to use ;;; ct_reload instead of ct_load. This mainly applies to the LISPM ;;; since the compiler and runtime environments live in the same world. (eval-when (compile eval) (cond ((or (not (boundp '*diana_nodetypes*)) (null *diana_nodetypes*) (not (boundp '*diana_attributes*)) (null *diana_attributes*)) (ct_reload 'dianatts) (ct_reload 'dianods) (ct_reload 'dianapos)))) (eval-when (load) (ct_load 'dianatts) (ct_load 'dianods)) #$. (ct_load 'dianapos) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- #+franz (declare (macros t)) (declare (special *diana_internp* *diana_purep*)) (cond ((not (boundp '*diana_internp*)) ;;; This is a runtime flag which can be lambda-bound to control the ;;; intern-ing of ct_id's. If non-nil, then diana_cons will put the ;;; gensym'd symbol which is the ct_id of a new node onto the system ;;; obarray so that it can be tested with eq, and set the value cell ;;; of the gensym'd symbol to point to the node itself. ;;; This is a system-wide specvar declared in ;;; intrpdcl. Its use is in diana_cons, in this file. Dianaio ;;; relies on the intern-ing feature (for saving trees before FE ;;; init) to build package standard. It is also useful in debugging. (setq *diana_internp* (or (status feature diana_debugging) (status feature debugging))))) (cond ((not (boundp '*diana_purep*)) (setq *diana_purep* nil))) (declare (special *diana_node_counter*) (fixnum *diana_node_counter*)) ;;; *diana_node_counter* -- a non-negative integer indicating how ;;; many Diana nodes have been created so far in this image. ;;; Primarily useful for comparison before and after parsing a given ;;; function. Slight operational change, computed in diana_cons ;;; rather than diana_ct_id. System-wide specvar, declared in intrpdcl. ;;; Maintained by diana_cons, all others treat this as read-only please. #$. (cond ((not (boundp '*diana_node_counter*)) (setq *diana_node_counter* 0))) #+franz (declare (localf diana_threadify_int diana_threadify_once)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Begin Access Function on Diana Nodes {Versus NodeTypes} #$. ;;;;;;;;;;;;;;;;;; (defun diana_nodetype_get macro (form) ;;;;;;;;;;;;;;;;;; ;;; (diana_nodetype_get node) must be given a well-formed ;;; Diana node as input. It will return an atomic symbol ;;; which is the name of the "Diana nodetype" of this node. (selfinsertmacro form #-diana_debugging `(chunk-get ,(cadr form) #.(diana_attribute_position 'ct_nodetype)) #+diana_debugging `(diana_nodetype_get_dbint ,(cadr form)))) #$. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_node_accepts_attributep (node att) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Note that the first arg, here, is a NODE, not a NODETYPE. (or (diana_attribute_universalp att) (memq att (diana_contingent_attributes (diana_nodetype_get node))))) (eval-when (compile eval #+diana_debugging load) ;;;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_node_attribute_check (node att fun) ;;;;;;;;;;;;;;;;;;;;;;;;;; (or (diana_node_accepts_attributep node att) (lose 'wta fun `("~&The attribute ~S is not allowed for nodetype: ~S~%" ,att ,(diana_nodetype_get node)))))) #$. ;;;;;;;;;;;;;;;;;;;;;;; (defun diana_virtual_node_size macro (form) ;;;;;;;;;;;;;;;;;;;;;;; ;;; Returns the size that this type of node OUGHT to be. (selfinsertmacro form `(diana_nodetype_size (diana_nodetype_get ,(cadr form))))) #$. ;;;;;;;;;;;;;;; (defun diana_nodep_int (frob) ;For internal use only. ;;;;;;;;;;;;;;; (and (chunkp frob) (diana_nodetypep (chunk-get frob #.(diana_attribute_position 'ct_nodetype))))) #$. ;;;;;;;;;;; (defun diana_nodep macro (form) ;;;;;;;;;;; ;;; (diana_nodep frob) can be given an arbitrary LISP object ;;; as input. Returns non-nil iff the frob has the essential ;;; syntactic shape to qualify as a Diana node. The check is ;;; cheap {and tries to optimize at compile time}. By contrast, ;;; diana_wffp is more expensive but completely thorough. It ;;; is safe to apply diana_nodep to any type of frob. (selfinsertmacro form (let ((frob (cadr form))) (cond ;First try for compile-time const. ((and (consp frob) (eq (car frob) 'quote)) `(quote ,(diana_nodep_int (cadr frob)))) ((symbolp frob) ;OK to have multiple evaluation. `(and (chunkp ,frob) ;Assumes ct_nodetype is slot 1. (diana_nodetypep (chunk-get ,frob 1)))) (t `(diana_nodep_int ,frob)))))) #$. ;;;;;;;;;;;;;;;;; (defun diana_nodep_check (node fun) ;;;;;;;;;;;;;;;;; (cond ((diana_nodep node) node) (t (lose 'wta fun `("~&Datum should be a Diana node: ~S~%" ,node)) nil))) (eval-when (compile eval #+diana_debugging load) ;;;;;;;;;;;;;;;;; (defun diana_ct_id_dbint (nod) ;Internal-use-only, debugging. ;;;;;;;;;;;;;;;;; (and (diana_nodep_check nod 'diana_ct_id) (symbolp-check (chunk-get nod #.(diana_attribute_position 'ct_id)) 'diana_ct_id)))) (eval-when (compile eval #+diana_debugging load) ;;;;;;;;;;;;;;; (defun diana_get_dbint (node att) ;Internal-use-only ;;;;;;;;;;;;;;; (and (diana_nodep_check node 'diana_get) (diana_attributep_check att 'diana_get) (diana_node_attribute_check node att 'diana_get) (chunk-get node (diana_attribute_position att))))) #$. ;;;;;;;;; (defun diana_get macro (form) ;;;;;;;;; ;;; (diana_get node att) -- returns the value of the attribute ;;; slot in node. Node must be a legal Diana node, and att ;;; must be the name of a legal attribute for that type of ;;; node. Whenever possible, code should be written using a ;;; quoted constant symbol for the attribute, as in: ;;; (diana_get dn 'as_list), as very efficient code is compiled ;;; for this common case. (let ((nod (cadr form)) (att (caddr form))) (selfinsertmacro form #+diana_debugging `(diana_get_dbint ,nod ,att) #-diana_debugging `(chunk-get ,nod ,(cond ;Check for compile-time constant. ((and (consp att) (eq (car att) 'quote) (diana_attributep_check (cadr att) 'diana_get)) (diana_attribute_position (cadr att))) (t `(diana_attribute_position ,att))))))) (eval-when (load eval) ;Eventually flush. ++Pass6 ;;;;;;;;;;; ;Setup obsolete funwarn switch?? (defun diana_ct_id macro (form) ;Equiv to (diana_get n 'ct_id) ;;;;;;;;;;; (selfinsertmacro form `(diana_get ,(cadr form) 'ct_id)))) #$. ;;;;;;;;;;;;;; (defun diana_mapc_int (node fun) ;Internal expander function. ;;;;;;;;;;;;;; (let ((i (gensym)) (nod (gensym)) (max (gensym)) (att (gensym)) (typ (gensym))) `(let ((,nod ,node)) #+diana_debugging (diana_nodep_check ,nod 'diana_mapc) (let ((,max (diana_virtual_node_size ,nod)) (,typ (diana_nodetype_get ,nod))) (declare (fixnum ,max)) (do ((,i 0 (1+ ,i))) ((= ,i ,max) nil) (declare (fixnum ,i)) ;;; NB: It is important that the "combination" ((lambda .. ) args) ;;; in the body of this loop be implemented as is, and not, say, as ;;; as a funcall, in order to get proper lexical scoping from Liszt. (let ((,att (diana_attribute_symbol ,typ ,i))) ;;; NB: Can get a null attribute since some slots are ;;; supposed to be unused by some nodes. Do not give ;;; null attributes to the function to grok!! (and ,att (,fun ,att (chunk-get ,nod ,i))))))))) (eval-when (eval compile load) ;;; Replaces old calls to "eval" below. (defun soley-strip-off-lambda-quoting (form) (cond ((atom form) form) ((memq (car form) '(function quote)) (second form)) (t form)))) #$. ;;;;;;;;;; (defun diana_mapc macro (form) ;;;;;;;;;; ;;; (diana_mapc func node) -- analogous to mapc for the ;;; attributes of a given Diana node. Func should accept TWO ;;; arguments, the symbolic NAME of the attribute, and its ;;; value. Normally, this should be more efficient than using ;;; mapc with an analogous one-argument function over the ;;; (diana_actual_attributes node). Note that the functional ;;; argument is "eval'd" at compile time {thus removing one level ;;; of "FUNCTION" or "QUOTE" wrapper}, as you might expect. (selfinsertmacro form ;;; The following form calls an internal function to do ;;; the expansion, and thus is not itself backquoted. (diana_mapc_int (caddr form) (soley-strip-off-lambda-quoting (cadr form))))) #$. ;;;;;;;;;;;;;;;; (defun diana_mapcar_int (node fun) ;Internal expander function. ;;;;;;;;;;;;;;;; (let ((i (gensym)) (nod (gensym)) (max (gensym)) (val (gensym)) (att (gensym)) (typ (gensym))) `(let ((,nod ,node)) #+diana_debugging (diana_nodep_check ,nod 'diana_mapcar) ;For LOSE effect. (let ((,max (diana_virtual_node_size ,nod)) (,val nil) (,typ (diana_nodetype_get ,nod))) (declare (fixnum ,max)) (do ((,i 0 (1+ ,i))) ((= ,i ,max) (nreverse ,val)) (declare (fixnum ,i)) ;;; NB: It is important that the "combination" ((lambda .. ) args) ;;; in the body of this loop be implemented as is, and not, say, as ;;; as a funcall, in order to get proper lexical scoping from Liszt. (let ((,att (diana_attribute_symbol ,typ ,i))) ;;; Remember that NULL attributes appear for ;;; unused slots. Do not pass these along!! (and ,att (setq ,val (cons (,fun ,att (chunk-get ,nod ,i)) ,val))))))))) #$. ;;;;;;;;;;;; (defun diana_mapcar macro (form) ;;;;;;;;;;;; ;;; Like diana_mapc but returns list of results. (selfinsertmacro form ;;; The following form calls an internal function to do ;;; the expansion, and thus is not itself backquoted. (diana_mapcar_int (caddr form) (soley-strip-off-lambda-quoting (cadr form))))) (eval-when (compile eval #+diana_debugging load) ;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_nodetype_get_dbint (node) ;;;;;;;;;;;;;;;;;;;;;;;; (cond ((chunkp node) (diana_nodetypep_check (chunk-get node #.(diana_attribute_position 'ct_nodetype)) 'diana_nodetype_get)) (t (lose 'wta 'diana_nodetype_get `("~&Datum should be a Diana node: ~S~%" ,node)) nil)))) (eval-when (compile eval #+diana_debugging load) ;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_nodetype_set_dbint (nod typ) ;Internal-use-only. ;;;;;;;;;;;;;;;;;;;;;;;; (and (diana_nodep_check nod 'diana_nodetype_set) (diana_nodetypep_check typ 'diana_nodetype_set) (let* ((pos #.(diana_attribute_position 'ct_nodetype)) (otyp (chunk-get nod pos))) (cond ((diana_compatiblep otyp typ) (chunk-put nod typ pos)) (t (lose 'diana_randomness 'diana_nodetype_set `("~&Diana Node types must be compatible:~% ~S~% ~S~%" ,otyp ,typ)))))))) #$. ;;;;;;;;;;;;;;;;;; (defun diana_nodetype_set macro (form) ;;;;;;;;;;;;;;;;;; ;;; (diana_nodetype_set node typ) must be given a well-formed ;;; Diana node and legal type as input. It will return a modified node ;;; which has the new "Diana nodetype". Dangerous, since the slots ;;; might be wrong now -- CAVEAT EMPTOR!! Note that Diana_Put can ;;; do this, anyway, without being checked {sigh}. ++Pass6 (selfinsertmacro form #-diana_debugging `(chunk-put ,(cadr form) ,(caddr form) #.(diana_attribute_position 'ct_nodetype)) #+diana_debugging `(diana_nodetype_set_dbint ,(cadr form) ,(caddr form)))) (eval-when (compile eval #+diana_debugging load) ;;;;;;;;;;;;;;; (defun diana_put_dbint (node val att) ;Internal-use-only. ;;;;;;;;;;;;;;; (and (diana_nodep_check node 'diana_put) (diana_attributep_check att 'diana_put) (diana_attribute_value_check att val 'diana_put) (diana_node_attribute_check node att 'diana_put) (chunk-put node val (diana_attribute_position att))))) #$. ;;;;;;;;; (defun diana_put macro (form) ;;;;;;;;; ;;; Re-write these comments to bring up to date -- ++Pass6 ;;; In particular, we return the VALUE, NOT the NODE. ;;; Note that what is pure is determined by the attribute now!! ;;; ;;; (diana_put node value att) => value. Clobbers node such ;;; that (diana_get node att) => value. NB: The previous ;;; value of that slot might become uncollectable garbage. ;;; Also, this is possibly risky if things really can become ;;; read-only or if we find a way to make pure space sharable. ;;; NB: more efficient code is generated in the case where ;;; att is a quoted constant symbol, just as in diana_get. (selfinsertmacro form (let ((nod (cadr form)) (val (caddr form)) (att (cadddr form))) #-diana_debugging `(chunk-put ,nod ,val ,(cond ;Check for compile-time constant. ((and (consp att) (eq (car att) 'quote) (diana_attributep_check (cadr att) 'diana_put)) (diana_attribute_position (cadr att))) (t `(diana_attribute_position ,att)))) #+diana_debugging `(diana_put_dbint ,nod ,val ,att)))) ;;;Commented out diana rem. This function is obsolete. The only attributes ;;;which will be removeable will be the "late" attributes. --wab 4-11-84 #| ;;;;;;;;; (defun diana_rem macro (form) ;;;;;;;;; ;;; (diana_rem node att) => (). Clobbers node such that ;;; (diana_get node att) => nil. Functionally equivalent to ;;; (diana_put node nil att), but could possibly release some ;;; storage depending on the implementation (not guaranteed). ;;; NB: The previous value of (diana_get node 'att) MIGHT ;;; become uncollectable garbage. Possibly risky, see ;;; diana_put. More efficient if att is a quoted constant ;;; symbol, just as in diana_put. (selfinsertmacro form ;;; Current just expands to the corresponding diana_put. `(diana_put ,(cadr form) nil ,(caddr form)))) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; User-Callable Functions -- ;;;Three new functions for manipulating the "late" attributes. Late ;;;attributes are added at run time rather than at front end time. The ;;;late attributes are kept in a disembodied property list which is ;;;hung off the ct_late_attributes attribute of a node. ;;;;;;;;;;;;;; (defun diana_late_put (node value indicator) ;;;;;;;;;;;;;; (putprop (diana_get node 'ct_late_attributes) value indicator)) ;;;;;;;;;;;;;; (defun diana_late_get (node indicator) ;;;;;;;;;;;;;; (get (diana_get node 'ct_late_attributes) indicator)) ;;;;;;;;;;;;;; (defun diana_late_rem (node indicator) ;;;;;;;;;;;;;; (remprop (diana_get node 'ct_late_attributes) indicator)) ;;;;;;;;;;;;;;;;;;;;;;; (defun diana_actual_attributes (node) ;;;;;;;;;;;;;;;;;;;;;;; ;;; Conses up a list of the attribute names currently defined ;;; and non-NIL on THIS PARTICULAR Diana node. This may not be the ;;; same as the legal list for this TYPE of node, eg if there are ;;; any debugger etc. properties that are not always present. (let ((ans_so_far nil) (typ (diana_nodetype_get node))) (do ((i 0 (1+ i))) ((= i (diana_nodetype_size typ)) ans_so_far) ;NB: in reverse order. (declare (fixnum i)) (and (chunk-get node i) ;Non-nil values only. (setq ans_so_far (cons (diana_attribute_symbol typ i) ans_so_far)))))) ;;;;;;;;;;;;;; (defun diana_children (node) ;;;;;;;;;;;;;; ;;; This function is as specified by the debugger group. It ;;; returns a list of all Diana nodes which are values of attributes ;;; of the current node, except that ct_threadp and ct_cont ;;; attributes are ignored. Attributes whose values are not ;;; Diana nodes are also ignored. Duplicate occurrences of a ;;; given child node are skipped. #+diana_debugging (diana_nodep_check node 'diana_children) (let ((ans_so_far nil)) (diana_mapc #'(lambda (att val) (cond ((or (eq att 'ct_threadp) ;Skip threads and conts (eq att 'ct_cont))) ((diana_nodep val) (or (memq val ans_so_far) ;Skip repeats. (setq ans_so_far (cons val ans_so_far)))) ((consp val) ;List of nodes? (do ((rst val (cdr rst))) ((not (consp rst)) ;Beware dotted tails. (cond ((and (diana_nodep rst) (not (memq rst ans_so_far))) (setq ans_so_far (cons rst ans_so_far))))) (and (diana_nodep (car rst)) (not (memq (car rst) ans_so_far)) (setq ans_so_far (cons (car rst) ans_so_far))))))) node) ans_so_far)) ;;;;;;;;;; (defun diana_cons (type) ;;;;;;;;;; ;;; Returns a new Diana node of nodetype type. {This happens to be ;;; a possibly-pure "chunk" of an appropriate size, but PLEASE do not rely ;;; on the representation -- it may change!!} Except for the ct_id, the ;;; ct_nodetype, ct_threadp, ct_late_attributes and ct_cont, all slot values are initialized ;;; to nil. Diana_cons maintains the specvar *diana_node_counter*, and ;;; is sensitive to the specvar *diana_internp*. If non-nil, the ;;; generated ct_id for the node will be interned on the obarray. ;;; If interned, it will also have the node itself stuffed into ;;; the symbol's value cell. If *diana_purep* is non-nil, the node is ;;; created on an unswept page. #+diana_debugging (diana_nodetypep_check type 'diana_cons) ;For LOSE effect. (setq *diana_node_counter* (1+ *diana_node_counter*)) (let ((g (cond (*diana_internp* (intern (gensym))) (t (gensym)))) (n (cond (*diana_purep* (make-pure-chunk (diana_nodetype_size type))) (t (make-chunk (diana_nodetype_size type)))))) (chunk-put n g #.(diana_attribute_position 'ct_id)) (chunk-put n type #.(diana_attribute_position 'ct_nodetype)) ;Comment out this initialization -- wab 4-12-84 ; (chunk-put n '*to_be_threaded* #.(diana_attribute_position 'ct_threadp)) (chunk-put n '*to_be_continued* #.(diana_attribute_position 'ct_cont)) (chunk-put n (ncons nil) #.(diana_attribute_position 'ct_late_attributes)) (cond (*diana_internp* (set g n))) n)) ;;;;;;;;;; (defun diana_copy (node) ;;;;;;;;;; ;;; Returns a new node with a new unique ct_id which is a ;;; toplevel-only copy of node. That is, it is a node with the same ;;; nodetype and the same values of the same attributes. It is up to ;;; the caller to do any appropriate substitutions (if needed) or to ;;; copy at all levels (if needed). {It would have been slightly ;;; cleaner to build this using diana_mapc, but going directly to the ;;; chunk representation level is a lot more efficient.} #+diana_debugging (diana_nodep_check node 'diana_copy) (let ((new (diana_cons (chunk-get node #.(diana_attribute_position 'ct_nodetype)))) (max (diana_virtual_node_size node))) (declare (fixnum max)) (do ((i 2 (1+ i))) ;;NB: Skip ct_id and ct_nodetype, ((= i max) new) ;;the "2" is ugly but cheap. (declare (fixnum i)) ;; --mlm (chunk-put new (chunk-get node i) i)))) ;;;;;;;;;;;;;;; (defun diana_threadify (nod) ;;;;;;;;;;;;;;; ;;; Installs threads and possibly certain other CT implementation- ;;; specific fields into a Diana structure. Must be run between front ;;; end and backend. Makes one pass over the ENTIRE structure. Returns ;;; modified node. Threads can be up to parents or sideways, as ;;; appropriate. Top level node has continuation NIL {ie nothing left ;;; to do}. #+diana_debugging (diana_nodep_check nod 'diana_threadify) (diana_threadify_int nod nil) ;Arg 2 is mom {ct_threadp}. nod) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internal Use Only ;;;Commented out old version of diana_threadify_int. --wab 4-11-84 #| ;;; Internal-only to diana_threadify -- see localf declaration above. ;;;;;;;;;;;;;;;;;;; (defun diana_threadify_int (frob mom) ;;;;;;;;;;;;;;;;;;; (cond ;;; Ct_threadp points to mom always. ((diana_nodep frob) ;;; If still to be threaded, jump into it. (cond ((eq (diana_get frob 'ct_threadp) '*to_be_threaded*) (diana_put frob mom 'ct_cont) (diana_put frob mom 'ct_threadp) (diana_mapc ;Thread non-backptr children. #'(lambda (att val) (or (memq att '(ct_cont ct_threadp ct_id ct_nodetype sm_defn sm_first sm_deff_occurence as_subprogram_def)) (diana_threadify_int val frob))) frob)))) ((consp frob) ;Perhaps a list of Diana nodes? (do ((rest frob (cdr rest))) ((not (consp (cdr rest))) ;Being wary of (a b . c) stuff, (cond ((diana_nodep (car rest)) ;but assuming c cannot be a node. (diana_threadify_int (car rest) mom)))) (cond ((diana_nodep (car rest)) ;;Recursive decent threadify, (diana_threadify_int (car rest) mom) ;;but fix wrong continuation. (diana_put (car rest) (cadr rest) 'ct_cont))))))) |# ;;;New version of diana_threadify_int. Difference is that we now make ct_threadp a ;;;list of all nodes which point to a given node rather than the first one we find. ;;;Note that we did not start a node with a list of (*to_be_threaded*) because generic ;;;instantiations do not copy the threadp attribute and hence would end up sharing ;;;a cons cell. ;;;Threadp now starts off as nil. If we have visited the node by the back door route ;;;but not via the front door, then threadp will be a list containing *to_be_threaded*. ;;;When we reach the node via the front door route, then the *to_be_threaded* will be ;;;rplaca'ed out of the list. ;;;Note, front door route means entering the node the same way as the old threadifier did. ;;;This is so that the backend can look for first of threadp and get the same old value. ;;;Note also, that we start threadp as nil now so that it is always legal to take first ;;;of it. ;;;;;;;;;;;;;;;;;;; (defun diana_threadify_int (frob mom &aux current_threadp) ;;;;;;;;;;;;;;;;;;; (cond ((diana_nodep frob) ;A single diana node? (setq current_threadp (diana_get frob 'ct_threadp)) (cond ((null current_threadp) ;;First time here so thread it and try descending. (diana_put frob (ncons mom) 'ct_threadp) (diana_put frob mom 'ct_cont) (diana_mapc ;Thread non-backptr children. #'(lambda (att val) (cond ((memq att '(ct_cont ct_threadp))) ((memq att '(ct_id ct_nodetype sm_defn sm_first as_subprogram_def)) (diana_threadify_once val frob)) (t (diana_threadify_int val frob)))) frob)) ((eq (first current_threadp) '*to_be_threaded*) ;;Been here before but through the back door. Thread it and try descending. (rplaca (delq mom current_threadp) mom) (diana_put frob mom 'ct_cont) (diana_mapc ;Thread non-backptr children. #'(lambda (att val) (cond ((memq att '(ct_cont ct_threadp))) ((memq att '(ct_id ct_nodetype sm_defn sm_first as_subprogram_def)) (diana_threadify_once val frob)) (t (diana_threadify_int val frob)))) frob)) (t ;;Otherwise just add to the thread list. (diana_threadify_once frob mom)))) ((consp frob) ;Perhaps a list of Diana nodes? (do ((rest frob (cdr rest))) ((not (consp (cdr rest))) ;Being wary of (a b . c) stuff, (cond ((diana_nodep (car rest)) (diana_threadify_int (car rest) mom)))) (cond ((diana_nodep (car rest)) ;;Recursive decent threadify, (diana_threadify_int (car rest) mom) ;;but fix wrong continuation. (diana_put (car rest) (cadr rest) 'ct_cont))))))) ;;;Helper function for the threadify. Diana_threadify_once is called when ;;;we need to thread a node but we don't want to do a recursive descent on its ;;;children. 7 ;;;;;;;;;;;;;;;;;;;; (defun diana_threadify_once (frob mom &aux current_threadp) ;;;;;;;;;;;;;;;;;;;; (cond ((diana_nodep frob) ;A single diana node? (setq current_threadp (diana_get frob 'ct_threadp)) (cond ((null current_threadp) ;;First time here. (diana_put frob (list '*to_be_threaded* mom) 'ct_threadp)) ((not (memq mom current_threadp)) ;;Been here before. Just add to the end. (nconc current_threadp (ncons mom))))) ((consp frob) ;Perhaps a list of Diana nodes? (do ((rest frob (cdr rest))) ((not (consp (cdr rest))) ;Being wary of (a b . c) stuff, (cond ((diana_nodep (car rest)) (diana_threadify_once (car rest) mom)))) (cond ((diana_nodep (car rest)) ;Thread each node (diana_threadify_once (car rest) mom))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Diana Pretty Printer ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+franz (declare (localf diana_pprint_int_node diana_pprint_int)) ;;;;;;;;;;;; (defun diana_pprint (nod &optional (lev 100.) (verbose nil)) ;;;;;;;;;;;; ;;; (diana_pprint nod [lev 100.] [verbose nil]) -- ;;; Pretty-prints a given Diana node with nesting indicated ;;; using indentation, up to a depth of lev. Certain less ;;; interesting attributes are suppressed from the listing ;;; unless verbose is non-nil. (let ((*diana_printed_so_far* (list nod))) (declare (special *diana_printed_so_far*)) (diana_nodep_check nod 'diana_pprint) (ct_terpri) (ct_princ "[") (ct_princ (diana_get nod 'ct_nodetype)) (diana_pprint_int_node nod 1 lev verbose) (ct_princ "]") (ct_terpri) t)) ;;;;;;;;;;;;;;;; (defun diana_pprint_int (frob inden lev verbose) ;;;;;;;;;;;;;;;; (declare (special *diana_printed_so_far*)) (let* ((nodep (diana_nodep frob)) (id (and nodep (diana_get frob 'ct_id)))) (nl_indent inden) (cond ((ct_atomp frob) (ct_princ frob)) ((lessp lev 1) (ct_princ " ... ")) ((and nodep (not (memq id *diana_printed_so_far*))) (setq *diana_printed_so_far* (cons id *diana_printed_so_far*)) (ct_princ " [") (ct_princ (diana_get frob 'ct_nodetype)) (diana_pprint_int_node frob (+ 2 inden) lev verbose) (ct_princ "]")) (nodep (ct_princ id)) ((atomic-listp frob) (ct_princ " [") (do ((rst frob (cdr rst))) ((not (consp rst)) ;Beware of dotted tails. (cond (rst (ct_princ " . ") (ct_princ rst))) (ct_princ "]")) (ct_princ (car rst)) (cond ((consp (cdr rst)) (ct_princ " "))))) ((consp frob) ;Non-atomic list. (ct_princ " [") (do ((rst frob (cdr rst))) ((not (consp rst)) ;Beware of dotted tails. (cond (rst (ct_princ " . ") (diana_pprint_int rst (1+ inden) (1- lev) verbose))) (ct_princ " ]")) (diana_pprint_int (car rst) (1+ inden) (1- lev) verbose) (cond ((consp (cdr rst)) (nl_indent inden))))) (t (lose 'wta 'diana_pprint_int `("Frob should be node, atom or list.")))))) ;;;;;;;;;;;;;;;;;;;;; (defun diana_pprint_int_node (node inden lev verbose) ;;;;;;;;;;;;;;;;;;;;; (diana_mapc #'(lambda (att val) (cond ((or verbose (and val (diana_attribute_interestingp att) (not (eq att 'ct_threadp)))) (nl_indent (+ 3 inden)) (ct_princ att) (cond ((eq att 'lx_comments) (ct_princ " --") (mapc #'(lambda (x) (ct_princ " ") (ct_princ x)) val)) ((or (ct_atomp val) (eq att 'lx_srcpos)) (ct_princ " ") (ct_princ val)) ((and (consp val) (memq (car val) '(lex_string lex_ident))) (ct_princ " ") (ct_princ `(,(car val) ,(apply 'implode (cdr val))))) ((and (diana_nodep val) ;;; Check for potentially forward-circular link types. (memq att '(ct_threadp ct_st_defining_block ct_cont))) (ct_princ " ") (ct_princ (diana_get val 'ct_id))) (t (diana_pprint_int val (+ 3 inden) (1- lev) verbose)))))) node)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Slow Garbage ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #| ;;;;;;;;;;;;;;;;;;;;;; (defun diana_actual_node_size macro (form) ;;;;;;;;;;;;;;;;;;;;;; ;;; Returns the size of the object as viewed by the array or ;;; hunk level of representation. This may have a lot of nil ;;; or empty slots compared to the logical size. This is also ;;; not the ALLOCATED size, ie not the next higher power of two. ;;; Use this sparingly -- Franz iterates over the hunk for this one. ;;; Perhaps what you want is diana_nodetype_size? (selfinsertmacro form `(chunksize ,(cadr form)))) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; TO DO ;;; Deferred Until ++Pass6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; o Try to reduce the number of universal attributes. ;;; ;;; o Consider issue of diana_rem and using ct_impure slot for the ;;; impure, infrequent properties {eg debugger}. ;;; ;;; o Bring documentation up-to-date. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; SOMEDAY ;;; ;;; {Low Priority Things To Do} ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; o Provide a semi-programmable diana_walker that can filter out ;;; just certain predicates. ;;; ;;; o Merge on-line documentation into source code using ;%; idea. ;;; ;;; o Flesh out the legality-of-value predicates on attribute defs. ;;; This would allow debugging mode to offer better error-checking ;;; help, esp. on diana_put's. ;;; ;;; o Sort all the ct-defined attributes under each nodetype definition ;;; alphabetically so that it is possible to find whether things are ;;; there or not. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; eof ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;