;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;  $Header: /ct/interp/adas50.l,v 1.51 85/01/30 11:18:50 penny Exp $
;;;  

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


;;;-- 4.4  Expressions
;;;
;;;-- Syntax 4.4.A
;;;--  expression ::=
;;;--     relation {'and' relation}
;;;--   | relation {'or' relation}
;;;--   | relation {'xor' relation}
;;;--   | relation {'and' 'then' relation}
;;;--   | relation {'or' 'else' relation}
;;;--
;;;
;;;
;;;    EXP ::=              binary;          -- only for short-circuit
;;;                                          -- expressions
;;;
;;;    binary =>            as_exp1          : EXP,
;;;                         as_binary_op     : BINARY_OP,
;;;                         as_exp2          : EXP;
;;;    binary =>            lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    binary =>            sm_exp_type      : TYPE_SPEC,  -- always the TYPE_SPEC
;;;                                          -- of the predefined binary type
;;;                         sm_value         : value;
;;;
;;;
;;;    BINARY_OP ::=        SHORT_CIRCUIT_OP;
;;;    SHORT_CIRCUIT_OP ::= and_then | or_else;
;;;
;;;    and_then =>          lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    or_else  =>          lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- Syntax 4.4.B
;;;--  relation ::=
;;;--     simple_expression [relational_operator simple_expression]
;;;--   | simple_expression ['not'] 'in' range
;;;--   | simple_expression ['not'] 'in' subtype_indication
;;;--
;;;
;;;
;;;    EXP ::=              membership;
;;;    TYPE_RANGE ::=       RANGE;
;;;    TYPE_RANGE ::=       CONSTRAINED;
;;;
;;;    membership =>        as_exp           : EXP,
;;;                         as_membership_op : MEMBERSHIP_OP,
;;;                         as_type_range    : TYPE_RANGE;
;;;    membership =>        lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    membership =>        sm_exp_type      : TYPE_SPEC,  -- always the TYPE_SPEC
;;;                                          -- of the predefined boolean type
;;;                         sm_value         : value;
;;;
;;;
;;;    MEMBERSHIP_OP ::=    in_op | not_in;
;;;
;;;    in_op =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    not_in =>            lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- Syntax 4.4.C
;;;--  simple_expression ::=
;;;--     [unary_operator] term {adding_operator term}
;;;--  term ::= factor {multiplying_operator factor}
;;;--  factor ::= primary ['**' primary]
;;;--  primary ::=
;;;--     literal | aggregate | name | allocator | function_call
;;;--   | type_conversion | qualified_expression | '('expression')'
;;;--
;;;
;;;
;;;    EXP ::=              NAME;
;;;    EXP ::=              parenthesized;
;;;                                          -- This is not a construct in the
;;;                                          -- Formal Definition.
;;;                                          -- see 4.4.A, 4.1, 4.8, 6.4, 4.6, 4.7
;;;
;;;    parenthesized =>     as_exp           : EXP;
;;;    parenthesized =>     lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    parenthesized =>     sm_exp_type      : TYPE_SPEC,
;;;                         sm_value         : value;
;;;
;;;-- 4.5  Operators and Expression Evaluation
;;;
;;;-- Syntax 4.5
;;;--  logical_operator ::= 'and' | 'or' | 'xor'
;;;--
;;;--  relational_operator ::= '=' | '/=' | '<' | '<=' | '>' | '>='
;;;--
;;;--  adding_operator ::= '+' | '-' | '&'
;;;--
;;;--  unary_operator ::= '+' | '-' | 'not'
;;;--
;;;--  multiplying_operator ::= '*' | '/' | 'mod' | 'rem'
;;;--
;;;--  exponentiating_operator ::= '**'
;;;--
;;;
;;;    -- operators are incorporated in function calls, see 3.3.3 of rationale
;;;
		;;;;;;
(def_ada_syntax factor
		;;;;;;

	(pr_and 
	  (lambda(as)
	    (cond
	      ((null (second as))(first as))
	      (t (sc_function_call 
		   (cons 'factor (list (first as) (list (second as))))))))
	  primary 
	  (pr_or nil 
		 (pr_and nil 
			 oper_starstar 
			 primary) 
		 nil)))
    
		;;;;;;;;;;
(def_ada_syntax expression
		;;;;;;;;;;

	(pr_and 
	  (lambda(as)
	    (cond
	      ((null (second as))(first as))
	      ((memq (caar (second as)) '(symb_and_then symb_or_else))
	       (cond			  ;make sure its args are boolean exprs.
		 ((not
		    (and
		      (boolean_expression_p (first as))
		      (boolean_expression_p (cadar (second as)))))
		  (semgripe		  ;ERRMSG
		    'arg_to_scop_not_bool)))
#|	        (sc_diana dn_binary
			 as_exp1 (first as)
			 as_exp2 (cadar (second as))
			 as_binary_op
			 (cond
			   ((eq (caar (second as)) 'symb_and_then)
			    (sc_diana dn_and_then))
			   (t
			    (sc_diana dn_or_else))))
|#
	       (sc_function_call (cons 'expression as)))
	      (t (sc_function_call (cons 'expression as)))))
	  relation
	   (pr_repeat nil
		     (pr_and nil 
			     (pr_or nil 
				    symb_xor
				    (pr_and
				      (lambda(as)
					(cond
					  ((null (second as)) 'symb_or)
					  (t 'symb_or_else)))
				      symb_or
				      (pr_or nil symb_else nil))
				    (pr_and
				      (lambda(as)
					(cond
					  ((null (second as)) 'symb_and)
					  (t 'symb_and_then)))
				      symb_and
				      (pr_or nil symb_then nil)))
			     relation))))
    
		;;;;
(def_ada_syntax term
		;;;;

	(pr_and 
	  (lambda(as)
	    (cond 
	      ((null (second as))(first as))
	      (t (sc_function_call (cons 'term as)))))
	  factor
	  (pr_repeat nil
		     (pr_and nil 
			     (pr_or nil 
				    oper_star
				    oper_slash
				    symb_mod
				    symb_rem)
			     factor))))
    
		;;;;;;;;
(def_ada_syntax relation
		;;;;;;;;

	(pr_and 
	  (lambda(as)
	    (cond
	      ((null (second as))(first as))
	      ((and (consp (second as))(eq (car (second as)) 'oper_notequals))
	       (sc_function_call
		 (list
		   'not_equals_transformation
		   (sc_function_call
		     (cons 'relation
			   (list (first as)
				 (list (list 'oper_equals (second (second as)))))))
		   '((symb_not)))))		 
	      ((and (diana_nodep (second as))
		    (eq (diana_nodetype_get (second as)) 'dn_membership))
	       (diana_put (second as) (first as) 'as_exp)
	       (extract_basetype (first as))
	       (second as))
	      (t (sc_function_call 
		   (cons 'relation (list (first as)(cdr as)))))))
	  simple_expression
	  (pr_or nil 
		 (pr_and nil
			 (pr_or nil 
				oper_equals
				oper_notequals
				oper_lt
				oper_le
				oper_gt
				oper_ge)
			 simple_expression)
		 (pr_and
		   (lambda(as)
		     (extract_basetype (second as));; force attribute checking
		     (sc_diana dn_membership
			       as_exp nil ;gets filled in later.
			       as_membership_op
			       (cond ((eq (first as) 'symb_in)
				      (sc_diana dn_in_op))
				     (t (sc_diana dn_not_in)))
			       sm_exp_type (extract_basetype
					     (ada_declared
					       (ada_ident boolean) nil 'type))
			       as_type_range (second as)
			       ))
		   (pr_or nil
			  (pr_and
			    (lambda(as)
			      'symb_notin)
			    symb_not
			    symb_in)
			  symb_in)
		   (pr_and
		     (lambda(as)
		       (cond
			 ((and (consp (second as))
			       (eq (first (second as)) 'oper_dotdot))
			  (sc_diana dn_range
					  as_exp1 (first as)
					  as_exp2 (second (second as))))
			 ((null (second as))(first as));shud check for typemark.
			 (t (sc_diana dn_constrained
				      as_name (first as)
				      as_constraint (second as)))))
		     simple_expression
		     (pr_or nil 
			    (pr_and nil
			      oper_dotdot
			      simple_expression)
			    range_constraint
			    fixed_point_constraint
			    floating_point_constraint
			    nil)))
		 nil)))
    
		;;;;;;;;;;;;;;;;;
(def_ada_syntax simple_expression
		;;;;;;;;;;;;;;;;;

	(pr_and 
	  (lambda(as)
	    (let ((sexp
		    (let ((backpart
		    (cond 
		      ((null (third as))(second as))	  ; trivial case.
		      (t (sc_function_call
				     (cons 'simple_expression (cdr as)))))))
	      (cond 
		((null (first as)) backpart)	  ; no unary op.
		(t
		 (let ((fc (sc_function_call
			     `(simple_expression ,backpart ((,(first as)))))))
		   (diana_put fc t 'lx_prefix)
		   fc))))))
	      (cond ((and *in_record*
			  *disc_used*
			  sexp
			  (diana_nodep sexp)
			  (neq (diana_nodetype_get sexp) 'dn_used_name_id))
		     (semgripe 'illegal_use_of_disc)))
	      (setq *disc_used* nil)
	      sexp))
	  (pr_or nil oper_plus oper_minus symb_not nil)
	  term
	  (pr_repeat nil
		     (pr_and nil 
			     (pr_or nil  oper_plus
				    oper_minus
				    oper_ampersand)
			     term))))
	 ;;;;;;;;;;;;;;;;;;;
  (defun unary_operator_name(lextoken)	; converts lexical token into a name.
	 ;;;;;;;;;;;;;;;;;;;

    `(lex_operator ,(nconc (exploden 'unary_)(cdddddr (exploden lextoken)))))
  
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun conversion_type_compatible_check (dn)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (let ((pbt (extract_basetype dn t))
	(ebt (extract_basetype (diana_get dn 'as_exp) t)))
    (cond ((or (null ebt)
	       (null pbt))
	   t)
	  ((or (assignment_compatible pbt ebt)
	       (assignment_compatible ebt pbt))); cross derivation conversion ok
	  ((or (eq (diana_nodetype_get pbt) 'dn_enum_literal_s)
	       (eq (diana_nodetype_get ebt) 'dn_enum_literal_s))
	   (semgripe 'unconvertable_types))
	  (t ;add check for arrays and numeric types here+++
	   nil))))

(def_ada_syntax general_aggregate_exp
 (pr_and
   (lambda(as)
     (let* ((sec (and (diana_nodep (first as))
		      (eq (diana_nodetype_get (first as))
			  'dn_parenthesized)
		      (diana_get (first as) 'as_exp)))
	    (fs_sec
	      (cond
		((and sec
		      (memq (diana_nodetype_get sec)
		       '(dn_selected dn_used_name_id)))
		 (find_selected sec))
		(t sec)))
	    (smdef (and fs_sec
			(diana_nodep fs_sec)
			(eq (diana_nodetype_get fs_sec) 'dn_used_name_id)
			(diana_get fs_sec 'sm_defn))))
       (cond ((and *in_record*
		   smdef
		   (eq (diana_nodetype_get
			 smdef) 'dn_dscrmt_id))
	      (semgripe 'illegal_use_of_disc))))
     (first as))
   general_aggregate))


                ;;;;;;;
(def_ada_syntax primary
		;;;;;;;

	(pr_or nil 
		 general_aggregate_exp	  ;see below
	       #|(pr_and
		 (lambda (as)
		   (semgripe
		     'proc_or_entry_in_exp
		     (implode
		       (lowuplist
		      (cadr (diana_get (first (first as)) 'lx_symrep)))))
		   (first (first as)))
		 (pr_or
		   nil
		   (pr_restrict entry name)
		   (pr_restrict procedure name)
		   )
		 oper_lparen
		 (pr_or nil actual_parameter_part nil)
		 oper_rparen)|#
		 (pr_and
		   (lambda(as)		  ;(break in-primary)
		     (name_declared_check (first as))
		     (cond ((null (second as)) (first as))
			   (t
			    ;;implant the type.
			    (diana_put (second as)(first as) 'as_name)
			    ;;implant the type information.
			    (diana_put (second as)(extract_basetype (first as))
				       'sm_exp_type)
			    (cond
			      ((eq (diana_nodetype_get (second as))
				   'dn_conversion)
			       (conversion_type_compatible_check (second as)))
			      ((eq (diana_nodetype_get (second as))
				   'dn_qualified)
			       (qualify_type (second as))))
			    (second as))))
		   (pr_and
		     (lambda (as)
		       (cond
			 ((and (consp (first as))
			       (memq (diana_nodetype_get (first (first as)))
				     '(dn_proc_id dn_entry_id)))
			  (putback_symbol (diana_get (car (first as)) 'lx_symrep))
			  'fail)
			 (t (first as))))
		     name)
		   (pr_or nil 
			  (pr_and	  ;qualified expression
			    (lambda(as)
			      (sc_diana dn_qualified
					as_name nil	  ;gets put in later
					as_exp (second as)
					sm_exp_type nil))
			    oper_quote
			    general_aggregate_exp)
			  (pr_and	  ;type conversion
			    (lambda(as)	  ;(break qualified-expr)
			      (sc_diana dn_conversion
					as_name nil	  ;gets put in later
					as_exp (first as)
					sm_exp_type nil))
			    general_aggregate_exp)
			  nil))
	       (pr_and
		 (lambda(as)		  ; allocator.
		   (let ((ts (find_name (second as) nil)))
		     (cond ((and ts
				 (eq (diana_nodetype_get ts)
				     'dn_used_name_id))
			    (setq ts (diana_get ts 'sm_defn))))
		     ;;now,,, if it was eine qualified allogator, better
		     ;;shove der typemark into los dn_qualified.
		     (cond
		       ((and (diana_nodep (third as))
			     (eq (diana_nodetype_get (third as))
				 'dn_qualified))
			(diana_put (third as)(second as) 'as_name)
			(diana_put
			  (third as)
			  (diana_get ts 'sm_type_spec)
			  'sm_exp_type)
			(qualify_type (third as))
;			(normalize_aggregate (diana_get (third as) 'as_exp))
			(sc_diana dn_allocator
				  as_exp_constrained 
				  (third as)
				  sm_exp_type ts
				  sm_value nil))
		       (t
			(cond
			  ((and
			     (eq (basetype (second as))
				 '|ACCESS|)
			     (find_constraint_for2 (second as)))
			   (semgripe 'cant_constrain_a_constr_access)))
			(sc_diana dn_allocator
				  as_exp_constrained 
				  (sc_diana dn_constrained
					    as_name ts
					    as_constraint
					    (find_constraint ts (third as)))
				  sm_exp_type ts
				  sm_value nil)))))
		 symb_new
		 type_mark
		 (pr_or nil
			(pr_and 	  ;qualified expression
			  (lambda(as)
			    (sc_diana dn_qualified
				      as_name nil ;gets put in later
				      as_exp (second as)
				      sm_exp_type nil))
				oper_quote
				general_aggregate_exp)
			general_aggregate_exp 
			nil))
	       literal))

       ;;;;;;;;;;
(defun ada_type_p (dn)
       ;;;;;;;;;;
  (cond (dn
	 (ct_selectq
	   (diana_nodetype_get dn)
	   (dn_used_name_id
	     (ada_type_p (diana_get dn 'sm_defn)))
	   ((
	     dn_subtype_id dn_private_type_id  dn_formal_float
	     dn_l_private_type_id dn_type_id dn_predefined_type
	     dn_derived dn_fixed dn_float dn_integer dn_record
	     dn_enum_literal_s dn_task_spec dn_access dn_array
	     dn_formal_dscrt dn_formal_integer dn_formal_fixed)
	    t)
	   (otherwise nil)))))

                ;;;;;;;;;
(def_ada_syntax type_mark 
		;;;;;;;;;

	 (pr_and
	   (lambda(as)
	     ;(break look-at-types)
	     (cond ((null (ada_type_p (find_selected (first as))))
		    (semgripe 'type_mark_expected)
		    nil)
		   (t
		    (first as))))
	   name)
	 )
    
		;;;;;;;;;;;;;;;;;
(def_ada_syntax general_aggregate
		;;;;;;;;;;;;;;;;;

	(pr_and 
	  (lambda(as)
	    ;(break look-at-wot-we-got)
	    (cond
	      ((null (second as))
	       (semgripe 'empty_parens_not_allowed)
	       (sc_diana dn_parenthesized
			 sm_exp_type nil
			 as_exp nil))
	      ((and
		 (not (diana_nodep (second as)))
		 (eq (car (second as)) '*aggie*)
		 (eq (diana_nodetype_get
		       (car (cadr (second as))))
		     'dn_constrained))
	       (sc_diana dn_dscrt_range_s
			 as_list (cadr (second as))))
	      ((and
		 (not (diana_nodep (second as)))
		 (eq (car (second as)) '*aggie*))
	       (let ((aggdn (sc_diana dn_aggregate as_list (cadr (second as)))))
 		 (ct_push aggdn *awaiting_aggregate_disambiguation*)
		 (normalize_aggregate aggdn)
		 aggdn))
	      ((and (diana_nodep (second as))
		    (eq (diana_nodetype_get (second as)) 'dn_named))
	       (let ((aggdn (sc_diana dn_aggregate as_list (list (second as)))))
 		 (ct_push aggdn *awaiting_aggregate_disambiguation*)
		 (normalize_aggregate aggdn)
		 aggdn))
	      ((and (diana_nodep (second as))
		    (eq (diana_nodetype_get (second as))
			'dn_choice_s)
		    (eq (diana_nodetype_get
			  (car (diana_get (second as) 'as_list)))
			'dn_constrained))
	       (sc_diana dn_dscrt_range_s
			 as_list (diana_get (second as) 'as_list)))
	      (t 
	       (sc_diana dn_parenthesized
			 sm_exp_type (extract_basetype (second as))
			 as_exp (second as)))))
	  oper_lparen;(pr_or pascal_bracket_check oper_lparen)
	  general_aggregate_naka
	  oper_rparen;(pr_or pascal_bracket_check oper_rparen)
	  ))
    
		;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax general_aggregate_naka
		;;;;;;;;;;;;;;;;;;;;;;

	(pr_or nil 
	       (pr_and 
		 (lambda(as)
		   (sc_diana dn_named
			     as_exp (third as)
			     as_choice_s 
			     (sc_diana dn_choice_s
				 as_list (list (sc_diana dn_others)))
			     )
		   )
		 symb_others oper_goes expression)
	       general_aggregate_naka_no_naka))

       ;;;;;;;;;;;;;;;;;
(defun unravel_aggregate(l)
       ;;;;;;;;;;;;;;;;;

      (cond
	((diana_nodep l) (list l))
	((null l) nil)
	((and (eq (car l) '*aggie*)(second (second l)))
	 (second l))
	((eq (car l) '*aggie*)
	 (list (first (second l))))
	(t   (list l))))
    
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax general_aggregate_naka_no_naka
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	(pr_and 
	  (lambda(as)
	    (cond
	      ((and (null (second as))(null (third as))) (first as))
	      ((null (second as))	  ;but third aint.
	       (list '*aggie* (cons (first as)
				    (unravel_aggregate (third as)))))
	      (t 
	       ;; must be a named element.
	       (list '*aggie*
		   (cons
		       (sc_diana dn_named
			   as_choice_s 
			     (sc_diana dn_choice_s
				 as_list
				 (cond
				   ((eq (diana_nodetype_get (first as))
					'dn_choice_s)
				    (diana_get (first as) 'as_list))
				   (t   (list (first as)))))
			   as_exp (second as))
		       (unravel_aggregate (third as))))
	      )
	    ))
	  general_aggregate_naka_no_naka_car
	  (pr_or nil (pr_and cadr oper_goes expression) nil)
	  (pr_or nil 
		 (pr_and cadr
			 oper_comma
			 general_aggregate_naka)
		 nil)))
    
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax general_aggregate_naka_no_naka_car
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (cond
	      ((and (null (second as))(null (third as)))(first as))
	      (t (sc_diana dn_choice_s
			   as_list
			   (cond
			     ((null (second as));(break huh)
			      (cons (first as)(third as)))
			     ((and (consp (second as))
				   (eq (first (second as)) 'oper_dotdot))
			      (cons
				(sc_diana dn_range
					  as_exp1 (first as)
					  as_exp2 (second (second as))
					  sm_base_type nil;++
					  )
				(third as)))
			     (t
			      (cond ((memq (diana_nodetype_get
					     (diana_get (first as) 'sm_defn))
					   '(dn_type_id dn_subtype_id)))
				    (t (semgripe
					 'non_type_range_constraint
					 (implode
					   (lowuplist
					     (cadr (diana_get
						     (first as) 'lx_symrep)))))))
			      (cons
				(sc_diana dn_constrained
					  as_name (first as)
					  as_constraint (second as))
				(third as)))
			   )))))
	  (pr_or nil
	    (pr_and2c
	      (lambda(as)
		(sc_diana dn_used_name_id
			  lx_symrep (first as)
			  sm_defn (let ((henry (ada_declared
						 (first as) nil nil t)))
				    (cond ((= (length henry) 1)
					   (car henry))
					  (t henry))))
		)
	      lex_ident
	      oper_goes
	      
	      lex_ident)
	    (pr_and2c
	      (lambda(as)
		(sc_diana dn_used_name_id
			  lx_symrep (first as)
			  sm_defn (let ((henry (ada_declared
						 (first as) nil nil t)))
				    (cond ((= (length henry) 1)
					   (car henry))
					  (t henry))))
		)
	      lex_ident
	      oper_bar
	      
	      lex_ident)
	    expression)
	  (pr_or nil 
		 range_constraint
		 (pr_and nil oper_dotdot simple_expression)
		 nil)
	  (pr_or nil 
		 (pr_and 
		     (lambda(as)
			 (cond
			     ((eq (diana_nodetype_get (second as))
				  'dn_choice_s)
		              (diana_get (second as) 'as_list))
			     ((null (second as)) nil)
			     (t   (list (second as)))))
		     oper_bar 
		     general_aggregate_naka_no_naka_car)
		 nil)))
    
#|
(diana_put
				(third as)
				(cons (first as)(diana_get (third as) 'as_list))
				'as_list)
|#