;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- ;;; $Header: /ct/interp/types.l,v 1.56 85/01/24 18:03:52 penny Exp $ ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; types.l ;;; ;;; Paul Robertson October 18, 1983 ;;; ;;; ;;; ;;; The C*T Ada Interpreters Static Semantic support ;;; ;;; ;;; ;;; 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, 1982. The C*T Ada Tutor: Guide to the Implementation. ;;; ;;; Charniak et al., 198?. Artificial Intelligence Programming. ;;; ;;; ;;; ;;; The following code assumes familiarity with the above. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ensure presence of needed files. (eval-when (compile load eval) (ct_load 'aip)) ;AIP macros pkg. (eval-when (compile load eval) (ct_load 'compat)) ;Franz/LM compat pkg. (eval-when (compile load eval) (ct_load 'charmac)) (eval-when (compile load eval) (ct_load 'time)) ;Timing functions. (eval-when (compile load eval) (ct_load 'diana)) ; Diana tools. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- #+franz (declare (macros t)) (declare (ct_includef 'intrpdcl)) ; get the specials (eval-when (compile load eval) (ct_load 'ferec)) ; get the macros etc. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Externally Call-able Functions/Macros -- ;;; Static semantic code schemas are structured as follows. ;;; Body contains lisp code that returns a piece of diana tree or nil. ;;; The main way of building a diana tree is with the sc_diana functon. ;;; Simple node will consist only of these nodes. sc_diana looks like this... ;;; (sc_diana dn_foo slotname code slotname code slotname code .. .. .. ..) ;;; The above example creates a diana node with the names slots, and calls the ;;; appropriate code to fill the slots. One reason why this function should be ;;; used is that it hides the internal representation of a diana node making ;;; future modifications easy (which would be necessary for say a production ;;; compiler. ;;; The abstract syntax is available for inclusion in the diana tree or ;;; other in a free variable called *abstract_syntax*. This variable may be ;;; altered by the code for effeciency reasons without intefering with the ;;; parsing process. Syntax nodes that do not have ssemantics code will ;;; produce abstract syntax subtree's. To return a null node have a ssemantic ;;; property that returns nil. ;;;;;;;;;;;;;;; (defun find_constraint(ts ag) ;;;;;;;;;;;;;;; (cond ((null ag) nil) ((and (diana_nodep ts) (diana_node_accepts_attributep ts 'sm_defn) (eq (diana_nodetype_get ts) 'dn_used_name_id) (null (diana_get ts 'sm_defn))) (semgripe 'undecl_id (implode (lowuplist (cadr (diana_get ts 'lx_symrep))))) nil) (t (let* ((basetype (extract_basetype ts)) (discs (and basetype (diana_node_accepts_attributep basetype 'sm_discriminants) (diana_get basetype 'sm_discriminants)))) (ct_selectq (diana_nodetype_get ag) (dn_parenthesized (cond (discs (sc_diana dn_dscrmt_aggregate as_list (list ag))))) (dn_aggregate ;(semgripe 'probably_missing_tick) ag) (otherwise (lose 'fe_chtc 'find_constraint ))))))) ;;;;;;;;;;;; (defun qualify_type (dn) ;;;;;;;;;;;; (let ((type (diana_get dn 'sm_exp_type)) (expr (diana_get dn 'as_exp))) (cond ((and expr (diana_node_accepts_attributep expr 'as_exp) (diana_get expr 'as_exp) (not (diana_get expr 'sm_exp_type))) (diana_put expr type 'sm_exp_type) (qualify_type expr)) ((and expr (diana_node_accepts_attributep expr 'as_exp) (diana_get expr 'as_exp) (diana_get expr 'sm_exp_type) (not (assignment_compatible expr type))) (semgripe 'qualify_types_not_compatible (implode (lowuplist (cadr (diana_get (find_selected (diana_get dn 'as_name)) 'lx_symrep))))) (diana_put expr type 'sm_exp_type)) (expr (diana_put expr type 'sm_exp_type))))) ;;;;;;;;;;;;;; (defun private_type_p(dn) ;;;;;;;;;;;;;; (cond ((null dn) nil) (t (memq (diana_nodetype_get dn) '(dn_private_type_id dn_l_private_type_id))))) ;;; find basetype of range. Incorporates rules from 3.6.1 ;;;;;;;;;;;;;;;;;;; (defun find_type_for_range(first last &optional sloppy) ;;;;;;;;;;;;;;;;;;; (cond ;; If both first and last are numeric universal integer literals, ;; the type of the discrete range is INTEGER. ((or (null first) (null last)) (semgripe 'missing_first_or_last_exp_for_range) nil) ((and (numberp (fe_static_eval first)) (numberp (fe_static_eval last))) (let ((val1 (fe_static_eval first)) (val2 (fe_static_eval last))) (cond ((and (fixp val1) (fixp val2)) (ada_declared (ada_ident integer) nil 'type)) ((and (floatp val1) (floatp val2)) *universal_real*) (t (semgripe 'types_not_consist_in_discrt_range))))) ((numberp (fe_static_eval first)) (cond ((not (assignment_compatible first last)) (semgripe 'types_not_consist_in_discrt_range))) (extract_basetype last)) ((numberp (fe_static_eval last)) (cond ((not (assignment_compatible last first)) (semgripe 'types_not_consist_in_discrt_range))) (extract_basetype first)) (t (let ((t1 (extract_basetype first sloppy)) (t2 (extract_basetype last sloppy))) (cond ((assignment_compatible t1 t2) t1) (t (semgripe 'types_not_consist_in_discrt_range) nil)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun find_parents_of_derived_type (leaf) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((parents nil)) (let* ((typespec (extract_basetype leaf)) (kind (diana_nodetype_get typespec))) (cond ((eq kind 'dn_derived) ;; the type is a derived type so add its parent to the parent list. (ct_push (extract_basetype (diana_get typespec 'as_constrained)) parents) ;; now form the transitive closure by following the parents parents. (append parents (find_parents_of_derived_type (car parents)))) ((memq (diana_nodetype_get leaf) '(dn_integer dn_float dn_fixed)) ;; the type is a derived type so add its parent to the parent list. (ct_push (extract_basetype leaf t) parents)))))) ;;;;;;;;;;;;;;;; (defun consistant_types (t1 t2 &optional seethroughderivedtypes) ;;;;;;;;;;;;;;;; (let ((tp1 (extract_basetype t1 seethroughderivedtypes)) (tp2 (extract_basetype t2 seethroughderivedtypes))) (not (and tp1 tp2 (neq tp1 tp2))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun consistant_types_with_inheritance(la t1 t2 &optional seethroughderivedtypes) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((tp1 (and t1 (extract_basetype t1 seethroughderivedtypes))) (tp2 (extract_basetype t2 seethroughderivedtypes)) (tp1s (and tp1 (find_parents_of_derived_type (substituted_derived_type tp1 la))))) (not (and tp1 tp2 (neq tp1 tp2) (not (memq tp2 tp1s)))))) ;;;;;;;;;;;;;;;; (defun extract_basetype (spec &optional seethroughderivedtypes) ;;;;;;;;;;;;;;;; ;; before we do this lets check if we have it already (cond ((null spec) nil) ((and (not seethroughderivedtypes) (diana_node_accepts_attributep spec 'ct_base_type) (diana_get spec 'ct_base_type)) ;;get its' ct_parent_type (diana_get spec 'ct_base_type)) ((and seethroughderivedtypes (diana_node_accepts_attributep spec 'ct_parent_type) (diana_get spec 'ct_parent_type)) ;;get its own ct_base_type (diana_get spec 'ct_parent_type)) (t ;;don't have it so lets find it and put it on its plist (let ((foundtype (ct_selectq (diana_nodetype_get spec) (dn_constrained (extract_basetype (diana_get spec 'as_name) seethroughderivedtypes)) (dn_index (extract_basetype (diana_get spec 'as_name) seethroughderivedtypes)) (dn_dscrmt_id (extract_basetype (diana_get spec 'sm_obj_type) seethroughderivedtypes)) (dn_used_name_id (extract_basetype (diana_get spec 'sm_defn) seethroughderivedtypes)) (dn_in_id (extract_basetype (diana_get spec 'sm_obj_type) seethroughderivedtypes)) (dn_out_id (extract_basetype (diana_get spec 'sm_obj_type) seethroughderivedtypes)) (dn_in_out_id (extract_basetype (diana_get spec 'sm_obj_type) seethroughderivedtypes)) (dn_var_id (extract_basetype (diana_get spec 'sm_obj_type) seethroughderivedtypes)) (dn_selected (cond ((diana_get spec 'as_designator_char) (extract_basetype (cond ((consp (diana_get spec 'as_designator_char)) (first (diana_get spec 'as_designator_char))) (t (diana_get spec 'as_designator_char))) seethroughderivedtypes)) (t spec))) (dn_comp_id (extract_basetype (diana_get spec 'sm_obj_type) seethroughderivedtypes)) (dn_iteration_id (extract_basetype (diana_get spec 'sm_obj_type) seethroughderivedtypes)) (dn_parenthesized (extract_basetype (diana_get spec 'sm_exp_type) seethroughderivedtypes)) (dn_allocator #|(extract_basetype (diana_get spec 'sm_exp_type) seethroughderivedtypes)|# spec) (dn_subtype_id (extract_basetype (diana_get spec 'sm_type_spec) seethroughderivedtypes)) (dn_const_id (extract_basetype (diana_get spec 'sm_obj_type) seethroughderivedtypes)) (dn_binary (cond ((boolean_expression_p (diana_get spec 'as_exp1)) (extract_basetype (diana_get spec 'as_exp1) seethroughderivedtypes)) ((boolean_expression_p (diana_get spec 'as_exp2)) (extract_basetype (diana_get spec 'as_exp2) seethroughderivedtypes)) (t nil))) (dn_number_id nil) ;;universal type. treated as a literal. (dn_aggregate nil) (dn_numeric_literal (cond ((la_num%floatp (diana_get spec 'lx_numrep)) *universal_real*) (t *universal_integer*))) (dn_string_literal nil) (dn_character_literal nil) (dn_all (extract_basetype (let* ((asnam (diana_get spec 'as_name)) (bt (and asnam (extract_basetype asnam)))) (cond ((and bt (diana_nodep bt) (diana_node_accepts_attributep bt 'as_constrained)) (diana_get bt 'as_constrained)) (t nil))) seethroughderivedtypes)) (dn_rename (extract_basetype (diana_get spec 'as_name) seethroughderivedtypes)) (dn_conversion (extract_basetype (diana_get spec 'as_name) seethroughderivedtypes)) (dn_qualified (extract_basetype (diana_get spec 'sm_exp_type) seethroughderivedtypes)) (dn_attribute_call (let* ((att (diana_get spec 'as_name)) (arg (diana_get spec 'as_exp)) (attrib (and att (diana_get att 'as_id))) (type (extract_basetype (diana_get att 'as_name) seethroughderivedtypes))) (extract_basetype (find_type_attribute (diana_get att 'as_name) type attrib arg) seethroughderivedtypes))) (dn_membership (extract_basetype (ada_declared (ada_ident boolean) nil 'type))) (dn_indexed (let ((bt (extract_basetype (diana_get spec 'as_name) t))) ;(break look-at-indexed-spec) (extract_basetype (diana_get (cond ((and bt (eq (diana_nodetype_get bt) 'dn_access)) (extract_basetype ;implicit dereference. (diana_get bt 'as_constrained) t)) (t bt)) 'as_constrained) seethroughderivedtypes))) ;; (dn_selected ;; (extract_basetype ;; (diana_get spec 'sm_exp_type))) (dn_slice (extract_basetype (diana_get spec 'as_name))) (dn_enum_id (diana_get spec 'sm_obj_type)) (dn_def_char (diana_get spec 'sm_obj_type)) (dn_function_call (extract_basetype (diana_get spec 'sm_exp_type) seethroughderivedtypes)) (dn_derived (cond (seethroughderivedtypes (extract_basetype (diana_get spec 'as_constrained) seethroughderivedtypes)) (t spec))) (dn_range (extract_basetype (diana_get spec 'sm_base_type) seethroughderivedtypes)) (dn_type_id (cond (seethroughderivedtypes (let* ((typespec (diana_get spec 'sm_type_spec)) (kind (and typespec (diana_nodetype_get typespec)))) (cond ((eq kind 'dn_derived) (extract_basetype (diana_get typespec 'as_constrained) seethroughderivedtypes)) (t typespec)))) (t (extract_basetype (diana_get spec 'sm_type_spec))))) (dn_integer (cond (seethroughderivedtypes (extract_basetype *universal_integer*)) (t spec))) (dn_float (cond (seethroughderivedtypes (extract_basetype *universal_float*)) (t spec))) (dn_fixed (cond (seethroughderivedtypes (extract_basetype *universal_fixed*)) (t spec))) #|(dn_formal_float *universal_float*) (dn_formal_integer *universal_integer*) (dn_formal_fixed *universal_fixed*)|# #| (dn_predefined_type (cond (seethroughderivedtypes (cond ((equal (diana_get spec 'lx_symrep) (ada_ident integer)) *universal_integer*) ((equal (diana_get spec 'lx_symrep) (ada_ident float)) (ada_declared (ada_ident **any_float**) nil 'type)) (t (break oh-frob)))) (t spec)))|# (t spec)))) (cond ((and (diana_node_accepts_attributep spec 'ct_parent_type) (not (diana_get spec 'ct_generic_membership)) foundtype seethroughderivedtypes) (diana_put spec foundtype 'ct_parent_type) foundtype) ((and (diana_node_accepts_attributep spec 'ct_base_type) (not (diana_get spec 'ct_generic_membership)) foundtype) (diana_put spec foundtype 'ct_base_type) foundtype) (t foundtype)))))) ;;;;;;;;;;;;;;; (defun type_compatable(t1 t2) ;;;;;;;;;;;;;;; (cond ((and t1 t2)(eq t1 t2)) (t t))) ;;;;;;;;;;;;;;;;;;; (defun find_constraint_for(dt) ;;;;;;;;;;;;;;;;;;; (cond ((null dt) nil) (t (ct_selectq (diana_nodetype_get dt) (dn_used_name_id (find_constraint_for (diana_get dt 'sm_defn))) (dn_type_id (find_constraint_for (diana_get dt 'sm_type_spec))) (dn_constrained (let ((asn (diana_get dt 'as_name)) (asc (diana_get dt 'as_constraint))) (cond ((and asc (null (eq (diana_nodetype_get asc) 'dn_void))) asc) (t (find_constraint_for asn))))) (dn_array (find_constraint_for (diana_get dt 'as_dscrt_range_s))) (dn_dscrt_range_s dt) (dn_index nil) (dn_enum_literal_s dt) #| (let* ((literals (diana_get dt 'as_list)); the enumeration literals. (first (first literals)) ;the first literal in the type. (last (last_car literals)) ;the last literal in the type. ) (sc_diana dn_range as_exp1 (sc_diana dn_used_name_id sm_defn first lx_symrep (diana_get first 'lx_symrep)) as_exp2 (sc_diana dn_used_name_id sm_defn last lx_symrep (diana_get last 'lx_symrep)) sm_base_type dt))|# (dn_access (diana_get dt 'as_constrained)) (t dt ) )))) ;;;;;;;;;;;;;;;;;;;; (defun boolean_expression_p (aex) ;;;;;;;;;;;;;;;;;;;; (eq (extract_basetype aex t) (extract_basetype (ada_declared (ada_ident boolean) nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun types_consistant_after_implicit_conversion (univ candidate) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cond ((eq univ *universal_integer*) (ct_selectq (diana_nodetype_get (extract_basetype candidate)) (dn_integer t) (dn_predefined_type (cond ((eq univ candidate) t) (t nil))) (dn_float nil) (dn_fixed nil) (dn_access nil) (dn_derived (types_consistant_after_implicit_conversion univ (extract_basetype candidate t))) (dn_formal_integer t) (dn_array nil) (dn_record nil) (dn_enum_literal_s nil) ((dn_l_private_type_id dn_private_type_id dn_private dn_l_private) nil) (dn_function_id (types_consistant_after_implicit_conversion univ (diana_get (diana_get candidate 'sm_spec) 'as_name_void))) (otherwise (lose 'fe_wwgot 'types_consistant_after_implicit_conversion )))) ((eq univ *universal_real* ) (ct_selectq (diana_nodetype_get (extract_basetype candidate)) (dn_integer nil) (dn_predefined_type (cond ((memq candidate `(,*universal_fixed* ,*universal_real*)) t))) (dn_float t) (dn_fixed t) (dn_formal_float t) (dn_access nil) (dn_derived (cond ((eq (extract_basetype candidate) (extract_basetype (ada_declared (ada_ident **any_float**) nil 'type nil))) t) (t (types_consistant_after_implicit_conversion univ (extract_basetype candidate t))))) (dn_array nil) (dn_record nil) (dn_enum_literal_s nil) ((dn_l_private_type_id dn_private_type_id dn_private dn_l_private) nil) (dn_function_id (types_consistant_after_implicit_conversion univ (diana_get (diana_get candidate 'sm_spec) 'as_name_void))) (otherwise (lose 'fe_wwgot 'types_consistant_after_implicit_conversion )))) ((eq univ *universal_fixed* ) (ct_selectq (diana_nodetype_get (extract_basetype candidate)) (dn_integer nil) (dn_predefined_type (cond ((eq univ candidate) t) (t nil))) (dn_float nil) (dn_fixed t) (dn_formal_fixed t) (dn_access nil) (dn_derived (types_consistant_after_implicit_conversion univ (extract_basetype candidate t))) (dn_array nil) (dn_record nil) (dn_enum_literal_s nil) ((dn_l_private_type_id dn_private_type_id dn_private dn_l_private) nil) (dn_function_id (types_consistant_after_implicit_conversion univ (diana_get (diana_get candidate 'sm_spec) 'as_name_void))) (otherwise (lose 'fe_wwgot 'types_consistant_after_implicit_conversion )))))) ;;;;;;;;;;;;;;;; (defun extract_typespec (dn) ;;;;;;;;;;;;;;;; ;(break look-at-dn) (ct_selectq (diana_nodetype_get dn) ((dn_constrained dn_type_id dn_subtype_id dn_integer dn_fixed dn_float) dn) (dn_used_name_id (extract_typespec (diana_get dn 'sm_defn))) (dn_var_id (diana_get dn 'sm_obj_type)) (otherwise (extract_basetype dn)))) ;;;;;;;;;;;;;;;;;;;;; (defun assignment_compatible (rhs lhs) ;;;;;;;;;;;;;;;;;;;;; (let ((lhst (extract_basetype lhs)) (rhst (extract_basetype rhs))) (cond ((and lhst (eq (diana_nodetype_get lhst) 'dn_access) rhst (eq (diana_nodetype_get rhst) 'dn_null_access)) t) ((and rhst (diana_nodep rhst) (eq (diana_nodetype_get rhst) 'dn_enum_literal_s)) (eq (extract_basetype lhs t) rhst)) ((ada_literal_or_aggregate_p rhs) (formal_consistant_with_literalp (extract_basetype lhs t) rhs)) ((and rhs (eq (diana_nodetype_get rhs) 'dn_aggregate)) (%= *awaiting_aggregate_disambiguation* (delq rhs *_*)) (diana_put rhs (extract_typespec lhs) 'sm_exp_type) (cond ((null (diana_get rhs 'sm_normalized_comp_s)) (normalize_aggregate rhs))) t) ((and (not rhst) rhs (eq (diana_nodetype_get rhs) 'dn_function_call)) (diana_put rhs lhst 'sm_exp_type) (dissambiguate_function_reference rhs)) ((and rhst lhst (eq (diana_nodetype_get rhst) 'dn_allocator)) (cond ((not (eq (diana_nodetype_get (extract_basetype lhs t)) 'dn_access)) (semgripe 'non_access_recipient_for_allocator) nil) (t (assignment_compatible (diana_get rhst 'as_exp_constrained) ;rhs (diana_get (extract_basetype lhs t) 'as_constrained))))) ;lhs (t (or (not rhst) (not lhst) (eq lhst rhst) (cond ((memq lhst *universal_types*) (types_consistant_after_implicit_conversion lhst rhst)) ((memq rhst *universal_types*) (types_consistant_after_implicit_conversion rhst lhst)))))))) ;;;;;;;;;;;; (defun assignable_p (dn) ;;;;;;;;;;;; (and (diana_nodep dn) (ct_selectq (diana_nodetype_get dn) (dn_used_name_id (assignable_p (diana_get dn 'sm_defn))) (dn_var_id (let ((ren (diana_get dn 'sm_obj_def))) (cond ((and ren (eq (diana_nodetype_get ren) 'dn_rename) (null (assignable_p (diana_get ren 'as_name)))) nil) (t t)))) (dn_in_out_id t) (dn_out_id t) (dn_in_id nil) (dn_iteration_id nil) ;can't change loop variables. ; (dn_indexed ??) (dn_selected (assignable_p (find_selected dn))) (dn_const_id nil) ;can't assign to constants. (dn_number_id nil) ;can't assign to numbers either. (dn_numeric_literal nil) (dn_string_literal nil) (dn_character_literal nil) (dn_function_call nil) (dn_dscrmt_id nil) (t ;(break assignable-kind_p) t)))) ;;;;;;;;;;;;;;; (defun hunky_subtype_p(dn) ;;;;;;;;;;;;;;; ;(break foo) )