;;; -*- Mode: lisp;package:user; fonts: CPTFONTB -*-
;;;  $Header: /ct/interp/adas39a.l,v 1.43 84/12/26 16:40:54 penny Exp $
;;;  


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


;;;-- 3.9  Declarative Parts
;;;
;;;-- Syntax 3.9
;;;--  declarative_part ::=
;;;--     {declarative_item} {later_declarative_item}
;;;--  declarative_item ::= declaration | use_clause
;;;--    | representation_specification
;;;--  later_declarative_item ::= body | subprogram_declaration
;;;--   | generic_declaration | use_clause
;;;--   | package_declaration | task_declaration | body_stub
;;;--  body ::= subprogram_body | package_body | task_body
;;;--
;;;
;;;    DECL ::=             REP | use;       --representation is declarative item
;;;
;;;    ITEM_S ::=           item_s;
;;;    ITEM ::=             DECL | package_body | subprogram_body
;;;                         | task_body;
;;;                                                   -- see 3.1, 6.1, 7.1, 10.2
;;;
;;;    item_s =>            as_list          : Seq Of ITEM;
;;;    item_s =>            lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;;;;;;;
(def_ada_syntax declarative_item
		;;;;;;;;;;;;;;;;

	(pr_and car
;;;	    (pr_repeat nil pragma) ; is this really allowed? check-it
		(pr_or nil 
		       pragma		; pragmas are allowed wherever declarations
					; are.
		       use_clause
		       obj_num_exc_declaration
		       type_declaration
		       subtype_declaration
		       representation_specification
		       (pr_and
			 (lambda(as)	; subprogram declaration.
			   (ct_pop *returntypestack*)
			   (popcontext)
			   (sc_diana dn_subprogram_decl
				     as_designator
				     (let ((nod (second as)))
				       (diana_put nod (third as) 'sm_spec)
				       nod)
				     as_header 
				     (sc_diana
				       dn_procedure
				       as_param_s
				       nil)	  ; no header info available
					; yet.
				     ))
			 symb_procedure
			 (pr_and
			   (lambda(as)
			     (ct_push nil *returntypestack*)
			     (prog1
			       (add_name
				 (first as)	  ; procedure name
				 'procedure
				 (sc_diana dn_proc_id
					   lx_symrep (first as)
					   sm_spec nil
					   sm_body (sc_diana dn_stub))
				 nil)
			       (pushproccontext)))
			   lex_ident)
			 (pr_or nil 
				(pr_and cadr symb_is generic_instantiation)
				(pr_and car	  ;++
					(pr_or nil proc_formal_part nil)
					(pr_or nil 
					       (pr_and 
						 (lambda(as)
					  ; what do we do with the
					  ; expression ++
						   (sc_diana dn_rename
							     as_name (second as)))
						 symb_renames
						 (pr_restrict proc_or_entry name)
						 (pr_or nil 
							(pr_and cadr
								oper_lparen
								expression
								oper_rparen)
							nil))
					       nil)))
			 oper_semicolon)
		       (pr_and 
			 (lambda(as)
			   (ct_pop *returntypestack*)
			   (popcontext)
			   (sc_diana dn_subprogram_decl
				     as_designator
				     (let ((nod (second as)))
				       (diana_put nod
						  (first (third as)) 'sm_spec)
				       (diana_put (first (third as))
						  (second (third as))
						  'as_name_void)
				       nod)
				     as_header
				     (sc_diana dn_function
					       as_param_s nil)
				     ))
			 symb_function
			 (pr_and
			   (lambda(as)
			     (ct_push nil *returntypestack*)
			     (prog1
			       (add_name
				 `(lex_ident ,(cadr (first as))) ;function name
				 'function
				 (sc_diana dn_function_id
					   lx_symrep (first as)
					   sm_spec nil
					   sm_body (sc_diana dn_stub)
					   sm_location nil
					   sm_stub nil
					   sm_first nil)
				 nil)
			       (pushproccontext)))
			   (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 cadr
					symb_is
					generic_instantiation)
				(pr_and nil
					(pr_and
					  (lambda(as)
					    (cond
					      ((first as)(first as))
					      (t (sc_diana dn_function))))
					  (pr_or nil funct_formal_part nil))
					(pr_and cadr	  ; temporary fix!++
						symb_return
						(pr_and
						  (lambda (as)
						    (rplaca *returntypestack*
							    (first as))
						    (first as))
						  subtype_indication)
						(pr_or nil 
						       (pr_and cadr
							       symb_renames
							       (pr_restrict
								 function name))
						       nil))))
			 oper_semicolon)
		       (pr_and 
			 (lambda(as)
			   (ct_pop *returntypestack*)
			   (matching_ident
			     (diana_get (second as) 'lx_symrep)
			     (ct_pop *identstack*))
			   (let ((pkg_id (second as)))
			       (cond
				   ((eq (diana_nodetype_get (third as))
					'dn_instantiation)
				       (let ((instantiation
						 (instantiated_spec (third as))))
					   (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)))))
				   (t
				       (diana_put
					   (second as)  ;pkg_id
					   (third as)  ;spec
					   'sm_spec))))
			   (popcontext)
			   (sc_diana dn_package_decl
				     as_id (second as)
				     as_package_def (third as)))
			 symb_package
			 (pr_and
			   (lambda(as)
			     (ct_push 'package *returntypestack*)
			     (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 
				  (lambda(as)
				    (ct_push nil *identstack*)
				    (sc_diana dn_rename
					      as_name (second as)))
				  symb_renames
				  (pr_restrict package name))
				(pr_and cadr
					symb_is
					(pr_or nil 
					       (pr_and
						 (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)))))
			 oper_semicolon)
		       (pr_and (lambda (as)
				 (ct_pop *returntypestack*)
				 (second as))
			       (pr_and
				 (lambda (as)
				   (ct_push 'task *returntypestack*)
				   (first as))
				 symb_task)
			       (pr_or nil 
				      (pr_and 
					(lambda(as)
					  (popcontext)
					  (matching_ident (first as)
							  (ct_pop *identstack*))
					  (sc_diana dn_task_decl
						    as_id (first as)
						    as_task_def (second as)))
					(pr_and
					  (lambda(as)
					    (add_name
					      (first as)
					      'task
					      (sc_diana dn_var_id
							lx_symrep
							(first as)
							ct_named_context
							(pushcontext))
					      nil)
					    )
					  lex_ident)
					(pr_or nil 
					       (pr_and 
						 (lambda(as)
						   (ct_push nil *identstack*)
						   (sc_diana dn_rename
							     as_name (second as)))
						 symb_renames
						 (pr_restrict task name))
					       (pr_and 
						 (lambda(as)
						   (ct_push (third as)
							    *identstack*)
						   (second as))
						 symb_is
						 task_spec_part
						 (pr_or nil lex_ident nil))
					       nil))
				      (pr_and 
					(lambda(as)
					  (matching_ident (second as)
							  (ct_pop *identstack*))
					  (let* ((ttd
						   (sc_diana
						     dn_var_id
						     lx_symrep (second as)
						     sm_obj_type (third as)))
						 (td
						   (sc_diana
						     dn_task_decl
						     as_id ttd
						     as_task_def (third as))))
					    (add_name
					      (second as)
					      'task
					      ttd
					      nil)
					    td))
					symb_type
					lex_ident
					(pr_or nil 
					       (pr_and 
						 (lambda(as)
						   (ct_push (third as)
							    *identstack*)
						   (second as))
						 symb_is
						 task_spec_part
						 (pr_or nil lex_ident nil))
					       nil)))
			       oper_semicolon)
		       (pr_and
			 (lambda(as)
			   (ct_pop *current_generic_nestitude*)
			   (first as))
			       generic_specification
			       oper_semicolon))
		)
    )
    
;;;-- Syntax 3.6.B
;;;--  index ::= type_mark 'range' '<>'
;;;--
;;;
;;;
;;;    DSCRT_RANGE ::=      index;
;;;
;;;    index =>             as_name          : NAME;
;;;    index =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;;
(def_ada_syntax index_range
		;;;;;;;;;;;

	(pr_and 
	  (lambda(as)
	    (cond
	      ((and (consp (second as))
		    (eq (first (second as)) 'oper_dotdot))	  ; range
	       (sc_diana dn_range
			 as_exp1 (first as)
			 as_exp2 (second (second as))
			 sm_base_type (find_type_for_range (first as)
					  (second (second as)))))
	      ((second as)		  ; constrained.
	       (sc_diana dn_constrained
			 as_name (first as)
			 as_constraint (second as)))
	      (t ;; simple_expression must be a typemark need to check
	       (cond ((eq (diana_nodetype_get (first as))
			  'dn_parenthesized)
		      (semgripe 'erroneous_non_range_expression)
		      (first as))
		     ((and
			(eq (diana_nodetype_get (first as))
			  'dn_used_name_id)
			(diana_get (first as) 'sm_defn)
			(memq (diana_nodetype_get
				(diana_get (first as) 'sm_defn))
			    '(dn_type_id dn_subtype_id)))
		      (first as))
		     ((and (eq (diana_nodetype_get (first as))
			       'dn_attribute_call)
			   (equal
			     (diana_get
			       (diana_get
				 (diana_get (first as) 'as_name)
				 'as_id)
			       'lx_symrep)
			     (ada_ident range)))
		      (first as))
		     (t
		      (semgripe 'range_in_for_must_be_a_discrete_type)
		      (first as))))
	      ))
	  simple_expression
	  (pr_or nil 
		 (pr_and nil oper_dotdot simple_expression)
		 range_constraint
		 nil))) 

;;;-- Syntax 3.7.B
;;;--  component_list ::=
;;;--     component_declaration {component_declaration}
;;;--   | {component_declaration} variant_part | 'null' ';'
;;;--  component_declaration ::=
;;;--     identifier_list ':' subtype_indication
;;;--                            [':=' expression] ';'
;;;--
;;;
;;;
;;;    COMP ::=             var | null_comp | variant_part;
;;;                                          -- where 'ID' is always a 'comp_id'.
;;;
;;;    COMP ::=             pragma;          -- pragmas are allowed in
;;;                                          -- component declarations
;;;
;;;    null_comp =>         lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    DEF_ID ::=           comp_id;
;;;
;;;    comp_id =>           lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    comp_id =>           sm_obj_type      : TYPE_SPEC,
;;;                         sm_init_exp      : EXP_VOID;
;;;    comp_id =>           cd_position      : Integer,
;;;                         cd_first_bit     : Integer,
;;;                         cd_last_bit      : Integer;
;;;
		;;;;;;;;;;;;;;
(def_ada_syntax component_list
		;;;;;;;;;;;;;;

     (pr_or nil 
	    (pr_and 
	      (lambda(as)
		(cons (sc_diana dn_null_comp) nil))
	      symb_null 
	      oper_semicolon)
	    (pr_and
	      (lambda(as)
		(cond
		  ((null (second as))(first as))
		  (t (append (first as)(list (second as))))))
	      (pr_repeat
		(lambda(as)
		  (mapcar
		    #'(lambda(part)
			(let ((type
				(cond
				  ((is_subtype_ind_init (fourth part))
				   (subtype_ind_init%sub_ind
				     (fourth part)))))
			      (init
				(cond
				  ((is_subtype_ind_init (fourth part))
				   (subtype_ind_init%initexp
				     (fourth part)))))
			      (part_type
				(cond
				  ((is_subtype_ind_init
				     (fourth part))
				   (subtype_ind_init%sub_ind
				     (fourth part)))
				  (t	  ; constrained array
				   (first (fourth part))))))
			  (cond ((and
				    (first as)
				    (null (extract_basetype type)))
				    (semgripe 'incomplete_type)))
			  (cond
			    ((and init (null (assignment_compatible  init type)))
			     (semgripe 'init_exp_wrong_type)))
			  (cond
			    ((non_constant_unconstrained_array_type_p type)
			     (cond (init
				    (semgripe
				      'non_constant_unconstrained_array_type))
				   (t (semgripe
					'unconstrained_array_declaration)))))
			  (sc_diana dn_var
				    as_object_def
				    (let ((def (cond
						 ((is_subtype_ind_init
						    (fourth part))
						  (and (subtype_ind_init%initexp
							 (fourth part))
						       (diana_put
							 (subtype_ind_init%initexp
							   (fourth part))
							 part_type
							 'sm_exp_type))
						  (subtype_ind_init%initexp
						    (fourth part)))
						 (t	  ;array aggregate (if present).
						  (and (second (fourth part))
						       (diana_put
							 (second (fourth part))
							 part_type
							 'sm_exp_type))
						  (second (fourth part))
						  ))))
				      (and def (let ((cp (diana_copy def)))
						 (cond ((eq (diana_nodetype_get cp)
							    'dn_aggregate)
							(normalize_aggregate cp)))
						 cp)))
				    as_type_spec part_type
				    as_id_s
				    (nreverse
				      (mapcar
					#'(lambda(id)
					    (add_name
					      (diana_get id 'lx_symrep)
					      'object
					      (let*
						((part_type
						   (cond
						     ((is_subtype_ind_init
							(fourth part))
						      (subtype_ind_init%sub_ind
							(fourth part)))
						     (t	  ; constrained array.
						      (first (fourth
							       part)))))
						 (compid id))
						(diana_put 
						  compid
						  (cond
						    ((is_subtype_ind_init
						       (fourth part))
						     (and (subtype_ind_init%initexp
							    (fourth part))
							  (diana_put
							    (subtype_ind_init%initexp
							      (fourth part))
							    part_type
							    'sm_exp_type))
						     (subtype_ind_init%initexp
						       (fourth part)))
						    (t	  ; array aggregate
					  ; (if present)
						     (and
						       (second
							 (fourth part))
						       (diana_put
							 (second (fourth
								   part))
							 part_type
							 'sm_exp_type))
						     (second (fourth
							       part))))
						  'sm_init_exp)
						
						(diana_put compid
							   part_type 'sm_obj_type)
						(diana_put compid compid 'sm_defn)
						compid)
					      nil))	  ;put tparent type defn here..
					(cons (first part)(second part)))))))
		    as))
		(pr_and nil
			(pr_and
			  (lambda (as)
			    (let ((node (sc_diana dn_comp_id
						  lx_symrep (first as))))
			      (adjust_source_pos node -1 -1)
			      node))
			  lex_ident)
			(pr_repeat nil
				   (pr_and cadr oper_comma
					   (pr_and
					     (lambda (as)
					       (let ((node
						       (sc_diana dn_comp_id
								 lx_symrep
								 (first as))))
						 (adjust_source_pos node -1 -1)
						 node))
					     lex_ident)))
			oper_colon
			(pr_or nil 
			       subtype_indication_init
			       constrained_array_type_definition_init)
			oper_semicolon))
	      (pr_or nil
		     (pr_and 
		       (lambda(as)
			 (sc_diana dn_variant_part
				   as_name (first ;++ need to fix this pr.
					     (ada_declared
					     (second as)
					     nil 'object t))
				   as_variant_s
				   (sc_diana dn_variant_s
					     as_list (fourth as))))
		       symb_case
		       lex_ident
		       symb_is
		       component_list_when_part
		       symb_end
		       symb_case
		       oper_semicolon)
		     nil))))

(defun static_choicep(ch)
  (and
    (diana_nodep ch)
    (ct_selectq
      (diana_nodetype_get ch)
      ((dn_numeric_literal dn_enum_id dn_def_char
	dn_number_id)
       t)
      ((dn_type_id ;check that it is statically constrained
	dn_derived dn_constrained)
       (static_choicep (find_constraint_for ch)))
      (dn_subtype_id
	(static_choicep (diana_get ch 'sm_type_spec)))
      (dn_range
	(and (static_choicep (diana_get ch 'as_exp1))
	     (static_choicep (diana_get ch 'as_exp2))))
      (dn_used_name_id
	(static_choicep (diana_get ch 'sm_defn)))
      ((dn_var_id dn_const_id)
       nil)
      (otherwise
	(cond ((neq (fe_static_eval ch)
		   '*diana_node_not_static_expression*)
	       t))))))
    
		;;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax component_list_when_part
		;;;;;;;;;;;;;;;;;;;;;;;;

	(pr_and cadr
		symb_when
		(pr_or nil 
		       (pr_and 
			 (lambda(as)
			   (list
			     (sc_diana dn_variant
				       as_choice_s (list (sc_diana dn_others))
				       as_record
				       (sc_diana dn_inner_record
						 as_list (third as)))))
			 symb_others 
			 oper_goes 
			 component_list)
		       (pr_and 
			 (lambda(as)
			   (let ((chs (cons (first as)(second as))))
			     (mapc
			       #'(lambda (ch)
				   (cond
				     ((null (static_choicep ch))
				      (semgripe 'not_static_choice
						(source_region%linenumber
						  (diana_get ch 'lx_srcpos))))))
				   chs)
			     (cons
			       (sc_diana dn_variant
					 as_choice_s chs
					 as_record
					 (sc_diana dn_inner_record
						   as_list (fourth as)))
			       (fifth as))))
			 choice_range
			 (pr_repeat nil
				    (pr_and cadr oper_bar choice_range))
			 oper_goes
			 component_list
			 (pr_or nil component_list_when_part nil)))))
    
		;;;;;;;;;;;;
(def_ada_syntax choice_range
		;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (cond
	      ((and (consp (second as))
		    (eq (first (second as)) 'oper_dotdot))	  ; range
	       (sc_diana dn_range
			 as_exp1 (first as)
			 as_exp2 (second (second as))
			 sm_base_type (find_type_for_range (first as)
					  (second (second as)))))
	      ((null (second as))	  ; expression.
	       (first as))
	      (t			  ; constrained.
	       (sc_diana dn_constrained
			 as_name (first as)
			 as_constraint (second as)))))
	  simple_expression
	  (pr_or nil 
		 range_constraint
		 (pr_and nil oper_dotdot simple_expression)
		 nil)))
    
;;;-- 3.7.1  Discriminants
;;;
;;;-- Syntax 3.7.1
;;;--  discriminant_part ::=
;;;--     '(' discriminant_declaration
;;;--                        {';' discriminant_declaration}')'
;;;--  discriminant_declaration ::=
;;;--     identifier_list ':' subtype_indication [:= expression]
;;;--
;;;
;;;
;;;    VAR_S ::=            var_s;
;;;
;;;    var_s =>             as_list          : Seq Of VAR;
;;;    var_s =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    VAR ::=              var;             -- where 'ID' is always a 'dscrmt_id'
;;;
;;;    VAR ::=              pragma;          -- pragma can occur after ';'
;;;                                          -- in discriminant list
;;;
;;;    DEF_ID ::=           dscrmt_id;
;;;                                                   -- see section 3.2.A
;;;
;;;    dscrmt_id =>         lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    dscrmt_id =>         sm_obj_type      : TYPE_SPEC,
;;;                         sm_init_exp      : EXP_VOID;
;;;    dscrmt_id =>         cd_position      : Integer,
;;;                         cd_first_bit     : Integer,
;;;                         cd_last_bit      : Integer;
;;;
		;;;;;;;;;;;;;;;;;
(def_ada_syntax discriminant_part
		;;;;;;;;;;;;;;;;;

	(pr_and cadr
		(pr_and
		  (lambda (as)
		    (setq *numdiscs* 0 *numinitexp* 0)
		    (first as))
		  oper_lparen)
		discriminant_part_body
		(pr_and
		  (lambda (as)
		    (cond ((and (> *numinitexp* 0)
				(> *numdiscs* *numinitexp*))
			   (semgripe 'all_or_none_of_discs_default)))
		    (first as))
		  oper_rparen)))
    

		;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax discriminant_part_body
		;;;;;;;;;;;;;;;;;;;;;;

 (pr_and
   (lambda(as)
     (let*
       ((vars 
	  (sc_diana
	    dn_dscrmt_var_s
	    as_list 
	    (cons
	      (sc_diana
		dn_var
		as_id_s
		(mapcar 
		  '(lambda(id)
		     (%= *numdiscs* (1+ *_*))
		     (cond ((subtype_ind_init%initexp
			      (fourth as))
			    (%= *numinitexp* (1+ *_*))))
		     (add_name
		       id
		       'object
		       (let
			 ((did
			    (sc_diana dn_dscrmt_id
				      lx_symrep id
				      sm_obj_type
				      (subtype_ind_init%sub_ind
					(fourth as))
				      sm_init_exp
				      (subtype_ind_init%initexp
					(fourth as))	
				      )))
			 (diana_put did did 'sm_defn)
					  ;check each disc is a dscrt type
			 (cond ((and (subtype_ind_init%sub_ind
				       (fourth as))
				     (not (is_discrete_subtype
					    (subtype_ind_init%sub_ind
					      (fourth as)) nil)))
				(semgripe 'disc_not_dscrt)))
			 did)
		       nil))
		  (cons (first as)(second as)))
		as_type_spec
		(subtype_ind_init%sub_ind (fourth as))
		as_object_def (subtype_ind_init%initexp
				(fourth as))
		)
	      (and (fifth as)(diana_get (fifth as) 'as_list))))))
     vars))
   lex_ident
   (pr_repeat nil (pr_and cadr oper_comma lex_ident))
   oper_colon
   subtype_indication_init
   (pr_or nil
	  (pr_and cadr
		  oper_semicolon
		  discriminant_part_body)
	  nil)))