;;; -*- mode:lisp;package:user;base:10.;fonts: cptfontb -*- 
;;; $Header: /ct/interp/generics.l,v 1.20 84/12/26 16:44:03 penny Exp $
;;;
;;;

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



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Semantic functions to normalize generic parameters and instantiate
;;; generic units.
       ;;;;;;;;;;;;
(defun add_sm_defns(ids)
       ;;;;;;;;;;;;
  (mapc #'(lambda (dn)
	    (diana_put dn dn 'sm_defn))
	ids))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun normalize_generic_parameters (gen_unit gen_pars)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  (cond
    ((null gen_unit) nil)
    (t
					  ;gen_unit is a generic_id
     (let* ((formals (and
		       (diana_node_accepts_attributep
			 gen_unit 'sm_generic_param_s)
		       (diana_get
			 (diana_get gen_unit 'sm_generic_param_s)
			 'as_list)))
	    (positional t)		  ;at first assume positional order.
	    (actuals gen_pars)
	    (normalized nil))
       (mapc
	 #'(lambda(fp)			  ;normalize by iterating through formals
	     (ct_selectq
	       (diana_nodetype_get fp)
	       (dn_in
		 (ct_push
		   (cond
		     ((and positional
			   (not
			     (and actuals
				  (eq (diana_nodetype_get
					(first actuals))
				      'dn_assoc))))
		      (let ((od (ct_pop actuals)))
			(sc_diana
			  dn_constant
			  as_id_s
			  (add_sm_defns
			    (mapcar
			      #'(lambda(id)
				  (add_name
				    (diana_get id 'lx_symrep)
				    'object
				    (sc_diana
				      dn_const_id
				      lx_symrep (diana_get id 'lx_symrep)
				      sm_obj_type (diana_get id 'sm_obj_type)
				      sm_obj_def od)
				    nil))
			      (diana_get fp 'as_id_s)))
			  as_type_spec (diana_get fp 'as_name)
			  as_object_def od)))
		     (t
		      (setq positional nil)	  ;all remaining params are positional.
		      (let ((od nil))	  ;++
			(sc_diana
			  dn_constant
			  as_id_s
			  (add_sm_defns
			    (mapcar
			      #'(lambda(id)
				  (add_name
				    (diana_get id 'lx_symrep)
				    'object
				    (sc_diana dn_const_id
					      lx_symrep (diana_get id 'lx_symrep)
					      sm_obj_type
					      (diana_get id 'sm_obj_type)
					      sm_obj_def od)
				    nil))
			      (diana_get fp 'as_id_s)))
			  as_type_spec (diana_get fp 'as_name)
			  as_object_def od))))
		   normalized))
	       (dn_in_out
		 (lose 'fe_giopnyi 'normalize_generic_parameters)
		 (ct_push
		   (cond
		     ((and positional
			   (not (eq (diana_nodetype_get (first actuals)) 'dn_assoc)))
		      (let ((od (sc_diana dn_rename
					  as_name (ct_pop actuals))))
			(sc_diana dn_var
				  as_id_s
				  (add_sm_defns
				    (mapcar
				      #'(lambda(id)
					  (add_name
					    (diana_get id 'lx_symrep)
					    'object
					    (sc_diana
					      dn_var_id
					      lx_symrep (diana_get id 'lx_symrep)
					      sm_obj_type
					      (diana_get id 'sm_obj_type)
					      sm_obj_def od)
					    nil))
				      (diana_get fp 'as_id_s)))
				  as_type_spec (diana_get fp 'as_name)
				  as_object_def od)))
		     (t
		      (setq positional nil)	  ;all remaining params are positional.
		      (let ((od (sc_diana dn_rename
					  as_name nil)))  ;++
			(sc_diana
			  dn_var
			  as_id_s
			  (add_sm_defns
			    (mapcar
			      #'(lambda(id)
				  (add_name
				    (diana_get id 'lx_symrep)
				    'object
				    (sc_diana dn_var_id
					      lx_symrep (diana_get id 'lx_symrep)
					      sm_obj_type
					      (diana_get id 'sm_obj_type)
					      sm_obj_def od)
				    nil))
			      (diana_get fp 'as_id_s)))
			  as_type_spec (diana_get fp 'as_name)
			  as_object_def od))))
		   normalized))
	       (dn_type
		 (ct_push
		   (cond
		     ((and positional
			   (not (eq (diana_nodetype_get
				      (first actuals)) 'dn_assoc)))
		      (let ((ts (sc_diana dn_constrained
					  as_name (ct_pop actuals)
					  as_constraint (sc_diana dn_void))))
			(sc_diana dn_subtype
				  as_id
				  (add_name
				    (diana_get (diana_get fp 'as_id) 'lx_symrep)
				    'type
				    (sc_diana dn_subtype_id
					      lx_symrep
					      (diana_get
						(diana_get fp 'as_id) 'lx_symrep)
					      sm_type_spec ts)
				    nil)
				  as_constrained ts)))
		     (t
		      (setq positional nil)	  ;all remaining params are positional.
		      (let ((ts 
			      (sc_diana dn_constrained
					as_name (extract_matching_assoc fp actuals)
					as_constraint (sc_diana dn_void))))
			(sc_diana dn_subtype
				  as_id
				  (add_name
				    (diana_get (diana_get fp 'as_id) 'lx_symrep)
				    'type
				    (sc_diana dn_subtype_id
					      lx_symrep
					      (diana_get (diana_get fp 'as_id) 'lx_symrep)
					      sm_type_spec ts)
				    nil)
				  as_constrained ts))))
		   normalized))
	       (dn_subprogram_decl
		 (lose 'fe_gsppnyi 'normalize_generic_parameters))))
	 formals)
       (reverse normalized)))))

       ;;;;;;;;;;;;;;;;;;;;;;
(defun extract_matching_assoc (fp actuals)
       ;;;;;;;;;;;;;;;;;;;;;;

  (let ((key (diana_get (diana_get fp 'as_id) 'lx_symrep)))
    (do ((ap actuals (cdr ap))
	 (mv nil))
	((or (not ap) mv) mv)
      (let ((actnam (diana_get (car ap) 'as_designator)))
	(cond
	  ((equal (cadr key)(cadr actnam))
	   (return (diana_get (car ap) 'as_actual))))))))

(defun check_legal_generic_parameter (g i)
  (ct_selectq (diana_nodetype_get g)
	      (dn_type
		(ct_selectq
		  (diana_nodetype_get (diana_get g 'as_type_spec))
		  (dn_formal_dscrt	  ;12.3.3
		    (ct_selectq
		      (diana_nodetype_get
			(extract_basetype (diana_get i 'as_id) t))
		      ((dn_formal_dscrt dn_integer
					dn_formal_integer
					dn_enum_literal_s))
		      (dn_predefined_type
			(cond
			  ((eq
			     (extract_basetype
			       (diana_get i 'as_id) t)
			     *universal_integer*))
			  (t
			   (semgripe
			     'incompat_generic_param_formal_dscrt))))
		      (otherwise
			(semgripe
			  'incompat_generic_param_formal_dscrt))))
		  (dn_formal_integer	  ;12.3.3
		    (ct_selectq
		      (diana_nodetype_get
			(extract_basetype (diana_get i 'as_id) t))
		      (( dn_integer dn_formal_integer))
		      (dn_predefined_type
			(cond
			  ((eq
			     (extract_basetype
			       (diana_get i 'as_id) t)
			     *universal_integer*))
			  (t
			   (semgripe
			     'incompat_generic_param_formal_int))))
		      (otherwise
			(semgripe
			  'incompat_generic_param_formal_int))))
		  (dn_formal_float	  ;12.3.3
		    (ct_selectq
		      (diana_nodetype_get
			(extract_basetype (diana_get i 'as_id) t))
		      ((dn_formal_float dn_float))
		      (dn_predefined_type
			(cond
			  ((let ((bt 
				   (extract_basetype
				     (diana_get i 'as_id) t)))
			     (or (eq bt *universal_real*)
				 (eq bt *universal_float*))))
			  (t
			   (semgripe
			     'incompat_generic_param_formal_float))))
		      (otherwise
			(semgripe
			  'incompat_generic_param_formal_float))))
		  (dn_formal_fixed	  ;12.3.3
		    (ct_selectq
		      (diana_nodetype_get
			(extract_basetype (diana_get i 'as_id) t))
		      ((dn_formal_fixed dn_fixed))		      
		      (otherwise
			(semgripe
			  'incompat_generic_param_formal_fixed))))
		  ((dn_private dn_l_private)		  ;12.3.2
		    )
		  (dn_access
		    #|(semgripe
		      'generic_array_parameters_nyi)|#)
		  (dn_array
		    #|(semgripe
		      'generic_array_parameters_nyi)|#)
		  (otherwise (lose 'fe_ugpt 
				   'check_legal_generic_parameter ))))
	      (dn_in )
	      (dn_in_id
		)
		  (dn_type_id
		    (ct_selectq (diana_nodetype_get (diana_get g 'as_type_spec))
				(dn_formal_dscrt
				  (break look-at-formal-dscrt))
				(otherwise (lose 'fe_ugpt '
						 check_legal_generic_parameter ))))
		  (otherwise (lose 'fe_bgp 'check_legal_generic_parameter ))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun make_alist_of_generic_subst (gp ip)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (mapcan
    #'(lambda(g i)
	(check_legal_generic_parameter g i)
	(cond
	  ((diana_nodep (nameable g))
	   `((,(nameable g) . ,(nameable i))))
	  (t (make_alist_of_generic_subst (nameable g)(nameable i)))))
    gp ip))

(declare (special *this_generic* *visited* *glist* *enforce_copy* *in_abstract_syntax* splicer))


       ;;;;;;;;;
(defun splice_in (splyicer splicee)
       ;;;;;;;;;
       (cond
	 ((diana_nodep splyicer)
	  (diana_nodetype_set splyicer (diana_nodetype_get splicee))
	  (diana_mapc
	    #'(lambda(attr val)
		(cond ((eq attr 'ct_id))
		      (attr (diana_put splyicer val attr))))
	    splicee))
	 (t (rplaca splyicer (car splicee))
	    (rplacd splyicer (cdr splicee)))))
       
       ;;;;;;;;;;;;;;;;;;;;;;;
(defun copy_with_substitutions (dn subs)  ;subs is an alist.
       ;;;;;;;;;;;;;;;;;;;;;;;
  
  (cond
    ((symbolp dn) dn)
    ((and (diana_nodep dn)  ;nil		  ;nil should be deleted pmj
	  (not (memq *this_generic*	  ;if outside the generic.
		     (diana_get dn  'ct_generic_membership))))
     dn)				  ;don't copy.
    ((diana_nodep dn)
     (add_visited dn (makdummy (diana_nodetype_get dn)))
     (let ((copied (substitute_generic dn subs)))
       (let ((placeholder (cdr (find_visited dn))))
	 (splice_in placeholder copied);splice in
	 (delete_placeholder placeholder)
	 (cond ((same_to_one_level_p dn copied)
		(clear_visited dn)
		dn)
	       (t placeholder)))))
    ((and (consp dn)(diana_nodep (car dn)))
     (add_visited dn (cons nil nil))
     (let ((copied 
       (mapcar
	 #'(lambda(elem)
	     (cond
	       ((find_visited elem)
		(cdr (find_visited elem)))
	       (t
		(let ((copied (copy_with_substitutions elem subs)))
#|		  (let ((placeholder (cdr (find_visited elem))))
		    (splice_in  placeholder copied)	  ;splice in
		    (delete_placeholder placeholder)
		    (cond ((same_to_one_level_p elem copied)
			   (clear_visited elem)
			   elem)
			  (t placeholder)))|#
		     copied))))
	 dn)))
       (let ((placeholder (cdr (find_visited dn))))
	 (splice_in placeholder  copied);splice in
	 (delete_placeholder placeholder)
	 (cond ((same_list_to_one_level_p dn copied)
		(clear_visited dn)
		dn)
	       (t placeholder)))))
    (t dn)))

       ;;;;;;;;;;;;;;;;;;
(defun substitute_generic (dn subs)
       ;;;;;;;;;;;;;;;;;;
  (let ((subst (cdr (assq dn subs))))
    (cond
      (subst  subst)			  ;a generic substitution.
      
      (t ;;at this point, we must recursively fix the diana tree.
       ;;if the subtree needs no changing, return unchanged node.
       (let ((copied (diana_cons (diana_nodetype_get dn))))
	 (diana_mapc
	   #'(lambda(attr val)
	       (cond
		 ((eq attr 'ct_id))
		 ((eq attr 'ct_generic_membership)
		  (diana_put copied
			     (append val *current_generic_nestitude*)
			     attr))
		 ((null attr) nil)	  ;++ remove later ++
		 ((memq attr
			'(ct_threadp ct_cont ct_st_defining_block
				     ct_named_context))
		  (diana_put copied val attr))
		 ((and (diana_nodep val); nil	  ;nil should be deleted pmj
		       (not (memq *this_generic*
				  (diana_get val 'ct_generic_membership))))
		  (diana_put copied val attr))
		 ((find_visited val)
		  (diana_put copied (cdr (find_visited val)) attr))
		 (t
		  (let* ((*enforce_copy*
			   (and (non_semantic_attribute_p attr)
				*in_abstract_syntax*))
			 (*in_abstract_syntax*
			   (and *in_abstract_syntax*
				*enforce_copy*))
			 (new (copy_with_substitutions val subs)))
		    (cond
		      ((not (eq new val))
		       (add_visited val new)))
		    (diana_put copied new attr)))))
	   dn)
	 (cond ((same_to_one_level_p dn copied)
		(let ((placeholder (cdr (find_visited dn))))
		  (splice_in placeholder copied)  ;splice in
		  (delete_placeholder placeholder)
		  (clear_visited dn)
		  dn))
	       (t
		(let ((placeholder (cdr (find_visited dn))))
		  (splice_in placeholder copied)  ;splice in
		  (delete_placeholder placeholder)
		  placeholder))))))))

       ;;;;;;;;;;;;;;;;;;;;;;;;
(defun non_semantic_attribute_p (attr)
       ;;;;;;;;;;;;;;;;;;;;;;;;
  (let ((nam (exploden attr)))
    (or (memq attr '(sm_body sm_spec))
#| (not (get attr 'semantic_attribute_p)) |#
	(not (equal (exploden 'sm_) 
	     (list (first nam)(second nam)(third nam)))))))

       ;;;;;;;;
(defun makdummy (nodetype)
       ;;;;;;;;
  (let ((dummy (diana_cons nodetype)))		  ;a placeholder.
    (add_placeholder dummy)
    dummy))

       ;;;;;;;;;;;;;;;;;;;
(defun same_to_one_level_p(a b)
       ;;;;;;;;;;;;;;;;;;;

  (and
    (not *enforce_copy*)
    (eq (diana_nodetype_get a)(diana_nodetype_get b))
    (let ((same t))
      (*catch
	'different
	(diana_mapc
	  #'(lambda(attr val)
	      (cond
		((null attr))		  ; ++ remove later ++
		((null (sameonep val (diana_get b attr)))
		 (setq same nil)
		 (*throw 'different nil))))
	  a))
      same)))

(defun same_list_to_one_level_p(a b)
  (and
    (not *enforce_copy*)
    (apply #'and
	   (mapcar #'sameonep a b))))

       ;;;;;;;;
(defun sameonep (x y)
       ;;;;;;;;
  (cond
    ((or 
	 (placeholder_p x)
	 (placeholder_p y)
	 (eq x y)) t)))

       ;;;;;;;;
(defun nameable (g)
       ;;;;;;;;

  (ct_selectq (diana_nodetype_get g)
	      (dn_in   (diana_get g 'as_id_s))
	      (dn_in_out (diana_get g 'as_id_s))
	      (dn_in_id  g)
	      (dn_in_out_id  g)
	      (dn_const_id g)
	      (dn_var_id g)
	      (dn_constant (diana_get g 'as_id_s))
	      (dn_var (diana_get g 'as_id_s))
	      (dn_type (diana_get g 'as_id))
	      (dn_subtype (diana_get g 'as_id))
	      (t (lose 'fe_nyi 'nameable))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun same_generic_actual_parameterp  (ap pp)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (ct_selectq (diana_nodetype_get pp)
	      (dn_subtype_id
		(cond ((eq (diana_nodetype_get ap) 'dn_subtype_id)
		       (let ((ppname
				   (diana_get pp 'sm_type_spec))
			     (apname
				   (diana_get ap 'sm_type_spec)))
			 (eq ppname apname)))
		      (t nil)))
	      (dn_type_id
		(cond ((eq (diana_nodetype_get ap) 'dn_type_id)
		       (let ((ppname
			       (diana_get pp 'sm_type_spec))
			     (apname
			       (diana_get ap 'sm_type_spec)))
			 (eq ppname apname)))
		      (t nil)))
	      (otherwise nil)))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun find_matching_instantiation (eis subal)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (do ((ei  eis (cdr ei))(match nil ))
      ((or match (null ei)) match)
    (let*  ((thisi (car ei))
	    (pmatch (cdr thisi))
	    (cal (car thisi)))
      (cond ((apply #'and
		    (mapcar #'(lambda (thisgp)
				(let* ((ap (cdr thisgp))
				       (pp (cdr (assq (car thisgp) cal))))
				  (same_generic_actual_parameterp ap pp)
				  ))
			    subal))
	     (setq match pmatch))))))

       ;;;;;;;;;;;;;;;;;
(defun instantiated_spec (dn)		  ;dn is a dn_instantiation
       ;;;;;;;;;;;;;;;;;

  (let* ((gen  (and dn (diana_get dn 'as_name)))
	 (spec (and gen (diana_get gen 'sm_spec)))
	 (body (and gen (diana_get gen 'sm_body)))
	 (gps  (and gen (diana_get gen 'sm_generic_param_s)))
	 (gpls (and gps (diana_get gps 'as_list)))
	 (gds  (and dn
		    (diana_node_accepts_attributep
		      dn 'sm_decl_s)
		    (diana_get dn 'sm_decl_s)))
	 (pls  (cond ((and spec
			   (memq
			     (diana_nodetype_get spec)
			     '(dn_function dn_procedure)))
		      (diana_get spec 'as_param_s))))
	 (subal(and gpls
		    gds
		    (make_alist_of_generic_subst gpls gds)))
	 (eis (and gps
		   (diana_get gps 'ct_existing_instantiations)))
	 (mei (and eis
		   subal
		   (find_matching_instantiation eis subal)))
	 (instantiatedspecbody nil)
	 (*visited* (small_temporary_hasharray))  ;visited nodes.
	 (*glist* (small_temporary_hasharray))	  ;list of placeholders
	 (*this_generic* (and gps
			      (car (diana_get gps 'ct_generic_membership))))
	 (*enforce_copy* t)		  ;to force copying of abs. syntax.
	 (*in_abstract_syntax* t))	  ;remember when we have gone over an sm_
    (cond ((null gen)
	   (semgripe 'no_generic_spec)
	   (setq instantiatedspecbody nil))
	  (mei (setq instantiatedspecbody mei))
	  (t (setq instantiatedspecbody
		   (copy_with_substitutions gen subal))
	     (diana_put
	       gps
	       (cons (cons subal instantiatedspecbody ) eis)
	       'ct_existing_instantiations)))
;    (break in-instantiated_spec)
    (setq *visited* nil *glist* nil)	; free up space used by hash arrays.
    instantiatedspecbody))

(defun small_temporary_hasharray()
    #+lispm (make-array (list 1024))
    #+franz (let* ((arnam (gensym))
		   (foo (*array arnam t 1024))
		   (arr (getd arnam)))
		(putd arnam nil)
		arr))

(eval-when (compile load eval)
(defun smalltemphash macro (n)
    #+franz `(boole 1 (maknum ,(second n)) 1023)
    #+lispm `(remainder (abs (%pointer ,(second n))) 1024))
)

(defun find_visited (old)
    (assq old
	#+franz (arraycall t *visited* (smalltemphash old))
	#+lispm (aref *visited*        (smalltemphash old))))

(defun add_visited (old new)
    (let* ((haddr (smalltemphash old))
	   (hentry #+franz (arraycall t *visited* haddr)
	           #+lispm (aref *visited*        haddr)))
	#+franz (set (arrayref *visited* haddr)(cons `(,old . ,new) hentry))
	#+lispm (aset (cons `(,old . ,new) hentry) *visited* haddr)))

(defun clear_visited (old) 
    (rplacd (find_visited old) old))

(defun add_placeholder (ph)
    (let* ((haddr (smalltemphash ph))
	   (hentry #+franz (arraycall t *glist* haddr)
	           #+lispm (aref *glist*        haddr)))
	#+franz (set (arrayref *glist* haddr)(cons ph hentry))
	#+lispm (aset (cons ph hentry) *glist* haddr)))

(defun delete_placeholder (ph)
    (let* ((haddr (smalltemphash ph))
	   (hentry #+franz (arraycall t *glist* haddr)
	           #+lispm (aref *glist*        haddr)))
	#+franz (set (arrayref *glist* haddr)(delq ph hentry))
	#+lispm (aset (delq ph hentry) *glist* haddr)))

(defun placeholder_p (ph)
    (memq ph
	#+franz (arraycall t *glist* (smalltemphash ph))
	#+lispm (aref *glist*        (smalltemphash ph))))


       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun redeclare_package_declarations (ps)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (let* ((dcls (diana_get (diana_get ps 'as_decl_s1) 'as_list)))
    (mapc
      #'(lambda(dcl)
	  (ct_selectq (diana_nodetype_get dcl)
		      (dn_generic) ;++ should do more than this I think!!
		      (dn_subprogram_decl
			(let*
			  ((spi (diana_get dcl 'as_designator))
			   (spn (diana_get spi 'lx_symrep))
			   (spc
			     (ct_selectq
			       (diana_nodetype_get spi)
			       (dn_proc_id 'procedure)
			       (dn_function_id 'function)
			       (t (lose 'fe_uks
					'redeclare_package_declarations)))))
			  (add_name spn spc spi nil)))
		      (dn_type 
			(let* ((typeid (diana_get dcl 'as_id))
			       (typenm (diana_get typeid 'lx_symrep))
			       (typesp (diana_get dcl 'as_type_spec)))
			  (cond
			    ((eq (diana_nodetype_get typesp)
				 'dn_enum_literal_s)
			     (mapc
			       #'(lambda(ei)
				   (add_name
				     (diana_get ei 'lx_symrep)
				     'function
				     ei
				     nil))
			       (diana_get typesp 'as_list))))
			  (add_name typenm 'type typeid nil)))
		      (dn_exception
			(mapc
			  #'(lambda(ni)
			      (add_name
				(diana_get ni 'lx_symrep)
				'exception
				ni
				nil))
			  (diana_get (diana_get dcl 'as_id_s) 'as_list)))
		      (dn_subtype 
			(let* ((typeid (diana_get dcl 'as_id))
			       (typenm (diana_get typeid 'lx_symrep)))
			  (add_name typenm 'type typeid nil)))
		      (dn_number
			(mapc
			  #'(lambda(ni)
			      (add_name
				(diana_get ni 'lx_symrep)
				'object
				ni
				nil))
			  (diana_get dcl 'as_id_s)))
		      (dn_var
			(mapc
			  #'(lambda(ni)
			      (add_name
				(diana_get ni 'lx_symrep)
				'object
				ni
				nil))
			  (diana_get dcl 'as_id_s)))
		      (dn_constant
			(mapc
			  #'(lambda(ni)
			      (add_name
				(diana_get ni 'lx_symrep)
				'object
				ni
				nil))
			  (diana_get dcl 'as_id_s)))
			(t (break how-do-i-redeclare-this?)
			 nil)))
      dcls)))

(defun change_generic_membership (tree membership)
  (cond ((null tree))
	((null membership))
	(t
	 (diana_put tree
		    (append  membership
			     (diana_get tree 'ct_generic_membership))
		    'ct_generic_membership)
	 (ct_selectq
	   (diana_nodetype_get tree)
	   ; these are the leaf nodes.
	   ((dn_type_id dn_void dn_formal_integer dn_formal_float dn_formal_fixed
			dn_formal_dscrt dn_subtype_id dn_derived dn_access
			dn_private dn_l_private dn_private_type_id
			dn_l_private_type_id dn_enum_literal_s
			dn_numeric_literal dn_character_literal))
	   ; following cases require recursive treewalking to fix subtrees.
	   (dn_procedure
	     (mapc
	       #'(lambda (tr)
		   (change_generic_membership  tr membership))
	       (diana_get tree 'as_param_s ) ))
	   (dn_function
	     (change_generic_membership (diana_get tree 'as_name_void) membership)
	     (mapc
	       #'(lambda (tr)
		   (change_generic_membership  tr membership))
	       (diana_get tree 'as_param_s ) ))
	   (dn_used_name_id
	     (change_generic_membership (diana_get tree 'ct_base_type) membership)
	     (change_generic_membership (diana_get tree 'ct_parent_type)
					membership)
	     (change_generic_membership (diana_get tree 'sm_defn) membership)
	     )
	   ((dn_in_id dn_out_id dn_in_out_id)
	    (change_generic_membership (diana_get tree 'sm_obj_type) membership))
	   
	   ((dn_in dn_out dn_in_out)
	    (change_generic_membership (diana_get tree 'as_name) membership)
	    (mapc
	      #'(lambda (tr)
		  (change_generic_membership  tr membership))
	      (diana_get tree 'as_id_s ) ))
	   (dn_constrained
	     (change_generic_membership (diana_get tree 'ct_parent_type)
					membership)
	     (change_generic_membership (diana_get tree 'ct_base_type) membership)
	     (change_generic_membership (diana_get tree 'as_name) membership)
	     (change_generic_membership (diana_get tree 'as_constraint) membership)
	     (change_generic_membership (diana_get tree 'ct_base_type) membership))
	   (dn_predefined_type
	     nil)
	   (otherwise
	     ;this case has not been considered. treat as a leaf if not debugging.
	     (cond ((status feature debugging)
		    (break wot-we-got-other))
		   ))))))

;;; EOF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;