;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;  $Header: /ct/interp/adas39.l,v 1.62 85/01/24 18:00:54 penny Exp $
;;;  


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                            adas39.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.6  Array Types
;;;
;;;-- Syntax 3.6.A
;;;--  array_type_definition ::=
;;;--     unconstrained_array_definition | constrained_array_definition
;;;--  unconstrained_array_definition ::=
;;;--     'array' '(' index {',' index}')' 'of' subtype_indication
;;;--  constrained_array_definition ::=
;;;--     'array' index_constraint 'of' subtype_indication
;;;--
;;;
;;;
;;;    TYPE_SPEC ::=        array;
;;;
;;;    array =>             as_dscrt_range_s : DSCRT_RANGE_S,
;;;                         as_constrained   : CONSTRAINED;
;;;    array =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    array =>             sm_size          : EXP_VOID,
;;;                         sm_packing       : Boolean;
;;;    array =>             cd_impl_size     : Integer,
;;;                         cd_alignment     : Integer;
;;;
;;;    DSCRT_RANGE_S ::=    dscrt_range_s;
;;;
;;;    dscrt_range_s =>     as_list          : Seq Of DSCRT_RANGE;
;;;    dscrt_range_s =>     lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
    (declare (special ranges))		;temporary hack.

		;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax array_type_definition
		;;;;;;;;;;;;;;;;;;;;;

	(pr_and 
	  (lambda(as)			  ;(break in-array_type_definition)
	    (let ((ranges
		    (ct_selectq
		      (car (fourth as))
		      (*dscrtrange*
			(cond
			  ((null (array_type_bits%sechalf 
				     (second (fourth as))))
			   (find_constraint_for (third as)))
			  (t
			   (sc_diana dn_range
				     as_exp1
				     (third as)
				     as_exp2
				     (array_type_bits%sechalf 
					 (second (fourth as)))
				     sm_base_type 
				     (find_type_for_range
					 (third as)
					 (array_type_bits%sechalf
					     (second (fourth as))))
				     ))))
		      (*constrained*
			(sc_diana dn_constrained
				  as_name (third as)
				  as_constraint (array_type_bits%sechalf
						  (second (fourth as)))))
		      (*unconstrained*
			(sc_diana dn_index
				  as_name (third as))))))
	      (sc_diana dn_array
			as_dscrt_range_s
			(sc_diana
			  dn_dscrt_range_s
			  as_list
			  (cons ranges
				(array_type_bits%ranges2 (second (fourth as)))))
			as_constrained
			(array_type_bits%comptyp (second (fourth as)))
			)))
	  symb_array
	  (pr_or pascal_bracket_check oper_lparen)
	  simple_expression
	  (pr_or nil 
		 (pr_and cadr
			 symb_range
			 (pr_or nil 
				(pr_and 
				  (lambda(as)
				    `(*unconstrained*
				       ,(array_type_bits 
					  (third as)
					  (second as)
					  nil)))
				  oper_ltgt
				  (pr_or nil array_type_definition_toploop nil)
				  array_type_definition_centreexit)
				(pr_and 
				  (lambda(as)
				    `(*constrained*
				       ,(array_type_bits
					  (third as)
					  (second as)
					  (first as))))
				  range
				  (pr_or nil array_type_definition_bottomloop nil)
				  array_type_definition_centreexit)))
		 (pr_and 
		   (lambda(as)
		     `(*dscrtrange*
			,(array_type_bits
			   (third as)
			   (second as)
			   (first as))))
		   (pr_or nil 
			  (pr_and cadr
				  oper_dotdot
				  simple_expression)
			  nil)
		   (pr_or nil array_type_definition_bottomloop nil)
		   array_type_definition_centreexit))))
    
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax array_type_definition_centreexit
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	(pr_and caddr
		(pr_or pascal_bracket_check oper_rparen)
		symb_of
		(pr_and
		  (lambda (as)
		    (cond ((and
			     (first as)
			     (null (extract_basetype (first as))))
			   (semgripe 'incomplete_type)))
		    (first as))
		  subtype_indication)))
    
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax array_type_definition_bottomloop
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	(pr_and 
	  (lambda(as)(cons (first as)(second as)))
	  (pr_and cadr oper_comma index_range)	
	  (pr_repeat nil (pr_and cadr oper_comma index_range))))
    
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax array_type_definition_toploop
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	(pr_and 
	  (lambda(as)(cons (first as)(second as)))
	  (pr_and
	    (lambda(as)
	      (sc_diana dn_index
			as_name (second as)))
	    oper_comma 
	    type_mark
;		(pr_restrict discrete name) 
	    symb_range 
	    oper_ltgt)
	  (pr_repeat nil
		     (pr_and cadr
			     oper_comma 
			     type_mark;(pr_restrict discrete type_mark) 
			     symb_range 
			     oper_ltgt))))
    
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax constrained_array_type_definition_init
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	(pr_and 
	  (lambda(as)
	    (subtype_ind_init
	      (sc_diana dn_array
			as_dscrt_range_s 
			(sc_diana dn_dscrt_range_s
				  as_list (cons (third as)(fourth as)))
			as_constrained   (seventh as)
			)
	      (eighth as)))
	  symb_array
	  (pr_or pascal_bracket_check oper_lparen)
	  index_range
	  (pr_repeat nil (pr_and cadr oper_comma index_range))
	  (pr_or pascal_bracket_check oper_rparen)
	  symb_of
	  subtype_indication
	  (pr_or nil
		 (pr_and cadr
			 oper_assign
			 general_aggregate)
		 nil)))

;;;-- 3.7  Record Types
;;;
;;;-- Syntax 3.7.A
;;;--  record_type_definition ::=
;;;--     'record'
;;;--         component_list
;;;--     'end' 'record'
;;;--
;;;
;;;
;;;    TYPE_SPEC ::=        record;
;;;
;;;    record =>            as_list          : Seq Of COMP;
;;;    record =>            lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    record =>            sm_size          : EXP_VOID,
;;;                         sm_discriminants : VAR_S,
;;;                         sm_packing       : Boolean;
;;;    record =>            cd_impl_size     : Integer,
;;;                         cd_alignment     : Integer;
;;;

		;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax record_type_definition
		;;;;;;;;;;;;;;;;;;;;;;

    (pr_and 
      (lambda(as)
	  (setq *in_record* nil)
	  (setq *disc_not_allowed* nil)
	  (setq *disc_list* nil)
	  (prog1
	      (sc_diana dn_record
		  ct_named_context **current_block**
		  as_list (second as))
	      (popcontext)))
      (pr_and 
	  (lambda(as)
	      (setq *in_record* t)
	      (pushcontext)
	      (car as))
	  symb_record)
      component_list
      symb_end
      symb_record))

		;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax access_type_definition 
		;;;;;;;;;;;;;;;;;;;;;;

  (pr_and
    (lambda(as)
      (sc_diana dn_access
		as_constrained (second as)))
    symb_access
    (pr_and
      (lambda (as)
	(cond ((and
		 (first as)
		 (null (extract_basetype (first as)))
		 (eq (diana_nodetype_get (first as))
					 'dn_constrained)
		 (neq (diana_nodetype_get
			(diana_get (first as) 'as_constraint))
					 'dn_void))
	       (semgripe 'incomplete_type)))
	(first as))
      subtype_indication)))

;;;-- 2.8  Pragmas
;;;-- These productions do not correspond to productions in the
;;;-- concrete syntax.
;;;
;;;-- Syntax 2.8.A
;;;--   pragma ::=
;;;--     'pragma' identifier ['('argument {',' argument}')']';'
;;;--
;;;
;;;
;;;    PRAGMA ::=           pragma;
;;;
;;;    pragma =>            as_id            : ID,    -- a 'used_name_id'
;;;                         as_param_assoc_s : PARAM_ASSOC_S;
;;;    pragma =>            lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;
;;;    PARAM_ASSOC_S ::=    param_assoc_s;
;;;
;;;    param_assoc_s =>     as_list          : Seq Of PARAM_ASSOC;
;;;    param_assoc_s =>     lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- Syntax 2.8.B
;;;--  argument ::=
;;;--     [identifier '=>' ] name
;;;--   | [identifier '=>' ] expression
;;;--
;;;    -- see 6.4
;;;
		;;;;;;
(def_ada_syntax pragma
		;;;;;;

	(pr_and
	  (lambda(as)
;;; Here a pragma has been parsed. The Static semantics for a Pragma
;;; consist of producing the dn_pragma node, and calling a lisp
;;; function whose name is pragma_<pragmaidentifier> eg. pragma_list.
	    (cond ((and (diana_nodep (second as))
			(eq (diana_nodetype_get (second as)) 'dn_semantic_error)))
		  (t
		   (let ((pragmasf (implode  (append (exploden '|pragma_|)
						     (cadr (second as))))))
		     (cond
		       ((fdefinition pragmasf)
			(funcall pragmasf (third as)))
		      (t		;;ERRMSG
			(semgripe 'unimp_pragma
				  (implode (lowuplist (cadr (second as))))))))))
	    (sc_diana dn_pragma
		      as_id (second as)
		      as_param_assoc_s
		      (sc_diana dn_param_assoc_s
				as_list (third as))))
	  symb_pragma
	  (pr_restrict pragma lex_ident)
	  (pr_or nil 
		 (pr_and cadr
			 oper_lparen
			 actual_parameter_part
			 oper_rparen)
		 nil)
	  oper_semicolon))
    
;;;-- 3.2  Object and Number Declarations
;;;
;;;-- Syntax 3.2.A
;;;--  object_declaration ::=
;;;--     identifier_list ':' ['constant'] subtype_indication
;;;--                               [':=' expression] ';'
;;;--   | identifier_list ':' ['constant'] constrained_array_definition
;;;--                               [':=' expression] ';'
;;;--
;;;
;;;
;;;    OBJECT_DEF ::=       EXP_VOID;
;;;    EXP_VOID ::=         EXP | void;
;;;    TYPE_SPEC ::=        CONSTRAINED;
;;;
;;;    constant =>          as_id_s          : ID_S,  -- sequence of 'const_id'
;;;                         as_type_spec     : TYPE_SPEC,
;;;                         as_object_def    : OBJECT_DEF;
;;;    constant =>          lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    var =>               as_id_s          : ID_S,  -- a sequence of 'var_id'
;;;                         as_type_spec     : TYPE_SPEC,
;;;                         as_object_def    : OBJECT_DEF;
;;;    var =>               lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;
;;;    DEF_ID ::=           var_id;
;;;
;;;    var_id =>            lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    var_id =>            sm_obj_type      : TYPE_SPEC,
;;;                         sm_address       : EXP_VOID,
;;;                         sm_obj_def       : OBJECT_DEF;
;;;
;;;
;;;    DEF_ID ::=           const_id;
;;;
;;;    -- see the rationale for a discussion of deferred constants
;;;
;;;    const_id =>          lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    const_id =>          sm_address       : EXP_VOID,
;;;                         sm_obj_type      : TYPE_SPEC,
;;;                         sm_obj_def       : OBJECT_DEF;
;;;
;;;-- Syntax 3.2.C
;;;--  identifier_list ::= identifier {',' identifier}
;;;--
;;;
;;;
;;;    ID_S ::=             id_s;
;;;
;;;    id_s =>              as_list          : Seq Of ID;
;;;    id_s =>              lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
       ;;;;;;;;;;;;;;;;;
(defun copy_if_anonymous (dn)
       ;;;;;;;;;;;;;;;;;

  (ct_selectq (diana_nodetype_get dn)
	      ((dn_array dn_record) (diana_copy dn))
	      (otherwise dn)))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun non_constant_unconstrained_array_type_p (type)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (and (arrayp type)
       (let ((indices (find_constraint_for type)))
	 (cond ((and indices
		     (eq (diana_nodetype_get indices) 'dn_dscrt_range_s))
		(let ((il (diana_get indices 'as_list))
		      (constrainedp t))
		  (mapc #'(lambda(i)
			    (cond ((eq (diana_nodetype_get i) 'dn_index)
				   (setq constrainedp nil))))
			il)
		  (not constrainedp)))
	       (t nil)
		))))

(defun adjust_source_pos (dn beg end)
  (let ((sp (diana_get dn 'lx_srcpos)))
    (%= (source_region%startchar sp) (max 1 (+ beg *_*)))
    (%= (source_region%endchar sp) (max 1 (+ end *_*)))
    (%= (source_region%column sp) (max 1 (+ end *_*)))
    (%= (source_region%colstart sp) (max 1 (+ beg *_*)))))
	 

		;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax obj_num_exc_declaration
		;;;;;;;;;;;;;;;;;;;;;;;
(pr_and
 (lambda (as)
  (cond
   ((is_object_definition (second as))
    (let ((type (cond ((is_subtype_ind_init (object_definition%obdef (second as)))
		       (subtype_ind_init%sub_ind
			 (object_definition%obdef (second as))))))
	  (init (cond ((is_subtype_ind_init (object_definition%obdef (second as)))
		       (subtype_ind_init%initexp
			 (object_definition%obdef (second as)))))))
      (cond
	((and init (eq (diana_nodetype_get init) 'dn_rename))
	 (cond
	   ((null (assignment_compatible  init type))
	    (semgripe 'rename_wrong_type))))
	((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_id_s
		(mapcar
		  '(lambda (id)
		     (add_name (diana_get id 'lx_symrep)
			       'object
			       (let ((varid id))
				  (diana_put varid 
					     (copy_if_anonymous type)
					     'sm_obj_type)
				  (diana_put varid init 'sm_obj_def)
				  (diana_put varid varid 'sm_defn))
			       nil))
		  (cons (first as) (object_definition%id_s (second as))))
		as_type_spec type
		as_object_def init)))

   ((eq (car (second as)) '*typemark*)
    (let ((type (second (second as)))	  ;++ should be subtype_ind_init%sub_ind?
	  (init (third (third (second as)))))
      (cond
	((non_constant_unconstrained_array_type_p type)
	 (cond (init
		(semgripe 'non_constant_unconstrained_array_type))
	       (t (semgripe 'unconstrained_array_declaration)))))
      (cond
	((and init (eq (diana_nodetype_get init) 'dn_rename))
	 (cond
	   ((null (assignment_compatible  init type))
	    (semgripe 'rename_wrong_type)))
	 (cond ((and (diana_node_accepts_attributep init 'as_name)
		     (eq (diana_nodetype_get
		      (diana_get init 'as_name))
		    'dn_indexed))
		(semgripe 'cannot_rename_an_array_element
			  (implode
			    (lowuplist
			      (cadr (diana_get
				      (diana_get
					(diana_get init 'as_name)
				      'as_name)
				      'lx_symrep))))))))
	((and init (null (assignment_compatible  init type)))
	 (semgripe 'init_exp_wrong_type)))
      (sc_diana dn_var
		as_id_s
		(list (add_name (diana_get (first as) 'lx_symrep)
				'object
				(let ((varid (first as)))
				  (diana_put varid 
					     (second (second as))
					     'sm_obj_type)
				  (diana_put varid init 'sm_obj_def)
				  (diana_put varid varid 'sm_defn))
				nil))
		as_type_spec type
		as_object_def init)))

   ((eq (car (second as)) '*constrained_array_type_definition_init*)
    (let ((type (subtype_ind_init%sub_ind (second (second as))))
	  (init (subtype_ind_init%initexp (second (second as)))))
      
      (cond
	((and init (eq (diana_nodetype_get init) 'dn_rename))
	 (cond
	   ((null (assignment_compatible  init type))
	    (semgripe 'rename_wrong_type)))
	 )
	((and init (null (assignment_compatible  init type)))
	 (semgripe 'init_exp_wrong_type)))
      (sc_diana dn_var
		as_id_s
		(list (add_name (diana_get (first as) 'lx_symrep)
				'object
				(let ((varid (first as)))
				  (diana_put varid 
					     (subtype_ind_init%sub_ind
					       (second (second as)))
					     'sm_obj_type)
				  (diana_put varid init 'sm_obj_def)
				  (diana_put varid varid 'sm_defn))
				nil))
		as_type_spec type
		as_object_def init)))

    ((eq (first (second as)) '*constant_definition*)
     ;;create diana node (result) and add each entry to the ST
     (let ((result (second (second as))))
       (cond
	 ((is_subtype_ind_init result)
	  (let ((type (subtype_ind_init%sub_ind result))
		(init (subtype_ind_init%initexp result)))
	    (cond
	      ((and init (null (assignment_compatible  init type)))
	       (semgripe 'init_exp_wrong_type)))
	    (setq result
		  (sc_diana dn_constant
			    as_type_spec type
			    as_object_def  init))
	    (cond ((null (diana_get result 'as_object_def))
		   (ct_push result *awaiting_deferred_value*)
		   (cond ((memq
			    (diana_nodetype_get
			      (extract_basetype
				(diana_get result 'as_type_spec)
				t))
			    '(dn_l_private dn_private dn_private_type_id
					   dn_l_private_type_id)))
			 (t (semgripe 'def_const_must_be_private)))))
	    (diana_put
	      result
	      (mapcar #'(lambda(id)
			  (add_name (diana_get id 'lx_symrep)
				    (cond ((number_declaration_p result )
					   'number)
					  (t 'constant))
				    (let ((conid
					    (sc_diana dn_const_id
						      sm_obj_type
						      (diana_get result 'as_type_spec)
						      sm_init_exp
						      (let
							((od
							   (diana_get result
								      'as_object_def)))
							(and od (diana_copy od)))
						      lx_symrep
						      (diana_get
							id 'lx_symrep))))
				      (diana_put conid
						 (diana_get id 'lx_srcpos)
						 'lx_srcpos)
				      (diana_put conid conid 'sm_defn))
				    nil))
		      (cons (first as) (third (second as))))
	      'as_id_s)))
	 (t
	  (diana_put
	    result
	    (mapcar #'(lambda(id)
			(add_name (diana_get id 'lx_symrep)
				  (cond ((number_declaration_p result )
					 'number)
					(t 'constant))
				  (let
				    ((nombres
				       (sc_diana dn_number_id
						 sm_obj_type
						 (diana_get result 'as_type_spec)
						 sm_init_exp
						 (diana_get result 'as_exp)
						 lx_symrep
						 (diana_get
							id 'lx_symrep))))
				    (diana_put nombres 
						 (diana_get id 'lx_srcpos)
						 'lx_srcpos)
				    (diana_put nombres nombres 'sm_defn)
				    (fe_static_eval nombres)
				    nombres)
				  nil))
		    (cons (first as) (third (second as))))
	    'as_id_s)))
      result))

   ((eq (car (second as)) '*exception*)
    (sc_diana dn_exception
              as_id_s
              (sc_diana dn_id_s
                        as_list
                        (mapcar
			  (function
			    (lambda (id)
			      (add_name (diana_get id 'lx_symrep)
					'exception
					(let ((excid
						(sc_diana dn_exception_id
							  lx_symrep
							  (diana_get
							    id 'lx_symrep)
							  sm_exception_def
							  (cond
							    ((third (second as))
							     (third (second as)))
							    (t
							     (sc_diana
							       dn_void))))))
					  (diana_put excid
						 (diana_get id 'lx_srcpos)
						 'lx_srcpos)
					  (diana_put excid excid 'sm_defn))
					nil)))
			  (cons (first as) (second (second as)))))
              as_exception_def
              (cond
		((third (second as))
		 (third (second as)))
		(t (sc_diana dn_void)))))
   (t as)))
 (pr_and
   (lambda (as)
     (let ((node (sc_diana dn_var_id
	       lx_symrep (first as))))
       (adjust_source_pos node -1 -1)
       node))
   lex_ident)
 (pr_or nil
	(pr_and cadr
		oper_colon
		(pr_or nil
		       (pr_and
			 (lambda (as)
			   `(*constrained_array_type_definition_init* ,(first as)))
			 constrained_array_type_definition_init)
		       (pr_and
			 (lambda (as)
			   `(*constant_definition* ,(second (first as)) nil))
			 constant_definition)
		       (pr_and
			 (lambda (as)
			   `(*exception* nil ,(second as)))
			 symb_exception
			 (pr_or nil
				(pr_and cadr
					symb_renames
					(pr_restrict exception name))
				nil))
		       (pr_and
			 (lambda (as)
			   (cond ((and
				    (first as)
				    (null (extract_basetype (first as))))
				    (semgripe 'incomplete_type)))
			   (cond
			     ((and (first as)
				   (eq (diana_nodetype_get
					 (extract_basetype (first as)))
				       'dn_access)
				   )
			      ; This needs to be more selective
			      (cond
				((and
				     (second as)
				     (diana_nodep
				       (subtype_ind_init%sub_ind (second as)))
				     (null
				       (memq
				       (diana_nodetype_get
					 (subtype_ind_init%sub_ind (second as)))
				       '(dn_dscrt_range_s dn_dscrmt_aggregate))))
				 (semgripe 'cant_constrain_an_access))
				((and
				     (second as)
				     (diana_nodep
				       (subtype_ind_init%sub_ind (second as)))
				     (eq
				       (diana_nodetype_get
					 (subtype_ind_init%sub_ind (second as)))
				       'dn_dscrmt_aggregate)
				     (find_constraint_for2 (first as)))
				 (semgripe 'cant_constrain_a_constr_access)))
			      ))
			   (cons
			     '*typemark*
			     (cond
			       ((eq (car (second as)) '*subindinit*)
				;check not constraining a non_array type
				; and if an array correct number of indices
				(cond
				  ((and
				     (diana_nodep
				       (subtype_ind_init%sub_ind
					 (second as)))
				     (eq (diana_nodetype_get
					   (subtype_ind_init%sub_ind
					     (second as)))
					 'dn_dscrt_range_s))
				   (let ((typ
					   (cond ((eq (basetype (first as))
						      '|ACCESS|)
						  (diana_get
						    (diana_get
						      (extract_basetype
							(first as))
						      'as_constrained)
						    'as_name))
						 (t (first as)))))
				     (cond
				     ((or
					(is_scalar_typep
					  (diana_get typ 'sm_defn)
					  (basetype typ))
					(eq (basetype typ)
					    '|RECORD|)
					(memq (diana_nodetype_get
						(diana_get typ 'sm_defn))
					      '(dn_private_type_id
						 dn_l_private_type_id)))
				      (semgripe
					'attempt_to_constrain_non_array_type))
				     (t
				      (let*
					((rng (find_range typ))
					 (len (length
						(and rng
						     (diana_get rng 'as_list))))
					 (len2 (length
						 (diana_get
						   (subtype_ind_init%sub_ind
						     (second as))
						   'as_list))))
					(cond
					  ((and len len2
						(null (= len len2)))
					   (semgripe 'non_matching_num_ind
						     len2 len)))))))))
				(list (sc_diana dn_constrained
						as_name
						(first as)
						as_constraint
						(second (second as)))
				      (second as)))
			       (t
				(list
				  (sc_diana dn_constrained
					    as_name (first as)
					    as_constraint nil)
				  (second as))))))
			 type_mark	  ;was name pr. 
			 (pr_or nil
				(pr_and (lambda (as)
					  `(*subindinit* ,(first as) ,(second as)))
					constraint
					(pr_or nil
					       (pr_and cadr
						       oper_assign
						       expression)
					       nil))
				(pr_and (lambda (as)
					  `(*subindinit* nil ,(second as)))
					oper_assign
					expression)
				(pr_and (lambda(as)
					  `(*subindinit* nil
							 ,(sc_diana dn_rename
								    as_name
								    (second as))))
					symb_renames
					#|(pr_or (pr_restrict object name)
					       (pr_restrict constant name))|#
					name)
				nil))))
	(pr_and (lambda (as)
		  (cond ((eq 'symb_exception (fifth as))
			 `(*exception* (,(second as) . ,(third as)) nil))
			((eq 'symb_constant (first (fifth as)))
			 `(*constant_definition* ,(second (fifth as))
						 (,(second as) . ,(third as)) ))
			(t
			 (object_definition (cons (second as) (third as))
					    (fifth as)))))
		oper_comma
		(pr_and
		  (lambda (as)
		    (let ((node (sc_diana dn_var_id
					  lx_symrep (first as))))
		      (adjust_source_pos node -1 -1)
		      node))
		  lex_ident)
		(pr_repeat nil
			   (pr_or
			     nil
			     (pr_and2c cadr oper_comma lex_ident
				       oper_comma
				      (pr_and
					(lambda (as)
					  (let ((node
						  (sc_diana dn_var_id
							    lx_symrep (first as))))
					    (adjust_source_pos node -1 -1)
					    node))
					lex_ident))
			     (pr_and
			       (lambda (as)
				 (semgripe 'obj_expected '"IDENTIFIER")
				 'fail)
			       oper_comma)))
		oper_colon
		(pr_or nil
		       subtype_indication_init  
		       constrained_array_type_definition_init
		       constant_definition
		       symb_exception)))
 oper_semicolon)
)

;;;--     identifier_list ':' 'constant' ':=' expression ';'
;;;--
;;;
;;;
;;;    number =>            as_id_s          : ID_S,  -- always a sequence
;;;                                                   -- of 'number_id'
;;;                         as_exp           : EXP;
;;;    number =>            lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;
;;;    DEF_ID ::=           number_id;
;;;
;;;    number_id =>         lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    number_id =>         sm_obj_type      : TYPE_SPEC,  -- always refers to a
;;;                                                        -- universal type
;;;                         sm_init_exp      : EXP;
;;;
		;;;;;;;;;;;;;;;;;;;
(def_ada_syntax constant_definition  ; object declaration
		;;;;;;;;;;;;;;;;;;;

	(pr_and nil
		symb_constant
		(pr_or nil 
		       subtype_indication_init
		       constrained_array_type_definition_init
		       (pr_and
			 (lambda(as)
			   (fe_static_eval (second as))
			   (sc_diana dn_number
				     as_id_s nil  ; gets filled in later.
				     as_exp (second as)))
			 oper_assign 
			 expression))))
    
;;;-- Syntax 3.3.D
;;;--  subtype_indication ::= type_mark [constraint]
;;;--  type_mark ::= name
;;;--  constraint ::=
;;;--     range_constraint | accuracy_constraint
;;;--   | index_constraint | discriminant_constraint
;;;--
;;;
;;;
;;;    CONSTRAINED ::=      constrained;
;;;    CONSTRAINT ::=       void;
;;;
;;;    constrained =>       as_name          : NAME,
;;;                         as_constraint    : CONSTRAINT;
;;;    constrained =>       lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    constrained =>       sm_type_struct   : TYPE_SPEC,
;;;                         sm_base_type     : TYPE_SPEC,
;;;                         sm_constraint    : CONSTRAINT;
;;;    constrained =>       cd_impl_size     : Integer,
;;;                         cd_alignment     : Integer;
;;;
       ;;;;;;
(defun rangep (asl)
       ;;;;;;
  (cond ((eq (diana_nodetype_get asl) 'dn_range) t)
	(t nil)))

       ;;;;;;;;;;;;;;;;;;;;
(defun number_declaration_p (res)
       ;;;;;;;;;;;;;;;;;;;;
  (cond ((eq (diana_nodetype_get res) 'dn_number)
	 t)
   ))
  
		;;;;;;;;;;
(def_ada_syntax constraint
		;;;;;;;;;;
		
   (pr_or nil 
	  range_constraint
	  fixed_point_constraint
	  floating_point_constraint
	  (pr_and
	    (lambda (as)		  ;(break  constraint)
	      (cond
		((and (diana_nodep (first as))
		      (eq (diana_nodetype_get (first as))
			  'dn_dscrt_range_s))
		 (first as))
		((and
		   (diana_nodep (first as))
		   (diana_node_accepts_attributep (first as) 'as_list)
		   (diana_get (first as) 'as_list)
		   (eq (diana_nodetype_get
			 (first (diana_get (first as) 'as_list)))
		       'dn_choice_s))
		 (sc_diana dn_dscrt_range_s
			   as_list
			   (mapcan #'(lambda (choice)
				       (diana_get choice 'as_list))
			     (diana_get (first as)
					'as_list))))
		((and (diana_nodep (first as))
		      (eq (diana_nodetype_get (first as)) 'dn_parenthesized))
		   (cond ((and
			    (diana_node_accepts_attributep (first as) 'as_exp)
			     (diana_nodep (diana_get (first as) 'as_exp))
			     (diana_node_accepts_attributep
			       (diana_get (first as) 'as_exp) 'as_list)
			     (rangep (first
				       (diana_get
					 (diana_get (first as) 'as_exp)
					 'as_list))))
			(sc_diana dn_dscrt_range_s
			   as_list
			     (diana_get
			       (diana_get (first as) 'as_exp)
			       'as_list)))
			 ((and (diana_node_accepts_attributep (first as) 'as_exp)
			       (diana_nodep (diana_get (first as) 'as_exp))
			       (eq (diana_nodetype_get
				     (diana_get (first as) 'as_exp))
				   'dn_used_name_id)
			       (memq (diana_nodetype_get
				       (diana_get
					 (diana_get (first as) 'as_exp)
					 'sm_defn))
				     '(dn_type_id dn_subtype_id
				       dn_constrained dn_access
				       dn_derived dn_integer
				       dn_fixed dn_float dn_formal_fixed
				       dn_formal_float dn_formal_integer
				       dn_formal_dscrt dn_enum_literal_s
				       dn_private_type_id dn_l_private_type_id
				       dn_predefined_type)))
			  ;must be a type to represent the range
			  (sc_diana dn_dscrt_range_s
				    as_list
				    (list (diana_get (first as) 'as_exp))))
			(t 
			   (let ((da (sc_diana dn_dscrmt_aggregate
			   as_list (let ((asl
					   (diana_get (first as) 'as_exp)))
				     (cond
				       ((diana_nodep asl)
					(list asl))
				       (t asl))))))
			     (normalize_aggregate da)
			     da))))
		(t   ;a dsrmt_aggregate.
		 (let* ((agg (first as))
			(comps (diana_get agg 'as_list)))
		   (mapc
		     #'(lambda (named)
			 (cond
			   ((and (diana_nodep named)
				 (eq (diana_nodetype_get named)
				     'dn_named))
			    (let* ((asl (diana_get
					  (diana_get named 'as_choice_s)
					  'as_list)))
			      (mapc
				#'(lambda (ids)
				    (let ((dn_dsc
					    (and
					      (diana_nodep ids)
					      (or
						(and
						  (diana_node_accepts_attributep
						    ids 'sm_defn)
						  (diana_get ids 'sm_defn))
						(and
						  (eq (diana_nodetype_get
						      ids)
						    'dn_selected)
						  ids)))
					    ))
				      (cond
					((and dn_dsc
					      (eq (diana_nodetype_get
						      dn_dsc)
						    'dn_selected)
					      )
					 (cond
					   ((diana_nodep
					      (find_selected dn_dsc))
					    (semgripe
					      'non_disc_in_disc_const
					      (implode
						(lowuplist
						  (cadr
						    (diana_get
						      (find_selected dn_dsc)
						      'lx_symrep))))))
					   (t
					    (semgripe
					      'illegal_name_for_disc
					      nil))))
					((and dn_dsc
					      (diana_nodep dn_dsc)
					      (neq
						(diana_nodetype_get dn_dsc)
						'dn_dscrmt_id))
					 (semgripe
					   'non_disc_in_disc_const
					   (implode
					     (lowuplist
					       (cadr
						 (diana_get dn_dsc
							    'lx_symrep)))))))))
				asl)))))
		     comps))
		 (let ((da (sc_diana dn_dscrmt_aggregate
			   as_list (let ((asl
					   (diana_get (first as) 'as_list)))
				     (cond
				       ((diana_nodep asl)
					(list asl))
				       (t asl))))))
		   (normalize_aggregate da )
		   da))))
	    general_aggregate)))