;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 

;;;  $Header: /ct/interp/adas40.l,v 1.74 84/10/08 18:21:24 penny Exp $

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                            adas40.l                              ;;;
;;; Paul Robertson                                  January 30, 1983 ;;;
;;;                                                                  ;;;
;;;      The C*T Ada Interpreters Syntax and Static Semantics        ;;;
;;;                                                                  ;;;
;;; 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 'time))       ;Timing functions. 

(eval-when (compile load eval) (ct_load 'stdenv))     ; contains vital macro

(eval-when (compile load eval) (ct_load 'sema))     ; contains vital MACRO

(eval-when (compile load eval) (ct_load 'pser))     ; contains vital MACRO
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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.


		;;;;;;;;;;;;;;;;
(def_ada_syntax declarative_part
		;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)			
	    (cond ((null (first as))(second as))  ;fix it later.
		  (t (cons (first as)(second as)))))
	  (pr_repeat nil pragma)
	  (pr_or nil 
		 (pr_and
		   (lambda(as)		  ; build up into a list.
		     (cons (first as)(second as)))
		   use_clause 
		   (pr_or nil declarative_part nil))
		 (pr_and 
		   (lambda(as)		  ; build up into a list.
		     (cons (first as)(second as)))
		   obj_num_exc_declaration 
		   (pr_or nil declarative_part nil))
		 (pr_and
		   (lambda(as)		  ; build up into a list.
		     (cons (first as)(second as)))
		   type_declaration 
		   (pr_or nil declarative_part nil))
		 (pr_and
		   (lambda(as)		  ; build up into a list.
		     (cons (first as)(second as)))
		   subtype_declaration 
		   (pr_or nil declarative_part nil))
 		 (pr_and
		   (lambda(as)		  ; build up into a list.
		     (cons (first as)(second as)))
		   representation_specification
		   (pr_or nil declarative_part nil))
		 (pr_and
		   (lambda(as)		  ; subprogram declaration.
		     (ct_pop *returntypestack*)
		     (setq *current_generic_nestitude*
			   (ct_pop *generic_nestitude_stack*))
		     (matching_ident 
		       (diana_get (second as) 'lx_symrep)
		       (ct_pop *identstack*))
		     (ct_pop *identstack*); pop of the proc_id.
		     (cons 
		       (sc_diana dn_subprogram_decl
				 as_designator 
				 (let ((nod (second as))
				       (others (diana_get
						 (second as)
						 'sm_first)))
;				      (break look-at-third-as)
				   (cond
				     ((proc_decl_bits%body (third as))
				      (cond
					((eq (diana_nodetype_get
					       (proc_decl_bits%body (third as)))
					     'dn_instantiation)
					 (let ((instantiation
						(instantiated_spec
						       (proc_decl_bits%body
							 (third as)))))
					(cond
					  (instantiation
					   (diana_put nod
						   (diana_get
						     instantiation
						     'sm_spec)
						   'sm_spec)
					(diana_put nod
						   (diana_get
						     instantiation
						     'ct_spec)
						   'ct_spec)
					(diana_put nod
						   (diana_get
						     instantiation
						     'sm_body)
						   'sm_body)))))
					(t
					 (diana_put
					   nod
					   (proc_decl_bits%header (third as)) 
					   'sm_spec)
					 (diana_put
					   nod
					   (proc_decl_bits%body (third as))
					   'sm_body)))
				      (cond
					(others
					 (diana_put others
						    (proc_decl_bits%header
						      (third as)) 
						    'ct_spec)))
				      (cond 
					((and
					   others
					   (diana_get others 'sm_body)
					   (not
					     (stub_p (diana_get others 'sm_body))))
					 (cond 
					   ((proc_decl_bits%body (third as))
					    #|
					    (semgripe `body_already_spec
					       (implode (uplowlist (cadr
						 (diana_get nod
						    'lx_symrep)))))|#)))
					(t 
					 (cond
					   (others
					    (cond
					      ((eq (diana_nodetype_get
						     (proc_decl_bits%body
						       (third as)))
						   'dn_instantiation)
					       (let ((instantiation
						       (instantiated_spec
							 (proc_decl_bits%body
							   (third as)))))
						 (cond
						   (instantiation
						    (diana_put others
							       (diana_get
								 instantiation
								 'ct_spec)
							       'ct_spec)
						    (diana_put others
							       (diana_get
								 instantiation
								 'sm_body)
							       'sm_body)))))
					      (t
					       (diana_put others
							  (proc_decl_bits%header
							    (third as))
							  'ct_spec)
					       (diana_put others
							  (proc_decl_bits%body
							    (third as))
							  'sm_body))))
					   )))))
				   nod)
				 as_header nil;(proc_decl_bits%header (third as))
				 as_subprogram_def 
				 (or (proc_decl_bits%body (third as))
				     (sc_diana dn_void)))
		       (proc_decl_bits%nextdecl (third as))))
		   symb_procedure
		   (pr_and 
		     (lambda(as)
		       (ct_push nil *returntypestack*)
		       (let*
			 ((stub (ada_declared (first as) nil
					      '(procedure generic_unit) t))
			  (this (add_name
				  (first as)	  ; name
				  (cond ((generic_defo_p stub)
					 'generic_unit); class
					(t 'procedure))
				  (sc_diana dn_proc_id
					    lx_symrep (first as)
					    sm_spec nil
					    sm_body (sc_diana dn_stub)
					    sm_location nil
					    sm_stub nil
					    sm_first nil)
				  nil)))
			 
			 (ct_push *current_generic_nestitude*
				  *generic_nestitude_stack*)
			 (diana_put this stub 'sm_first)
			 (diana_put this (pushproccontext)
				    'ct_named_context)
			 (cond
			   ((generic_defo_p stub)
			    (diana_put **current_block**
				       (list
					 (diana_get
					   (car stub) 'ct_named_context))
				       'ct_mixin_s)))
			 (ct_push this *identstack*)	  ;communicate with others.
			 this))		  ;we always return the current one!
		     lex_ident)
		   (pr_or
		     nil 
		     (pr_and 
		       (lambda(as)
			 (ct_push nil *identstack*)
			 (proc_decl_bits nil nil (fifth as)))
		       symb_renames
		       (pr_restrict proc_or_entry name)
		       (pr_or nil
			      (pr_and nil
				      oper_lparen
				      expression
				      oper_rparen)
			      nil)
		       (pr_and
			 (lambda(as)
			   (popcontext)	  ;leave procedure context before decl.
			   (first as))
			 oper_semicolon)
		       (pr_or nil
			      declarative_part
			      nil))
		     
		     (pr_and
		       (lambda(as)
			 (ct_push nil *identstack*)
			 (proc_decl_bits nil nil (second as)))
		       (pr_and
			 (lambda(as)
			   (popcontext)	  ;leave procedure context before decl.
			   (sc_diana dn_stub))
			 oper_semicolon)
		       declarative_part)
		     
		     (pr_and
		       cadr
		       (pr_and
			 (lambda(as)
			   (let* ((this  (car *identstack*))
				  (stub (with_same_type_profile
					  this
					  (diana_get this 'sm_first))))
			     (cond
			       (stub
				;;if any of these have matching specs and come
				;;from either here or the corresponding package
				;;declaration, we have the def_occurence.
				(let*
				  ((defo
				     (mapcan
				       #'(lambda(fun)
					   (cond
					     ((and
						(diana_get fun 'sm_body)
						(eq (diana_nodetype_get
						      (diana_get fun 'sm_body))
						    'dn_stub))
					      (list fun))
					     (t nil)))
				       stub))
				   (defo (find_defo defo)))
				  (cond
				    (defo 
				     (diana_put
				       **current_block**
				       (list (diana_get defo 'ct_named_context))
				       'ct_mixin_s)				 
				     (diana_put defo
						(diana_get this 'sm_spec)
						'ct_spec)
				      (setq *current_generic_nestitude*
					    (diana_get defo
						       'ct_generic_membership))))
				  (diana_put this defo 'sm_first)))
			       (t (diana_put this nil 'sm_first)))))
			 symb_is)
		       (pr_or
			 nil 
			 (pr_and 
			   (lambda(as)	  ; body is not present
			     (ct_push nil *identstack*)	  ;(break foo)
			     (proc_decl_bits nil (first as) (second as)))
			   (pr_and
			     (lambda(as)
			       (popcontext)	  ;leave procedure context before decl.
			       (sc_diana dn_stub))
			     symb_separate)
			   declarative_part_extnb)
			 
			 (pr_and 
			   (lambda(as)  
			     (ct_push (second as) *identstack*)
			     (proc_decl_bits
			       nil (first as)(third as)))
			   (pr_and
			     (lambda(as)  ;(break fix2)
			       (let* ((this (first *identstack*))
				      (defo (diana_get this 'sm_first)))
				 (cond (defo
					(diana_put defo (first as) 'sm_body)))
				 (diana_put this (first as) 'sm_body))
			       (popcontext)
			       (first as))
			     body_part)
			   (pr_or nil
				  lex_ident
				  nil)
			   declarative_part_extnb)
			 
			 (pr_and 
			   (lambda(as)
			     (ct_push nil *identstack*)
			     (proc_decl_bits 
			       nil (first as)(third as)))
			   (pr_and
			     (lambda(as)
			       (let ((instantiation
				       (instantiated_spec
					 (first as)))
				     (nod (first *identstack*)))
;				 (break in-declarative_part)
				 (cond
				   (instantiation
				    (diana_put
				      nod
				      (1-
					(diana_get
					  (diana_get
					    instantiation
					    'sm_spec)
					  'ct_pnl));;temporary
				      'ct_pnl)
				    (diana_put nod
					       (diana_get
						 instantiation
						 'sm_spec)
					       'sm_spec)
				    (diana_put nod
					       (diana_get
						 instantiation
						 'ct_spec)
					       'ct_spec)
				    (diana_put nod
					       (diana_get
						 instantiation
						 'sm_body)
					       'sm_body))))
			       (first as));return the unchanged instantiation.
			     generic_instantiation)
			   (pr_and
			     (lambda(as)
			       (popcontext)	  ;leave procedure context before decl.
			       (first as))
			     oper_semicolon)
			   (pr_or nil declarative_part nil))))
		     (pr_and 
		       (lambda(as)
			 (%= (proc_decl_bits%header 
			       (second as))(first as))
			 (cond ((and
				  (proc_decl_bits%body
				    (second as))
				  (eq (diana_nodetype_get
					(proc_decl_bits%body
					  (second as)))
				      'dn_rename))
				(do ((nud (proc_decl_bits%body
					    (second as)))
				     (ichs (diana_get
					     (proc_decl_bits%body
					       (second as))
					     'as_name))
				     (chs (let ((nam
						  (diana_get
					    (proc_decl_bits%body
					      (second as))
					    'as_name)))
					    (cond ((and (diana_nodep nam)
							(eq (diana_nodetype_get
							      nam)
							    'dn_selected))
						   (setq nam
							 (diana_get
							   nam
							   'as_designator_char))))
					    (cond ((diana_nodep nam)
						   (list nam))
						  (t nam)))
					  (cdr chs))
				     (chosen nil))
				    ((null chs)
				     (cond ((= (length chosen) 1)
					    (diana_put
					      (proc_decl_bits%body
						(second as))
					      (car chosen)
					      'as_name))
					   ((and ichs (null chosen))
					    (semgripe
					      'not_the_same_profile_in_rename
					      (implode
						(uplowlist (cadr
						  (diana_get (car ichs)
							     'lx_symrep))))))
					   ((null chosen)
					    (semgripe
					      'undeclared_proc_in_rename
					      ))
					   (t
					    (semgripe
					      'ambiguous_proc_in_rename
					      (implode
						(uplowlist (cadr
						  (diana_get (car ichs)
							     'lx_symrep))))))))
				  (cond ((same_type_profile_p
					   (car chs)
					   (sc_diana dn_proc_id
						     sm_spec (first as)))
					 (ct_push (car chs) chosen)))
				  )))
			 (second as))
		       (pr_and
			 (lambda(as)
			   (diana_put
			     (first *identstack*)
			     (first as)
			     'sm_spec)
			  #|(let ((def (diana_get (first *identstack*) 'sm_first)))
			     (cond
			       (def
				(break fix4)
				(diana_put def (first as) 'sm_spec))))|#
			   (first as))
			 proc_formal_part); formal parameters.
		       (pr_or
			 nil 
			 (pr_and
			   (lambda (as)
			     (ct_push nil *identstack*)
			     (proc_decl_bits
			       nil
			       (sc_diana dn_rename
					 as_name (second as))
			       
			       (fifth as)))
			   symb_renames
			   (pr_restrict proc_or_entry name)
			   (pr_or
			     nil
			     (pr_and
			       nil
			       oper_lparen
			       expression
			       oper_rparen)
			     nil)
			   (pr_and
			     (lambda(as)
			       (popcontext)	  ;leave procedure context before decl.
			       (first as))
			     oper_semicolon)
			   (pr_or nil
				  declarative_part
				  nil))
			 
			 (pr_and 
			   (lambda(as)
			     (proc_decl_bits nil nil (cadr as)))
			   (pr_and
			     (lambda(as)
			       (ct_push nil *identstack*)
			       (popcontext)	  ;leave procedure context before decl.
			       (first as))
			     oper_semicolon)
			   declarative_part)
			 
			 (pr_and
			   cadr
			   (pr_and
			     (lambda(as)
			       (let* ((this (car *identstack*))
				      (stub (with_same_type_profile
					      this
					      (diana_get this 'sm_first))))
				 (cond
				   (stub
				    ;;if any of these have matching specs and come
				    ;;from either here or the corresponding package
				    ;;declaration, we have the def_occurence.
				    (let*
				      ((defo
					 (mapcan
					   #'(lambda(fun)
					       (cond
						 ((and
						    (diana_get fun 'sm_body)
						    (eq (diana_nodetype_get
							  (diana_get fun 'sm_body))
							'dn_stub))
						  (list fun))
						 (t nil)))
					   stub))
				       (defo (find_defo defo)))
				      (cond
					(defo 
					 (diana_put
					   **current_block**
					   (list
					     (diana_get defo 'ct_named_context))
					   'ct_mixin_s)				 
					 (diana_put defo
					     (diana_get this 'sm_spec)
					     'ct_spec)
					 (setq *current_generic_nestitude*
					       (diana_get
						 defo
						 'ct_generic_membership))
					 (change_generic_membership
					   (diana_get this 'sm_spec)
					   *current_generic_nestitude*)))
				      (diana_put this defo 'sm_first)))
				   (t (diana_put this nil 'sm_first)))))
			     symb_is)
			   (pr_or
			     nil 
			     (pr_and 
			       (lambda(as)
				 (ct_push nil *identstack*)
				 (proc_decl_bits nil nil
						 (second as)))
			       (pr_and
				 (lambda(as)	  ;leave procedure context before decl.
				   (popcontext)
				   (sc_diana dn_stub))
				 symb_separate)
			       declarative_part_extnb)
			     
			     (pr_and 
			       (lambda(as)			 
				 (ct_push (second as) *identstack*)
				 (proc_decl_bits
				   nil (first as)(third as)))
			       (pr_and
				 (lambda(as)	  ;(break fix1)
				   (diana_put
				     (first *identstack*)
				     (first as)
				     'sm_body)
				   (let
				     ((def (diana_get
					     (first *identstack*)
					     'sm_first)))
;					  (break fix2)
				     (cond
				       (def
					(diana_put def (first as) 'sm_body))))
				   (popcontext)
				   (first as))
				 body_part)
			       (pr_or nil
				      lex_ident
				      nil)
			       declarative_part_extnb)))))))
		 (pr_and
		   (lambda(as)		  ; subprogram declaration.
		     (ct_pop *returntypestack*)
		     (cond ((null (ct_pop  *return_stmt_stack*))
			    (semgripe
			      'no_return_statement_in_function
			      (implode
				(lowuplist
				  (cadr
				    (diana_get (second as) 'lx_symrep)))))))
		     (setq *current_generic_nestitude*
			   (ct_pop *generic_nestitude_stack*))
		     (matching_ident 
		       (diana_get (second as) 'lx_symrep)
		       (ct_pop *identstack*))
		     (ct_pop *identstack*); pop of the proc_id.
		     (cons 
		       (sc_diana
			 dn_subprogram_decl
			 as_designator 
			 (let ((nod (second as))
			       (others (diana_get
					 (second as)
					 'sm_first)))
			   (cond
			     ((funk_decl_bits%body (third as))
			      
			      (diana_put nod
					 (funk_decl_bits%header (third as))
					 'sm_spec)
			      #|			      ;;dont forget the result type.
;			      (break foodle)
			      (diana_put (funk_decl_bits%header (third as))
					 (funk_decl_bits%result (third as))
					 'as_name_void)
|#
			      
			      (diana_put nod
					 (funk_decl_bits%body (third as))
					 'sm_body)
			      (cond
				(others
				 (diana_put others
					    (funk_decl_bits%header (third as)) 
					    'ct_spec)))
			      (cond 
				((and
				   others
				   (diana_get others 'sm_body)
				   (not (stub_p (diana_get others 'sm_body))))
				 (cond 
				   ((funk_decl_bits%body (third as))
				    #|				    (semgripe `body_already_spec
					   (implode
					      (uplowlist (cadr
					       (diana_get nod 'lx_symrep)))))|#)))
				(t 
				 (cond
				   (others
				    (diana_put others
					       (funk_decl_bits%body (third as))
					       'sm_body)))
				 ))))
			   nod)
			 as_header (funk_decl_bits%header (third as))
			 as_subprogram_def 
			 (or (funk_decl_bits%body (third as))
			     (sc_diana dn_void)))
		       (funk_decl_bits%nextdecl (third as))))
		   symb_function
		   (pr_and
		     (lambda(as)
		       (ct_push nil *returntypestack*)
		       (ct_push nil *return_stmt_stack*)
		       (rplacd (first as) (list (uplowlist (cadr (first as)))))
		       (let*
			 ((stub (ada_declared `(lex_ident ,(cadr (first as)))
					      nil
					      '(function generic_unit) t))
			  (this (add_name
				  `(lex_ident ,(cadr (first as))) ; name
				  (cond ((generic_defo_p stub)
					 'generic_unit); class
					(t 'function))
				  (sc_diana dn_function_id
					    lx_symrep (first as)
					    sm_body (sc_diana dn_stub) )
				  nil)))
					  ;(pushproccontext)
			 (ct_push *current_generic_nestitude*
				  *generic_nestitude_stack*)
			 (diana_put this stub 'sm_first)
			 (diana_put this (pushproccontext)
				    'ct_named_context)
			 (cond
			   ((generic_defo_p stub)
			    (diana_put **current_block**
				       (list
					 (diana_get
					   (car stub) 'ct_named_context))
				       'ct_mixin_s)))

			 (ct_push this *identstack*)	  ;communicate with others.
			 this))		  ;we always return the current one!
		     (pr_or nil
			    (pr_and
			      (lambda(as)
				(cond ((not (user_definable_function_p as))
				       (semgripe 'not_user_definable_operator
						 (implode (cadr (first as))))))
				(first as))
			      lex_string)
			    lex_ident))
		   (pr_or nil 
			  (pr_and 
			    (lambda(as)
			      (funk_decl_bits nil nil (fourth as) nil))
			    (pr_and
			     (lambda(as)
			       (let* ((this (car *identstack*))
				      (stub (with_same_type_profile
					      this
					      (diana_get this 'sm_first))))
				 (cond
				   (stub
				    ;;if any of these have matching specs and come
				    ;;from either here or the corresponding package
				    ;;declaration, we have the def_occurence.
				    (let*
				      ((defo
					 (mapcan
					   #'(lambda(fun)
					       (cond
						 ((and
						    (diana_get fun 'sm_body)
						    (eq (diana_nodetype_get
							  (diana_get fun 'sm_body))
							'dn_stub))
						  (list fun))
						 (t nil)))
					   stub))
				       (defo (find_defo defo)))
				      (cond
					(defo 
					 (diana_put
					   **current_block**
					   (list
					     (diana_get defo 'ct_named_context))
					   'ct_mixin_s)
					 (diana_put defo
					     (diana_get this 'sm_spec)
					     'ct_spec)
					 (setq *current_generic_nestitude*
					       (diana_get
						 defo
						 'ct_generic_membership))))
				      (diana_put this defo 'sm_first)))
				   (t (diana_put this nil 'sm_first)))))
			     symb_is)
			    (pr_and
			      (lambda(as)
				(rplaca *return_stmt_stack* t)
				(let ((instantiation
					(instantiated_spec
					  (first as)))
				      (nod (first *identstack*)))
;				 (break in-declarative_part)
				  (cond
				    (instantiation
				     (diana_put nod
						(diana_get
						  instantiation
						  'sm_spec)
						'sm_spec)
				     (diana_put nod
						(diana_get
						  instantiation
						  'ct_spec)
						'ct_spec)
				     (diana_put nod
						(diana_get
						  instantiation
						  'sm_body)
						'sm_body))))
				(first as))	  ;return the unchanged instantiation.
			      generic_instantiation)
			    (pr_and
			      (lambda(as)
				(rplaca *return_stmt_stack* t)
				(ct_push nil *identstack*)
				(popcontext)	  ;leave procedure context before decl.
				(first as))
			      oper_semicolon)
			    (pr_or nil declarative_part nil))
			  (pr_and 
			    (lambda(as)
			      (cond
				((is_funk_decl_bits (fourth as))
				 (%= (funk_decl_bits%header
				       (fourth as)) (first as))
				 (%= (funk_decl_bits%result
				       (fourth as)) (third as)))
				)
			      (cond
				((and
				   (funk_decl_bits%body
				     (fourth as))
				   (eq (diana_nodetype_get
					 (funk_decl_bits%body
					   (fourth as)))
				       'dn_rename))
				 (do ((nud (funk_decl_bits%body
					     (fourth as)))
				      (ichs (diana_get
					      (funk_decl_bits%body
						(fourth as))
					      'as_name))
				      (chs (diana_get
					     (funk_decl_bits%body
					       (fourth as))
					     'as_name)
					   (cdr chs))
				      (chosen nil))
				     ((null chs)
				      (cond ((= (length chosen) 1)
					     (diana_put
					       (funk_decl_bits%body
						 (fourth as))
					       (car chosen)
					       'as_name))
					    ((and ichs (null chosen))
					     (semgripe
					       'not_the_same_profile_in_rename
					       (implode
						 (uplowlist (cadr
						   (diana_get (car ichs)
							      'lx_symrep))))))
					    ((null chosen)
					     (semgripe
					       'undeclared_func_in_rename
					       ))
					    (t
					     (semgripe
					       'ambiguous_func_in_rename
					       (implode
						 (uplowlist (cadr
						   (diana_get (car ichs)
							      'lx_symrep))))))))
				   (cond ((same_type_profile_p
					    (car chs)
					    (sc_diana dn_function_id
						      sm_spec (first as)))
					  (ct_push (car chs) chosen)))
				   )))
			      (fourth as))				    
			    (pr_and
			      (lambda(as)
				(let ((formals
					(cond
					  ((first as)(first as))
					  (t (sc_diana dn_function)))))
				  (diana_put
				    (first *identstack*)
				    formals
				    'sm_spec)
				#|(let
				    ((def (diana_get (first *identstack*)
						     'sm_first)))
				    (cond
				      (def
				       (diana_put def formals 'sm_spec))))|#
				  formals
				  ))
			      (pr_or nil
				     funct_formal_part
				     nil))
			    symb_return
			    (pr_and
			      (lambda(as)
				(diana_put
				  (diana_get (first *identstack*) 'sm_spec)
				  (first as)
				  'as_name_void)
			      #|(let
				  ((def (diana_get (first *identstack*)
						   'sm_first)))
				  (cond
				    (def
				     (diana_put
				       (diana_get def 'sm_spec)
				       (first as) 'as_name_void))))|#
				)
			      (pr_and
				(lambda (as)
				  (rplaca *returntypestack*
					  (first as))
				  (first as))
				subtype_indication))
			    (pr_or
			      nil 
			      (pr_and
				(lambda (as)
				  (setq *function_name_only* nil)
				  (funk_decl_bits
				    nil
				    (sc_diana dn_rename
					      as_name (second as)) 
				    (fourth as)
				    nil))
				(pr_and
				  (lambda (as)
				    (rplaca *return_stmt_stack* t)
				    (setq *function_name_only* t)
				    (car as))
				  symb_renames)
				(pr_restrict function name)
				(pr_and
				  (lambda(as)	  ;leave procedure context before decl.
				    (ct_push nil *identstack*)
				    (popcontext)  
				    (first as))
				  oper_semicolon)
				(pr_or nil
				       declarative_part
				       nil))
			      (pr_and 
				(lambda(as)
				  (funk_decl_bits 
				    nil 
				    (second as)
				    (third as)
				    nil))
				(pr_and
			     (lambda(as)
			       (let* ((this (car *identstack*))
				      (stub (with_same_type_profile
					      this
					      (diana_get this 'sm_first))))
				 (cond
				   (stub
				    ;;if any of these have matching specs and come
				    ;;from either here or the corresponding package
				    ;;declaration, we have the def_occurence.
				    (let*
				      ((defo
					 (mapcan
					   #'(lambda(fun)
					       (cond
						 ((and
						    (diana_get fun 'sm_body)
						    (eq (diana_nodetype_get
							  (diana_get fun 'sm_body))
							'dn_stub))
						  (list fun))
						 (t nil)))
					   stub))
				       (defo (find_defo defo)))
				      (cond
					(defo 
					 (diana_put
					   **current_block**
					   (list
					     (diana_get defo 'ct_named_context))
					   'ct_mixin_s)				 
					 (diana_put defo
					     (diana_get this 'sm_spec)
					     'ct_spec)
					  (setq *current_generic_nestitude*
					       (diana_get
						 defo
						 'ct_generic_membership))
					  (change_generic_membership
					   (diana_get this 'sm_spec)
					   *current_generic_nestitude*)))
				      (diana_put this defo 'sm_first)))
				   (t (diana_put this nil 'sm_first)))))
			     symb_is)
				(pr_or
				  nil 
				  (pr_and 
				    (lambda(as)
				      (rplaca *return_stmt_stack* t)
				      (popcontext)
				      (ct_push nil *identstack*)
				      (sc_diana dn_stub))
				    symb_separate)
				  (pr_and
				    (lambda(as)
				      (ct_push (second as) *identstack*)
				      (first as))
				    (pr_and
				      (lambda(as)
					;;leave procedure context before decl.
					(popcontext)
					(diana_put
					  (first *identstack*)
					  (first as)
					  'sm_body)
					(let
					  ((def (diana_get
						  (first *identstack*)
						  'sm_first)))
;					  (break fix5)
					  (cond
					    (def
					     (diana_put def (first as) 'sm_body))))
					(first as))
				      body_part)
				    (pr_or nil	  
					   lex_ident
					   operator_symbol
					   nil)))
				declarative_part_extnb)
			      (pr_and 
				(lambda(as)
				  (funk_decl_bits nil nil (second as) nil))
				(pr_and
				  (lambda(as)
				    (rplaca *return_stmt_stack* t)
				    (ct_push nil *identstack*)
				    (popcontext)
				    ;;leave procedure context before decl.
				    (first as))
				  oper_semicolon)
				declarative_part)))))
		 (pr_and
		   (lambda(as)
		     (ct_pop *returntypestack*)
		     (second as))
		   (pr_and
		     (lambda (as)
		       (ct_push 'package *returntypestack*)
		       (first as))
		     symb_package)
		   (pr_or
		     nil 
		     (pr_and
		       (lambda(as)
			 (let ((pkg_id (first as))
			       (pkg_bits (second as)))
			   (cond
			     ((eq (diana_nodetype_get
				    (pckg_decl_bits%header pkg_bits))
				  'dn_rename)
			      (diana_put
				pkg_id
				(let* ((smdef
					 (diana_get
					   (diana_get
					     (pckg_decl_bits%header pkg_bits)
					     'as_name)
					   'sm_defn))
				       (ctn1
					 (and smdef
					      (diana_get
						smdef
						'ct_named_context))))
				  ctn1)
				'ct_named_context)
;			      (break look-at-pkg-id-context)
			      ))
			   (cond
			     ((eq (diana_nodetype_get
				    (pckg_decl_bits%header pkg_bits))
				  'dn_instantiation)
			      (let ((instantiation
				      (instantiated_spec
					(pckg_decl_bits%header pkg_bits))))
				(cond
				  (instantiation
				   (diana_put
				     pkg_id
				     (diana_get
				       instantiation
				       'sm_spec)
				     'sm_spec)
				   (diana_put
				     pkg_id
				     (diana_get
				       instantiation
				       'sm_body)
				     'sm_body)
				   (let ((**current_block**
					   (diana_get
					     pkg_id
					     'ct_named_context)))
				     (redeclare_package_declarations
				       (diana_get
					 instantiation
					 'sm_spec)))
;					(break redeclare-instantiated-declarations)
				   ))))
			     (t
			      (diana_put
				pkg_id
				(pckg_decl_bits%header pkg_bits)
				'sm_spec)
			      (diana_put
				pkg_id
				(sc_diana dn_void)
				'sm_body)))
;too late here!		      (popcontext)
			   (cons
			     (sc_diana
			       dn_package_decl
			       as_id pkg_id
			       as_package_def (pckg_decl_bits%header pkg_bits))
			     (pckg_decl_bits%nextdecl pkg_bits))
			   ))
		       (pr_and
			 (lambda(as)
			   (let ((this_pkg (sc_diana dn_package_id
						     lx_symrep (first as))))
			     (add_name
			       (first as)
			       'package
			       this_pkg
			       nil)
			     (pushcontext);was proc
			     (ct_push this_pkg *identstack*)
			     (diana_put this_pkg
					**current_block**
					'ct_named_context)
			     this_pkg))
			 lex_ident)
		       (pr_or nil
			      (pr_and (lambda(as)
					;(break look-at-secondas)
					(pckg_decl_bits
					  (sc_diana dn_rename 
						    as_name (second as))
					  nil
					  (fourth as)))
				      symb_renames
				      (pr_restrict package name)
				      oper_semicolon
				      (pr_or nil
					     declarative_part
					     nil))
			      (pr_and cadr
				      symb_is
				      (pr_or nil 
					     (pr_and
					       (lambda(as)
						 (matching_ident
						   (diana_get
						     (ct_pop *identstack*)
						     'lx_symrep)
						   (second as)) 
						 (pckg_decl_bits
						   (first as)
						   (sc_diana dn_void)
						   (fourth as)))
					       (pr_and
						 (lambda(as)
						   (popcontext)
						   (first as))
						 package_spec_part)
					       (pr_or nil lex_ident nil)
					       oper_semicolon
					       (pr_or nil
						      declarative_part
						      nil))
					     (pr_and
					       (lambda(as)
						 (pckg_decl_bits
						   (first as)
						   (sc_diana dn_void)
						   (third as)))
					       (pr_and
						 (lambda(as)
						   (let ((instantiation
							   (instantiated_spec
							     (first as)))
							 (nod (ct_pop *identstack*)))
;						     (break in-declarative_part)
						     (cond
						       (instantiation
							(diana_put nod
								   (diana_get
								     instantiation
								     'sm_spec)
								   'sm_spec)
							(diana_put nod
								   (diana_get
								     instantiation
								     'sm_body)
								   'sm_body)
							(redeclare_package_declarations
							  (diana_get
							    instantiation
							    'sm_spec)))))
						   (popcontext)
						   (first as))	
						 generic_instantiation)
					       oper_semicolon
					       (pr_or nil
						      declarative_part
						      nil))))))
		     (pr_and
		       (lambda(as)	  ;(break look-at-identstack)
			 (setq *current_generic_nestitude*
			       (ct_pop *generic_nestitude_stack*))
			 (let ((fname (ct_pop *identstack*))
			       (sname (diana_get (ct_pop *identstack*)
						    'lx_symrep)))
			   (matching_ident 
				sname fname)	 
					 )
			 (let ((pkg_id (second as)))
			   (diana_put pkg_id (fourth as) 'sm_body)
			   (let ((nu_pkg
				   (sc_diana dn_package_id
					     sm_spec (diana_get pkg_id 'sm_spec)
					     sm_body (fourth as))))
			     (cons
			       (sc_diana dn_package_body
					 as_id nu_pkg
					 as_block_stub (fourth as))
			       (fifth as)))))
		       symb_body
		       (pr_and
			 (lambda(as)
			   (let* ((pkg_id
				    (let ((pid (ada_declared
						 (first as)
						 nil
						 '(package generic_unit))))
				      (cond
					((eq (diana_nodetype_get pid)
					     'dn_used_name_id)
					 (semgripe
					   'cant_find_matching_spec_for_package_body)
					 (sc_diana dn_package_id
						   lx_symrep (first as)))
					(t pid))))
				  (spec_context
				    (diana_get pkg_id 'ct_named_context))
				  (spec_mixins
				    (and spec_context
					 (diana_get
					   (diana_get spec_context
						      'ct_is_enclosed_by)
					   'ct_mixin_s)))
				  (mycontext
				    (diana_get
				      **current_block** 'ct_mixin_s))
				  (hidden_context
				    (and spec_context
					 (diana_get spec_context
					       'ct_hidden_context))))
			     
			     (savecontext)
			     ;(break llok-at-hidden-context)
			     (setq **current_block** (or hidden_context
							  spec_context))
			     (setq **current_block** (new_block))
			     
			     (ct_push *current_generic_nestitude*
				      *generic_nestitude_stack*)
			     (setq *current_generic_nestitude*
				   (diana_get pkg_id
					      'ct_generic_membership))
			     (diana_put **current_block**
					(cons hidden_context
					      (append spec_mixins
						      mycontext))
					'ct_mixin_s)
			     (diana_put **current_block**
					hidden_context
					'ct_hidden_context)
			     (diana_put pkg_id
					**current_block**
					'ct_package_inner_environment)
			     (ct_push pkg_id *identstack*)
			     pkg_id))
			 lex_ident)
		       symb_is
		       (pr_or nil 
			      (pr_and
				(lambda(as)
				  (ct_push nil *identstack*)
				  (popcontext)
				  (sc_diana dn_stub))
				symb_separate)
			      (pr_and
				(lambda(as)
				  (diana_put (first *identstack*)
					     (first as)
					     'sm_body)
				  (ct_push (second as) *identstack*)
				  (popcontext)
				  (first as))
				body_part
				(pr_or nil lex_ident nil)))
		       declarative_part_extnb)))
		 (pr_and
		   (lambda(as)
		     (ct_pop *returntypestack*)
		     (cons 
		       (task_decl_bits%body (second as))
		       (task_decl_bits%nextdecl (second as))))
		   (pr_and
		     (lambda (as)
		       (ct_push 'task *returntypestack*)
		       (first as))
	 	     symb_task)
		   (pr_or nil
			  (pr_and
			    (lambda(as)
			      (task_decl_bits nil (first as) (third as)))
			    (pr_and
			      (lambda(as)
				(popcontext)
				;;first fill in the body field of the sm_obj_spec
				;;field of the var_id, to point to the spec.
				(diana_put (first as)
					   (cond ((second as) (second as))
						 (t
						  (sc_diana dn_task_spec)))
					   'sm_obj_type)
				(sc_diana dn_task_decl
					  as_id (first as)
					  as_task_def
					  (diana_get (first as) 'sm_obj_type)))
			      (pr_and
				(lambda(as)
				  (let ((vid
					  (sc_diana dn_var_id
						    lx_symrep (first as)
						    sm_obj_type nil)))	  ;later
				    (add_name
				      (first as)
				      'task
				      vid
				      nil)
				    (diana_put vid (pushcontext)
					       'ct_named_context)
				    vid))
				lex_ident)
			      (pr_or nil
				     (pr_and cadr
					     symb_renames
					     (pr_restrict task name))
				     (pr_and cadr
					     symb_is
					     task_spec_part
					     (pr_or nil lex_ident nil))
				     nil))
			    oper_semicolon
			    declarative_part)
			  (pr_and
			    (lambda (as)
			      (let ((tdb (first as)))
				(%= (task_decl_bits%nextdecl tdb)
				    (second as))
				tdb))
			    (pr_and
			      (lambda (as)
				(let* ((tts (cond ((third as) (third as))
						  (t (sc_diana dn_task_spec))))
				       (ttd (sc_diana dn_type_id
						      lx_symrep (second as)
						      sm_type_spec tts))
				       (td (sc_diana dn_type
						     as_id ttd
						     as_type_spec tts)))
				  (add_name
				    (second as)
				    'type
				    ttd
				    nil)
				  (task_decl_bits (third as)
						  td
						  nil)))
			      symb_type
			      lex_ident
			      (pr_or nil
				     (pr_and cadr  
					     symb_is
					     task_spec_part
					     (pr_or nil lex_ident nil))
				     nil)
			      oper_semicolon)
			    declarative_part)
			  (pr_and
			    (lambda(as)
;				   (popcontext)
			      ;;put the body into the task_body_id
			      (diana_put (second as) (fourth as) 'sm_body)
			      ;;and into the spec's body.
			      (let ((sts
				      (diana_get (second as) 'sm_type_spec)))
				(and sts (diana_put sts
						    (fourth as)
						    'sm_body)))
					  ;(break look-at-task-decl-bits)
			      (task_decl_bits
				nil
				(sc_diana dn_task_body
					  as_id (second as)
					  as_block_stub (fourth as))
				(fifth as)))
			    symb_body
			    (pr_and
			      (lambda(as)
				(pushproccontext)
				(let ((ts (ada_declared (first as) nil
							'(task type))))
;					     (break in-declarative_part)
				  (install_mixins
				    (list
				      (diana_get ts 'ct_named_context)))
				  (add_name
				    (first as)
				    'task
				    (sc_diana dn_task_body_id
					      lx_symrep (first as)
					      sm_type_spec
					      (cond ((eq (diana_nodetype_get ts)
							 'dn_var_id)
						     (diana_get
						       ts 'sm_obj_type))
						    (t
						     (diana_get
						       ts 'sm_type_spec)))
					      sm_body nil ;later!
					      sm_first ts)
				    nil)))
			      lex_ident)
			    symb_is
			    (pr_and
			      (lambda(as)
				(popcontext)
				(first as))
			      (pr_or nil 
				     (pr_and
				       (lambda(as)
					 (sc_diana dn_stub))
				       symb_separate)
				     (pr_and car
					     body_part
					     (pr_or nil lex_ident nil))))
			    declarative_part_extnb)))
		 (pr_and (lambda(as)
					  ;  (popcontext)
			   
			   (cons (first as)(third as)))
			 (pr_and
			   (lambda (as)
			     (ct_pop *current_generic_nestitude*)
			     (first as))
			   generic_specification)
			 oper_semicolon
			 (pr_or nil declarative_part nil))
		 #|		 (pr_and (lambda(as)
			   (append (cons (first as)(second as))(third as)))
			 representation_specification
			 (pr_repeat nil
				    representation_specification)
			 (pr_repeat nil program_component))|#
		 )))
    
		;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax declarative_part_extnb
		;;;;;;;;;;;;;;;;;;;;;;

	(pr_and 
	  (lambda(as) (cond ((second as)(second as)) (t t)))
	  oper_semicolon 
	  (pr_repeat nil program_component)))