;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;  $Header: /ct/interp/adas120.l,v 1.69 84/10/08 18:25:34 penny Exp $
;;;  

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



;;;-- 10.  Program Structure and Compilation Issues
;;;-- =============================================
;;;-- 10.1  Compilation Units _ Library Units
;;;
;;;-- Syntax 10.1.A
;;;--  compilation ::= {{pragma} compilation_unit}
;;;--
;;;
;;;
;;;    COMPILATION ::=      compilation;
;;;
;;;    compilation =>       as_list          : Seq Of COMP_UNIT;
;;;    compilation =>       lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- Syntax 10.1.B
;;;--  compilation_unit ::=
;;;--     context_specification subprogram_declaration
;;;--   | context_specification subprogram_body
;;;--   | context_specification package_declaration
;;;--   | context_specification package_body
;;;--   | context_specification subunit
;;;--   | context_specification generic_declaration
;;;--
;;;
;;;
;;;    COMP_UNIT ::=        comp_unit;
;;;    UNIT_BODY ::=        package_body | package_decl | subunit | generic
;;;                         | subprogram_body | subprogram_decl | void;
;;;    -- UNIT_BODY is void only when comp_unit consists of only pragmas
;;;
;;;    PRAGMA_S ::=         pragma_s;
;;;
;;;    pragma_s =>          as_list          : Seq Of PRAGMA;
;;;    pragma_s =>          lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    comp_unit =>         as_context       : CONTEXT,
;;;                         as_unit_body     : UNIT_BODY,
;;;                         as_pragma_s      : PRAGMA_S;   -- extension to FD.
;;;    comp_unit =>         lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    CONTEXT_ELEM ::=     pragma;          -- pragma allowed in clause
;;;
;;;-- Syntax 10.1.C
;;;--  context_specification ::= {with_clause [use_clause]}
;;;--
;;;
;;;
;;;    CONTEXT_ELEM ::=     use;
;;;    CONTEXT ::=          context;
;;;
;;;    context =>           as_list          : Seq Of CONTEXT_ELEM;
;;;    context =>           lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- Syntax 10.1.D
;;;--  with_clause ::= 'with' name {',' name} ';'
;;;--
;;;
;;;
;;;    CONTEXT_ELEM ::=     with;
;;;
;;;    with =>              as_list          : Seq Of NAME;
;;;    with =>              lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;

                ;;;;;;;;;;;
(def_ada_syntax compilation
                ;;;;;;;;;;;
   (pr_and
     (lambda(as)
;	(popcontext)
       (sc_diana dn_compilation
		 as_list (cons (first as) (third as))))
     compilation_unit
     oper_semicolon
     (pr_repeat nil
       (pr_and
	 (lambda(as)
	   (car as))
	 compilation_unit
	 oper_semicolon))
     lex_eof))

(defun flatten_one_level (lus)
  (let ((res nil))
    (mapc #'(lambda (el)
	      (cond ((consp el)
		     (setq res
			   (append
			     res
			     (mapcar
			       #'(lambda (id)
				   (sc_diana dn_used_name_id
					     lx_symrep (diana_get id 'lx_symrep)
					     sm_defn id))
				   el))))
		    (t (setq res (cons el res)))))
	  lus)
    res))

		;;;;;;;;;;;;;;;;
(def_ada_syntax compilation_unit
		;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as);(break in-compilation)
	    (popcontext)		  ;end of comp_unit's context.
	    ;;First of all, we need to normalize any outstanding calls.
	    ;;now bitch about ambiguous subphrogs.
            (complain_about_awaiting_disambiguation)
	    (try_to_normalize) 
            ;; if there are any parameters still waiting to be normalized,
	    ;; it is too late to normalize them. We must prevent execution
	    ;; by making the semantic errors nonzero.
	    (cond
		(*awaiting_parameter_normalization* 
                 (semgripe 'bad_subprog_call)))

	    ;; Add this object to the symbol table as a library unit.
	    (add_name
	      (first *library_unit*)
	      'library_unit
	      (second *library_unit*)
	      nil)
		 
	    (sc_diana dn_comp_unit
		      as_context (third as)	  ;with .. use clauses.
		      as_unit_body (fourth as)	  ; compilation body
		      as_pragma_s (second as)))	  ; pragmas.


	  (pr_or pushcontext)		  ; a context for the comp_unit.
	  (pr_repeat nil pragma)	  ; a list of pragmas
	  
	  (pr_repeat 	
	    (lambda(as)
	      (sc_diana dn_context
			as_list
			(mapcan
			  '(lambda(e)
			     (cond
			       ((null (cadr e)) (list (car e)))
			       (t (cons (car e)(cadr e)))))
			  as)))
	    (pr_or nil
		   (pr_and nil
		    (pr_and		  ; with clause
		      (lambda(as)
			(let ((library_units (cons 
					       (find_name (second as)
							  'library_unit)
					       (third as))))
			  (setq library_units
				(flatten_one_level library_units))
			  (with_library_units library_units)
			  (sc_diana dn_with
				    as_list library_units)))
		      symb_with
		      (pr_restrict library_unit name)
		      (pr_repeat nil
				 (pr_and 
				   (lambda(as)
				     (find_name (second as) 'library_unit))
				   oper_comma 
				   (pr_restrict library_unit name)))
		      oper_semicolon
		      )
		    (pr_or nil
			   (pr_repeat nil
				      use_clause) nil)
		    )
		  (pr_and
		    (lambda (as)
		      (cond ((first as)
			     (semgripe 'use_without_with_at_top_level)))
		      'fail)
		    (pr_repeat nil
			       use_clause)))
	    )
	  
	  (pr_or nil
		 ;; this section should produce a compilation
		 ;; body.(procedure function package generic
		 ;; or subunit). it also recursively picks up
		 ;; other compilation units. 
		 (pr_and		  ; this is the procedure case...
		   (lambda(as)
		     (ct_pop *returntypestack*)
		     (popcontext)
		     (matching_ident 
		       (diana_get (second as) 'lx_symrep)
		       (ct_pop *identstack*))
		     ;; if a name is given check it for sameness.
		     (setq *current_generic_nestitude*
			   (ct_pop *generic_nestitude_stack*))
		       (sc_diana dn_subprogram_decl
				 as_designator 
				 (let ((nod (second as))
				       (others (diana_get (second as) 'sm_first)))
				   (cond
				     ((and (subprogdecl%def (third as))
					   (eq (diana_nodetype_get
						 (subprogdecl%def (third as))) 
					       'dn_instantiation))
;					(break instantiating)
				      (let ((instantiation
					      (instantiated_spec
						(subprogdecl%def (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
						   (subprogdecl%head (third as))
						   'ct_spec)
					(diana_put nod
						   (subprogdecl%head (third as))
						   'sm_spec)
					(diana_put nod
						   (subprogdecl%body (third as))
						   'sm_body)))  
				   (cond 
				   ((and
				      others
				      (diana_get others 'sm_body)
				      (not (stub_p
					     (diana_get others 'sm_body)))))
				   (others
				    (cond ((eq (diana_nodetype_get
						 (subprogdecl%def (third as)))
					       'dn_instantiation)
					   (let ((instantiation
						   (instantiated_spec
						     (subprogdecl%def
						       (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
							(subprogdecl%head
							  (third as))
							'ct_spec)
					     (diana_put others
							(subprogdecl%body
							  (third as))
							'sm_body)))
;					(break installed-body-and-spec)
				    ))
				   nod)
				 as_header (subprogdecl%head (third as))
				 as_subprogram_def 
				 (subprogdecl%def (third as))))
		   symb_procedure
		   (pr_and 
		  (lambda(as)
		    (ct_push nil *returntypestack*)
		      (let*
			((stub (ada_declared (first as) nil
					     '(procedure generic_unit
							 library_unit) t))
			 (this (add_name
				 (first as)	  ; name
				 'procedure	  ; class
				 (sc_diana dn_proc_id
					   lx_symrep (first as)
					   sm_spec nil
					   sm_body nil
					   sm_location nil
					   sm_stub nil
					   sm_first nil)
				 nil)))
;			(break look-at=stub)
			(setq *library_unit* (list (first as) this))
			
			(ct_push *current_generic_nestitude*
				 *generic_nestitude_stack*)
			(cond
			  (stub
			   ;;if any of these have matching specs and come
			   ;;from either here of the corresponding package
			   ;;declaration, we have the def_occurence.
			   (let* ((defo
				    (mapcan
				      #'(lambda(fun)
					  (cond
					    ((and (diana_nodep fun)
						  (diana_nodep
						    (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 
#|				(savecontext)
				(setq **current_block**
				      (diana_get defo 'ct_named_context))
				(setq *pnl* (1+ *pnl*))
				(setq **current_block** (new_block))|#
				(pushproccontext)
				(diana_put
				  **current_block**
				  (list (diana_get defo 'ct_named_context))
				  'ct_mixin_s)
				(diana_put this **current_block**
				    'ct_named_context)
				(setq *current_generic_nestitude*
				      (diana_get defo
						 'ct_generic_membership)))
			       (t (diana_put this (pushproccontext)
				    'ct_named_context)))
			     (cond
			       (defo (diana_put this defo 'sm_first)))))
			  (t (diana_put this (pushproccontext)
				    'ct_named_context))
			  )
			this))		  ;we always return the current one!
		  lex_ident)		   
		   (pr_or nil 
			  (pr_and cadr
				  symb_is
				  (pr_or nil 
					 (pr_and 
					   (lambda(as)
					     (subprogdecl 
					       (sc_diana dn_procedure
							 as_param_s nil
							 )
					       nil 
					       (first as)))
					   generic_instantiation)
					 (pr_and 
					   (lambda(as)
					     (ct_push (second as) *identstack*)
					  ; remember the ident for
					  ; matching.
					     (subprogdecl 
					       nil 
					       (first as)
					       (sc_diana dn_void)))
					   body_part
					   (pr_or nil lex_ident nil))))
			  (pr_and 
			    (lambda(as)
			      (subprogdecl 
				(first as)
				(second as)
				(sc_diana dn_void)))
			    proc_formal_part
			    (pr_or nil 
				   (pr_and 
				     (lambda(as)
				       (ct_push (third as) *identstack*)
				       (second as))
			     symb_is
				     body_part
				     (pr_or nil lex_ident nil))
				   nil))
			  nil))
		 (pr_and
		   (lambda(as)
		     (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*))
		     (popcontext)
		     (matching_ident (diana_get (second as) 'lx_symrep)
				     (ct_pop *identstack*))
		     ;; if a name is given check it for sameness.
		       (sc_diana
			 dn_subprogram_decl
			 as_designator
			 (let ((nod (second as))
			       (others (diana_get (second as) 'sm_first)))
			   (cond
			     ((and (subprogdecl%def (third as))
				   (eq (diana_nodetype_get
					 (subprogdecl%def (third as)))
				       'dn_instantiation))
;				    (break about-to-instantiate)
			      (let ((instantiation
				      (instantiated_spec
					(subprogdecl%def (third as)))))
				(cond
				  (instantiation
				   (diana_put nod
					   (diana_get
					     instantiation
					     'ct_spec)
					   'ct_spec)
				(diana_put nod
					   (diana_get
					     instantiation
					     'sm_spec)
					   'sm_spec)
				(diana_put nod
					   (diana_get
					     instantiation
					     'sm_body)
					   'sm_body)))))
			     (t
			      (diana_put
				nod
				(subprogdecl%head (third as))
				'ct_spec)
			      (diana_put
				nod
				(subprogdecl%head (third as))
				'sm_spec)
			      (diana_put
				nod
				(subprogdecl%body (third as))
				'sm_body)
			      ))
			   (cond
			     (others
				    (cond
				      ((not (stub_p
					      (diana_get others 'sm_body))))
				      ((eq (diana_nodetype_get
					     (subprogdecl%def
					       (third as)));++pmj
					   'dn_instantiation)
				       (let ((instantiation
					       (instantiated_spec
						 (subprogdecl%def
						   (third as)))));++pmj
					 (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
					 (subprogdecl%head (third as));++pmj 
					 'ct_spec)
				       (diana_put
					 others
					 (subprogdecl%body (third as));++pmj
					 'sm_body)))))
			   nod)
			 as_header (subprogdecl%head (third as))
			 as_subprogram_def 
			 (subprogdecl%def (third as))))
		   symb_function		   
		   (pr_and
		  (lambda(as)
		    (ct_push nil *return_stmt_stack*)
		    (ct_push nil *returntypestack*)
		      (let*
			((stub (ada_declared (first as) nil
					     '(function generic_unit
							library_unit) t))
			 (this (add_name
				 `(lex_ident ,(cadr (first as)))	  ; name
				 'function; class
				 (sc_diana dn_function_id
					   lx_symrep (first as)
					   sm_spec nil
					   sm_body nil
					   sm_location nil
					   sm_stub nil
					   sm_first nil)
				 nil)))
			(setq *library_unit*
			      (list `(lex_ident ,(cadr (first as))) this))
			
			(ct_push *current_generic_nestitude*
				 *generic_nestitude_stack*)
			(cond
			  (stub
			   ;;if any of these have matching specs and come
			   ;;from either here of the corresponding package
			   ;;declaration, we have the def_occurence.
			   (let* ((defo
				    (mapcan
				      #'(lambda(fun)
					  (cond
					    ((eq (diana_nodetype_get
						   (diana_get fun 'sm_body))
						 'dn_stub) (list fun))
					    (t nil)))
				      stub))
				  (defo (find_defo defo)))
			     (cond
			       (defo 
#|				(savecontext)
				(setq **current_block**
				      (diana_get defo 'ct_named_context))
				(setq *pnl* (1+ *pnl*))
				(setq **current_block** (new_block))|#
				(pushproccontext)
				(diana_put
				  **current_block**
				  (list (diana_get defo 'ct_named_context))
				  'ct_mixin_s)
				(diana_put this **current_block**
				    'ct_named_context)
				(setq *current_generic_nestitude*
				      (diana_get defo
						 'ct_generic_membership)))
			       (t (diana_put this (pushproccontext)
				    'ct_named_context)))
			     (cond
			       (defo (diana_put this defo 'sm_first))
			       )
			     ))
			  (t (diana_put this (pushproccontext)
				    'ct_named_context)))
			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));++pmj
		   (pr_or nil 
			  (pr_and cadr
				  symb_is
				  (pr_and 
				    (lambda(as)
				      (rplaca *return_stmt_stack* t)
				      (subprogdecl 
					nil
					nil 
					(first as)))
				    generic_instantiation))
			  (pr_and 
			    (lambda(as)
			      (subprogdecl
				(first as)
				(fourth as)
				(sc_diana dn_void)))
			    
			    (pr_and
			      (lambda(as)
				(cond
				  ((first as)(first as))
				  (t (sc_diana dn_function))))
			      (pr_or nil funct_formal_part nil))
			    symb_return
			    (pr_and
			      (lambda (as)
				(rplaca *returntypestack*
					(first as))
				(first as))
			      subtype_indication)
			    (pr_or nil 
				   (pr_and cadr
					   symb_is
					   body_part
					   (pr_or nil lex_ident nil))
				   nil))))
		 (pr_and
		   (lambda(as)
		     (ct_pop *returntypestack*)
			(matching_ident
			  (diana_get (diana_get (second as) 'as_id)
				     'lx_symrep)
			  (ct_pop *identstack*))
		     ;; if a name is given check it for sameness.
		     (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)))
				(cond
				     ((and (diana_nodetype_get (third as))
					   (eq (diana_nodetype_get (third as))
					       'dn_instantiation))
				      (let ((instantiation
					      (instantiated_spec (third as))))
					(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
					(third as)
					'sm_spec)
				      (diana_put
					pkg_id
					(sc_diana dn_void)
					'sm_body)))
				(popcontext)
				(sc_diana dn_package_decl
					  as_id pkg_id
					  as_package_def (third as))))
			    (pr_and
			      (lambda(as)
				(let ((this_pkg (sc_diana dn_package_id
							  lx_symrep (first as))))
				  (setq *library_unit* (list (first as) this_pkg))
				  (add_name
				    (first as)
				    'package
				    this_pkg
				    nil)
				  (pushcontext)	 
				  (diana_put this_pkg
					     **current_block** 'ct_named_context)
				  this_pkg))
			      lex_ident)
			    symb_is
			    (pr_or nil 
				   (pr_and; keep the ident stack balanced.
				     (lambda(as)
				       (ct_push nil *identstack*)
				       (first as))
				     generic_instantiation)
				   (pr_and 
				     (lambda(as)
				       (ct_push (second as) *identstack*)
				       (first as))
				     package_spec_part
				     (pr_or nil lex_ident nil))))
			  (pr_and 
			    (lambda(as)
			      (popcontext);pop back context after body.
			      (setq *current_generic_nestitude*
				    (ct_pop *generic_nestitude_stack*))
			      (ct_push (fifth as) *identstack*)
			      (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)
					  lx_symrep
					  (diana_get pkg_id 'lx_symrep))))
				  (sc_diana dn_package_body
					    as_id nu_pkg
					    as_block_stub (fourth as)))))
			    symb_body
			    (pr_and
			      (lambda(as)
				;; To handle a body, we--
				;; (1)  make a new context.
				;; (2)  find the context for the spec.
				;; (3)  make the spec context and
				;;      its private parts  mixins.
                                ;; (4)  make the packages inner environment
                                ;;      acccessable in case of separates.
				(let ((pkg_id
					(let ((pid (ada_declared
						 (first as)
						 nil
						 '(package generic_unit
							   library_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)))))
				  (let* ((spec_context
					   (diana_get
					     pkg_id
					     'ct_named_context))
					 (thiscontext **current_block**)
					 (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)
				    (setq **current_block** spec_context)
				    (setq **current_block** (new_block))
				    ;;make a fresh context for body
				    
				    (diana_put **current_block**
					       (cons hidden_context 
						 mycontext)
					       'ct_mixin_s)
				    (diana_put **current_block**
					       hidden_context
					       'ct_hidden_context)
				    (setq **current_block** (new_block))
				    (diana_put pkg_id
					       **current_block**
					       'ct_package_inner_environment)|#
					(savecontext)
				    (setq **current_block**
					  (or hidden_context thiscontext))
				    (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 spec_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)
;				    (break in-package-body)
				    )
				  pkg_id))
			      lex_ident)
			    symb_is
			    body_part
			    (pr_or nil lex_ident nil))))
		 (pr_and
		   (lambda(as)
		     ;(break look-at-current-g-n)
		     (ct_pop *current_generic_nestitude*)
		     (setq *library_unit*
			   (list
			     (diana_get (diana_get (first as) 'as_id) 'lx_symrep)
			     (diana_get (first as) 'as_id)))
		     (first as))
		   generic_specification)
		 subunit)))
    
;;;-- 10.2  Subunits of Compilation Units
;;;
;;;-- Syntax 10.2.A
;;;--  subunit ::=
;;;--     'separate' '(' name')' subunit_body
;;;--  subunit_body ::=
;;;--     subprogram_body | package_body | task_body
;;;--
;;;
;;;
;;;    subunit =>           as_name          : NAME,
;;;                         as_subunit_body  : SUBUNIT_BODY;
;;;    subunit =>           lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    SUBUNIT_BODY ::=     subprogram_body | package_body | task_body;
;;;
;;;-- Syntax 10.2.B
;;;--  body_stub ::=
;;;--     subprogram_specification    'is' 'separate' ';'
;;;--   | 'package' 'body' simple_name 'is' 'separate' ';'
;;;--   | 'task' 'body' simple_name    'is' 'separate' ';'
;;;--
;;;
;;;
;;;    BLOCK_STUB ::=       stub;
;;;
;;;    stub =>              lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;
(def_ada_syntax subunit
		;;;;;;;

	(pr_and
	  (lambda(as)
	    (popcontext)
	    (sc_diana dn_subunit
		      as_name (find_name (third as) nil)
		      as_subunit_body (fifth as)))
	  symb_separate
	  oper_lparen
	  (pr_and
	    (lambda(as)
	       ;first as is the parent unit.
	      (savecontext)		  ;save this context till after separate.
	      (let ((parent_unit
		      (diana_get (find_selected (first as)) 'sm_defn))
		    (mymixins (diana_get **current_block** 'ct_mixin_s)))
		(cond ((null parent_unit)
		       (semgripe 'cant_find_mummy_in_subunit))
		      (t (setq *pnl* (diana_get parent_unit 'ct_pnl))
			 (setq *bnl*  (diana_get parent_unit 'ct_bnl))
			 (cond ((memq (diana_nodetype_get parent_unit)
				      '(dn_proc_id dn_function_id dn_task_body_id))
				(setq *pnl* (1+ *pnl*))))
			 (setq **current_block**
			       (or
				 (and
				   (diana_node_accepts_attributep
				     parent_unit 'ct_package_inner_environment) 
				   (diana_get
				     parent_unit
				     'ct_package_inner_environment))
				 (diana_get
				   parent_unit
				   'ct_named_context)))
			 (setq **current_block** (new_block))
			 (diana_put **current_block** mymixins 'ct_mixin_s)
			 (cond
			   ((diana_get
			      parent_unit
			      'ct_package_inner_environment)
			    (diana_put **current_block**
				       (cons
					 (diana_get
					   parent_unit
					   'ct_package_inner_environment)
					 (diana_get **current_block** 'ct_mixin_s))
				       'ct_mixin_s)))
			 (cond 
			   ((diana_get parent_unit 'ct_package_inner_environment)))))
		;;climb into package.
		(first as)))
	    name)
	  oper_rparen
	  (pr_or
	    nil 	
	    (pr_and
	      (lambda(as)
		(ct_pop *returntypestack*)
		(ct_pop *identstack*)
		(sc_diana
		  dn_subprogram_decl
		  as_designator
		  (do ((nod (second as))
		       (others (diana_get (second as) 'sm_first)
				(diana_get others 'sm_first)))
		      ((null others) nod)
		    (cond
		      ((third (third as))
		       (diana_put nod
				  (first (third as))
				  'sm_spec)
		       (diana_put nod
				  (third (third as))
				  'sm_body)
;;		       (break look-at-others)
		       (cond
			 (others
			  (diana_put others
				     (first (third as))
				     'ct_spec))
			 (t (semgripe 'cant_find_matching_stub_in_subunit
				      (implode
					(uplowlist
					(cadr (diana_get nod 'lx_symrep))))))
			 )
		       (cond 
			 ((and
			    others
			    (diana_get others 'sm_body)
			    (not (stub_p (diana_get others 'sm_body))))
			  (cond 
			    ((third (third as))	  ;body suplied?
			     (semgripe 'body_already_spec
				 (implode
				    (uplowlist
				      (cadr (diana_get nod 'lx_symrep)))))
			      	)))
			 (others
			  (diana_put others
				     (third (third as))
				     'sm_body)
			  (diana_put others
				     (first (third as)) 
				     'ct_spec)
			  ))
		       )))
		  as_header nil
		  as_subprogram_def
		  (or
		    (third (third as))
		    (sc_diana dn_void)))  ; procedure defn.
		)
	      symb_procedure
	      (pr_and 
		(lambda(as)
		  (ct_push nil *returntypestack*)
		    (let*
		      ((stub (ada_declared (first as) nil 'procedure t))
		       (this (add_name
			       (first as) ; name
			       'procedure ; class
			       (sc_diana dn_proc_id
					 lx_symrep (first as)
					 sm_spec nil
					 sm_body nil
					 sm_first nil)
			       nil)))
		      (ct_push this *identstack*)
		      (diana_put this stub 'sm_first)
		      (diana_put this (pushproccontext)
				    'ct_named_context)
#|		      (cond
			(stub
			   ;;if any of these have matching specs and come
			   ;;from either here of the corresponding package
			   ;;declaration, we have the def_occurence.
			   (let* ((defo
				    (mapcan
				      #'(lambda(fun)
					  (cond
					    ((eq (diana_nodetype_get
						   (diana_get fun 'sm_body))
						 'dn_stub) (list fun))
					    (t nil)))
				      stub))
				  (defo (find_defo defo)))
			     (cond
			       (defo (diana_put this defo 'sm_first))
			       )
			     )))|#
		      this)		  ;we always return the current one!
		    )
		lex_ident)
	      (pr_and nil
		      (pr_and
			(lambda(as)
			  (diana_put (first *identstack*) (first as) 'sm_spec)
			  (first as))
			(pr_or nil proc_formal_part nil))
		      (pr_and
			  (lambda(as)
			    (let* ((this (first *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 of the corresponding package
				 ;;declaration, we have the def_occurence.
				 (let* ((defo
					  (mapcan
					    #'(lambda(fun)
						(cond
						  ((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)
				      (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_and
			(lambda(as)
			  (popcontext)
			  (first as))
			body_part)
		      (pr_or nil lex_ident nil))) ;if specified, must match.
	    
	    (pr_and 
	      (lambda(as)
		(ct_pop *returntypestack*)
		(cond ((null (ct_pop  *return_stmt_stack*))
		       (semgripe
			 'no_return_statement_in_function
			 (implode
			   (uplowlist
			     (cadr
			       (diana_get (second as) 'lx_symrep)))))))
		(matching_ident (diana_get (second as) 'lx_symrep)
				(ct_pop *identstack*))
		(ct_pop *identstack*)
		(sc_diana dn_subprogram_decl
			  as_designator
			  (do ((nod (second as))
			       (others (diana_get (second as) 'sm_first)
				       (diana_get others 'sm_first)))
			      ((null others) nod)
			    (cond
			      ((third (third as))
			       (diana_put nod
					  (first (third as))
					  'sm_spec)
			       (diana_put nod
					  (fifth (third as))
					  'sm_body)
			       (diana_put nod
					  (first (third as))
					  'sm_spec)
			       (diana_put (first (third as))
					  (third (third as))
					  'as_name_void)
			       (cond 
				 ((and
				    others
				    (diana_get others 'sm_body)
				    (not (stub_p (diana_get others 'sm_body))))
				  (cond 
				    ((fifth (third as))	  ;body suplied?
				     (semgripe 'body_already_spec
				      (implode
					(uplowlist
					  (cadr (diana_get nod 'lx_symrep)))))
                                       )))
				 (others
				  (diana_put others
					     (first (third as)) 
					     'ct_spec)
				  (diana_put others
					     (fifth (third as))
					     'sm_body))))))
			  as_header nil
			  as_subprogram_def
			  (or
			    (fifth (third as))
			    (sc_diana dn_void)))  ; procedure defn.
		)
	      symb_function
	      (pr_or nil 
		     (pr_and
		       (lambda(as)
			 (ct_push nil *return_stmt_stack*)
			 (ct_push nil *returntypestack*)
			   (let*
			     ((stub (ada_declared (first as) nil 'function t))
			      (this (add_name
				      `(lex_ident ,(cadr (first as)))  ; name
				      'function	  ; class
				      (sc_diana dn_function_id
						lx_symrep (first as)
						sm_spec nil
						sm_body nil
						sm_first nil)
				      nil)))
			     (ct_push this *identstack*)
			     (diana_put this stub 'sm_first)
			     (diana_put this (pushproccontext)
				    'ct_named_context)
			     this)	  ;we always return the current one!
			 )
		       lex_ident)
		     operator_symbol)
	      (pr_and nil				
		      (pr_and
			(lambda(as)
			  (cond
			    ((first as)(first as))
			    (t (diana_put (first *identstack*)
				       (sc_diana dn_function)
				       'sm_spec))))
			(pr_and
			  (lambda (as)
			    (diana_put (first *identstack*)
				       (first as)
				       'sm_spec)
			    (first as))
			  (pr_or nil funct_formal_part nil)))
		      symb_return
		      (pr_and
			(lambda (as)
			  (rplaca *returntypestack*
				  (first as))
			  (diana_put
			    (diana_get (first *identstack*) 'sm_spec)
			    (first as)
			    'as_name_void)
			  (first as))
			subtype_indication)
		      (pr_and
			  (lambda(as)
			    (let* ((this (first *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 of the corresponding package
				 ;;declaration, we have the def_occurence.
				 (let* ((defo
					  (mapcan
					    #'(lambda(fun)
						(cond
						  ((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)
				      (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)
				 (ct_push nil *identstack*)
				 (popcontext)
				 (first as))
			       symb_separate)
			     (pr_and 
			       (lambda(as)
				 (ct_push (second as) *identstack*)
				 (first as))
			       (pr_and
				 (lambda(as)
				   (popcontext)
				   (first as))
				 body_part)
			       (pr_or nil 
				      lex_ident
				      operator_symbol
				      nil)))))
	    (pr_and
	      (lambda(as)
		(ct_pop *returntypestack*)
		(matching_ident (third as)(sixth as))	  ;see below ...
		(sc_diana dn_package_body
			  as_id 
			  (sc_diana dn_package_id
				    lx_symrep (third as)
				    sm_body (fifth as))
			  as_block_stub (fifth as)))
	      (pr_and
		(lambda (as)
		  (ct_push 'package *returntypestack*)
		  (first as))
		symb_package)
	      symb_body
	      lex_ident
	      symb_is
	      body_part
	      (pr_or nil lex_ident nil))  ;if specified, must match.
	    (pr_and
	      (lambda(as)
		(ct_pop *returntypestack*)
		(matching_ident (diana_get (third as) 'lx_symrep)
				(sixth as))	  ;see below ...
		(popcontext)
		;;now put the body in to the first.
		;(break put-in-separate-task)
		(diana_put
		  (extract_basetype (third as)) ;which is a dn_task_spec.
		  (fifth as)
		  'sm_body)
		(sc_diana dn_task_body
			  as_id (sc_diana dn_task_body_id
					  sm_first (third as)
					  sm_body (fifth as)
					  sm_type_spec
					  (extract_basetype (third as)))
			  as_block_stub (fifth as)))
	      (pr_and
		(lambda (as)
		  (ct_push 'task *returntypestack*)
		  (first as))
		symb_task)
	      symb_body
	      (pr_and
		(lambda(as)
		  (pushproccontext)
		  (let ((ts (ada_declared (first as) nil 'task)))
		    (install_mixins
		      (list
			(diana_get ts 'ct_named_context)))
		    ts))
		lex_ident)
	      symb_is
	      body_part
	      (pr_or nil lex_ident nil)))))	  ;if specified, must match.
    
;;;-- 11.3  Raise Statements
;;;
;;;-- Syntax 11.3
;;;--  raise_statement ::= 'raise' [name]';'
;;;--
;;;
;;;
;;;    STM ::=              raise;
;;;
;;;    raise =>             as_name_void     : NAME_VOID;
;;;    raise =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;;;;;;
(def_ada_syntax raise_statement
		;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (sc_diana dn_raise
		      as_name_void
		      (cond
			((null (second as))
			 (cond ((null (car *exception_handler_stack* ))
				(semgripe
				  'null_raise_not_in_exception_handler)))
			 (sc_diana dn_void))
			(t (find_name (second as) 'exception)))))
	  symb_raise
	  (pr_or nil (pr_restrict exception name) nil)
	  oper_semicolon))