;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; $Header: /ct/interp/resolve.l,v 1.39 84/12/07 16:32:53 penny Exp $

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                            resolve.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.

;;; if the function reference is not ambiguous, wire it in, otherwise
;;; put it on the  *awaiting_disambiguation* list till later.

;;; ++ this function should check that the indices legal for this choice
;;;    and return non nil if OK.

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun returns_array_with_compatible_indicesp (choice)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (and (eq(diana_nodetype_get choice) 'dn_function_id) t));++unfinished

       ;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun result_type_after_indexing (choice)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;

  (let* ((spec (diana_get choice 'sm_spec))
	 (rtntyp (and spec (extract_basetype (diana_get spec 'as_name_void))))
	 (arrtyp
	   (and rtntyp
		(cond
		  ((diana_node_accepts_attributep rtntyp 'as_constrained)
		   (extract_basetype (diana_get rtntyp 'as_constrained)))
		  (t rtntyp)))))
    arrtyp))

       ;;;;;;;;;;;;;;;;;;;;;;;;;
(defun coerce_funcall_to_indexed (dn)
       ;;;;;;;;;;;;;;;;;;;;;;;;;

  (let ((indices (diana_get dn 'as_param_assoc_s)))
    (diana_nodetype_set dn 'dn_indexed)
    (diana_put dn nil 'ct_parent_type)
    (diana_put dn nil 'ct_base_type)
    (diana_put dn indices 'as_exp_s)
    (diana_put dn
	       (sc_diana dn_function_call
			 as_name
			 (let ((choice (car (diana_get dn 'tp_vfuns))))
			   (sc_diana dn_used_name_id
				     lx_symrep (diana_get choice 'lx_symrep)
				     sm_defn choice)))
	       'as_name)))

(declare (special labels_alist labels_alist2))	  ;used in several places!

       ;;;;;;;;;;;
(defun subprog_bit (ch)
       ;;;;;;;;;;;
  (cond ((null ch) nil)
	((eq (diana_nodetype_get ch) 'dn_selected)
	 (diana_get ch 'as_designator_char))
	 (t ch)))

       ;;;;;;;;;;;;;;;;;;;;;;;
(defun filter_static_functions (dn choices)
       ;;;;;;;;;;;;;;;;;;;;;;;
  (cond ((= (length choices) 1) choices)
	
	((all_actuals_are_universal_static_expressions_p
	   (let ((aps (diana_get dn 'as_param_assoc_s)))
	     (and aps (diana_get aps 'as_list))))
	 (let ((wazzoo_funs
		 (mapcan #'(lambda (fn)
			     (cond
			       ((universal_function_p fn) (list fn))))
			 choices)))
	   (cond (wazzoo_funs  wazzoo_funs)
		 (t choices))))
	(t choices)))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dissambiguate_function_reference (dn)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;(break in-dissambiguate-func-ref)
  (cond ((memq dn *awaiting_parameter_normalization*)
	 (normalize_params dn)))
  (let ((choices (filter_static_functions
		   dn
		   (filter_matching_functions dn (diana_get dn 'tp_vfuns)))))
					  ;(break look-at-choices)
    ;; choices is candidates filter based on subordinate types.
    (cond
      ((eq
       (*catch
	 'still_ambiguous
	 (cond ((= (length choices) 1);(break frob)
		;;compare type with expected type for this node.
		(let* ((labels_alist
			 (car
			   ;;pass the type of each parameter to the corresponding
			   ;;actual subtree if it has a 'nil' exp_type.
			   (consistant_type_profilep
			     (let ((apas (diana_get dn 'as_param_assoc_s)))
			       (and apas (diana_get apas 'as_list)))
			     (let ((sms (diana_get
					  (subprog_bit (car choices)) 'sm_spec)))
			       (and sms (diana_get sms 'as_param_s)))
			     t)))	  ;persuader!
		       (labels_alist2
			 (and
			   (let ((apas (diana_get dn 'as_param_assoc_s)))
			       (and apas (diana_get apas 'as_list)))
			   (returns_array_with_compatible_indicesp
			     (subprog_bit (car choices)))
			   (car
			     (consistant_type_profilep
			       nil
			       (let ((sms (diana_get
					    (subprog_bit (car choices)) 'sm_spec)))
				 (and sms (diana_get sms 'as_param_s)))
			       t))))
		       (expected_type
			 (cond ((eq (diana_nodetype_get dn) 'dn_function_call)
				(diana_get dn 'sm_exp_type)))))
		  ;(break frob2)
		  (cond ((or
			   (not (eq (diana_nodetype_get dn) 'dn_function_call))
			   (and
			     (or (not labels_alist) expected_type)
			     labels_alist2
			     (consistant_types_with_inheritance labels_alist2
			       expected_type	
			       (result_type_after_indexing
				 (subprog_bit (car choices))))
			     (coerce_funcall_to_indexed dn))
			   (and
			     (or (not labels_alist2) expected_type)
			     (consistant_types_with_inheritance labels_alist
			       expected_type	  ;this will be NIL if a procedure!
			       (substituted_derived_type
				 (diana_get
				   (diana_get
				     (subprog_bit (car choices)) 'sm_spec)
				   'as_name_void)
				 labels_alist)))
			   (and
			     expected_type
			     (derivable_subprogram
			       expected_type
			       (diana_get
				 (diana_get (subprog_bit (car choices)) 'sm_spec)
				 'as_name_void)))))
			((and labels_alist labels_alist2)
			 ;;there is still an ambiguity about funcall/arrindex.
			 (*throw 'still_ambiguous 'still_ambiguous))
			(t (semgripe 'type_mismatch_in_subprog
				     (let* ((spb (subprog_bit (car choices)))
					    (lxs (and spb
						      (find_selected_name spb))))
				       (implode
					 (cadr lxs))))))
		  ;;now proporgate the type if its a function..
		  (cond
		    ((eq (diana_nodetype_get dn) 'dn_function_call)
		     ;(break foo)
		     (cond ((and (universal_function_p (car choices))
				 (all_actuals_are_universal_static_expressions_p
				   (let ((aps (diana_get dn 'as_param_assoc_s)))
				     (and aps (diana_get aps 'as_list)))))
			    (let ((ret (substituted_derived_type
					 (extract_basetype
					   (diana_get
					     (diana_get
					       (subprog_bit (car choices))
					       'sm_spec)
					     'as_name_void))
					 labels_alist)))
			    ;(break look-at-ret)
				  (cond ((eq ret (extract_basetype
						   *universal_float*))
					 (diana_put dn
						    *universal_real*
						    'sm_exp_type))
					(t
					 (diana_put dn
						    ret
						    'sm_exp_type)))))
			   (t
			    (diana_put dn
				(substituted_derived_type
				  (extract_basetype
				    (diana_get
				      (diana_get
					(subprog_bit (car choices)) 'sm_spec)
				      'as_name_void))
				  labels_alist)
				'sm_exp_type))))))
		;;and wire it in.
		(diana_put dn
			   (sc_diana dn_used_name_id
				     lx_symrep
				     (let* ((spb (subprog_bit (car choices)))
					    (lxs (and spb
						      (find_selected_name spb))))
				       lxs)
				     sm_defn (car choices))
			   'as_name)
		;;check that its parameters have been normalized.
		(cond ((null (diana_get dn 'sm_normalized_param_s))
		       (%= *awaiting_parameter_normalization* (delq dn *_*))
		       (normalize_params dn)))
		;;now see if this disambiguation can be proportated down to any
		;;of the subortinate subtrees.
		(disambiguate_subordinate_subtrees dn)
		;; If this function call was really an enumeration literal
		;; then we need to clobber the function call with the
		;; dn_used_name_id.
		(cond ((memq (diana_nodetype_get (car choices))
			     '(dn_enum_id dn_def_char))
		       (let ((id (sc_diana dn_used_name_id
					   lx_symrep (diana_get
						       (car choices)
						       'lx_symrep)
					   sm_defn (car choices))))
;		    (break about-to-lose)
;		    (rplaca dn (car id))
;		    (rplacd dn (cdr id))
			 (diana_nodetype_set dn (diana_nodetype_get id))
			 (diana_mapc
			   #'(lambda(attr val)
			       (diana_put dn val attr))
			   id)
;		    (break have-a-quick-peek-at-dn)
			 )))
		;; This node is no longer waiting to be disambiguated.
		;;so if it was on the waiting list, remove it.
		
		(diana_put dn nil 'tp_vfuns)	  ;this is it discard temporary.
		(%=   *awaiting_disambiguation*  (delq dn *_*)))
	       ((null choices)		  ;no matching function found.
		(let* ((chs (diana_get dn 'tp_vfuns))
		       (nm  (and chs (find_selected_name (car chs)))))
		  (cond
		    ((null chs)
		     (%=   *awaiting_disambiguation*  (delq dn *_*))
		     (semgripe 'undecl_subprog))
		    ;; operator is undefined but in ada equality and inequality
		    ;; is always defined, so put one in.
		    ((equal (cadr nm) '(#/=))
		     ;;now proporgate the type if its a function..
		     (cond
		       ((eq (diana_nodetype_get dn) 'dn_function_call)
			(diana_put dn
				   (diana_get
				     (diana_get
				       (ada_declared
					 (ada_ident **any_equal**)
					 nil)
				       'sm_spec)
				     'as_name_void)
				   'sm_exp_type)))
		     (diana_put dn
				(sc_diana dn_used_name_id
					  lx_symrep (ada_ident =)
					  sm_defn (ada_declared
						    (ada_ident **any_equal**)
						    nil))
				'as_name)
		     (%=   *awaiting_disambiguation*  (delq dn *_*)))
		    ;; operator is undefined but in ada equality and inequality
		    ;; is always defined, so put one in.
		    ((equal (cadr nm) '(#// #/=))
		     (diana_put dn
				(sc_diana dn_used_name_id
					  lx_symrep (ada_ident /=)
					  sm_defn (ada_declared
						    (ada_ident **any_equal**)
						    nil))
				'as_name)
		     (%=   *awaiting_disambiguation*  (delq dn *_*)))
		    (t			  ;(break in-t-state)
		     (%=   *awaiting_disambiguation*  (delq dn *_*))
		     (semgripe 'undecl_subprog
			       (let* ((tpvfuns (first (diana_get dn 'tp_vfuns)))
				      (lxsr (and
					      tpvfuns
					      (find_selected_name tpvfuns))))
				 (implode
				   (cadr
				     lxsr)))))))) 
	       (t
		;; remember current state of disambiguation.
		(diana_put dn choices 'tp_vfuns)
		;; and wait for another shot at it.
		(cond
		  ((memq dn  *awaiting_disambiguation*))
		  (t (ct_push dn *awaiting_disambiguation*))))))
       'still_ambiguous)
      ;; remember current state of disambiguation.
      (diana_put dn choices 'tp_vfuns)
      (diana_put dn nil 'ct_base_type)
      (diana_put dn nil 'ct_parent_type)
      ;; and wait for another shot at it.
      (cond
       ((memq dn  *awaiting_disambiguation*))
       (t (ct_push dn *awaiting_disambiguation*))))))
dn)

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun check_pending_disambiguations ()
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; First of all give the waiting list a chance to be disambiguated.
  (%= *awaiting_disambiguation*
      (mapcan
	#'(lambda(dp)
	    ;;try to disambiguate this one.
	    (dissambiguate_function_reference dp)
	    ;;if it succeeded, remove it from the pending list.
	    (cond ((null (diana_get dp 'tp_vfuns))
		   nil)
		  (t
		   (list dp))))
	*_*))
  ;; Any remaining in the list are ambiguous.. Say so.
  (mapc
    #'(lambda(loser)
	(semgripe 'ambig_func_ref))
    *awaiting_disambiguation*)
  ;;now clean out the list for next time.
  (setq *awaiting_disambiguation* nil)
)
       ;;;;;;;;;;;;;;;;
(defun any_params_fixed(fn)
       ;;;;;;;;;;;;;;;;
  (let ((pars (diana_get
		(diana_get fn 'sm_spec)
		'as_param_s)))
    (do ((par pars (cdr par))
	 (btu (extract_basetype *universal_fixed*)))
	((null par) nil)
      (cond ((eq btu
		 (extract_basetype
		   (car (diana_get (car par) 'as_id_s))))
	     (return t))))))

;;see if this is a universal operator- ie in the wazzoo
;;and return **any_float**
       ;;;;;;;;;;;;;;;;;;;;
(defun universal_function_p (fn)
       ;;;;;;;;;;;;;;;;;;;;

  (let* ((path (source_region%path
		(and (diana_node_accepts_attributep fn 'sm_body)
		     (diana_get fn 'sm_body)
		     (diana_get
		       (diana_get fn 'sm_body)
		       'lx_srcpos))))
	(smspec (and (diana_node_accepts_attributep fn 'sm_spec)
		       (diana_get
			 fn
			 'sm_spec)))
	(rettyp (and smspec
		     (diana_node_accepts_attributep smspec 'as_name_void)
		     (diana_get
		       smspec
		       'as_name_void))))
    (cond ((and (equal path '"wazzoo")
		(eq (extract_basetype rettyp)
		    (extract_basetype *ct_ada_true* )))
	   (cond ((not (any_params_fixed fn))
		  t)))
	  ((and (equal path '"wazzoo")
		(neq rettyp *universal_fixed*))
	   t))
	  ))

;;checks that each of the actuals is a universal expression
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun all_actuals_are_universal_static_expressions_p (al)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (not (memq '*diana_node_not_static_expression*
	(mapcar
	  #'(lambda (act)
	    (car (errset (fe_static_eval act) nil)))
	  al))))

;;; discard variants that could never suceed by virtue of the types of the
;;; actuals - if known.
 
       ;;;;;;;;;;;;;;;;;;;;;;;;;
(defun filter_matching_functions (dn choices)
       ;;;;;;;;;;;;;;;;;;;;;;;;;
	(let ((actuals (let ((aps (diana_get dn 'as_param_assoc_s)))
			 (and aps (diana_get aps 'as_list)))))
	  (mapcan
	    #'(lambda(choice)		  ;do actuals match formals?
		(cond
		  ((eq (diana_nodetype_get choice) 'dn_selected)
		   (mapcar #'(lambda (fn)
				 (sc_diana dn_selected
					 as_name (diana_get choice 'as_name)
					 as_designator_char fn)
			       )
			   (filter_matching_functions
				dn
				(let ((asdes
					(diana_get choice 'as_designator_char)))
				  (cond ((consp asdes) asdes)
					((null asdes ) nil)
					(t (list asdes)))))))
		  (t
		   (let* ((spec
			    (and
			      (diana_node_accepts_attributep choice 'sm_spec)
			      (diana_get choice 'sm_spec)))
			  (formals 
			    (and spec
				 (diana_get spec 'as_param_s))))
;	    (break in-filter)
		     (let ((labels_alist
			     (consistant_type_profilep actuals formals))
			   (labels_alist2
			     (consistant_type_profilep nil formals)))
;	      (break frob)
		       (cond
			 ((and actuals (not formals)) nil)
			 ((and labels_alist
			       (or
				 (not
				   (eq (diana_nodetype_get dn) 'dn_function_call))
				 (consistant_types_with_inheritance
				   labels_alist
				   (diana_get dn 'sm_exp_type)
				   (substituted_derived_type
				     (diana_get spec 'as_name_void)
				     (car labels_alist)))
				 (derivable_subprogram
				   (diana_get dn 'sm_exp_type)
				   (diana_get spec 'as_name_void))))
			  (list choice))
			 ((and labels_alist2
			       (eq (diana_nodetype_get dn) 'dn_function_call)
			       (or
				 (consistant_types_with_inheritance
				   labels_alist2
				   (diana_get dn 'sm_exp_type)
				   (result_type_after_indexing choice))
				 (derivable_subprogram
				   (diana_get dn 'sm_exp_type)
				   (diana_get spec 'as_name_void))))
			  (list choice))
			 (t nil)))	  ;cant be this function.
		     )))
		)
	    choices))
	   )

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun disambiguate_subordinate_subtrees  (dn)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (let ((actuals
	  (let ((apas (diana_get dn 'as_param_assoc_s)))
	    (and apas (diana_get apas 'as_list)))))
    (mapc
      #'(lambda(subordinate)
	  (cond ((memq subordinate *awaiting_disambiguation*)
		 (dissambiguate_function_reference subordinate))
		((memq subordinate *awaiting_aggregate_disambiguation*)
		 (dissambiguate_aggregate subordinate dn))));cul++
      actuals)))

       ;;;;;;;;;;;;;;;;;;;;;;;;
(defun consistant_type_profilep (actuals formals &optional persuader)
       ;;;;;;;;;;;;;;;;;;;;;;;;
    ;;step through actuals. If base type can be established, use it
    ;;if it can't skip to the next one. If a nonmatching basetype is found
    ;;return 'nil'. If all match or are unknown, return a list whose 'car'
    ;;is the labels_alist mapping of formals onto derived types, for use in
    ;;type propergation.
    ;;now, it just so happens that the actual might be a private type
    ;;and the actual aint. In this case, the private formal is coerced into
    ;;its 'hidden' basetype.
  (*catch '*unmatched_keyword*
    (progn
    (setq formals (extract_formal_id_s formals))
    (setq actuals
	  (sort_actuals_into_the_correct_order_if_possible actuals formals))
    (cond
      ((= (length actuals)(length formals))
       (do ((acts actuals (cdr acts))
	    (frms formals (cdr frms))
	    (labels_alist nil))		  ;a list of type maps for derived types.
	   ((null acts)
	    (list labels_alist))	  ;this one is consistant.
	 (let ((actual_basetype (extract_basetype (car acts)))
	       (formal_basetype
		 (substituted_derived_type
		   (extract_basetype (diana_get (caar frms) 'sm_obj_type))
						;;(cadar frms))
		   labels_alist)))
#|	   (cond ((and (not (private_type_p formal_basetype))
		       (private_type_p actual_basetype)
		       (diana_get actual_basetype 'sm_type_spec))
		  (setq actual_basetype
			(extract_basetype
			  (diana_get actual_basetype 'sm_type_spec)))))|#
	   (cond ((and persuader (not actual_basetype))
		  (diana_put (car acts) formal_basetype 'sm_exp_type)))
	   (cond 
	     ;;check possible constraint generated by literals.
	     ((ada_literal_or_aggregate_p (car acts))
	      (cond ((not (formal_consistant_with_literalp
			    formal_basetype
			    (car acts)))
		     (return nil))))
	     ((and actual_basetype
		   formal_basetype
		   (not
		     (derivable_subprogram actual_basetype formal_basetype)))
	      (return nil))))))))))


       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun sort_actuals_into_the_correct_order_if_possible (actuals formals)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  (do (
       (parampos 1)
       (aps actuals (cdr aps))
       (unsequenced nil)
       (normalized nil)
       (fps formals);returns a list of pairs.
       )
      ((null aps)
       (append (reverse normalized)
	       (sequence_kwp unsequenced fps parampos nil)))
    (ct_selectq (diana_nodetype_get (first aps))
		(dn_assoc
		  (let ((formpos (find_formal2 (first aps) fps parampos)))
		    (cond
		      ((zerop formpos) (*throw '*unmatched_keyword* nil))
		      (t (ct_push `(,formpos ,(first aps)) unsequenced)))))
		(otherwise
		  (%= fps (cdr fps))	  ; this formal is accounted for.
		  (%= parampos (1+ *_*))
;		  (ct_push (copy_dn (car aps))normalized)
		  (ct_push (car aps)normalized)))))

       ;;;;;;;;;;;;;;;;;;;;;;;;
(defun substituted_derived_type (type subst_alist)
       ;;;;;;;;;;;;;;;;;;;;;;;;
  (let ((substitution (assq type subst_alist)))
    (or (cdr substitution) type)))

       ;;;;;;;;;;;;;;;;;;;;
(defun derivable_subprogram (actt fort)
       ;;;;;;;;;;;;;;;;;;;;
  (setq actt (extract_basetype actt))
  (let ((parent_types (find_parents_of_derived_type actt))
	(for_bound (assq fort labels_alist)))
    (cond (for_bound
	   ;; this formal has been bound by a previous parameter, hereafter
	   ;; its type must be used religiously.
	   (or (eq actt (cdr for_bound))
	       (and (universal_typep actt )
		    (types_consistant_after_implicit_conversion actt fort))))
	  ((eq actt fort)
	   ;; the actual and formal match! make the binding to restrict later
	   ;; parameters in the scope of their matchability.
	   (cond ((universal_typep actt)
		  t)
		 (t (ct_push `(,fort . ,actt) labels_alist))))
	  ((memq fort parent_types)
	   ;; if the formal type is inherited by the derived type,
	   ;; we can inherit the operation provided that the formal be
	   ;; replaced by the actual type throughout the profile.
	   ;; so add the mapping to the labels_alist.
	   (cond ((universal_typep actt)
		  t)
		 (t (ct_push `(,fort . ,actt) labels_alist))))
	  ((types_consistant_after_implicit_conversion actt fort) t))))

       ;;;;;;;;;;;;;;;
(defun universal_typep (act)
       ;;;;;;;;;;;;;;;
  (memq act *universal_types*))
  
       ;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ada_literal_or_aggregate_p (act)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;
  (let ((name (strip_name act)))
    (and name
         (memq (diana_nodetype_get name)
	       '(dn_allocator
		  dn_number_id
		  dn_numeric_literal 
		  dn_string_literal
		  dn_character_literal
		  dn_null_access)))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun formal_consistant_with_literalp (for lit)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq lit (strip_name lit))
  (ct_selectq
    (diana_nodetype_get lit)
    (dn_numeric_literal
      (cond ((la_num%floatp (diana_get lit 'lx_numrep))
	     (or
	       (memq (let ((eb (extract_basetype for )))
		       (and eb (diana_nodetype_get eb)))
		     '(dn_float dn_fixed))
	       (consistant_types
		 *universal_real*
		 for
		 t)
	       (consistant_types
		 *universal_real*
		 (extract_basetype for t)
		 t)
#|	       (consistant_types
		 *universal_fixed*
		 for
		 t)|#
	       ))
	    (t
	     (or
	       (eq (let ((eb (extract_basetype for )))
		       (and eb (diana_nodetype_get eb)))
		   'dn_integer)
	       (consistant_types
		 *universal_integer*
		 (extract_basetype for t)
		 t)))))
    (dn_used_name_id
      (formal_consistant_with_literalp  for (diana_get lit 'sm_defn)))
    (dn_null_access
      (cond((null for ) nil)
	   ((eq (diana_nodetype_get for) 'dn_access)
	    t)
	   ((eq (diana_nodetype_get for) 'dn_derived)
	    (formal_consistant_with_literalp
	      (extract_basetype for t) lit))))
    (dn_string_literal
      (cond
	((null for) nil)
	((eq (diana_nodetype_get for) 'dn_array)
	 (eq (extract_basetype (diana_get for 'as_constrained) t)
	     (extract_basetype *character_type*)))))
    (dn_character_literal
      (cond ((boundp '*character_type*)
	     (consistant_types
	       *character_type*
	       for
	       t))
	    (t
	     (consistant_types
	       (ada_declared (ada_ident character) nil 'type)
	       for
	       t))))
    (dn_number_id
      (let ((obj (diana_get lit 'sm_init_exp)))
	(cond
	  ;; deferred constant?
	  ((null obj)
	   (or
	     (consistant_types
	       *universal_real*
	       for
	       t)
	     (consistant_types
	       *universal_integer*
	       for
	       t)))
	  ;; constant object definition available?
	  (t
	   (cond
	     ((eq (diana_nodetype_get obj) 'dn_function_call)
	      (consistant_types
		(extract_basetype obj)
		for
		t))
	     (t (formal_consistant_with_literalp for obj)))))))
    (dn_selected
      (formal_consistant_with_literalp for
				       (diana_get lit 'as_designator_char)))
    (dn_allocator
      (cond ((null for) nil)
	    (t (consistant_types
		 (diana_get lit 'sm_exp_type)
		 (diana_get for 'as_constrained)
		 nil))))
    (otherwise nil)))