;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- ;;; ;;;$Header: /ct/interp/dianatts.l,v 1.9 84/06/21 21:33:27 penny Exp $ ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; DIANATTS ;;; ;;; Mark Miller and Paul Robertson 4-Jan-84 ;;; ;;; ;;; ;;; 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: ;;; ;;; ;;; ;;; 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. ;;; ;;; ;;; ;;; This documentation is now out of date. ++Pass6 ;;; ;;; 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. ;;; ;;; ;;; ;;; 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. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Dependencies on External Files ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (comment assumes ctload and filemap) (declare (ct_includef 'intrpdcl)) (eval-when (compile load eval) (ct_load 'charmac)) ;;; One thing from charmac that we use heavily is the hash- ;;; dollar-period reader macro that expands an eval-when. #$. (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. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Special Variables ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+franz (declare (macros t)) ;;Default. ;;; Declared for external use in intrpdcl. (declare (special *diana_universal_attributes* ;;Pure-List. *diana_universals_count* ;;Length of above. *diana_attributes*)) ;;Can share structure. (setq *diana_universal_attributes* nil) (setq *diana_attributes* nil) (declare (special *dianatts_status_flag*)) ;;This file only. ;;;;;;;;;;;;;;;;;;;;;; (setq *dianatts_status_flag* ;;;;;;;;;;;;;;;;;;;;;; (or (status feature complr) (status feature diana_debugging))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Defining and Accessing Information about Diana Attributes ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; An attribute is a symbol with information on its plist. The details ;;; of this representation are subject to change without notice. However, ;;; various access functions and macros are provided for extracting it. ;;; You cannot define new ones at runtime, so this macro is only needed in ;;; this file. Care is taken to compactly represent the information about ;;; an attribute, since there are a goodly number of them. This macro ;;; is a bit long {2 pages}, but very straightforward. #+(and franz (not diana_debugging)) (declare (macros nil)) (eval-when (compile eval #+diana_debugging load) ;;;;;;;;;;;;;;;;;;; (defun diana_attribute_def macro (form) ;;;;;;;;;;;;;;;;;;; (let ((att (second form)) ;Name of the attribute. (tart (third form)) ;Whether Tartan or CT devised. (univ (fourth form)) ;Whether universal or contingent. (cat (fifth form)) ;Category, eg, lexical. (dyn (sixth form)) ;Whether dynamic or static. (pred (seventh form)) ;Legal values predicate. (inter (eighth form))) ;Whether interesting to print out. (cond ((and (= (length form) 8.) ;Check legality of defining form. (symbolp att) (memq tart '(tartan ct)) (memq univ '(universal contingent)) (memq cat '(other structural lexical semantic debugger code)) (memq dyn '(dynamic static)) (memq inter '(interesting uninteresting))) (selfinsertmacro form `(progn 'compile ,(cond ((eq univ 'universal) `(or (memq ',att *diana_universal_attributes*) (setq *diana_universal_attributes* (pure-cons ',att *diana_universal_attributes*)))) (t `(and *dianatts_status_flag* (not (memq ',att *diana_attributes*)) (setq *diana_attributes* (pure-cons ',att *diana_attributes*))))) (and *dianatts_status_flag* (pure-putprop ',att ',pred 'diana_attribute_predicate)) ;;; {progn 'compile -- continued on next page} ;;; {progn 'compile -- continued from previous page} (pure-putprop ',att (pure-cons -1 ;Empty attribute_position field. ,(+ ;Next encode the various properties (ct_selectq cat ;at compile time. (structural 1.) ;First, 3 bits for the category. (lexical 2.) (semantic 3.) (debugger 4.) (code 5.) (otherwise 0.)) ;Then, 1 bit per flag. (cond ((eq tart 'tartan) 8.) (t 0)) (cond ((eq univ 'universal) 16.) (t 0)) (cond ((eq dyn 'dynamic) 32.) (t 0)) (cond ((eq inter 'interesting) 64.) (t 0)))) 'diana_attribute_def)))) (t (lose 'wta 'diana_attribute_def `("~&Wrong format in attribute definition.~%~S~%" ,form))))))) #+franz (declare (macros t)) ;Restore default. #$. ;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_attribute_position macro (form) ;;;;;;;;;;;;;;;;;;;;;;;; ;;; Argument should be the symbol naming of a Diana attribute. (selfinsertmacro form `(car (get ,(cadr form) 'diana_attribute_def)))) #$. ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_attribute_position_set macro (form) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (selfinsertmacro form `(car (rplaca (get, (cadr form) 'diana_attribute_def) ,(caddr form))))) #+(and franz (not diana_debugging)) (declare (macros nil)) (eval-when (compile eval #+diana_debugging load) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_attribute_field_mask_int macro (form) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Given an attribute name and a fixnum representing a bitmask, ;;; returns a fixnum resulting from the bitwise-and with the ;;; appropriate field in the Diana Attribute representation. (selfinsertmacro form `(boole 1. (cdr (get ,(cadr form) 'diana_attribute_def)) ,(caddr form))))) #+franz (declare (macros t)) ;Restore default. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_attribute_flag_bitp_int (att mask) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Return non-nil iff the bit for this attribute flag is set. ;;; Mask is a fixnum identifying the appropriate bit. (declare (fixnum mask)) (> (diana_attribute_field_mask_int att mask) 0)) #+diana_debugging ;;; The next is temporarily unsupported, except in diana_debugging ;;; mode, because no one currently needs or uses it. Please remove ;;; this conditionalization if and when someone needs tartanp. The ;;; following code is correct, as of Sunday 8 January 10:26pm -- mlm. #$. ;;;;;;;;;;;;;;;;;;;;;;; (defun diana_attribute_tartanp macro (form) ;;;;;;;;;;;;;;;;;;;;;;; ;;; Argument should be the symbol naming of a Diana attribute. (selfinsertmacro form `(diana_attribute_flag_bitp_int ,(cadr form) 8.))) #$. ;;;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_attribute_universalp macro (form) ;;;;;;;;;;;;;;;;;;;;;;;;;; (selfinsertmacro form `(diana_attribute_flag_bitp_int ,(cadr form) 16.))) #$. ;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_attribute_dynamicp macro (form) ;;;;;;;;;;;;;;;;;;;;;;;; (selfinsertmacro form `(diana_attribute_flag_bitp_int ,(cadr form) 32.))) #$. ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_attribute_interestingp macro (form) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Checks if att is flagged as one that is normally suitable for ;;; printing, even if verboseness has not been requested by user. (selfinsertmacro form `(diana_attribute_flag_bitp_int ,(cadr form) 64.))) ;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_attribute_category (att) ;;;;;;;;;;;;;;;;;;;;;;;; (ct_selectq (diana_attribute_field_mask_int att 7.) ;low 3 bits. (1 'structural) (2 'lexical) (3 'semantic) (4 'debugger) (5 'code) (otherwise 'other))) ;;;;;;;;;;;;;;;;;;;;;; (defun diana_attribute_valuep (att val) ;;;;;;;;;;;;;;;;;;;;;; ;;; Lenient check for whether this attribute can accept this value ;;; in a slot. If the value is NIL, we accept. If no predicate can ;;; be found, we accept. Many times the predicate is the TRUTH fun, ;;; so we then accept all values. Otherwise, we reject (return NIL). (or (null val) ;NIL is always ok in a slot, sigh. (let ((fun (get att 'diana_attribute_predicate))) (or (not fun) (funcall fun val))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_attribute_value_check (att val fun) ;;;;;;;;;;;;;;;;;;;;;;;;;;; (or (diana_attribute_valuep att val) (lose 'wta fun `("~&Illegal value ~S for Diana Attribute ~S~%." ,val ,att)))) #$. ;;;;;;;;;;;;;;;;;;;; (defun diana_attributep_int (frob) ;;;;;;;;;;;;;;;;;;;; (and (symbolp frob) (get frob 'diana_attribute_def))) #$. ;;;;;;;;;;;;;;;; (defun diana_attributep macro (form) ;;;;;;;;;;;;;;;; ;;; Return non-nil iff argument is a symbol that is the name of ;;; a legal CTAda Diana attribute. (selfinsertmacro form (let ((frob (cadr form))) (cond ;Try for compile-time constant. ((and (consp frob) (eq (car frob) 'quote)) `(quote ,(diana_attributep_int (cadr frob)))) ((symbolp frob) ;Multiple evaluation ok here. `(and (symbolp ,frob) (get ,frob 'diana_attribute_def))) (t `(diana_attributep_int ,frob)))))) ;;;;;;;;;;;;;;;;;;;;;; (defun diana_attributep_check (att fun) ;;;;;;;;;;;;;;;;;;;;;; (cond ((diana_attributep att) att) (t (lose 'wta fun `("~&Datum should be Diana Attribute: ~S~%" ,att))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Standard Diana Attributes (Tartan Version 3.0) -- ;;; Structural {Abstract Syntax} Attributes -- ;;;;;;;;;;;;;;;;;;;; (diana_attribute_def as_access_constraint tartan contingent ;;;;;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;; (diana_attribute_def as_actual tartan contingent ;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;; (diana_attribute_def as_alignment tartan contingent ;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;; (diana_attribute_def as_alternative_s tartan contingent ;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;; (diana_attribute_def as_binary_op tartan contingent ;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;; (diana_attribute_def as_block_stub tartan contingent ;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;; (diana_attribute_def as_choice_s tartan contingent ;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;; (diana_attribute_def as_comp_rep_s tartan contingent ;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;; (diana_attribute_def as_constrained tartan contingent ;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;;;;; (diana_attribute_def as_constrained_void tartan contingent ;;;;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;; (diana_attribute_def as_constraint tartan contingent ;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;; (diana_attribute_def as_context tartan contingent ;;;;;;;;;; structural static truth interesting) ;;;;;;;;;; (diana_attribute_def as_decl_s1 tartan contingent ;;;;;;;;;; structural static truth interesting) ;;;;;;;;;; (diana_attribute_def as_decl_s2 tartan contingent ;;;;;;;;;; structural static truth interesting) ;;;;;;;;; (diana_attribute_def as_decl_s tartan contingent ;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;; (diana_attribute_def as_designator tartan contingent ;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;;;; (diana_attribute_def as_designator_char tartan contingent ;;;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;; (diana_attribute_def as_dscrmt_var_s tartan contingent ;;;;;;;;;;;;;;; ;;; Was missing from v1? structural static truth interesting) ;;;;;;;;;;;;;; (diana_attribute_def as_dscrt_range tartan contingent ;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;; (diana_attribute_def as_dscrt_range_s tartan contingent ;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;;;;; (diana_attribute_def as_dscrt_range_void tartan contingent ;;;;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;; (diana_attribute_def as_exception_def tartan contingent ;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;; (diana_attribute_def as_exp1 tartan contingent ;;;;;;; structural static truth interesting) ;;;;;;; (diana_attribute_def as_exp2 tartan contingent ;;;;;;; structural static truth interesting) ;;;;;; (diana_attribute_def as_exp tartan contingent ;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;;;; (diana_attribute_def as_exp_constrained tartan contingent ;;;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;; (diana_attribute_def as_exp_s tartan contingent ;;;;;;;; structural static truth interesting) ;;;;;;;;;;; (diana_attribute_def as_exp_void tartan contingent ;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;;;; (diana_attribute_def as_generic_assoc_s tartan contingent ;;;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;;; (diana_attribute_def as_generic_header tartan contingent ;;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;;;; (diana_attribute_def as_generic_param_s tartan contingent ;;;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;; (diana_attribute_def as_header tartan contingent ;;;;;;;;; structural static truth interesting) ;;;;; (diana_attribute_def as_id tartan contingent ;;;;; ;;; Was missing from v1? structural static truth interesting) ;;;;;;; (diana_attribute_def as_id_s tartan contingent ;;;;;;; structural static truth interesting) ;;;;;;;;; (diana_attribute_def as_item_s tartan contingent ;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;; (diana_attribute_def as_iteration tartan contingent ;;;;;;;;;;;; structural static truth interesting) ;;;;;;; (diana_attribute_def as_list tartan contingent ;;;;;;; structural static listp interesting) ;;;;;;;;;;;;;;;; (diana_attribute_def as_membership_op tartan contingent ;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;; (diana_attribute_def as_name tartan contingent ;;;;;;; structural static truth interesting) ;;;;;;;;; (diana_attribute_def as_name_s tartan contingent ;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;; (diana_attribute_def as_name_void tartan contingent ;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;; (diana_attribute_def as_object_def tartan contingent ;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;; (diana_attribute_def as_package_def tartan contingent ;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;; (diana_attribute_def as_param_assoc_s tartan contingent ;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;; (diana_attribute_def as_param_s tartan contingent ;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;; (diana_attribute_def as_pragma_s tartan contingent ;;;;;;;;;;; structural static truth interesting) ;;;;;;;; (diana_attribute_def as_range tartan contingent ;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;; (diana_attribute_def as_range_void tartan contingent ;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;; (diana_attribute_def as_record tartan contingent ;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;;;; (diana_attribute_def as_select_clause_s tartan contingent ;;;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;; (diana_attribute_def as_stm tartan contingent ;;;;;; structural static truth interesting) ;;;;;;;;; (diana_attribute_def as_stm_s1 tartan contingent ;;;;;;;;; structural static truth interesting) ;;;;;;;;; (diana_attribute_def as_stm_s2 tartan contingent ;;;;;;;;; structural static truth interesting) ;;;;;;;; (diana_attribute_def as_stm_s tartan contingent ;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;;;; (diana_attribute_def as_subprogram_def tartan contingent ;;;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;;;; (diana_attribute_def as_subunit_body tartan contingent ;;;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;; (diana_attribute_def as_task_def tartan contingent ;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;;; (diana_attribute_def as_type_range tartan contingent ;;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;; (diana_attribute_def as_type_spec tartan contingent ;;;;;;;;;;;; structural static truth interesting) ;;;;;;;;;;;; (diana_attribute_def as_unit_body tartan contingent ;;;;;;;;;;;; structural static truth interesting) ;;;;;;;; (diana_attribute_def as_var_s tartan contingent ;;;;;;;; structural static truth interesting) ;;;;;;;;;;;; (diana_attribute_def as_variant_s tartan contingent ;;;;;;;;;;;; structural static truth interesting) ;;; End Tartan Standard Structural Attributes, Definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Begin Tartan Standard Lexical Attributes, Definitions ;;;;;;;;; (diana_attribute_def lx_numrep tartan contingent ;;;;;;;;; ;;; Internal rep for numeric literal. lexical static truth interesting) ;;;;;;;;;; (diana_attribute_def lx_default tartan contingent ;;;;;;;;;; ;;; Value is type boolean. Indicates whether the mode of an ;;; in-parameter was defaulted (versus specified). lexical static booleanp interesting) ;;;;;;;;; (diana_attribute_def lx_prefix tartan contingent ;;;;;;;;; ;;; Goes on dn_function_call nodes. Value is type boolean. ;;; Indicates whether a function call was written using ;;; prefix (versus infix) notation. lexical static booleanp interesting) ;;;;;;;;; (diana_attribute_def lx_srcpos tartan universal ;;;;;;;;; ;;; Internal rep for src pos of node. ;;; Tartan Standard does not allow on all nodes, but CT has generalized. lexical static truth interesting) ;;;;;;;;; (diana_attribute_def lx_symrep tartan contingent ;;;;;;;;; ;Internal rep for ident or string. lexical static truth interesting) ;;;;;;;;;;; (diana_attribute_def lx_comments tartan universal ;;;;;;;;;;; ;;; Internal rep for src comments. Value-type is implementation-defined. ;;; Tartan Standard does not allow on all nodes, but CT has generalized. lexical static atomic-listp interesting) ;;; End Tartan Tartan Lexical Attributes, Definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Begin Tartan Standard Semantic Attributes, Definitions ;;;;;;;;;;;;;;; (diana_attribute_def sm_actual_delta tartan contingent ;;;;;;;;;;;;;;; ;Universal rational containing ; corresponding predefined att. semantic static truth interesting) ;;;;;;;;;; (diana_attribute_def sm_address tartan contingent ;;;;;;;;;; ;Denotes expr given in a rep spec ; for corresponding predefined att. semantic static truth interesting) ;;;;;;;; (diana_attribute_def sm_first tartan contingent ;;;;;;;; ;First occur. of mult. def. id. semantic static truth interesting) ;;;;;;;;;;;; (diana_attribute_def sm_base_type tartan contingent ;;;;;;;;;;;; ;Base type of a subtype. semantic static truth interesting) ;;;;;;; (diana_attribute_def sm_bits tartan contingent ;;;;;;; ;Universal int. for predef. att. semantic static truth interesting) ;;;;;;; (diana_attribute_def sm_body tartan contingent ;;;;;;; ;Body of a subprog/pkg. Void if ; body/stub not in same comp unit. ; For init'd/renamed entities has type ; INSTANTIATION/RENAME. For generic ; formal subprograms denotes the ; FORMAL_SUBPROG_DEF. If pragma ; interface appl'd, denotes def. ; occurr. of given language name. semantic static truth interesting) ;;;;;;;;;;;; (diana_attribute_def sm_comp_spec tartan contingent ;;;;;;;;;;;; ;;; NB: was previously missing. semantic static truth interesting) ;;;;;;;;;;;;; (diana_attribute_def sm_constraint tartan contingent ;;;;;;;;;;;;; ;For expressions and subtypes. semantic static truth interesting) ;;;;;;;;;;;;; (diana_attribute_def sm_controlled tartan contingent ;;;;;;;;;;;;; ;Indicates whether pragma CONTROLLED ; has been applied to type. semantic static truth interesting) ;;;;;;;;;;;;; (diana_attribute_def sm_decl_exp_s tartan contingent ;;;;;;;;;;;;; ;Belongs to instantiation node. ; Refers to normalized param list ; which contains expr. node for every ; formal object, and a declar. node ; which provides new def. place for ; all other formal params. semantic static truth interesting) ;;;;;;;;; (diana_attribute_def sm_decl_s tartan contingent ;;;;;;;;; ;Added somewhere between v1 and v3. ;Limited to dn_instantiation nodes? semantic static truth interesting) ;;;;;;; (diana_attribute_def sm_defn tartan contingent ;;;;;;; ;;; In CTAda, sm_defn has been generalized to allow appearance on any ;;; nodetypes of the form dn_xxx_id, to help speed up the back end. semantic static truth interesting) ;;;;;;;;;;;;;;;; (diana_attribute_def sm_discriminants tartan contingent ;;;;;;;;;;;;;;;; ;Seq. of discr'ts for record or ; priv. type, may be empty. semantic static truth interesting) ;;;;;;;;;;;;;;;; (diana_attribute_def sm_exception_def tartan contingent ;;;;;;;;;;;;;;;; ;Except. Def. subtree of an exc. ; declar., normally void. A ; RENAME node if renam. declar. semantic static truth interesting) ;;;;;;;;;;; (diana_attribute_def sm_exp_type tartan contingent ;;;;;;;;;;; ;Type of expr. as result of ; overloading resolution. semantic static truth interesting) ;;;;;;;;;;;;;;;;;; (diana_attribute_def sm_generic_param_s tartan contingent ;;;;;;;;;;;;;;;;;; ;List of generic params of a ; generic subprog or pkg. semantic static truth interesting) ;;;;;;;;;;; (diana_attribute_def sm_init_exp tartan contingent ;;;;;;;;;;; ;Init'n expr. for nums, in params, ; record compon's, and discr'ts. semantic static truth interesting) ;;;;;;;;;;; (diana_attribute_def sm_location tartan contingent ;;;;;;;;;;; ;Loc. of subprog., may be void, ; pragma_id of INLINE if applied, ; or expr. supplied in addr. spec. semantic static truth interesting) ;;;;;;;;;;;;;;;;;;;; (diana_attribute_def sm_normalized_comp_s tartan contingent ;;;;;;;;;;;;;;;;;;;; ;;; NB: This had been missing previous to 27-DEC-83. semantic static truth interesting) ;;;;;;;;;;;;;;;;;;;;; (diana_attribute_def sm_normalized_param_s tartan contingent ;;;;;;;;;;;;;;;;;;;;; ;Normal. params. for proc., func. ;or entry call, incl. dflts. semantic static truth interesting) ;;;;;;;;;; (diana_attribute_def sm_obj_def tartan contingent ;;;;;;;;;; ;;; Denotes the initialization expression of an object. It is void ;;; if none is given. In the case of a renamed object it denotes ;;; the rename node of the declaration structure. semantic static truth interesting) ;;;;;;;;;;; (diana_attribute_def sm_obj_type tartan contingent ;;;;;;;;;;; ;;; Denotes the type specification of a declaration (constants, ;;; parameters, discriminants, numbers, variables, enumeration ;;; literals, and tasks). For deferred constants see 3.5.5. In ;;; case of numbers it denotes one of the universal types, see ;;;; Appendix I. semantic static truth interesting) ;;;;;;;;;;; (diana_attribute_def sm_operator tartan contingent ;;;;;;;;;;; ;;; Denotes one of the predefined operators or built-in ;;; subprograms, see 3.8.5. semantic static truth interesting) ;;;;;;;;;; (diana_attribute_def sm_packing tartan contingent ;;;;;;;;;; ;;; Indicates whether the pragma PACK has been applied to that ;;; type. semantic static truth interesting) ;;;;;; (diana_attribute_def sm_pos tartan contingent ;;;;;; ;;; Is of universal integer type, contains the value of the ;;; predefined language attribute POS of an enumeration literal. semantic static truth interesting) ;;;;;;;;;;;;;; (diana_attribute_def sm_record_spec tartan contingent ;;;;;;;;;;;;;; ;;; NB: Was previously missing. semantic static truth interesting) ;;;;;; (diana_attribute_def sm_rep tartan contingent ;;;;;; ;;; Universal integer type, contains the value of the ;;; predefined language attribute VAL of an enumeration literal, ;;; which can be set by the user. See also 3.4.2.3. semantic static truth interesting) ;;;;;;; (diana_attribute_def sm_size tartan contingent ;;;;;;; ;;; Denotes the expression given in a representation specification ;;; for the predefined language attribute SIZE; it is void if the ;;; user has not given such a specification. semantic static truth interesting) ;;;;;;; (diana_attribute_def sm_spec tartan contingent ;;;;;;; ;;; Denotes the specification of a subprogram or package. In the ;;; case of subprograms it is its header (for instantiations, see ;;; 3.6). In the case of packages it is the package specification; ;;; for instantiated packages see 3.6 and for renamed packages see ;;; 3.7. In the case of a generic unit it is the generic header of ;;; the unit. semantic static truth interesting) ;;;;;; (diana_attribute_def sm_stm tartan contingent ;;;;;; ;;; Denotes the statement to which a label definition belongs, or ;;; the loop which is left by an exit statement. semantic static truth interesting) ;;;;;;;;;;;;;;; (diana_attribute_def sm_storage_size tartan contingent ;;;;;;;;;;;;;;; ;;; Denotes the expression given in a representation specification ;;; for the predefined language attribute STORAGE_SIZE; it is void ;;; if the user has not given such a specification. semantic static truth interesting) ;;;;;;; (diana_attribute_def sm_stub tartan contingent ;;;;;;; ;;; Goes on dn_function_id nodes. ;;; Refers to the defining occurrence of the stub. semantic static truth interesting) ;;;;;;;;;;;; (diana_attribute_def sm_type_spec tartan contingent ;;;;;;;;;;;; ;;; Denotes the specification which belongs to a type identifier, ;;; for private and incomplete types see 3.5.1, for tasks and task ;;; body identifier see 3.5.5. semantic static truth interesting) ;;;;;;;;;;;;;; (diana_attribute_def sm_type_struct tartan contingent ;;;;;;;;;;;;;; ;;; Denotes the structural information of a subtype, c.f. 3.4.2.2, ;;; or derived type, c.f. 3.4.2.3. semantic static truth interesting) ;;;;;;;; (diana_attribute_def sm_value tartan contingent ;;;;;;;; ;;; Contains the value of the corresponding expression if it is ;;; staticly evaluated, its type is implementation dependent, see ;;; 3.8.1. semantic static truth interesting) ;;; End Tartan Standard Semantic Attributes, Definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Begin Tartan Standard Code Attributes, Definitions ;;; Only one code attribute survived through to Tartan v3.0. ;;; CT does not use any code attributes at all. However, the ;;; cd_impl_size attribute is recognized by our implementation as ;;; legal in Tartan Diana but unused in CTAda Diana. Note that ;;; currently no runtime storage is allocated for this slot. #+(or diana_debugging complr) ;;;;;;;;;;;; (diana_attribute_def cd_impl_size tartan contingent ;;;;;;;;;;;; ;;; Contains a universal integer which is the size of a type ;;; chosen by the compiler. May be less than user-defined size. code static truth interesting) ;;; End Tartan Standard Code Attributes, Definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Begin CTAda Implementation-Specific Diana Attributes, Definitions ;;; Not grouped by categories, most are semantic, some are in category ;;; "debugger" {only used by the debugger/driver}, rest are "other". ;;;;;;;;;;;; (diana_attribute_def ct_base_type ct contingent ;;;;;;;;;;;; semantic static truth interesting) ;;;;;; (diana_attribute_def ct_bnl ct universal ;;;;;; ;;; Block Nesting Level. semantic static fixp uninteresting) ;;;;;;; (diana_attribute_def ct_cont ct universal ;;;;;;; ;;; Every node -- continuation {what node to go to next}. other static truth interesting) ;;;;;;;;;;;;; (diana_attribute_def ct_time_stamp ct universal ;;;;;;;;;;;;; ;;; Required on every node -- thread upward to mom. This attribute's ;;; name has only historical signficance -- cf. ct_cont. other static truth ;Hard to arrange for nodep. interesting) ;;;;;;;;;;;;;;;;;;;;;;;;;; (diana_attribute_def ct_existing_instantiations ct contingent ;;;;;;;;;;;;;;;;;;;;;;;;;; semantic static truth interesting) ;;;;;; (diana_attribute_def ct_for ct contingent ;;;;;; ;;; Currently just on dn_predefined_attribute nodes and ;;; dn_predefined_pragma_parameter nodes. semantic static truth interesting) ;;;;;;;;;;; (diana_attribute_def ct_function ct contingent ;;;;;;;;;;; semantic static truth interesting) ;;;;;;;;;;;;;;;;;;;;; (diana_attribute_def ct_generic_membership ct universal ;;;;;;;;;;;;;;;;;;;;; ;;; Legal {but not necessarily required} on all nodes. ;;; Initialized in sc_diana. Speeds up front-end instantiator. semantic static truth interesting) ;;;;;;;;;;;;;;;;; (diana_attribute_def ct_hidden_context ct contingent ;;;;;;;;;;;;;;;;; semantic static truth interesting) ;;;;; (diana_attribute_def ct_id ct universal ;;;;; ;;; Unique gensym node id. May or may not be interned. other static symbolp interesting) ;;;;;;;;;;;;; (diana_attribute_def ct_index_list ct contingent ;;;;;;;;;;;;; ;;; For dn_aggregate. semantic static truth interesting) ;;;;;;;;;;;;;;;;; (diana_attribute_def ct_is_enclosed_by ct contingent ;;;;;;;;;;;;;;;;; semantic static truth uninteresting) ;;;;;;;;;; (diana_attribute_def ct_labeled ct contingent ;;;;;;;;;; ;;; For dn_label_id semantic static truth interesting) ;;;;;;;;;;;; (diana_attribute_def ct_lisp_func ct contingent ;;;;;;;;;;;; ;;; Goes on various nodes named like dn_predefined_xxx. semantic static truth interesting) ;;;;;;;;;; (diana_attribute_def ct_mixin_s ct contingent ;;;;;;;;;; semantic static truth uninteresting) ;;;;;;;;;;;;;;;; (diana_attribute_def ct_named_context ct contingent ;;;;;;;;;;;;;;;; semantic static truth uninteresting) ;;;;;;;;;;; (diana_attribute_def ct_nodetype ct universal ;;;;;;;;;;; ;;; The Diana nodetype of the node. Defined as an attribute for ;;; more uniform processing. other static symbolp ;Hard to arrange for nodetypep. uninteresting) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (diana_attribute_def ct_package_inner_environment ct contingent ;;;;;;;;;;;;;;;;;;;;;;;;;;;; semantic static truth interesting) ;;;;;;;;;;;;;; (diana_attribute_def ct_parent_type ct contingent ;;;;;;;;;;;;;; semantic static truth interesting) ;;;;;; (diana_attribute_def ct_pnl ct universal ;;;;;; ;;; Procedure Nesting Level. semantic static fixp uninteresting) ;;;;;;;;;;; (diana_attribute_def ct_posthook ct universal ;;;;;;;;;;; ;;; For driver to wake up the debugger. debugger dynamic truth interesting) ;;;;;;;;;; (diana_attribute_def ct_prehook ct universal ;;;;;;;;;; ;;; For driver to wake up the debugger. debugger dynamic truth interesting) ;;;;;;;;;; (diana_attribute_def ct_raising ct contingent ;;;;;;;;;; ;;; Related to exception-handling. semantic static truth interesting) ;;;;;;;;; (diana_attribute_def ct_resume ct contingent ;;;;;;;;; ;;; Related to exception-handling. semantic static truth interesting) ;;;;;;; (diana_attribute_def ct_spec ct contingent ;;;;;;; semantic static truth interesting) ;;;;;;;;;;; (diana_attribute_def ct_st_class ct contingent ;;;;;;;;;;; ;;; Symbol Table Class. other static truth uninteresting) ;;;;;;;;;;;;;;;;;;;; (diana_attribute_def ct_st_defining_block ct contingent ;;;;;;;;;;;;;;;;;;;; ;;; Symbol Table Defining Block. other static truth uninteresting) ;;;;;;;;;; (diana_attribute_def ct_st_type ct contingent ;;;;;;;;;; ;;; Symbol Table Type. other static truth uninteresting) ;;;;;;;;;;;;; (diana_attribute_def ct_task_entry ct contingent ;;;;;;;;;;;;; other static truth interesting) ;;;;;;;;;; (diana_attribute_def ct_threadp ct universal ;;;;;;;;;; ;;; Required on every node -- thread upward to mom. This attribute's ;;; name has only historical signficance -- cf. ct_cont. other static truth ;Hard to arrange for nodep. interesting) ;;;The following group of attributes have been removed. They should now be ;;;associated with diana nodes via the diana_late_... functions. --wab 4-11-84 #| ;;;;;;;;;;;;;;;; (diana_attribute_def ctadadt_inithook ct contingent ;;;;;;;;;;;;;;;; ;;; Currently allowed on dn_compilation's only debugger dynamic truth interesting) ;;;;;;;;;;;;;;;;; (diana_attribute_def :d-find-flat-tree ct contingent ;;;;;;;;;;;;;;;;; ;;; Currently allowed on dn_comp_unit's only debugger dynamic truth interesting) ;;;;;;;;;;;;;; (diana_attribute_def :d-find-a-list ct contingent ;;;;;;;;;;;;;; ;;; Currently allowed on dn_comp_unit's only debugger dynamic truth interesting) ;;;;;;;;;;;; (diana_attribute_def db%code_tags ct contingent ;;;;;;;;;;;; ;;; Currently allowed on dn_compilation's only debugger dynamic truth interesting) ;;;;;;;;;;;; (diana_attribute_def db%data_tags ct contingent ;;;;;;;;;;;; ;;; Currently allowed on dn_compilation's only debugger dynamic truth interesting) |# ;;;;;;;;;;;;;;;;;; (diana_attribute_def ct_late_attributes ct universal ;;;;;;;;;;;;;;;;;; ;;; This is a slot for "late" diana attributes, i.e., attributes which ;;; are installed at run time as opposed to front end time. The attribute ;;; is a disembodied property list. other dynamic truth interesting) (diana_attribute_def sm_name ct contingent ;;;;;;; ;;; For dn_goto. Analogous to as_name but think of as semantic. semantic static truth interesting) ;;;;;;;; (diana_attribute_def sm_wegot ct contingent ;;;;;;;; semantic static truth interesting) ;;;;;;;; (diana_attribute_def tp_vfuns ct contingent ;;;;;;;; semantic dynamic truth interesting) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; End Diana Attribute Definitions ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Load-Time Forms for Constant Data ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq *diana_universals_count* (length *diana_universal_attributes*)) (and *dianatts_status_flag* ;;; Arrange for structure sharing. The list of universals ;;; must come last. We do not need or create the full list ;;; of attributes in the production version of the run-time. (nconc *diana_attributes* *diana_universal_attributes*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; eof ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;