;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;  $Header: /ct/interp/adas44.l,v 1.59 84/10/23 17:41:23 penny Exp $

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

(defun stub_p(dn)(eq (diana_nodetype_get dn) 'dn_stub))

		;;;;;;;;;;;;;;;;;
(def_ada_syntax program_component
		;;;;;;;;;;;;;;;;;

	(pr_or
	  nil pragma			  ; allow pragmas as program components.
	  (pr_and
	    car				  ; throw away the semicolon.
	    (pr_or
	      nil  
	      (pr_and
		(lambda(as)
		  (matching_ident
		    (diana_get (second as) 'lx_symrep)
		    (ct_pop *identstack*))
		  (setq *current_generic_nestitude*
			   (ct_pop *generic_nestitude_stack*))
		  (ct_pop *identstack*)	  ;pop off the id node.
		  (sc_diana dn_subprogram_decl
			    as_designator
			    (let ((nod (second as))
				  (others (diana_get (second as) 'sm_first)))
;			      (break in-program-component)
			      (cond
				((third (third as))
				 (cond ((eq (diana_nodetype_get (third (third as)))
					    'dn_instantiation)
;					(break instantiating)
					(let ((instantiation
						(instantiated_spec
						       (third (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
						     (first (third as))
						     'sm_spec)
					  (diana_put nod
						     (third (third as))
						     'sm_body)))
				 (cond
				   (others
				    (diana_put others
					       (first (third as))
					       'ct_spec)))
				 (cond 
				   ((and
				      others
				      (diana_get others 'sm_body)
				      (not (stub_p (diana_get others 'sm_body)))))
				   (others
				    (cond ((eq (diana_nodetype_get
						 (third (third as)))
					       'dn_instantiation)
					   (let ((instantiation
						   (instantiated_spec
						     (third (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
							(first (third as))
							'ct_spec)
					     (diana_put others
							(third (third as))
							'sm_body)))
;					(break installed-body-and-spec)
				    ))))
			      
			      nod)
			    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 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 nil
					   sm_location nil
					   sm_stub nil
					   sm_first nil)
				 nil)))
;			(break look-at=stub)
			(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.
			(ct_push *current_generic_nestitude*
				 *generic_nestitude_stack*)
			(diana_put this stub 'sm_first)
			this))		  ;we always return the current one!
		  lex_ident)
		(pr_and
		  (lambda (as)
		    (list (first as);formal_part
			  (first (second as));symb_is
			  (cond ((null (second as))
				 (popcontext)
				 (ct_push nil *identstack*)
				 (sc_diana dn_stub))
				(t (second (second as))))));body
		  (pr_and
		    (lambda(as)
		      (diana_put
			(first *identstack*)
			(first as)
			'sm_spec)
		      (first as))
		    (pr_or nil proc_formal_part nil))
		  (pr_or
		    nil
		    (pr_and
		      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_or
			nil 
			(pr_and
			  (lambda(as)
			    (ct_push nil *identstack*)
			    (popcontext)  ;leave proc context before decl.
			    (sc_diana dn_stub))
			  symb_separate)
			(pr_and 
			  (lambda(as)
			    (ct_push nil *identstack*)
			    (popcontext)
			    (first as))
			  generic_instantiation)
			(pr_and 
			  (lambda(as)
			    (ct_push (second as) *identstack*)
			    (first as))
			  (pr_and
			    (lambda(as)
			      (popcontext)
			      ;;leave procedure context before decl.
			      (first as))
			    body_part)
			  (pr_or nil lex_ident nil))))
		    (pr_and 
		      (lambda(as)
			(let* ((this (first *identstack*))
			       (that (sc_diana dn_rename
						    as_name nil))
			       (stub (with_same_type_profile
				       this
				       (second as))))
			  (ct_push nil *identstack*)
			  (popcontext)
			  (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 (find_defo stub)))
			       (cond
				 (defo 
				  (diana_put that defo 'as_name)
				  (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*))
				 (t (semgripe 'not_the_same_profile_in_rename
					 (implode
					   (uplowlist
					     (cadr
					       (diana_get this 'lx_symrep)))))))
			       (diana_put this
					  that
					  'sm_body)))
			    (t (semgripe 'not_the_same_profile_in_rename
					 (implode
					   (uplowlist
					     (cadr
					       (diana_get this 'lx_symrep)))))))
			  (list that))
			)
		      symb_renames
		      (pr_restrict proc_or_entry name)
		      (pr_or nil
			     (pr_and nil
				     oper_lparen
				     expression
				     oper_rparen)
			     nil))
		    nil)))
	      (pr_and 
		(lambda(as)
		  (ct_pop *returntypestack*)
		  ;(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 off the id node.
		  (sc_diana dn_subprogram_decl
			    as_designator
			    (let ((nod (second as))
				  (others (diana_get (second as) 'sm_first)))
			      (cond
				((fifth (third as))
				 (cond
				   ((eq (diana_nodetype_get (fifth (third as)))
					'dn_instantiation)
;				    (break about-to-instantiate)
				    (let ((instantiation
					    (instantiated_spec
					      (fifth (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
				      (first (third as))
				      'sm_spec)
				    (diana_put
				      (first (third as))  ;a dn_function
				      (third (third as))  ;a subtypeind
				      'as_name_void)
				    (diana_put
				      nod
				      (fifth (third as))
				      'sm_body)
				    ))
				 (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
				    (cond
				      ((eq (diana_nodetype_get
					     (fifth (third as)))
					   'dn_instantiation)
				       (let ((instantiation
					       (instantiated_spec
						 (fifth (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
					 (first (third as)) 
					 'ct_spec)
				       (diana_put
					 others
					 (fifth (third as))
					 'sm_body)))))))
			      nod)
			    as_header nil
			    as_subprogram_def
			    (or
			      (fifth (third as))
			      (sc_diana dn_stub)))
		  )
		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_spec nil
					   sm_body nil
					   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!
		    )
		  (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_and
		  (lambda(as)
		    (list (first as);formal-part
			  (second as);symb_return
			  (third as);return type
			  (first (fourth as));symb is
			  (cond ((null (fourth as))
				 (ct_push nil *identstack*)
				 (rplaca *return_stmt_stack* t)
				 (popcontext)
				 (sc_diana dn_stub))
				(t (second (fourth as))))));body
		  (pr_and
		    (lambda(as)
		      (let
			((spc
			   (cond
			     ((first as)(first as))
			     (t (sc_diana dn_function)))))
			(diana_put
			  (first *identstack*)
			  spc
			  'sm_spec)
			spc))
		    (pr_or nil funct_formal_part nil))
		  (pr_or nil symb_return nil)
		  (pr_and
		    (lambda(as)
		      (diana_put
			(diana_get (first *identstack*) 'sm_spec)
			(cond
			  ((first as)(first as))
			  (t (sc_diana dn_void)))
			'as_name_void)
		      (first as))
		    (pr_or nil
			   (pr_and
			     (lambda (as)
			       (rplaca *returntypestack*
				       (first as))
			       (first as))
			     subtype_indication)
			   nil))
		  
		  (pr_or
		    nil
		    (pr_and
		      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_or nil 
			     (pr_and
			       (lambda(as)
				 (rplaca *return_stmt_stack* t)
				 (ct_push nil *identstack*)
				 (popcontext)
				 (sc_diana dn_stub))
			       symb_separate)
			     (pr_and 
			       (lambda(as)
				 (rplaca *return_stmt_stack* t)
				 (ct_push nil *identstack*)
				 (popcontext)
				 (first as))
			       generic_instantiation)
			     (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)
			(setq *function_name_only* nil)
			(let* ((this (first *identstack*))
			       (that (sc_diana dn_rename
					       as_name nil))
			       (stub (with_same_type_profile
				       this
				       (second as))))
			  (ct_push nil *identstack*)
			  (popcontext)
			  (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 (find_defo stub)))
			       (cond
				 (defo 
				  (diana_put that defo 'as_name)
				  (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*))
				 (t (semgripe 'not_the_same_profile_in_rename
					      (implode
						(uplowlist
						  (cadr
						    (diana_get this 'lx_symrep)))))))
			       (diana_put this
					  that
					  'sm_body)))
			    (t (semgripe 'not_the_same_profile_in_rename
					 (implode
					   (uplowlist
					     (cadr
					       (diana_get this 'lx_symrep)))))))
			  (list that)))
		      (pr_and
			(lambda (as)
			  (rplaca *return_stmt_stack* t)
			  (setq *function_name_only* t)
			  (car as))
			symb_renames)
		      (pr_restrict function name))
		    nil)))
	      (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)))
				   (cond
				     ((eq (diana_nodetype_get
					    (second as))
					  'dn_rename)
				      (diana_put
					pkg_id
					(let*
					  ((smdef
					     (diana_get
					       (diana_get
						 (second as)
						 'as_name)
					       'sm_defn))
					   (ctn1
					     (and smdef
						  (diana_get
						    smdef
						    'ct_named_context))))
					  ctn1)
					'ct_named_context)))
				   (cond
				     ((eq (diana_nodetype_get (second as))
					  'dn_instantiation)
				      (let ((instantiation
					      (instantiated_spec (second 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
					(second 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 (second as))))
			      
				 (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)
				     (diana_put
				       this_pkg
				       **current_block** 'ct_named_context)
				     this_pkg))
				 lex_ident)
				 
			       (pr_or
				 nil
				 (pr_and
				   cadr
				   symb_is
				   (pr_or nil
					  (pr_and car
						  package_spec_part
						  (pr_or nil lex_ident
							 nil))
					  generic_instantiation))
				 (pr_and (lambda(as)
					  ;(break look-at-secondas)
					   (sc_diana dn_rename 
						     as_name (second as)))
					 symb_renames
					 (pr_restrict package name)
					 )))
			     (pr_and
			       (lambda(as)
				 (popcontext)
				 (setq *current_generic_nestitude*
				       (ct_pop *generic_nestitude_stack*))
				 (matching_ident (ct_pop *identstack*)
						 (diana_get (ct_pop *identstack*)
							    'lx_symrep))
				 (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))))
				     (sc_diana dn_package_body
					       as_id nu_pkg
					       as_block_stub (fourth 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 look-at-hid-con)
				     (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*)
					  (sc_diana dn_stub))
					symb_separate)
				      (pr_and (lambda(as)
						(ct_push (second as) *identstack*)
						(first as))
					      body_part
					      (pr_or nil
						     lex_ident
						     nil)))))
		      )			  ;oper_semicolon)
	      (pr_and nil 
		      symb_body
		      lex_ident
		      symb_is
		      (pr_or nil 
			     (pr_and
			       (lambda(as)
				 (sc_diana dn_stub))
			       symb_separate)
			     (pr_and car
				     body_part
				     (pr_or nil lex_ident nil))))
	      
	      (pr_and (lambda (as)
			(ct_pop *returntypestack*)
			(second as)) 	  ;task++
		      (pr_and
			(lambda (as)
			  (ct_push 'task *returntypestack*)
			  (first as))
			symb_task)
		      (pr_or nil 
			     (pr_and 
			       (lambda(as)
				 (matching_ident (first as)(fourth 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
					   (add_name
					     (first as)
					     'task
					     (sc_diana dn_var_id
						       lx_symrep (first as))
					     nil)))
				     (diana_put vid (pushcontext)
						'ct_named_context)
				     vid))
				 lex_ident)
			       (pr_or nil
				      (pr_and cadr
					      symb_is
					      task_spec_part
					      (pr_or nil lex_ident nil))
				      (pr_and cadr
					     symb_renames
					     (pr_restrict task name))
				      nil))
			     (pr_and
			       (lambda (as)
				 (let* ((ttd (sc_diana dn_type_id
						       lx_symrep (second as)
						       sm_type_spec (third as)))
					(td (sc_diana dn_type
						      as_id ttd
						      as_type_spec (third as))))
				   (add_name
				     (second as)
				     'type
				     ttd
				     nil)
				   td))
			       symb_type
			       lex_ident
			       symb_is
			       task_spec_part
			       (pr_or nil lex_ident nil))
			     (pr_and
			       (lambda(as)
				 ;;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)))
				   (sc_diana dn_task_body
					     as_id (second as)
					     as_block_stub (fourth as)))
			       symb_body
			       (pr_and
				 (lambda(as)
				   (pushproccontext)
				   (let ((ts (ada_declared (first as) nil
							   '(task type))))
				     (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)))))
#|			     (pr_and
			       (lambda(as)
				 (popcontext)
				 (break pc_task-body)
				 (sc_diana dn_task_body
					   as_id  (second as)
					   as_block_stub (fourth as)))
			       symb_body
			       (pr_and
				 (lambda(as)
				   (let ((ts (ada_declared (first as) nil 'task)))
				     (pushproccontext)
				     (install_mixins
				       (list
					 (diana_get ts 'ct_named_context)))
				     ts))
				 lex_ident)
			       symb_is
			       (pr_or nil 
				      (pr_and
					(lambda(as)
					  (sc_diana dn_stub))
					symb_separate)
				      (pr_and
					(lambda(as)
					  (first as))
					body_part
					(pr_or nil lex_ident nil)))) |#
			     ))
	      (pr_and 
		(lambda(as)
		  (matching_ident (fourth as)(seventh as))
		  (prog1
		    (sc_diana dn_generic
			    as_id
			    (add_name
			      (fourth as)
			      'generic
			      (sc_diana dn_generic_id
					lx_symrep (fourth as)
					sm_generic_param_s (second as)
					sm_body (sc_diana dn_void)
					)
			      nil)
			    as_generic_param_s (second as)
			    as_generic_header  (sixth as))
		    (ct_pop *current_generic_nestitude*)))
		(pr_and
		  (lambda(as)
		    (ct_push (gensym)  *current_generic_nestitude*)
		    (first as))
		  symb_generic)
		generic_formal_parameter
		symb_package
		lex_ident
		symb_is
		package_spec_part
		(pr_or nil lex_ident nil))
	      (pr_and
		   (lambda(as)		  ; build up into a list.
		     (putback_symbol 'oper_semicolon)	  ;what a crock!
		     (first as))
		   use_clause))
	    oper_semicolon)))