;;; -*- mode:lisp;package:user;base:10.;fonts: cptfontb -*- 
;;; $Header: /ct/interp/visible.l,v 1.32 84/12/14 19:24:38 penny Exp $
;;;
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                            visible.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.
	     
;;; pr_in_block
;;; Parse the syntactic unit as a textually inferior 'block' of the
;;; current block. Block here refers to a block for identifier 
;;; resolution rather than an Ada BLOCK as a syntactic unit.
;;; Two special variables are handled here *bnl* and **current_block**
       ;;;;;;;;;;;
(defun pr_in_block fexpr (syn)
       ;;;;;;;;;;;

   (prog2
     (pushcontext)
     (parserd (first syn))
     (popcontext))
)

       ;;;;;;;;;;;
(defun savecontext()	
       ;;;;;;;;;;;

    (ct_push `(,*bnl* ,*pnl* ,**current_block**) *contextstack*))

       ;;;;;;;;;;
(defun popcontext()		; pop to mother block (must match
       ;;;;;;;;;;

				; pushcontext).
    (let ((b (first (first *contextstack*)))
	  (p (second (first *contextstack*)))
	  (c (third (first *contextstack*))))
      (setq *bnl* b *pnl* p **current_block** c))
    (ct_pop *contextstack*))

 #| This is the good version!
       ;;;;;;;;;;;
(defun pushcontext()		; make a nested block.
       ;;;;;;;;;;;

    (ct_push `(,*bnl* ,*pnl* ,**current_block**) *contextstack*)
    (%= *bnl* (1+ *_*))
    (%= **current_block** (new_block)))

       ;;;;;;;;;;;;;;;
(defun pushproccontext()		; make a nested subprogram
       ;;;;;;;;;;;;;;;

    (ct_push `(,*bnl* ,*pnl* ,**current_block**) *contextstack*)
    (%= *bnl* (1+ *_*))
    (%= *pnl* (1+ *_*))
    (%= **current_block** (new_block)))
|#

       ;;;;;;;;;;;
(defun pushcontext()		; make a nested block.
       ;;;;;;;;;;;

    (ct_push `(,*bnl* ,*pnl* ,**current_block**) *contextstack*)
    (and *bnl* (%= *bnl* (1+ *_*))) ;rubustification .. crock crock
    (%= **current_block** (new_block)))

       ;;;;;;;;;;;;;;;
(defun pushproccontext()		; make a nested subprogram
       ;;;;;;;;;;;;;;;

    (ct_push `(,*bnl* ,*pnl* ,**current_block**) *contextstack*)
    (and *bnl* (%= *bnl* (1+ *_*)))
    (and *pnl* (%= *pnl* (1+ *_*)))
    (%= **current_block** (new_block)))

;; pr_in_proc
;;; Parse the syntactic unit as a textually inferior 'subprogram' of the
;;; current subprogram.
       ;;;;;;;;;;
(defun pr_in_proc fexpr (syn)
       ;;;;;;;;;;

    (let ((*bnl* (1+ (or *bnl* 0)))	; increment the block nesting level
	  (*pnl* (1+ (or *pnl* 0)))	  ; increment the procedure nesting level
	  (**current_block** (or (second syn)(new_block))))	  ; create a new block-id.
      (parserd (first syn)))
)

;;; find_name, finds a matching entry in the symbol table and returns a
;;; pointer to the corresponding object in the diana tree.
;;; like ada_declared but works for names in general ... used ada_declared
;;; as a primitive.
  
       ;;;;;;;;;
(defun find_name(n cls &optional all_p)	; n is a structure containing the object.
       ;;;;;;;;;

  (cond
    ((and (not (diana_nodep n))(eq (car n) 'lex_ident))	  ;if its a trivial name...
     (ada_declared n nil cls all_p))
    (t (ct_selectq (and (diana_nodep n)(diana_nodetype_get n))
		   (dn_selected (let ((etry (diana_get n 'as_designator_char))
				      (bt (extract_basetype
						(diana_get n
							   'as_name))))
				     (cond
				       ((and bt
					     (memq (diana_nodetype_get bt)
					    '(dn_record dn_access)))
					(cond (all_p (list n))
					      (t n)))
				       (t 
					(cond (all_p   (list n))
					      (t n))))))
		   (otherwise (cond ((and all_p (diana_nodep n))
				     (list n))
				    (t n)))))
    )
)

;;; add_name(n c d tp)		; name class definition.
;;; adds the name to the symbol table with the current procedure nesting
;;; level and the specified class and definition.
;;; returns the definition parameter unchanged.
    				; add code to check for multiple defn at the
				; same pnl with the same type.
       ;;;;;;;;
(defun add_name(n c d tp)	; name class definition.
       ;;;;;;;;

  (let ((others (get_id n (la_hash (cadr n))))); other identifiers with the
					  ; same name (or nil).
    (cond (others (rem_id n (la_hash (cadr n)))))
    (put_id 
      n					  ; the name to be matched.
      (la_hash (cadr n))		  ; the hash address.
      (cons
	(la_id n *pnl* la_srcpos d c tp **current_block**); the new identifier.
	others))			  ; other identifiers with the same name.
    (diana_put d tp 'ct_st_type)	  ; save for symbol table reproducibility
    (diana_put d **current_block** 'ct_st_defining_block)
    (diana_put d c 'ct_st_class)
    d					  ; this is usually what is wanted -- saves a
					  ; progn in the code.
    ))

;;; Static semantics code for resolving identifiers in a context
;;; The current context is defined by a special variable *blockcontext*
;;; resolution is achieved in three stages.
;;;	Stage 1. Find all defined names that match
;;;	Stage 2. Extract from the above list, those that are in scope
;;;		 and visible in the current context
;;;	Stage 3. Extract from the stage 2 list, those that have a compatible
;;;		 type.
;;; The resulting list should contain one and only one identifier, this one
;;; is the resolved identifier. Should any of the above three stages
;;; terminate without finding any identifiers then the identifier is
;;; 'undeclared'. If the resulting list contains more than a single
;;; identifier, there is an ambiguity and hence illegal. The occurences
;;; should all be listed to indicate to the user what the ambiguity is
;;; and a tv:cvv could be used to choose one of them and proceed.
;;;
;;; Note: a weaker kind of checking is performed by pr_restrict for the
;;;       purpose of resolving ambiguous parses.

;;; new_block - creates a new block in the current context, sets the
;;;             parent block and specifies zero mixinsn.

	;;;;;;;;;
;(defun new_block()		; makes a new block id in the current
	;;;;;;;;;

;				; context.
;   (let ((nublok (intern (gensym))))	; later we may use a dpl.
;                                        ; (intern for debugging only)
;       (putprop nublok **current_block** 'is_enclosed_by); parent block
;       (putprop nublok nil               'mixins)       ; use clauses.
;       nublok
;   )
;)

       ;;;;;;;;;
(defun new_block()
       ;;;;;;;;;

    (sc_diana dn_ct_contextnode
	      ct_is_enclosed_by **current_block** ; parent block
	      ct_mixin_s        nil	  ; packages mixed in.
	      )
)

;;; walk_env (list from shadows) Filter environment
;;; returns a list of all occurences of list that can be reached by
;;; walking the environment tree from 'from'.

       ;;;;;;;;
(defun walk_env(idlist context)(walk_env_rec idlist context nil))
       ;;;;;;;;

       ;;;;;;;;;;;;
(defun walk_env_rec(idlist context shadows); filter out unreachable or hidden ids
       ;;;;;;;;;;;;
  (cond ((null context) nil)		  ; no idents reachable from here.
	(t (let ((hidden_context (diana_get context 'ct_hidden_context)))
;    (cond (hidden_context (break hc)))
	     
	     (do ((found nil)		  ; idents that matched at this block
		  (notfound nil)	  ; idents yet to be found
		  (candidates idlist (cdr candidates)))	  ; the candidates.
		 ((null candidates)	  ; stop when all candidates been tried.
		  (append
		    found
		    (traverse_context notfound context (append found shadows))))
	       (cond
		 ((and
		    (or
		      #| (eq	
		    hidden_context
		    (la_id%db (car candidates)))|#
		      (eq		  ; this candidate was defined in this block
			context
			(la_id%db (car candidates))))
		    (not_obscured_by (car candidates) shadows))
		  (ct_push (car candidates) found))
		 (t
		  (ct_push (car candidates) notfound)))
	       )))))

       ;;;;;;;;;;;;;;;;;;
(defun walk_env_one_level(idlist context shadows); filter unreachable or hidden ids
       ;;;;;;;;;;;;;;;;;;

    (cond 
      ((null context) nil)		  ; no idents reachable from here.
      (t (do ((found nil)		  ; idents that matched at this block
	      (candidates idlist (cdr candidates)))	  ; the candidates.
	     ((null candidates)		  ; stop when all candidates have been tried.
	      found)
	   (cond
	     ((and
		(eq			  ; this candidate was defined in this block
		  context
		  (la_id%db (car candidates)))
		(not_obscured_by (car candidates) shadows))
	      (ct_push (car candidates) found))
	     )
	   ))))

;;; traverse_context(idlist context shadows)
;;; recursively invokes 'walk_env_rec' for the parent node and then searches
;;; mixins.. Incorporates Ada's rules for hiding overloading and ambiguity.
       ;;;;;;;;;;;;;;;;
(defun traverse_context(idlist context shadows)
       ;;;;;;;;;;;;;;;;

    (cond
      ((null context) nil)
      ((null idlist) nil)		  ; nothing left to search for.
      (t (let ((texenc (walk_env_rec 
			 idlist 
			 (diana_get context 'ct_is_enclosed_by)
			 shadows)))
	   (do ((nuidlst (removeall texenc idlist))
		(nushadows (append shadows texenc))
		(foundlist texenc)
		(mixins (diana_get context 'ct_mixin_s) (cdr mixins)))
	       ((null mixins) foundlist)
	     (let ((mixinsfound
		     (walk_env_one_level
		       nuidlst		  ; idents remaining to be found.
		       (car mixins)	  ; this mixin.
		       nushadows)))
	       (%= nuidlst (removeall mixinsfound *_*))
	       (%= foundlist (append mixinsfound  *_*))))))))

#|
;;; traverse_context(idlist context shadows)
;;; recursively invokes 'walk_env_rec' for the parent node and then searches
;;; mixins.. Incorporates Ada's rules for hiding overloading and ambiguity.
       ;;;;;;;;;;;;;;;;
(defun traverse_context(idlist context shadows)
       ;;;;;;;;;;;;;;;;

    (cond
      ((null idlist) nil)		  ; nothing left to search for.
      (t (let ((texenc (walk_env_rec 
			 idlist 
			 (diana_get context 'ct_is_enclosed_by)
			 shadows)))
	   (do ((nuidlst (removeall texenc idlist))
		(nushadows (append shadows texenc))
		(foundlist texenc)
		(mixins (diana_get context 'ct_mixin_s) (cdr mixins)))
	       ((null mixins) foundlist)
	     (let ((mixinsfound
		     (walk_env_rec
		       nuidlst		  ; idents remaining to be found.
		       (car mixins)	  ; this mixin.
		       nushadows)))
	       (%= nuidlst (removeall mixinsfound *_*))
	       (%= foundlist (append mixinsfound  *_*))))))))
|#
	    
;;; removeall (thesefrom those) 
;;; performs set subtraction. result is a list of those elements of 
;;; 'those' that are not present in 'thesefrom'
       ;;;;;;;;;
(defun removeall(thesefrom those)
       ;;;;;;;;;

    (do ((remaining those)
	 (toremove  thesefrom (cdr toremove)))
	((null toremove) remaining)
      (%= remaining (delq (car toremove) remaining))))

;;; not_obscured_by 
;;; A predicate that decides if an identifier is overloaded or hidden, returns
;;; nil if the identifier is HIDDEN and t if it is either overloaded or 
;;; otherwise visible. Interfaces to the type_compatability code.
       ;;;;;;;;;;;;;;;
(defun not_obscured_by(identifier shadows)
       ;;;;;;;;;;;;;;;

    (do ((shade shadows (cdr shade)))
	((or (null shade)
	     (hides_p identifier (car shade)))
	 (null shade))))		  ; return t if identifier is NOT hidden.
	     

(defun generic_defo_p (stub)
  (cond ((and
	   (= (length stub) 1)
	   (eq (diana_nodetype_get (car stub))
	       'dn_generic_id))
	 t)))
	 
;;; Takes a single argument which is a class name and returns nil if it is
;;; not overloadable.
       ;;;;;;;;;;;;;;
(defun overloadable_p(ic)
       ;;;;;;;;;;;;;;

    (memq ic '(procedure function accept entry task package enumeration_literal)))

       ;;;;;;;
(defun hides_p(id1 id2)
       ;;;;;;;

  (cond
    ((eq (la_id%class id1) 'library_unit) nil)
    ((eq (la_id%class id2) 'library_unit) nil)
    ((overloads_p id1 id2) nil)		  ;if it overloads it cannot hide.
    ((same_name_p id1 id2) t  )		  ;if it doesnt overload but has the same
					  ;name, it hides.
    ))					  ;otherwise it doesnt.

       ;;;;;;;;;;;
(defun same_name_p(id1 id2)
       ;;;;;;;;;;;

  (let ((nid1 (diana_get (la_id%dn id1) 'lx_symrep))
	(nid2 (diana_get (la_id%dn id2) 'lx_symrep)))
;    (break nid1 nid2)
    (equal nid1 nid2)))

;;; Takes two identifier symbol table entries. Returns non-nil if
;;;  id2 overloads id1 and nil if id2 hides id1.
       ;;;;;;;;;;;
(defun overloads_p(id1 id2)
       ;;;;;;;;;;;

    (let ((c1 (la_id%class id1))	; Class of id1
	  (c2 (la_id%class id2))	  ; Class of id2
	  (d1 (la_id%dn    id1))	  ; Definition of id1
	  (d2 (la_id%dn    id2)))	  ; Definition of id2
      (cond
	((and (overloadable_p c1)(overloadable_p c2))
	 (or (neq c1 c2)		  ; overload if different
					  ; classes.
	     (not (same_type_profile_p d1 d2))))  ; overloads if different
					  ; type profile (otherwise
					  ; hides).
	(t nil))))			  ; id2 HIDES id1

;;; Takes two definitions of the same class and returns non-nil if they
;;; have the same type profile
       ;;;;;;;;;;;;;;;;;;;
(defun same_type_profile_p(d1 d2)
       ;;;;;;;;;;;;;;;;;;;

;  (break in-same_type_profile_p) t)
   (or (eq d1 d2)			  ;same node MUST have same profile.
       (ct_selectq
	 (diana_nodetype_get d1)	  ;a different rule for each case.
	 (dn_generic_id
	   (cond ((eq (diana_nodetype_get
			(diana_get d1 'sm_spec))
		      'dn_function)
		  (let ((p1 (let ((s1 (diana_get d1 'sm_spec)))
			      (and s1 (diana_get s1 'as_param_s))))
			(p2 (let ((s2 (diana_get d2 'sm_spec)))
			      (and s2 (diana_get s2 'as_param_s)))))
		    (and (compare_parameter_list_types p1 p2)
			 (same_type_despite_privacy
			   (extract_basetype
			     (let ((s1 (diana_get d1 'sm_spec)))
			       (and s1 (diana_get s1 'as_name_void))))
			   (extract_basetype
			     (let ((s2 (diana_get d2 'sm_spec)))
			       (and s2 (diana_get s2 'as_name_void))))))))
		 ((eq (diana_nodetype_get
			(diana_get d1 'sm_spec))
		      'dn_procedure)
		  (let ((p1 (let ((s1 (diana_get d1 'sm_spec)))
			      (and s1 (diana_get s1 'as_param_s))))
			(p2 (let ((s2 (diana_get d2 'sm_spec)))
			      (and s2 (diana_get s2 'as_param_s)))))
		    (compare_parameter_list_types p1 p2)))
		 (t t)))
	 (dn_proc_id
	   (let ((p1 (let ((s1 (diana_get d1 'sm_spec)))
		       (and s1 (diana_get s1 'as_param_s))))
		 (p2 (let ((s2 (diana_get d2 'sm_spec)))
		       (and s2 (diana_get s2 'as_param_s)))))
	     (compare_parameter_list_types p1 p2)))
	 (dn_function_id
	   (let ((p1 (let ((s1 (diana_get d1 'sm_spec)))
		       (and s1 (diana_get s1 'as_param_s))))
		 (p2 (let ((s2 (diana_get d2 'sm_spec)))
		       (and s2 (diana_get s2 'as_param_s)))))
	     (and (compare_parameter_list_types p1 p2)
		  (same_type_despite_privacy
		    (extract_basetype
		      (let ((s1 (diana_get d1 'sm_spec)))
			(and s1 (diana_get s1 'as_name_void))))
		    (extract_basetype
		      (let ((s2 (diana_get d2 'sm_spec)))
			(and s2 (diana_get s2 'as_name_void))))))))
	 (t t))))			  ;if we dont know assume yes!

;;; compares two formal parameter lists for 'same profile-ness'
;;; returns t if they are compatible nil otherwise.
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compare_parameter_list_types(p1 p2)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (let ((a1 nil)(a2 nil))
    (do ((fpgs1 p1 (cdr fpgs1)))	  ; loop on formal parameter groups of p1.
	((null fpgs1))
      (let ((parl1 (diana_get (first fpgs1) 'as_id_s)))
	(do ((afp1 parl1 (cdr afp1)))
	    ((null afp1))
	  (ct_push
	    (list (diana_nodetype_get (car fpgs1))(diana_get (car fpgs1) 'as_name))
	    a1))))
    (do ((fpgs2 p2 (cdr fpgs2)))	  ; loop on formal parameter groups of p2.
	((null fpgs2))
      (let ((parl2 (diana_get (first fpgs2) 'as_id_s)))
	(do ((afp2 parl2 (cdr afp2)))
	    ((null afp2))
	  (ct_push
	    (list (diana_nodetype_get (car fpgs2))(diana_get (car fpgs2) 'as_name))
	    a2))))			  ; add the parameter to the list.
    ;;now check them one by one.
    (or ;(null a1)
	;(null a2)
	(and (= (length a1)(length a2))	  ;must be the same number of them!
	     (do ((pa1 a1 (cdr pa1))
		  (pa2 a2 (cdr pa2)))	  ;iterate on the args.
		 ((or (null pa1)	  ;running out of params is good.
		      (not (eq (caar pa1)(caar pa2)))	  ;not same mode is bad.
		      (not (same_type_despite_privacy
			     (extract_basetype (cadar pa1))
			       (extract_basetype (cadar pa2)))))
		  (null pa1)))))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;
(defun same_type_despite_privacy (t1 t2)
       ;;;;;;;;;;;;;;;;;;;;;;;;;
  (cond ((and t1
	      (memq (diana_nodetype_get t1) '(dn_l_private_type_id
					  dn_private_type_id)))
	 (setq t1 (diana_get t1 'sm_type_spec))))
  (cond ((and t2
	      (memq (diana_nodetype_get t2) '(dn_l_private_type_id
					  dn_private_type_id)))
	 (setq t2 (diana_get t2 'sm_type_spec))))
  (eq t1 t2))

       ;;;;;;;;;;;;;;;;
(defun add_id_to_symtab(laid)
       ;;;;;;;;;;;;;;;;
#|
    (let* ((nam (la_id%name laid))
	   (defs (ada_declared nam nil nil t)))	  ; all same name entries.
      (setq defs (filter_standard_environment defs))	  ; take only those in
					  ; stdenv
      (cond
	((null defs)
	 (let ((hashval (la_hash (cadr nam))))
	   (let ((others (get_id nam hashval)))
	     (cond (others (rem_id nam hashval)))
	     (put_id
	       nam			  ; The name to be hashed against.
	       hashval			  ; The hash value based on the name.
	       (cons laid others))
	     nil)))
	(t  ;(ct_format terminal-io "linking symbol ~A~%" (implode (cadr nam)))
;		(break in-add_id_to_symtab)
	 (first defs))))
|#

      (let* ((nam (la_id%name laid))
	     (hashval (la_hash (cadr nam)))
	     (others (get_id nam hashval)))
	     ;(cond (others (rem_id nam hashval)))
	(cond ((eq (la_id%class laid) 'library_unit)
	       (cond
		 ((eq (diana_nodetype_get (la_id%dn laid))
		      'dn_package_id)
		  (put_id nam hashval
			  (cons
			    (la_id (la_id%name laid)
				   (la_id%pl laid)
				   (la_id%sfn laid)
				   (la_id%dn laid)
				   'package
				   (la_id%typ laid)
				    **current_block**)
			    others))
		  (setq others (get_id nam hashval))));need to put pkgs in twice
	       
	       (%= (la_id%db laid) **current_block**)
	       ;(break installing_lib_unit)
	       ))
	
	(put_id
	       nam			  ; The name to be hashed against.
	       hashval			  ; The hash value based on the name.
	       (cons laid others))
	     
	     ;(ct_format terminal-io "adding ~A to symtab~%"
	     ;		(implode (cadr nam)) )
	     nil))



;;; takes an id node 'me' and a list of id nodes 'them' and returns the result
;;; of filtering out the id's im them with different type profiles from 'me'
       ;;;;;;;;;;;;;;;;;;;;;;
(defun with_same_type_profile(me them)
       ;;;;;;;;;;;;;;;;;;;;;;
  
  (mapcan
    #'(lambda(him)
	(cond
	  ((eq him me) nil) ;;be careful not to include yourself!
	  ((same_type_profile_p me him) (list him))))
    them))

;;; takes an id node 'me' and a list of id nodes 'them' and returns the result
;;; of filtering out the id's im them with same type profiles as 'me'
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun with_different_type_profile(me them)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (mapcan
    #'(lambda(him)
	(cond
	  ((same_type_profile_p me him) nil)
	  (t (list him))))
    them))

;;; someday this optional should be made mandatory++
;;; cl is an optional class restriction (nil if no restriction)
;;;  p is a predicate to decide what to do if undeclared.
;;;    if p is t, no error message will be generated.. nil will be returned.
       ;;;;;;;;;;;;
(defun ada_declared (id tp &optional cl all_p); check to see if id is declared as a tp.
       ;;;;;;;;;;;;

    (let ((defs (walk_env_rec 
		  (get_id id (la_hash (cadr id))) **current_block** nil)))
      (%= cl (or cl *class_restriction*)) ;for names!
      (%= defs (cond ((null tp) defs)(t (filter_type tp defs))))
      (%= defs (cond ((null cl) defs)
		     (t
		      (cond
			((symbolp cl)(filter_class cl defs))
			(t (mapcan
			     #'(lambda(c)(filter_class c defs))
			     cl))))))   
      (%= defs (filter_private defs))	  ;filter out visible, if private avail.
;      (%= defs (filter_incarnations defs));temp fix
      (%= defs (filter_same_id defs))	  ;filter out identical identifiers.
      (cond
	(defs 
	 (cond
	   (all_p
	    (mapcar
	      #'(lambda(def)
		  (la_id%dn def))
	      defs)) ;; return all if asked for.
	   ((> (length defs) 1)		  ;(break ambiguous-id)
	    (semgripe 'ambig_id_ref
		      (implode (cadr id)))
	    (la_id%dn (car defs)))			  ;pick the first one.
	   (t (la_id%dn  (car defs)))))
	
	((not all_p)			  ;(break undeclared)
	 (semgripe 'undecl_id (implode (cadr id)))
	 (sc_diana dn_used_name_id
		   lx_symrep id)))))

       ;;;;;;;;;;;;;;;;;;;
(defun name_declared_check (dn)
       ;;;;;;;;;;;;;;;;;;;
  (cond
    ((null dn) nil)
    ((diana_nodep dn)
     (ct_selectq (diana_nodetype_get dn)
		 (dn_used_name_id 
		   (cond
		     ((null (diana_get dn 'sm_defn))
		      (ada_undeclared dn)
		      nil)
		     (t t)))		  ;not declared.
		 ((dn_indexed dn_slice dn_selected dn_attribute_call dn_attribute)
		   (name_declared_check (diana_get dn 'as_name)))
		 ((dn_function_call) t)	  ;++
		 (dn_all (name_declared_check (diana_get dn 'as_name)))
		 ((dn_proc_id dn_function_id dn_package_id dn_generic_id)
		  t)			  ;++
		 (otherwise
		   (break in-name_declared_check)
		   t)))
    (t t)))

       ;;;;;;;;;;;;;;
(defun ada_undeclared (dn)
       ;;;;;;;;;;;;;;
  (semgripe
    'undecl_id (implode (cadr (diana_get dn 'lx_symrep)))))

;;; Extracts entries that contain sm_first's that point to other entries.
       ;;;;;;;;;;;;;;;;;;;
(defun filter_incarnations (list)
       ;;;;;;;;;;;;;;;;;;;

    (mapcan
      (function
	(lambda(id)			  ;An la_id record.
	  (cond
	    ((re_incarnation_p id list) nil)
	    (t (list id)))))
      list))

       ;;;;;;;;;;;;;;
(defun filter_private (list)
       ;;;;;;;;;;;;;;

    (mapcan
      (function
	(lambda(id)			  ;An la_id record.
	  (cond
	    ((visible_brother_p id list) nil)
	    (t (list id)))))
      list))

       ;;;;;;;;;;;;;;
(defun filter_same_id (list)
       ;;;;;;;;;;;;;;

    (mapcon
      (function
	(lambda(id)			  ;An la_id record.
	  (cond
	    ((memb_id (la_id%dn (car id)) (cdr id)) nil)
	    (t (list (car id))))))
      list))

(defun memb_id (id l)
  (cond
    ((null l) nil)
    ((eq id (la_id%dn (car l))) t)
    (t (memb_id id (cdr l)))))

;;; returns T if the first id is a reincarnation of one in lids.
       ;;;;;;;;;;;;;;;;
(defun re_incarnation_p(id lids)
       ;;;;;;;;;;;;;;;;

    (let ((this_id (diana_get (la_id%dn id) 'sm_first))) ;this guy's first.
      (cond
        (this_id			  ;only if he has a first.
	 (do ((ids lids (cdr ids)))
	     ((null ids) nil)
	   (let ((that_id (la_id%dn (car ids))))
	     ;(break  re_incarnation_p)
	     (cond
	       ((eq this_id (la_id%dn id)) nil)
	       ((eq (diana_get (la_id%dn id) 'ct_st_defining_block)
		    (diana_get
		      (diana_get this_id 'ct_st_defining_block)
		      'ct_hidden_context))
		(return nil))		  ;dont jump the gun with hidden contexts.
	       ((eq this_id that_id)(return t)))  ;re_incarnation found!
	     ))))))

;;; returns T if the first id is a reincarnation of one in lids.
       ;;;;;;;;;;;;;;;;;
(defun visible_brother_p(id lids)
       ;;;;;;;;;;;;;;;;;

    (let ((this_id (la_id%dn id))) ;this guy's first.
      (cond
        (this_id			  ;only if he has a first.
	 (do ((ids lids (cdr ids)))
	     ((null ids) nil)
	   (let ((that_id (diana_get (la_id%dn (car ids)) 'sm_first)))
	     (cond
	       ((eq this_id that_id)(return t)))  ;visible_brother found!
	     ))))))

;;; Extracts all entries that are NOT in the standard environment
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun filter_standard_environment (list)	
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (mapcan
      (function
	(lambda(id)			  ; An la_id record.
;	      (break in-filter_standard_environment)
	  (cond 
	    ((eq (diana_get id 'ct_st_defining_block)
		 **standard_env**)
	     (list id))			  ;id IS in the standard environment.
	    (t nil))))
      list))

;;; Extracts those identifiers that are type compatibly with the specified
;;; type.
       ;;;;;;;;;;;
(defun filter_type (type list)	; extract entries with matching type.
       ;;;;;;;;;;;

    (mapcan
      (function
	(lambda(id)			  ; An la_id record.
	  (cond 
	    ((eq type (la_id%typ id)) (list id))
	    (t nil))))
      list))

       ;;;;;;;;;;;;
(defun filter_class (class list); extract entries with matching class.
       ;;;;;;;;;;;;

    (mapcan
      (function
	(lambda(id)			  ; An la_id record.
	  (cond
	    ((null (la_id%class id))     (list id))
	    ((eq class (la_id%class id)) (list id))
	    (t nil))))
      list))

       ;;;;;;;;;;;;;;;;;;;;;;;;;
(defun user_definable_function_p(fn)
       ;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;speed this up with hashtables later
  ;;;little hackeroo since calles with as not( first as)
  (memq (intern (implode (uplowlist (cadar fn)))
		'user)
		 '(|=| |>| |<| |>=| |<=| |and| |or| |xor| |not|
		       |+| |-| |abs| |*| !/ |rem| |mod| |**| |&|)))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun filter_non_visible_selected (dnl ddn)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (cond ((diana_nodep dnl)
	 (visible_selected dnl ddn))
	(t (mapcan #'(lambda (dn)
		       (list (visible_selected dn ddn)))
		   dnl))))

(defun find_list_of_compids (comp)
  (ct_selectq
    (diana_nodetype_get comp)
    (dn_var (copylist (diana_get comp 'as_id_s)))
    (dn_variant_part
      (find_list_of_compids (diana_get comp 'as_variant_s)))
    (dn_variant_s
      (mapcan #'find_list_of_compids
	      (diana_get comp 'as_list)))
    (dn_variant
      (find_list_of_compids (diana_get comp 'as_record)))
    (dn_inner_record
      (mapcan #'find_list_of_compids
	      (diana_get comp 'as_list)))
    (dn_null_comp nil)
    (otherwise
      (cond ((status feature debugging)
	     (break what-we-got-others))))))

(defun create_list_of_comps (rec)
  (let* ((smdisc (diana_get rec 'sm_discriminants))
	 (discs (and smdisc (diana_get smdisc 'as_list)))
	 (disclist (mapcan
		     #'(lambda (disc)
			 (copylist (diana_get disc 'as_id_s)))
		     discs))
	 (comps (diana_get rec 'as_list))
	 (complist (mapcan
		     #'find_list_of_compids
		     comps)))
    (append disclist complist)))

       ;;;;;;;;;;;;;;;
(defun compid_in_rec  (dn rec)
       ;;;;;;;;;;;;;;;
  (cond ((eq (diana_nodetype_get dn)
	     'dn_indexed)
	 (and (compid_in_rec (diana_get dn 'as_name) rec) dn))
	(t
	 (let ((compid (diana_get dn 'sm_defn))
	       (asl (create_list_of_comps rec))
	       )
	   (cond ((memq compid asl) dn)
		 (t (semgripe 'not_legal_component
			      (implode (uplowlist
					 (cadr (diana_get dn 'lx_symrep)))))
		    dn))))))


       ;;;;;;;;;;;;;;;;
(defun visible_selected (dn ddn)
       ;;;;;;;;;;;;;;;;
  (let ((dnbnl (cond ((and
			(eq (diana_nodetype_get dn)
			  'dn_used_name_id)
			(diana_get dn 'sm_defn)
			(eq (diana_nodetype_get
			      (diana_get dn 'sm_defn))
			  'dn_package_id))
		      (1+ (diana_get dn 'ct_bnl)))
		     (t (diana_get dn 'ct_bnl))))
	(bnl (cond ((eq (diana_nodetype_get
			  ddn)
			'dn_package_id)
		    (cond ((and
			     (diana_get ddn 'sm_spec)
			     (diana_get
			     (diana_get ddn 'sm_spec)
			     'ct_generic_membership))
			   (- (diana_get ddn 'ct_bnl) 2))
			  (t 
			   (1- (diana_get ddn 'ct_bnl)))))
		   (t (diana_get ddn 'ct_bnl)))))
    (cond
      ((memq
	 (diana_nodetype_get ddn)
	 '(dn_var_id dn_in_id dn_in_out_id dn_out_id))
       (let ((rec (extract_basetype ddn t)))
	 ;if this is a record check the selected is a compid
	 (cond ((and rec
		     (eq (diana_nodetype_get rec )
		    'dn_record))
		(compid_in_rec dn rec))
	       ((and rec (<  dnbnl (diana_get rec 'ct_bnl))) nil)
	       (t dn))
	 ))
      ((and (extract_basetype ddn t)
	    (eq (diana_nodetype_get (extract_basetype ddn t)) 'dn_access))
       (cond ((visible_selected dn (diana_get
				     (extract_basetype
				       ddn t)
				     'as_constrained))
	      )))
      ((eq (diana_nodetype_get dn) 'dn_function_call)
       (cond ((filter_non_visible_selected
		(or (diana_get
		      (diana_get dn 'as_name)
		      'sm_defn)
		    (diana_get dn 'tp_vfuns))
		ddn)
	      dn)
	     (t (diana_put dn nil 'as_name)
		(diana_put dn nil 'tp_vfuns)
		(dissambiguate_function_reference dn))))
      ((<  dnbnl (1+ bnl)) nil)
      (t dn))))

       ;;;;;;;;;;;;;;;;;;
(defun find_named_context (blk)
       ;;;;;;;;;;;;;;;;;;
  (cond ((and blk
	      (eq (diana_nodetype_get blk) 'dn_block))
	 (let* ((asit (car (diana_get blk 'as_item_s)))
	       (asids (and asit
			   (car (diana_get asit 'as_id_s))))
	       (defblk (and asids
			    (diana_get asids 'ct_st_defining_block))))
	   defblk))))