;;; -*- mode:lisp;package:user;base:10.;fonts: cptfontb -*- 
;;; $Header: /ct/interp/aggies.l,v 1.40 84/10/22 19:34:11 penny Exp $
;;;
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                            aggies.l                              ;;;
;;; Paul Robertson                                  October 18, 1983 ;;;
;;;                                                                  ;;;
;;;       The C*T Ada Interpreters Static Semantic support           ;;;
;;;                                                                  ;;;
;;; 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 'charmac))

(eval-when (compile load eval) (ct_load 'time))       ;Timing functions. 

(eval-when (compile load eval) (ct_load 'diana))      ; Diana tools.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros -- 

;;; Static semantic code schemas are structured as follows.
;;; Body contains lisp code that returns a piece of diana tree or nil.
;;; The main way of building a diana tree is with the sc_diana functon.
;;; Simple node will consist only of these nodes. sc_diana looks like this...
;;; (sc_diana dn_foo slotname code slotname code slotname code .. .. .. ..)
;;; The above example creates a diana node with the names slots, and calls the
;;; appropriate code to fill the slots. One reason why this function should be
;;; used is that it hides the internal representation of a diana node making
;;; future modifications easy (which would be necessary for say a production
;;; compiler.
;;; The abstract syntax is available for inclusion in  the diana tree or
;;; other in a free variable called *abstract_syntax*. This variable may be
;;; altered by the code for effeciency reasons without intefering with the
;;; parsing process. Syntax nodes that do not have ssemantics code will
;;; produce abstract syntax subtree's. To return a null node have a ssemantic
;;; property that returns nil.

;;; Section by pozsvath for (array & record) aggregate normalization


;;; If dn can be normalized, normalize it. Otherwise stick it on the
;;; normalize waiting list.

(defun get_real_type (dn) 
  (cond ((null dn) nil)
	(t (setq dn (extract_basetype dn t))
	   (cond ((null dn) nil)
		 ((eq (diana_nodetype_get dn) 'dn_access) 
		  (get_real_type (diana_get dn 'as_constrained)))
;		 ((eq (diana_nodetype_get dn) 'dn_constrained)
;		  (get_real_type dn))
		 ((eq (diana_nodetype_get dn) 'dn_void) 
		  nil)
		 (t dn)))))
                 
       ;;;;;;;;;;;;;;;;;;;
(defun normalize_aggregate(dn)
       ;;;;;;;;;;;;;;;;;;;
  (let ((type (get_real_type (diana_get dn 'sm_exp_type))))
    (cond
      ((dynamic_aggregatep dn))
      (type
       (ct_selectq
	 (diana_nodetype_get type)
	 (dn_enum_literal_s
	   ;; ++The errset was added in case the dn is severely confused
	   ;; (such as (...others='a') which causes type to be a
	   ;; dn_enum_literal_s.
	   (cond ((null (errset (normalize_enum_literal_aggregate dn) nil))
		  (cannot_normalize dn))))
	 (dn_record
	   (normalize_record_aggregate dn))
	 (dn_array
	   (cond
	     ((dynamic_aggregatep dn))
	     ((eq '*bad_index_list*
		      (*catch
			'*bad_index_list*
			(cond ((constrained_arrayp dn)
			       (normalize_constrained_array_aggregate
				 dn
				 (create_index_list
				   (find_constraint_for2
				     (diana_get dn 'sm_exp_type)))))
			      (t (normalize_unconstrained_array_aggregate dn)))))
		  (cond ((eq '*bad_index_list*
			     (*catch
			       '*bad_index_list*
			       (normalize_unconstrained_array_aggregate dn)))
			 )))))
	 ((dn_private_type_id dn_l_private_type_id)
	  (semgripe 'cant_mix_aggies_with_privates))
	 (otherwise (lose 'fe_batna ; BadAttributeToNormalizeAggregate ++ should
			  'normalize_aggregate)))) ; never happen!!!
      (t (ct_push dn *awaiting_aggregate_normalization*)))))

(defun return_dynamic_aggregate (dn choices val &optional index_list)
  (let ((index_list
	  (cond (index_list index_list)
		(t (*catch '*bad_index_list*
		     (cond
		       ((constrained_arrayp dn)
			(create_index_list (find_constraint_for2
					     (diana_get dn 'sm_exp_type))))))))))
    (cond ((null (diana_nodep val))
	   (semgripe 'cannot_normalize
		     (diana_get val 'lx_srcpos))
	   (*throw '*cannot_normalize*
		   '*cannot_normalize*)))
    (cond ((eq (diana_nodetype_get val) 'dn_aggregate)
	   (cond ((cdr index_list)
		  (normalize_constrained_array_aggregate
		    val
		    (cdr index_list)))
		 (t (normalize_aggregate val)))))
    (diana_put dn
	       (dynamic_range_rec (car choices) val)
	       'sm_normalized_comp_s)))

(defun dynamic_aggregatep (dn &optional index_list)
  (let ((seq (diana_get dn 'as_list)))
    (cond
      ((and (named_aggregatep seq)
	    (null (cdr seq)))
       (let* ((choices (diana_get (diana_get (car seq) 'as_choice_s) 'as_list))
	      (val (diana_get (car seq) 'as_exp))
	      (firstchoice (eval_named_choice (car choices))))
	 (cond
	   ((null (cdr choices))
	    (cond ((and (consp firstchoice)
			(or (diana_nodep (car firstchoice))
			    (diana_nodep (cadr firstchoice))))
		   (return_dynamic_aggregate dn choices val index_list))
		  ((diana_nodep firstchoice) 
		   (ct_selectq
		     (diana_nodetype_get firstchoice)
		     (dn_others)
		     ((dn_enum_id dn_def_char dn_character_literal))
		     (otherwise		  ; must be a dynamic_range
		       (return_dynamic_aggregate
			 dn choices val index_list))))))))))))
	      
(defun return_range (rng)
  (cond ((and (diana_node_accepts_attributep rng 'as_exp1)
	      (diana_node_accepts_attributep rng 'as_exp2))
	 (let ((e1 (return_index (diana_get rng 'as_exp1) nil))
	       (e2 (return_index (diana_get rng 'as_exp2) nil)))
	   `(,e1 ,e2)))
	((eq (diana_nodetype_get rng) 'dn_subtype_id)
	 (return_range (diana_get rng 'sm_type_spec)))
	((eq (diana_nodetype_get rng) 'dn_constrained)
	 (cond ((and (diana_get rng 'as_constraint)
		     (null (eq (diana_nodetype_get (diana_get rng 'as_constraint))
			       'dn_void)))
		(return_range (diana_get rng 'as_constraint)))
	       (t (return_range (diana_get rng 'as_name)))))
	((eq (diana_nodetype_get rng) 'dn_type_id)
	 (return_range (diana_get rng 'sm_type_spec)))
	((eq (diana_nodetype_get rng) 'dn_enum_literal_s)
	 `(,(diana_get (car (diana_get rng 'as_list)) 'sm_pos)
	   ,(diana_get (car (last (diana_get rng 'as_list)))
		       'sm_pos)))
	((and (eq (diana_nodetype_get rng) 'dn_used_name_id)
	      (diana_get rng 'sm_defn))
	 (return_range (diana_get rng 'sm_defn)))
	(t
	 nil)))

;;;CROCK++
(defun find_constraint_for2 (dn)
  (let ((res (find_constraint_for dn)))
    (cond ((eq (diana_nodetype_get res) 'dn_subtype_id)
	   (find_constraint_for (diana_get res 'sm_type_spec)))
	  ((eq (diana_nodetype_get res) 'dn_derived)
	   (find_constraint_for2 (diana_get res 'as_constrained)))
	  (t res))))

       ;;;;;;;;;;;;;;;;;
(defun create_index_list (range_list)
       ;;;;;;;;;;;;;;;;;;
  (mapcar
    #'return_range
    (diana_get range_list 'as_list)))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
(defun normalize_enum_literal_aggregate (dn)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (let* ((asl (diana_get dn 'as_list))
	(smexp (diana_get dn 'sm_exp_type));list of lits
	(normalized nil)
	(numsm (length (diana_get smexp 'as_list)))
	(numasl (length asl)))
    (cond ((not (eq numsm numasl))
	   (semgripe 'wrong_number_of_values_in_rep_clause))
	  ((eq (diana_nodetype_get (car asl)) 'dn_named);needs normalizing
	   (let* ((norm (do ((i 0 (1+ i))
			     (n nil))
			    ((= numasl i) n)
			  (setq n (append '(nil) n)))));list of of right length
	     (mapc #'(lambda (nam)		       
		       (let ((exp (diana_get nam 'as_exp));expression
			     (id (diana_get
				   (car (diana_get
					  (diana_get nam 'as_choice_s)
					  'as_list))
				   'lx_symrep)))  ;lex_ident			 
			 (cond ((neq (do ((j 0 (1+ j))
					  (count 0))
					 ((= j numasl) count)
				       (cond ((equal
						id
						(diana_get
						  (nth j
						       (diana_get smexp 'as_list))
						  'lx_symrep))		      
					      (rplaca (nthcdr j norm) exp)
					      (setq count (1+ count))))) 1)
				(semgripe 'incorrect_name_in_aggregate )))))
		   asl)
	     (mapc #'fe_static_eval norm)
	     (ascending_orderp norm)
	     (diana_put dn (sc_diana dn_exp_s
				     as_list norm)
			'sm_normalized_comp_s)))	     
	  (t ;map down asl and get as_exp
		  (mapc #'(lambda (exp)
			    (setq normalized
				  (append normalized (list exp))))
			asl)
		  (mapc #'fe_static_eval normalized)
		  (ascending_orderp normalized)
		  (diana_put dn (sc_diana dn_exp_s
				     as_list normalized)
			'sm_normalized_comp_s))))
  (%= *awaiting_aggregate_disambiguation* (delq dn *_*))
  dn)

       ;;;;;;;;;;;;;;;;
(defun ascending_orderp (lt)
       ;;;;;;;;;;;;;;;;
  (let ((currentval (diana_get (first lt) 'sm_value)))
    (mapc
      #'(lambda (nuval)
	  (cond (nuval
		 (let ((nval (diana_get nuval 'sm_value)))
		   (cond ((> nval currentval)
			  (setq currentval nval))
			 (t (semgripe 'integer_codes_in_wrong_order)))))))
	  (cdr lt))))

       ;;;;;;;;;;;;;;;;;;;;;;;
(defun constrained_arrayp (dn)
       ;;;;;;;;;;;;;;;;;;;;;;;
  (let ((type (diana_get dn 'sm_exp_type)))
    (and (arrayp type)
	 (let ((indices (find_constraint_for2 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)
		     constrainedp))
		 (t nil))))))


;;; This gets a diana node of type dn_aggregate (an array), which can
;;; can contain dn_nameds (things like (1 | 2 | 3..7 => 'a')). It returns
;;; a diana node which is an expansion (like (1 => 'a' 2 => 'a' etc.)).
;;; index_list is a list of lists of dimension boundaries. So for example,
;;; a(1..3,2..4,0..9) would be represented as ((1 3) (2 4) (0 9))
;;; index_list=nil for an unconstrained array
       ;;;;;;;;;;;;;;;;
(defun named_aggregatep (seq)
       ;;;;;;;;;;;;;;;;
  (eq (diana_nodetype_get (car seq)) 'dn_named))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun normalize_unconstrained_array_aggregate (dn)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  ;; Creates index_list and then normalizes array
  (cond ((dynamic_aggregatep dn))
	(t
	 (*catch
	   '*cannot_normalize*
	   (diana_put
	     dn ;; Should do a catch in case the aggregate is hopeless
	     (get_index_list_from_unconstrained_aggie
	       (diana_get dn 'as_list)
	       (length
		 (diana_get
		   (find_constraint_for2 dn)
		   'as_list)))
	     'ct_index_list)
	   (cond
	     ((null_indexlist (diana_get dn 'ct_index_list))
	      (*throw '*cannot_normalize* '*cannot_normalize*)))
	   (normalize_constrained_array_aggregate dn
						  (diana_get dn 'ct_index_list))
	   ))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get_index_list_from_unconstrained_aggie (meaty_part depth)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (cond
    ((named_aggregatep meaty_part)
     (let ((smallest nil) (largest nil) (rest_of_il nil))
       (mapc
	 #'(lambda (memb)
	     (cond
	       ((null (and (diana_nodep memb)
			   (eq (diana_nodetype_get memb) 'dn_named)))
		(semgripe 'cannot_disabiguate (diana_get memb 'lx_srcpos)))
	       (t
		(cond
		  ((and
		     (eq (diana_nodetype_get (diana_get memb 'as_exp))
			 'dn_aggregate)
		     (null rest_of_il)
		     (null (eq depth 1)))
		   (setq rest_of_il
			 (get_index_list_from_unconstrained_aggie
			   (diana_get (diana_get memb 'as_exp) 'as_list)
			   (1- depth)))))
		(mapc			  ; Iterate down the choices (1|2|3..4,etc)
		  #'(lambda (choice)
		      (setq choice (eval_named_choice choice))
		      (cond ((numberp choice)
			     (%= smallest
				 (ct_min smallest
					 (return_index choice)))
			     (%= largest
				 (ct_max largest
					 (return_index choice))))
			    ((consp choice)
			     (cond ((<= (return_index (car choice))
					(return_index (cadr choice))
				    (%= smallest
					(ct_min smallest
						(return_index (car choice))))
				    (%= largest
					(ct_max largest
						(return_index (cadr choice))))))))
			    ((diana_nodep choice)
			     (ct_selectq
			       (diana_nodetype_get choice)
			       (dn_others
				 (semgripe 'others_in_unconstrained_aggie)
				 (*throw '*cannot_normalize* '*cannot_normalize*))
			       ((dn_enum_id dn_def_char dn_character_literal)
				(%= smallest
				    (ct_min smallest
					    (return_index choice)))
				(%= largest
				    (ct_max largest
					    (return_index choice))))
			       
			       (otherwise ; Illegal choice
				 (dynamic_range choice))))
			    (t (dynamic_range choice))))
		  (diana_get		  ; Extract choices from diana node
		    (diana_get		  ; DN_CHOICE_S
		      memb		  ; DN_NAMED
		      'as_choice_s)
		    'as_list)))))
	 meaty_part)
       (cons (list smallest largest)
	     rest_of_il)))
    (t					  ;Must be sequenced	 
     (cons (list 1			  ;CROCKERY!!!++
		 (length meaty_part))
	   (cond ((and
		    (eq (diana_nodetype_get (car meaty_part))
			'dn_string_literal)
		    (null (eq depth 1)))
		  (cons (list 1
			      (length
				(cadr
				  (diana_get (car meaty_part)
					     'lx_symrep))))
			nil))
		 ((and
		    (eq (diana_nodetype_get (car meaty_part))
			'dn_aggregate)
		    (null (eq depth 1)))
		  (get_index_list_from_unconstrained_aggie
		    (diana_get (car meaty_part) 'as_list)
		    (1- depth))))))))
       ;;;;;;;
(defun ct_max (x y)
       ;;;;;;;
  (cond ((null x) y)
	((null y) x)
	(t (max x y))))

       ;;;;;;
(defun ct_min (x y)
       ;;;;;;
  (cond ((null x) y)
	((null y) x)
	(t (min x y))))

       ;;;;;;;;;;;;;;
(defun null_indexlist (il)
       ;;;;;;;;;;;;;;
  (null
    (mapcan #'(lambda(dim)
		(cond ((null (car dim)) nil)
		      (t (list (car dim))))
		(cond ((null (cadr dim)) nil)
		      (t (list (cadr dim)))))
	    il)))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun normalize_constrained_array_aggregate (dn index_list)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    (*catch
      '*cannot_normalize*
      (cond
	((null_indexlist index_list)
	 (normalize_unconstrained_array_aggregate dn))
	((dynamic_aggregatep dn index_list))
	(t
	 (diana_put
	   dn
	   (sc_diana 
	     dn_exp_s
	     as_list
	     (cond ((named_aggregatep (diana_get dn 'as_list))
		    (normalize_named_constrained_array_aggregate
		      (diana_get dn 'as_list)
		      index_list))
		   (t
		    (normalize_seq_constrained_array_aggregate
		      (diana_get dn 'as_list)
		      index_list))))
	   'sm_normalized_comp_s)
	 (cond ((memq nil
		      (diana_get
			(diana_get dn 'sm_normalized_comp_s)
			'as_list))
		(semgripe 'array_aggie_short))
	       )
	 index_list))))

(defun arragg_rplac_nth (index starti res val)
  (agg_rplac_nth
    (1+ (- index starti))
    res
    val))

(defun eval_named_choice(dn)
  (let ((res (agg_static_eval dn)))
    (cond ((null (diana_nodep res)) res)
	  (t
	   (ct_selectq
	     (diana_nodetype_get res)
	     (dn_range `(,(eval_named_choice (diana_get dn 'as_exp1))
			 ,(eval_named_choice (diana_get dn 'as_exp2))))
	     (dn_type_id (eval_named_choice (diana_get res 'sm_type_spec)))
	     (dn_subtype_id (eval_named_choice (diana_get res 'sm_type_spec)))
	     (dn_constrained (eval_named_choice (find_constraint_for2 dn)))
	     (dn_dscrmt_id nil)
	     (dn_enum_literal_s `(,(car (diana_get res 'as_list))
				  ,(car (last (diana_get res 'as_list)))))
	     (otherwise res))))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun normalize_named_constrained_array_aggregate (meaty_part index_list)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (let ((val nil) (res (expand_array index_list)))
    (mapc
      #'(lambda (memb)			  ; (let ((val (diana_get memb 'as_exp)))
	  (cond ((null (and (diana_nodep memb)
		            (eq (diana_nodetype_get memb) 'dn_named)))
		 (semgripe 'mix_namd_n_seq)
		 (throw '*cannot_normalize* '*cannot_normalize))
		(t
		 (setq val (diana_get memb 'as_exp))
		 (cond ((null (diana_nodep val))
			(semgripe 'cannot_normalize (diana_get val 'lx_srcpos))
			(*throw '*cannot_normalize* '*cannot_normalize*)))
		 (cond ((eq (diana_nodetype_get val) 'dn_aggregate)
			(cond ((cdr index_list)
			       (normalize_constrained_array_aggregate
				 val
				 (cdr index_list)))
			      (t (normalize_aggregate val)))))
		 (mapc			  ; Iterate down the choices (1|2|3..4,etc)
		   #'(lambda (choice)
		       (setq choice (eval_named_choice choice))
		       (cond
			 ((numberp choice)
			  (arragg_rplac_nth
			    (return_index choice) (caar index_list)
			    res
			    val))
			 ((consp choice)
			  (map_over_range
			    'arragg_rplac_nth
			    (return_index (car choice))
			    (return_index (cadr choice))
			    (caar index_list)
			    res val))
			 ((diana_nodep choice)
			  (ct_selectq (diana_nodetype_get choice)
				      (dn_others
					(ct_subst val nil res))
				      ((dn_enum_id dn_def_char dn_character_literal)
				       (arragg_rplac_nth
					 (return_index choice) (caar index_list)
					 res
					 val))
				      (otherwise  ; Illegal choice
					(dynamic_range choice val))))))
		   (diana_get		  ; Extract choices from diana node
		     (diana_get
		       memb     
		       'as_choice_s)
		     'as_list)))))
      meaty_part)
    res))

(defun agg_static_eval (dn)
  (*catch '*diana_node_not_static_expression* (static_eval dn t)))

(defun dynamic_range (dn val)
  (*throw '*cannot_normalize* '*cannot_normalize*))

(defun map_over_range (fn starting ending &rest other_args)
  (do ((c starting (1+ c)))
      ((> c ending))
    (apply fn (cons c other_args))))

(defun normalize_seq_constrained_array_aggregate (meaty_part index_list)
  (let ((res (expand_array index_list)))
    (map
      #'(lambda (membs cpp)
	  (cond
	    ((eq			  ; When done going down the array in order
	       (diana_nodetype_get (car membs)) 
	       'dn_named)
	     (let ((val (diana_get (car membs) 'as_exp)))
	       (cond ((eq (diana_nodetype_get val) 'dn_aggregate)
		      (cond ((cdr index_list)
			     (normalize_constrained_array_aggregate
			       val
			       (cdr index_list)))
			    (t (normalize_aggregate val)))))
	       ;; must be an OTHERS 
	       (cond ((null
			(eq
			  (diana_nodetype_get
			    (car (diana_get (diana_get (car membs) 'as_choice_s)
					    'as_list)))
			  'dn_others))
		      (semgripe 'mix_namd_n_seq)))
	       (ct_subst
		 val 
		 nil
		 res)))
	    ((eq			  ; Multi-dimensional array
	       (diana_nodetype_get 
		 (car membs))
	       'dn_aggregate)
	     (cond ((null (cdr index_list))	  ; Aggregate
		    (normalize_aggregate (car membs))
		    (rplaca cpp (car membs)))
		   (t			  ; Aggregate for other dimension
		    (normalize_constrained_array_aggregate (car membs)
							   (cdr index_list))
		    (rplaca cpp (car membs))))
	     (setq cpp (cdr cpp)))
	    (t				  ; A sequenced literal
	     (cond ((car index_list)	  ; Constrained array type
		    (rplaca cpp (car membs)))
		   (t (lose 'fe_uattna
			    ;; Unconstr.ArrayTypeToNormalizeArrayAggregate
			    ;; Should never happen! ++
			    'normalize_constrained_array_aggregate))))))
      meaty_part
      res)
    res))

;;; Takes an array which is a list of ranges of each dimension and expands
;;; it into a list with the number of elements in the range of the first 
;;; dimension with each element being the rest of the dimensions. This
;;; comment is longer than its corresponding code.

       ;;;;;;;;;;;;
(defun expand_array (index_list)
       ;;;;;;;;;;;;
  
  (cond ((null index_list) nil)
	(t
	 (let ((lb (return_index (caar index_list) nil))
	       (ub (return_index (cadar index_list) nil)))
	   (cond ((and (numberp lb) (numberp ub))
		  (do ((c (caar index_list) (1+ c))
		       (res nil (cons nil res)))
		      ((> c (cadar index_list)) res)))
		 (t (bad_index_list)))))))

(defun bad_index_list () (*throw '*bad_index_list* '*bad_index_list*))

;;; Substitute (dangerously) every occurance of `deletee' with `addee' in
;;; the top level of `object_of_replacement'

       ;;;;;;;;
(defun ct_subst (addee deletee object_of_replacement) 
       ;;;;;;;;

       (map
	 #'(lambda (whats_left)
	       (cond ((eq (car whats_left) deletee) (rplaca whats_left addee))))
	 object_of_replacement))

;;; Gets a lisp number out of a diana node of type DN_NUMERIC_LITERAL

       ;;;;;;;;;;;;
(defun return_index (dn &optional (die t))
       ;;;;;;;;;;;;
  (let ((val (cond ((diana_nodep dn) (fe_static_eval dn))
		   (t dn))))
    (cond ((eq val '*diana_node_not_static_expression*)
	   (setq val dn)))
    (cond ((diana_nodep val)
	   (ct_selectq
	     (diana_nodetype_get val)
	     (dn_numeric_literal (numval (diana_get val 'lx_numrep)))
	     (dn_character_literal (caadr (diana_get val 'lx_symrep)))
	     (dn_def_char (1+ (diana_get val 'sm_pos)))
	     (dn_enum_id (diana_get val 'sm_pos))
	     (otherwise
	       (cond (die
		      (sgripe
			`(,(ct_format
			     nil
			     "The aggregate on line ~A cannot be normalized."
			     (source_region%linstart
			       (diana_get val 'lx_srcpos))))
			'((lrmref "LRM" (lrmsec 13 3 nil) (lrmpar 4 nil))
			  (lrmref "LRM" (lrmsec 13 3 nil) (lrmpar 5 nil))))
		      (bad_index_list))
		     (T (bad_index_list))))))
	  (t val))))

;;; Replace the `int'th element of list `list' with `nuthing'. `int' must
;;; start with 1.

       ;;;;;;;;;
(defun agg_rplac_nth (int list nuthing &optional (complain t))
       ;;;;;;;;;
  (cond ((lessp int 0)
	 (cond (complain (*throw '*cannot_normalize* '*cannot_normalize*)
			 (semgripe 'array_aggie_index_too_low))))
	((greaterp int (length list))
	 (cond (complain (*throw '*cannot_normalize* '*cannot_normalize*)
			 (semgripe 'array_aggie_index_too_high))))
	(t
	 #+franz (rplaca (nth int list) nuthing)  ; starts with 1
	 #+lispm (do ((res list (cdr res)) (i int (1-  i)))
		     ((eq i 1) (rplaca res nuthing))))))
	
;;; Replace the `int'th element of list `list' with `nuthing'. `int' must
;;; start with 1. If int is greater than the length of the list, make
;;; the list larger with nils
	
       ;;;;;;;;;;;;;;;;;;;;
(defun agg_rplac_nth_create (int list nuthing)
       ;;;;;;;;;;;;;;;;;;;;
  
  (cond ((lessp int 0) (semgripe 'array_aggie_index_too_low))
        (t
	 (do ((res list (cdr res)) (i int (1-  i)))
	     ((eq i 1) (rplaca res nuthing))
	   (cond ((null (cdr res)) (rplacd res (cons nuthing nil))))))))
	
(defun offset_of (n l) (mod (- (length l) (length (memq n l))) (length l)))
	
(defun merge_out_nils (r d)
  (map #'(lambda (x y)
	   (cond ((car x))
		 ((cadddr (car y)) (rplaca x (cadddr (car y))))
		 (t (semgripe 'rec_aggie_short))))
       r
       d)
  r)

(defun cannot_normalize (dn)
  (sgripe
    `(,(ct_format
	 nil
	 "The aggregate on line ~A cannot be normalized."
	 (source_region%linstart
	   (diana_get dn 'lx_srcpos))))
    '((lrmref "LRM" (lrmsec 13 3 nil) (lrmpar 4 nil))
      (lrmref "LRM" (lrmsec 13 3 nil) (lrmpar 5 nil)))))

;;; Normalizing record aggregates consists of three phases:
;;;   1). Finding the discriminants and their values
;;;   2). Using the information from the first step, which is contained
;;;       in an alist of the form `((,dscrmnt1 ,value1) ... (,dscrmntN ,valueN)),
;;;       to create the offset alist, a list, in order containing
;;;       triples of the form (,<SYMREPn for Nth selector> ,<N> ,<Type spec>).
;;;   3). Using the information from step 2, fill a list with N elements with the
;;;       appropriate values


(defun normalize_record_aggregate (agg)
  (let* ((recdef (extract_basetype (diana_get agg 'sm_exp_type) t))
	 (dscrmt_aggie (find_constraint_for2 (diana_get agg 'sm_exp_type)))
	 (dscrmt_aggie
	   (cond ((null (diana_nodep dscrmt_aggie)) nil)
		 (t
		  (ct_selectq (diana_nodetype_get dscrmt_aggie)
			      (dn_record
				(setq recdef dscrmt_aggie)
				nil)
			      (dn_dscrmt_aggregate
				(diana_get dscrmt_aggie 'as_list))))))
	 (dscrmts
	   (find_dscrmt_values
	     (diana_get agg 'as_list)
	     recdef
	     dscrmt_aggie
	     ))
	 (offset_alist
	   (reverse
	     (build_list_of_triples
	       1 dscrmts
	       (cond
		 (dscrmts
		  (append (diana_get (diana_get recdef 'sm_discriminants) 'as_list)
			  (diana_get recdef 'as_list)))
		 (t (diana_get recdef 'as_list))))))
	 (res (mapcar #'(lambda (x) nil) offset_alist)))
    (%= res
	(fill_in_slots_to_record_aggregate
	  res offset_alist
	  (cond (dscrmt_aggie (append (mapcar #'cadr dscrmts)
				 (diana_get agg 'as_list)))
		(t (diana_get agg 'as_list)))
	  nil))
    (%= res (merge_out_nils res offset_alist))
    (diana_put agg (sc_diana dn_exp_s as_list res) 'sm_normalized_comp_s)
    ))

;;; 
;;; Finds the discriminant values.
;;; Produces an alist.
(defun find_dscrmt_values (agg recdef dscrmt_aggie)
  (cond ((and dscrmt_aggie (diana_get recdef 'sm_discriminants))
	 (let ((dscrmts
		 (mapcan
		   #'(lambda (var)
		       (mapcar #'(lambda (id) (diana_get id 'lx_symrep))
			       (diana_get var 'as_id_s)))
		   (diana_get (diana_get recdef 'sm_discriminants) 'as_list))))
	   (mapcar
	     #'(lambda (dscrmt val) `(,dscrmt ,val))
	     dscrmts dscrmt_aggie)))
	((diana_get recdef 'sm_discriminants)
	 (let*
	   ((dscrmts
	      (mapcan
		#'(lambda (var)
		    (mapcar #'(lambda (id) (diana_get id 'lx_symrep))
			    (diana_get var 'as_id_s)))
		(diana_get (diana_get recdef 'sm_discriminants) 'as_list)))
	    (offset_alist
	      (reverse
		(build_list_of_triples
		  1 nil
		  (append (diana_get (diana_get recdef 'sm_discriminants) 'as_list)
;			  (diana_get recdef 'as_list)
			  ))))
	    (res (mapcar #'(lambda (x) nil) offset_alist)))
	   (%= res (fill_in_slots_to_record_aggregate res offset_alist agg t))
	   (setq res (merge_out_nils res offset_alist))
	   (mapcar
	     #'(lambda (dscrmt val) `(,dscrmt ,val))
	     dscrmts res)))))

(defun is_in (inval choice_s)
  (do ((val (agg_static_eval inval))
       (rest choice_s (cdr rest)))
      ((null rest) nil)
    (cond ((or (eq (diana_nodetype_get (car rest)) 'dn_others)
	       (eq (agg_static_eval (car rest)) val))
	   (return t)))))

(defun build_list_of_triples (stoffset dlist vars)
  (let ((ct stoffset) (offset_alist nil))
    (mapc
      #'(lambda (elem)
	  (ct_selectq
	    (diana_nodetype_get elem)
	    (dn_variant_part
	      (let* ((name (diana_get (diana_get elem 'as_name) 'lx_symrep))
		     (val (cadr (assoc name dlist))))
		(do ((variants (diana_get (diana_get elem 'as_variant_s)
					  'as_list)
			       (cdr variants)))
		    ((null variants) ())
		  (cond ((is_in val
				(diana_get (car variants) 'as_choice_s))
			 (let* ((subres
				  (build_list_of_triples
				    ct
				    dlist
				    (diana_get
				      (diana_get (car variants) 'as_record)
				      'as_list))))
			   (%= offset_alist
			       (append subres *_*))
			   (%= ct (+ *_* (length subres))))
			 (return))))))
	    (dn_var    
	      (mapc
		#'(lambda (avar)
		    (ct_push `(,(diana_get avar 'lx_symrep)
			       ,ct
			       ,(diana_get elem 'as_type_spec)
			       ,(diana_get elem 'as_object_def))
			     offset_alist)
		    (%= ct (1+ *_*)))
		(diana_get elem 'as_id_s)))
	    (dn_null_comp)
	    (otherwise (cannot_normalize elem))))
      vars)
    offset_alist))

(defun fill_in_slots_to_record_aggregate
       (res offset_alist agg limited_res)
  (do					  ; Iterate down dn's as_list
      ((rest_of_agg agg (cdr rest_of_agg))
       (cpp res)
       (start_unsequenced nil))
      ((or (and (null start_unsequenced) (null cpp)) (null rest_of_agg))
       res)
      (cond
	((eq				  ; When done going down  record in order
	   (diana_nodetype_get (car rest_of_agg)) 
	   'dn_named)
	 (setq start_unsequenced t)
	 (let ((val (diana_get (car rest_of_agg) 'as_exp)))
	   (mapcar			  ; Iterate down the choices
	     #'(lambda (choice)
		 (ct_selectq
		   (diana_nodetype_get choice)
		   (dn_others		  ; Is it an "others"?
		     (cond ((eq (diana_nodetype_get val) 'dn_aggregate)
			    (diana_put val
				       (caddr
					 (nth
					   (offset_of nil res)
					   offset_alist))
				       'sm_exp_type)
			    (normalize_aggregate val)))
		     (ct_subst
		       val 
		       nil 
		       res))
		   (dn_selected		  ; like aField => someThing
		     (let* ((pair
			      (assoc
				(diana_get
				  (diana_get choice 'as_designator_char)
				  'lx_symrep)
				offset_alist))
			    (offset (cadr pair))
			    (type (caddr pair)))
		       (cond ((eq (diana_nodetype_get val) 'dn_aggregate)
			      (diana_put val
					 type
					 'sm_exp_type)
			      (normalize_aggregate val)))
		       (cond 
			 (limited_res
			  (cond ((and offset (<= offset (length res)))
				 (agg_rplac_nth
				   offset
				   res
				   val
				   nil))))
			 (offset
			  (agg_rplac_nth
			    offset
			    res
			    val
			    nil))
			 (t
			  (sgripe
			    `(,(ct_format
				 nil
				 "The selected component on line ~A is unknown."
				 (source_region%linstart
				   (diana_get choice 'lx_srcpos))))
			    '((lrmref "LRM" (lrmsec 4 3 1) (lrmpar 1 nil))
			      (lrmref "LRM" (lrmsec 4 3 1) (lrmpar 4 6))))))))
		   (dn_used_name_id
		     (let* ((pair
			      (assoc
				(diana_get choice 'lx_symrep)
				offset_alist))
			    (offset (cadr pair))
			    (type (caddr pair)))
		       (cond ((eq (diana_nodetype_get val) 'dn_aggregate)
			      (diana_put val
					 type
					 'sm_exp_type)
			      (normalize_aggregate val)))
		       (cond 
			 (limited_res
			  (cond ((and offset (<= offset (length res)))
				 (agg_rplac_nth
				   offset
				   res
				   val
				   nil))))
			 (offset
			  (agg_rplac_nth
			    offset
			    res
			    val
			    nil))
			 (t
			  (sgripe
			    `(,(ct_format
				 nil
				 "The selected component on line ~A is unknown."
				 (source_region%linstart
				   (diana_get choice 'lx_srcpos))))
			    '((lrmref "LRM" (lrmsec 4 3 1) (lrmpar 1 nil))
			      (lrmref "LRM" (lrmsec 4 3 1) (lrmpar 4 6))))))))
		   (otherwise		  ; Illegal choice ++
		     (lose 'fe_ictnra
			   'normalize_record_aggregate))))
	     (diana_get			  ; Extract choices from diana node
	       (diana_get		  ; DN_CHOICE_S
		 (car rest_of_agg)	  ; DN_NAMED
		 'as_choice_s)
	       'as_list) 
	     ))
	 )
	((eq				  ; Multi-dimensional array
	   (diana_nodetype_get 
	     (car rest_of_agg))
	   'dn_aggregate)
	 (diana_put (car rest_of_agg)
		    (caddr (ct_nth (1+ (- (length res) (length cpp)))
				   offset_alist))
		    'sm_exp_type)
	 (normalize_aggregate (car rest_of_agg))
	 (rplaca cpp (car rest_of_agg))	  ; PHROB !!!++
	 (setq cpp (cdr cpp)))
	(start_unsequenced
	 (semgripe
	   'el_out_of_order_aggie))
	(t				  ; A sequenced literal
	 (rplaca cpp (car rest_of_agg))
	 (setq cpp (cdr cpp))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; disambiguate aggregates and put in their type specs.

       ;;;;;;;;;;;;;;;;;;;;;;;
(defun dissambiguate_aggregate (dn mom)
       ;;;;;;;;;;;;;;;;;;;;;;;
  (let ((my_type    (diana_get dn 'sm_exp_type)))
    (cond
      (my_type
       (%= *awaiting_aggregate_disambiguation* (delq dn *_*))
       (normalize_aggregate dn)))))



;;;EOF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;