;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; $Header: /ct/interp/ctadadt.l,v 1.108 85/06/25 15:13:12 bill Exp $
;;;
;;; Hacked 15 August 1985 Richard Mark Soley for Lambda port


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                            ctadadt.l                             ;;;
;;; Paul Robertson                                 February 20, 1983 ;;;
;;;                                                                  ;;;
;;;               C * T Ada DataTypes definitions                    ;;;
;;;                                                                  ;;;
;;; 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:                                             ;;;
;;;   Foderaro and Sklower, The FRANZ LISP Manual, September 1981.   ;;;
;;;   Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981.   ;;;
;;;   Charniak et al., 1980.  Artificial Intelligence Programming.   ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(comment Assumes ct_load and some suitable ct_daba are present)

(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 'ctflav)); flavor compatability.

(eval-when (compile load eval) (ct_load 'ferec)); flavor compatability.

(eval-when (compile load eval) (ct_load 'diana));diana functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
(declare (ct_includef 'intrpdcl))
(declare (special *L* *R* *D*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros -- 

;;; The following Flavor definitions describe the Datatypes supported by
;;; C * T Ada and the protocol imposed upon these objects.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; C * T Ada Interpreter Data Type Protocol
(ct_defflavor ada_datatype
           (sm_defn		; Pointer to this objects defining type defn.
	    def_occurence	; Pointer to objects defining occurence.
	    ada_name
	    ada_index
	    ctadadt_id          ; A unique id for this instance
	    (ct_prehook nil)    ; Called before writes
	    (ct_posthook nil)   ; Called after writes
	   )
	   ()
	   :gettable-instance-variables
	   :settable-instance-variables
	   :documentation); "Protocol for C * T Ada datatypes")

(ct_defmethod (ada_datatype get_val)(path)
    (lose 'dt_sfr 'ada_datatype
	  ()
	  '("SubFlavor Responsibility - get_val")))

(ct_defmethod (ada_datatype set_val)(path nuval)
    (lose 'dt_sfr 'ada_datatype
	  ()
	  '("SubFlavor Responsibility - set_val")))

; 
; A before method for writing a variable. Looks for a pre hook function. If one is
; found then apply it.
; 

(ct_defmethod (ada_datatype :before set_val) (path nuval)
    (ctadadt_maybe_run_hook ct_prehook self path nuval 'before)
)

; 
; An after method for writing a variable. Looks for a pre hook function. If one is
; found then apply it.
; 

(ct_defmethod (ada_datatype :after set_val) (path nuval)
    (ctadadt_maybe_run_hook ct_posthook self path nuval 'after)
)

(ct_defmethod (ada_datatype attribute_handler)(at_name params)
    (lose 'dt_sfr 'ada_datatype
	  ()
	  '("SubFlavor Responsibility - attribute_handler")))

(ct_defmethod (ada_datatype initialize)(params)
    (%= sm_defn (first params))
    (%= def_occurence (and (fourth params)
			   (cond ((eq (diana_nodetype_get (fourth params))
				      'dn_allocator)
				  (fourth params))
				 (t (diana_get (fourth params) 'sm_defn)))))
    (%= ctadadt_id (new_ctadadt_id '|ALL| sm_defn))
); first parameter must be the sm_defn. fourth must be occurence.

(ct_defmethod (ada_datatype size) ()
    32)

; 
; An after method for initializing a variable. Called when ever a new variable is
; created. Looks for a hook on the diana tree. Used by the debugger.
; 

(ct_defmethod (ada_datatype :after initialize) (params)
    (ctadadt_maybe_run_hook (diana_late_get *diana* 'ctadadt_inithook) self params
			    def_occurence 'creation))

(ct_defmethod (ada_datatype printself)(stream)
    (lose 'dt_sfr 'ada_datatype
	  ()
	  '("SubFlavor Responsibility - printself")))

(ct_defmethod (ada_datatype copyself)()
    (lose 'dt_sfr 'ada_datatype
	  ()
	  '("SubFlavor Responsibility - copyself")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Enumeration Types

(ct_defflavor dt_enumeration_type

	   (current_value	; The current value of this object
	    lastpos		; position of the last literal (integer)
	    range)              ; range constraint
	   (ada_datatype)
	   :gettable-instance-variables
	   :settable-instance-variables
	   :documentation); "The Ada datatype - enumeration type")

(ct_defmethod (dt_enumeration_type copyself)()
    (ct_make_instance
	'dt_enumeration_type
	'ada_name ada_name
	'ada_index ada_index
	'range range
	'sm_defn sm_defn
	'current_value current_value
	'lastpos lastpos))

(ct_defmethod (dt_enumeration_type get_val)(path)
    (mapc
     #'(lambda (advice)
	 (cond ((and (eq (variable_advise_rec%reason advice) 'get)
		     (or  (null ada_index)
			  (null (variable_advise_rec%index advice) )
			  (equal ada_index
				 (variable_advise_rec%index advice))))
		(funcall (variable_advise_rec%funfrob advice)
		ada_name current_value nil ada_index))))	       	 
     (and *not_inside_debug_ta* (get ada_name 'ada_variable_advise)))
    current_value)		; Return the literal associated with this
				; enumeration object.

(ct_defmethod (dt_enumeration_type set_val)(path nuval)
   (cond ((instancep nuval)
	  (setq nuval (ct_send nuval 'current_value))))
    (mapc
     #'(lambda (advice)
	 (cond ((and (eq (variable_advise_rec%reason advice) 'set)
		     (or  (null ada_index)
			  (null (variable_advise_rec%index advice) )
			  (equal ada_index
				 (variable_advise_rec%index advice))))
		(funcall (variable_advise_rec%funfrob advice)
		 ada_name current_value nuval ada_index))))	       	 
     (and *not_inside_debug_ta* (get ada_name 'ada_variable_advise)))
    (cond ((and
	     (neq nuval '*unassigned*)
	     *range_checking*
	     range
	     (let ((nuvalpos (cond ((diana_nodep nuval)
				    (diana_get nuval 'sm_pos))
				   ((and (consp nuval)
					 (eq (car nuval) 'lex_string))
				    (caadr nuval))
				   ((numberp nuval) nuval))))
	       (or (> nuvalpos
		    (diana_get (second range) 'sm_pos))
		 (< nuvalpos
		    (diana_get (first range) 'sm_pos)))))
	   (ct_if *io_get_enum*
		  (ada_raise '|data_error|
			     "the enum value is out of range")
		  (ds_raise '|constraint_error| ))
	   (setq *io_get_enum* nil)))
    (%= current_value nuval)	; Update the literal associated with this
				; enumeration object.
    )
				
(ct_defmethod (dt_enumeration_type attribute_handler)(at_name params)
   (ct_selectq at_name
     (|pos| (diana_get current_value 'sm_pos))
     (|image| `(lex_string ,(cadr (diana_get current_value 'lx_symrep))))
     (|succ| 
       (let* ((pos (diana_get current_value 'sm_pos)))
	 (cond
	   ((ge pos lastpos)(ds_raise '|constraint_error|))
	   (t (n_th (1+ pos)
		    (diana_get
		      (or sm_defn (diana_get current_value 'sm_defn))
		      'as_list))))))
     (|pred| 
       (let* ((pos (diana_get current_value 'sm_pos)))
	 (cond
	   ((le pos 0)(ds_raise '|constraint_error|))
	   (t (n_th (1- pos)
		    (diana_get
		      (or sm_defn (diana_get current_value 'sm_defn))
		      'as_list))))))
     (|first| (n_th 0
		    (diana_get
		      (or sm_defn (diana_get current_value 'sm_defn))
		      'as_list)))
     (|last| (n_th lastpos
		    (diana_get
		      (or sm_defn (diana_get current_value 'sm_defn))
		      'as_list)))
     (otherwise
       (lose 'dt_tetanyi 'dt_enumeration_type
	     `("This enumeration type attribute is not yet implemented: ~A"
	       ,at_name)))))
 
(ct_defmethod (dt_enumeration_type initialize)(params)
    (%= sm_defn
	(let ((p (first params)))
	  (cond
	    ((and (diana_nodep p)
		  (eq (diana_nodetype_get p) 'dn_type_id))
	     (diana_get p 'sm_type_spec))
	    (t p))))
    (%= def_occurence (and (fourth params)
			   (cond ((eq (diana_nodetype_get (fourth params))
				      'dn_allocator)
				  (fourth params))
				 (t (diana_get (fourth params) 'sm_defn)))))
    (%= lastpos (1- (length
		      (and
			sm_defn
			(eq (diana_nodetype_get sm_defn) 'dn_enum_literal_s)
			(diana_get sm_defn 'as_list)))))
    (%= current_value '*unassigned*)
    (%= ctadadt_id (and sm_defn (new_ctadadt_id '|ENUMERATION| sm_defn)))

    (%= range (first (second params)))); With this we can trap errors.

(ct_defmethod (dt_enumeration_type printself) (stream)
 (let ((str (ct_if (diana_nodep current_value)
		   (apply 'ct_string_append
			  (second (diana_get current_value 'lx_symrep)))
		   '*unassigned*)))
    (cond ((equal str "'~'") (ct_format stream "'~~'"))
	  (t (ct_format stream str)))
	       ))

(ct_defmethod (dt_enumeration_type printvalue)()
 (cond ((equal current_value '*unassigned*)
	(ada_raise '|program_error|
		   "uninitialized enumeration type"))
       (t
	(second (diana_get current_value  'lx_symrep))) ;;AM -- for sequential io
	))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Integer Data Types

(ct_defflavor dt_integer_type
    (current_value		; The current value of this object (a lisp
				; integer).
     range)
    (ada_datatype)
    :gettable-instance-variables
    :settable-instance-variables
    :documentation); "The Ada datatype - Integer")

(ct_defmethod (dt_integer_type copyself)()
    (ct_make_instance
	'dt_integer_type
	'range range
	'ada_name ada_name
	'ada_index ada_index
	'sm_defn sm_defn
	'current_value current_value))

(ct_defmethod (dt_integer_type printself) (stream)
   (ct_format stream "~D" current_value))

  
(ct_defmethod (dt_integer_type get_val)(path)
   (mapc
     #'(lambda (advice)
	 (cond ( (and (eq (variable_advise_rec%reason advice) 'get)
		     (or  (null ada_index)
			  (null (variable_advise_rec%index advice) )
			  (equal ada_index
				 (variable_advise_rec%index advice))))
		(funcall (variable_advise_rec%funfrob advice)
		ada_name current_value nil ada_index))))	       	 
     (and *not_inside_debug_ta* (get ada_name 'ada_variable_advise)))
   (cond
     ((and (eq current_value '*unassigned*)
	   *not_inside_debug_ta*)
      ;(break can_we-see-if-out-id)
      #|(ct_format *errout*
	      "~%Warning: Attempt to use an unset variable on line ~A~%"
	      (source_region%linenumber (diana_get pc 'lx_srcpos)))|#      
      0)
    (t current_value)))		; Return the literal associated with this
				; integer

(ct_defmethod (dt_integer_type set_val)(path nuval)
   #|(cond ((instancep nuval)
	  (setq nuval (ct_send nuval 'current_value))))|#
    (mapc
     #'(lambda (advice)
	 (cond ((and (eq (variable_advise_rec%reason advice) 'set)
		     (or  (null ada_index)
			  (null (variable_advise_rec%index advice) )
			  (equal ada_index
				 (variable_advise_rec%index advice))))
		(funcall (variable_advise_rec%funfrob advice)
		 ada_name current_value nuval  ada_index))))	       	 
     (and *not_inside_debug_ta* (get ada_name 'ada_variable_advise)))
    (%= nuval (cond ((floatp nuval) (fix (plus 0.5 nuval)))
		    ((numberp nuval) nuval)
		    (t ;(ada_raise '|constraint_error| "not a number for integer")
		       nuval)))
    ;(break look-at-value-for-int)
    (cond ((and 
	     *range_checking*
	     (numberp nuval)
	     range
	     (or (> nuval (coerce_int (second range)))
		 (< nuval (coerce_int (first range)))))
	   (ct_if *io_get_integer*
		  (ada_raise '|data_error|
			     "the integer value is out of range")
		  (ds_raise '|constraint_error| ))
	   (setq *io_get_integer nil)
	   ))
    (%= current_value nuval))
    ;; Update the literal associated with this Integer.

(ct_defmethod (dt_integer_type attribute_handler)(at_name params)
   (ct_selectq at_name
     ;(break look-at-attributes-of-integer)
     (|image| `(lex_string ,(exploden (ct_format nil "~A" current_value))))
     (|succ| (1+ current_value));should check range for constraint error++
     (|pred| (1- current_value));should check range for constraint error++
     (|first| *integer_first*)			  ;wrong ++
     (|last| *integer_last*)			  ;wrong ++
     (otherwise
       (lose 'dt_titanyi 'dt_integer
	     `("This integer type attribute is not yet implemented: ~A"
	       ,at_name)))))

(ct_defmethod (dt_integer_type initialize)(params)
    (%= sm_defn (first params))
    (%= def_occurence (and (fourth params)
			   (cond ((eq (diana_nodetype_get (fourth params))
				      'dn_allocator)
				  (fourth params))
				 (t (diana_get (fourth params) 'sm_defn)))))
    (%= current_value '*unassigned*)
    (%= ctadadt_id (and sm_defn (new_ctadadt_id '|INTEGER| sm_defn)))
    (%= range (first (second params)))
    )

(ct_defmethod (dt_integer_type printvalue) ()
    (cond ((equal current_value '*unassigned*)      ;;AM -- for sequential io
	   (ada_raise '|program_error|
		      "uninitialized integer type"))
	  (t current_value)
    ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Floating Point Types

(ct_defflavor dt_floating_type
    (current_value		; The current value of this object (a lisp
				; flonum).
     range)
    (ada_datatype)
    :gettable-instance-variables
    :settable-instance-variables
    :documentation); "The Ada datatype - Floating")

(ct_defmethod (dt_floating_type copyself)()
    (ct_make_instance
	'dt_floating_type
	'ada_name ada_name
	'ada_index ada_index
	'range range
	'sm_defn sm_defn
	'current_value current_value))

(ct_defmethod (dt_floating_type printself) (stream)
   (ct_format stream "~F" current_value))

(ct_defmethod (dt_floating_type get_val)(path)
    (mapc
     #'(lambda (advice)
	 (cond ((and (eq (variable_advise_rec%reason advice) 'get)
		     (or  (null ada_index)
			  (null (variable_advise_rec%index advice) )
			  (equal ada_index
				 (variable_advise_rec%index advice))))
		(funcall (variable_advise_rec%funfrob advice)
		ada_name current_value nil ada_index))))	       	 
     (and *not_inside_debug_ta* (get ada_name 'ada_variable_advise)))
    (cond
     ((and (eq current_value '*unassigned*)
	   *not_inside_debug_ta*)
      ;(break can_we-see-if-out-id)
      #|(ct_format *errout*
	      "~%Warning: Attempt to use an unset variable on line ~A~%"
	      (source_region%linenumber (diana_get pc 'lx_srcpos)))|#      
      0.0)
    (t current_value)))		; Return the literal associated with this
				; floating_point object.

(ct_defmethod (dt_floating_type set_val)(path nuval)
   (cond ((instancep nuval)
	  (setq nuval (ct_send nuval 'current_value))))
    (mapc
     #'(lambda (advice)
	 (cond ((and (eq (variable_advise_rec%reason advice) 'set)
		     (or  (null ada_index)
			  (null (variable_advise_rec%index advice) )
			  (equal ada_index
				 (variable_advise_rec%index advice))))
		(funcall (variable_advise_rec%funfrob advice)
		 ada_name current_value nuval ada_index))))	       	 
     (and *not_inside_debug_ta* (get ada_name 'ada_variable_advise)))
    (%= nuval (cond ((numberp nuval)(float nuval))
	      (t (ada_raise '|constraint_error| "not a number for float")
		 0.0)))
    (cond ((and
	     *range_checking*
	     range
	     (or (> nuval (second range))
		 (< nuval (first range))))
	   (ct_if *io_get_float*
		  (ada_raise '|data_error|
			     "the float value is out of range")
		  (ds_raise '|constraint_error| ))
	   (setq *io_get_float* nil)))
    (%= current_value nuval))

(ct_defmethod (dt_floating_type attribute_handler)(at_name params)
    (lose 'ftahnyi 'dt_floating_type
	  '("floating type attribute handler NYI")))

(ct_defmethod (dt_floating_type initialize)(params)
    (%= sm_defn (first params))
    (%= def_occurence (and (fourth params)
			   (cond ((eq (diana_nodetype_get (fourth params))
				      'dn_allocator)
				  (fourth params))
				 (t (diana_get (fourth params) 'sm_defn)))))
    (%= range (first (second params))
	)
    ;(break look-at-it)
  (%= ctadadt_id (and sm_defn (new_ctadadt_id '|FLOAT| sm_defn)))
    (%= current_value '*unassigned*))

(ct_defmethod (dt_floating_type printvalue) ()
    (cond ((equal current_value '*unassigned*)      ;;AM -- for sequential io
	   (ada_raise '|program_error|
		      "uninitialized floating type"))
	  (t current_value)      ;;AM -- for sequential io
	  ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Fixed Point Types 

(def_record_type fixed_pt_value *FPV* (sign mantissa small_power pointpos))

(ct_defflavor dt_fixed_point_type
    (current_value			  ;a fixed_pt_value
      pointpos				  ;the number of decimal digits
      *D*				  ;DELTA 
      *L*				  ;left bound of range constraint
      *R*				  ;right bound of range constraint
      small				  ;min{2 ** x|2 ** x <= *D*}
      small_power			  ;small = 2 ** small_power
      lbound				  ;left bound of range constraint in
					  ;fixed_pt_value form
      rbound				  ;right bound of range constraint in
					  ;fixed_pt_value form
      )
                                ; The current value of this object (a lisp
				; integer).and the point posn. (lisp integer)
    (ada_datatype)
    #+Lispm (:special-instance-variables *D* *L* *R*)
    :gettable-instance-variables
    :settable-instance-variables
    :documentation); "The Ada datatype - Fixed Point")

(ct_defmethod (dt_fixed_point_type copyself)()
    (ct_make_instance
	'dt_fixed_point_type
	'ada_name ada_name
	'ada_index ADA_INDEX
	'pointpos pointpos
	'*D* *D*
	'*L* *L*
	'*R* *R*
        'small small
        'small_power small_power
	'lbound lbound
	'rbound rbound
	'def_occurence def_occurence
	'sm_defn sm_defn
	'current_value current_value))

(ct_defmethod (dt_fixed_point_type get_val)(path)
    (mapc
     #'(lambda (advice)
	 (cond ((and (eq (variable_advise_rec%reason advice) 'get)
		     (or  (null ada_index)
			  (null (variable_advise_rec%index advice) )
			  (equal ada_index
				 (variable_advise_rec%index advice))))
		(funcall (variable_advise_rec%funfrob advice)
		ada_name current_value nil ada_index))))	       	 
     (and *not_inside_debug_ta* (get ada_name 'ada_variable_advise)))
    (cond ((eq current_value '*unassigned*)
	   (ct_send self 'real_to_fpv_conversion 0.0))
	  (t current_value)))		; Return the literal associated with this
				; enumeration object.

(ct_defmethod (dt_fixed_point_type set_val)(path nuval)
   (cond ((instancep nuval)
	  (setq nuval (ct_send nuval 'current_value))))
   (mapc
     #'(lambda (advice)
	 (cond ((and (eq (variable_advise_rec%reason advice) 'set)
		     (or  (null ada_index)
			  (null (variable_advise_rec%index advice) )
			  (equal ada_index
				 (variable_advise_rec%index advice))))
		(funcall (variable_advise_rec%funfrob advice)
		 ada_name current_value nuval ada_index))))	       	 
     (and *not_inside_debug_ta* (get ada_name 'ada_variable_advise)))
   (cond ((numberp nuval)
	  (let ((nufval (real_to_fpv_conversion nuval small_power pointpos ))
		(*nopoint t)) 
		 (ct_if (out_of_bound nufval lbound rbound)
		       (ada_raise '|constraint_error|
				  "the value is out of the model numbers"))
		(%= current_value nufval)))
	  ((is_fixed_pt_value nuval)
	   (ct_if (out_of_bound nuval lbound rbound)
		  (progn (ct_if *io_get_fixed*
				(ada_raise '|data_error|
					   "the fixed point value is out of range")
				(ds_raise '|constraint_error| ))
			 (setq *io_get_float* nil))
		  (%= current_value nuval)))
	  ((not (numberp nuval))
	   (ada_raise '|constraint_error| "not a number"))
	  ))
       ;;;;;;;;;;;;
(defun out_of_bound (fpv lb rb )
       ;;;;;;;;;;;;

  (cond ((and fpv lb rb)
	 (let ((fv (fpv_to_real_conversion fpv))
	       (rv (fpv_to_real_conversion rb ))
	       (lv (fpv_to_real_conversion lb)))
	   (or (greaterp fv rv)
	       (lessp fv lv))))))

#+franz
       ;;;;;;;;;;;
(defun getpointpos (del)
       ;;;;;;;;;;;

    (let ((pos (minus (get-exp del))))
	 (ct_if (lessp pos 0) 0
		pos)))
#+franz
       ;;;;;;;
(defun get-exp (realnum)
       ;;;;;;;

    (let ((mask (times (expt 2 7) (sub1 (expt 2 8)))))
	 (difference (sub1 (lsh (boole 1 realnum mask) -7)) 128)
    )) 				;  *** VAX only *****
       ;;;;;;;;
(defun get-sign (realnum)
       ;;;;;;;;

    (ct_if (greaterp realnum 0.0) t
	   nil))
#+franz
(ct_defmethod (dt_fixed_point_type real_to_fpv_conversion)(realnum)
    (let* ((num (times (abs realnum) (expt 2 pointpos)))
	   (num (ct_if (lessp (difference num (fix num)) 0.5) (fix num)
		      (add1 (fix num))))
	   (*nopoint t))
	 (fixed_pt_value (get-sign realnum) (lsh num pointpos) pointpos)))

#+franz
(defun  real_to_fpv_conversion (realnum pointpos)
    (let* ((num (times (abs realnum) (expt 2 pointpos)))
	  (num (ct_if (lessp (difference num (fix num)) 0.5) (fix num)
		      (add1 (fix num))))
	  (*nopoint t))
	 (fixed_pt_value (get-sign realnum) (lsh num pointpos) pointpos)))

#+franz
(defun fpv_to_real_conversion (fpv)
    (let* ((pointpos (fixed_pt_value%pointpos fpv))
	   (num (lsh (fixed_pt_value%value fpv) (minus pointpos)))
	   (frac (boole 1 num (sub1 (expt 2 pointpos))))
	   (int (lsh (difference num frac) (minus pointpos)))
	   (val (add (float int) (frac_to_decimal frac pointpos))))
	   (ct_if (fixed_pt_value%sign fpv) val
		  (minus val))
    ))

#+franz
(defun frac_to_decimal (bnum pointpos)
    (do ((n pointpos (1- n))
	 (const 0.5 (times const 0.5))
	 (ans 0))
	((eq n 0) ans)
	(ct_if (greaterp (boole 1 bnum (expt 2 (1- n))) 0)
	       (setq ans (add ans const)))))
    

#+lispm
(ct_defmethod (dt_fixed_point_type real_to_fpv_conversion) (realnum)
  (fixed_pt_value
    (get-sign  realnum)
    (convert_float_to_model_num (abs realnum) small_power)
    small_power
    pointpos))

#+lispm
(defun convert_float_to_model_num (n small_power)
  (let* ((int_part (fix n))
	 (real_part (- n int_part)))
    (+ (* int_part (expt 2 (- small_power)))
       (fixr (* real_part (expt 2 (- small_power)))))
    ))

#+lispm
(defun real_to_fpv_conversion (n small_power pointpos)
    (cond (n (fixed_pt_value (get-sign n)
		    (convert_float_to_model_num (abs n) small_power)
		    small_power
		    pointpos
    ))))
    
#+lispm
(defun fpv_to_real_conversion (fpval)
    (cond (fpval
	   (let* ((ans (* (cond ((fixed_pt_value%sign fpval) 1)
			 (t -1))
		  (fixed_pt_value%mantissa fpval)
		  (expt 2.0 (fixed_pt_value%small_power fpval))))
	   (num_of_decimal_number (fixed_pt_value%pointpos fpval))
	   (int_part (fix ans))
	   (real_part (- ans int_part))
	   (*nopoint t))
	 ;(+ int_part (// (check_fix_fore real_part num_of_decimal_number)
	 ;		 (expt 10.0 num_of_decimal_number)))
	     ans)
	   ))
    )

;;; for a given flonum in the form 0.nnnnn... and the decimal precision m
;;; return the integer nnnn up to m length and rounding properly 
#+lispm
(defun check_fix_fore (n m)
  (let ((base 10.) (ibase 10.))
    (do ((ans 0)
       (exit nil)
       (cnt m (1- cnt))
       (num (cddr (exploden n)) (cdr num)))
      ((or (null num) exit) ans)
    (cond ((> cnt 0)
	   (%= ans (+ (* 10. ans) (- (car num) #/0))))
	  ((= cnt 0)
	   (ct_if (>= (- (car num) #/0) 5)
		  (%= ans (1+ ans)))
	   (%= exit t))
	  )
    )))

#+lispm
(defun get_small_power (delta)
  (fix (// (log delta) (log 2.0)))
  )

#+lispm
(defun getpointpos (delta)
  (cond ((>= delta 0.1) 1)
	(t (fix (- (// (log delta) (log 10.0))))))
  )
    
(ct_defmethod (dt_fixed_point_type initialize)(params)
   (%= *D* (or (second (second params))
	       (|attribute_delta| (first params) nil )))
   (%= *L* (or (first (first (second params)))
	       (cond ((memq (first params) *universal_types*)
		      nil)
		     (t (fpv_to_real_conversion
			  (|attribute_first| (first params) nil))))))
   (%= *R* (or (second (first (second params)))
	       (cond ((memq (first params) *universal_types*)
		      nil)
		     (t (fpv_to_real_conversion
			  (|attribute_last| (first params) nil)))))) 
   (%= def_occurence (and (fourth params)
			   (cond ((eq (diana_nodetype_get (fourth params))
				      'dn_allocator)
				  (fourth params))
				 (t (diana_get (fourth params) 'sm_defn)))))
   (%= current_value '*unassigned*)
   (%= sm_defn (first params))
   (%= ctadadt_id (and sm_defn (new_ctadadt_id '|FIXED| sm_defn)))
   (%= small_power (get_small_power *D*))
   (%= small (expt 2.0 small_power))
   (%= pointpos (getpointpos *D*))
   (%= lbound (real_to_fpv_conversion *L* small_power pointpos ))
   (%= rbound (real_to_fpv_conversion *R* small_power pointpos ))
   )

(ct_defmethod (dt_fixed_point_type attribute_handler) (at_name params)
    (ct_selectq at_name
;;		(|base|     )	
		(|first| *L*)
		(|last|  *R*)
		(|delta| *D*)
;;		(|safe_small|	)
;;		(|safe_large| 	)
    ))
       ;;;;;;;;;;;;
(defun get-mantissa (num pointpos)
       ;;;;;;;;;;;;

    (let ((val (lsh (lsh num (minus pointpos)) (minus pointpos))))
	 (do ((mask 1 (times mask 2))
	      (n 1 (1+ n)))
	     ((or (greaterp mask val) (eq val mask)) n)
	 )))
       ;;;;;;;;
(defun get-fore (lbound rbound)
       ;;;;;;;;

    (let  ((lv (fpv_to_real_conversion lbound))
	   (rv (fpv_to_real_conversion rbound)))
	 (do ((n 0 (1+ n))
	      (lval (ct_if (get-sign lv) (cons #/0 (exploden lv))
			   (exploden lv)) (cdr lval))
	      (rval (ct_if (get-sign rv) (cons #/0 (exploden rv))
			   (exploden rv)) (cdr rval))
	      (flagr nil)
	      (flagl nil))
	     ((and flagl flagr) (1- n))
	     (ct_if (and (not flagl) (eq (car lval) #/.))
		    (setq flagl t))
	     (ct_if (and (not flagr) (eq (car rval) #/.))
		    (setq flagr t))
	     )))

(defun get-aft (delta)
  (ct_if (or (greaterp delta 0.1) (eq delta 0.1))
	 1
	 (do ((n 0 (1+ n))
	      (ml 10 (times ml 10)))
	     ((or (greaterp (times ml delta) 1)
		  (eq (times ml delta) 10)) n)
	   )))
	

(ct_defmethod (dt_fixed_point_type printself) (stream)
   (ct_format stream "~F" (fpv_to_real_conversion current_value)))
    
(ct_defmethod (dt_fixed_point_type printvalue) ()
    (cond ((equal current_value '*unassigned*)      ;;AM -- for sequential io
	   (ada_raise '|program_error|
		      "uninitialized fixed type"))
	  (t (fpv_to_real_conversion current_value))
	  ))

#|	
;;; The following code used to do the conversion between la_num  and real
;;;      
(defun print_fixed_point_number (numberlist)
  (uci_let (len (length numberlist) *nopoint t)
	   (cond ((eq len pointpos) (ct_princ ".") (print_number numberlist))
		 ((> len pointpos) (ct_tyo (car numberlist))
		  (print_fixed_point_number (cdr numberlist)))
		 (t (print_fixed_point_number (cons 48 numberlist))))))

(defun print_number (numberlist)
  (do ((*nopoint t)
       (count (length numberlist) (sub1 count))
       (l numberlist (cdr l)))
      ((eq count 0) )
    (ct_tyo (car l))))

(defun mk-float (num_rec)
    (uci_let (base (la_num%base num_rec))
      (times (expt base (la_num%exp num_rec))
	   (add (mk-wpart base (la_num%wholepart num_rec))
	        (mk-fpart base (la_num%fractpart num_rec))))))

(defun mk-wpart (base wpart)
    (cond ((eq wpart 0) 0)
	  ((eq base 10) (float wpart))
	  (t (let ( (nl (mapcar '(lambda (x) (difference x 48)) (exploden
								   wpart))))
		  (do ( (l nl (cdr l))
			   (n (sub1 (length nl)) (sub1 n))
			   (ans 0))
		      ( (null l) (float ans))
		      (setq ans (add ans (times (expt base n) (car l)))))))))

(defun mk-fpart (base fpart)
    (cond ((eq fpart 0) 0)
	  ((eq base 10) (quotient (float fpart) (expt 10 (length (explode
								    fpart)))))
	  
	  (t (let ((nl (mapcar '(lambda (x) (difference x 48)) (exploden fpart))))
		  (do ( (l nl (cdr l))
			   (n 1 (add1 n))
			   (ans 0))
		      ( (null l) ans)
		      (setq ans (add ans (times (expt base (minus n))
						(car l)))))))))
		
(defun get-fore (la_l la_r)
    (uci_let (l (mk-float la_l) r (mk-float la_r))
	     (cond ((and (greaterp 0 l) (lessp 0 r)) 2)
		   (t (do ((ll (exploden l) (cdr ll))
			   (rr (exploden r) (cdr rr))
			   (out nil)
			   (counter 0 (add1 counter)))
		          (out (sub1 counter))                           
			  (setq out (or (eq 46 (car ll))
					(eq 46 (car rr)))))))))
|#


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Array Types

(CT_DEFflavor dt_array_type
    (array_storage index_list starters multipliers)
    				; lisp array and list of ranges.
    (ada_datatype)
    :gettable-instance-variables
    :settable-instance-variables
    :documentation); "The Ada datatype - Array")

(ct_defmethod (dt_array_type copyself)()
   (let* ((copy_array
	    (ct_make_instance
	      'dt_array_type
	      'ada_name ada_name
	      'ada_index ada_index
	      'sm_defn sm_defn
	      'index_list index_list
	      'starters starters
	      'multipliers multipliers
	      'array_storage (build_lisp_array_from index_list))) ; dont copy comps
	  (size (calc_array_size index_list))
	  (copy_array_st (ct_send copy_array 'array_storage)))
     (do ((index 0 (1+ index)))          ;;; iterate over the array
	 ((= index size) copy_array)    ;;; return the new ct_make_instance
       (let ((indexed
	       #+lispm (aref array_storage index)
	       #+franz (arraycall t array_storage  index)))
	 (cond ((instancep indexed)
		#+franz
		(set (arrayref copy_array_st index )
		     (ct_send  indexed 'copyself))
		#+lispm
		(aset
		  (ct_send indexed 'copyself)
		  copy_array_st index))
	       (t 
		
		#+franz
		(set (arrayref copy_array_st index ) indexed)
		#+lispm
		(aset indexed copy_array_st index)))
	 ))))


(ct_defmethod (dt_array_type get_val)(path)	       	 
   (cond
     ((null path) self)
     ((out_of_bounds_p path index_list)(ds_raise '|constraint_error|))
     (t
      (let ((index (apply 'plus (mapcar 
				  (function
				    (lambda(i s m)
				      (* m (- (coerce_int i) s))))
				  path starters multipliers))))
	(let ((indexed
		#+lispm	(aref array_storage index)
		#+franz	(arraycall t array_storage index)))
	  (ct_send indexed 'set-ada_name ada_name)
	  (ct_send indexed 'set-ada_index path)
	  indexed)))))

(ct_defmethod (dt_array_type current_value)()	       	 
   (ct_send self 'array_storage))

(defun size macro (l)
       `(difference (second ,(second l)) (first ,(second l))))

(ct_defmethod (dt_array_type  compatible_dimensions_p )(indexes)
	      (prog nil
		(mapc #'(lambda (dimer dimee)
			(cond ((= (size dimer) (size dimee)))
			      (t (return nil))))
		    index_list indexes)
		(return t)))

(ct_defmethod (dt_array_type set_val)(path nuval)
 ;(break up-before-the-cond)
 (cond
     ((null nuval)
      (cond ((> 1 (- (second (first index_list)) (first (first index_list)))))
	    (t (ada_raise '|constraint_error| "array value wrong size"))))
     ((null path)
      (cond
	((consp nuval)			 ;;if its a list, its an aggregate!
	 (ct_send self
	     'initialize_in_order_over_all_indices_to_aggregate nuval))
	((eq nuval '*unassigned*))
	((null array_storage)
	 (setq array_storage (ct_send nuval 'array_storage))
	 (setq starters (ct_send nuval 'starters))
	 (setq multipliers (ct_send nuval 'multipliers))
	 (setq index_list (ct_send nuval 'index_list)))
	((> (length index_list) 1)
	 (let ((ilcopyee (ct_send nuval 'index_list)))
	   (cond ((ct_send self 'compatible_dimensions_p ilcopyee)
		  (do ((i 0 (1+ i)))
		      ((= i  (second (arraydims array_storage))) )
		    (ct_send (aref array_storage i)
			     'set_val
			     nil
			     (ct_send
			       (aref (ct_send nuval 'array_storage) i)
			       'current_value))))
		 (t (ds_raise '|constraint_error| )))))
	(t
	 ;;check that the sizes of the two array/slices are the same.
	 (cond
	   ((zerop
	      (- (- (coerce_int (second (car index_list)))
		    (coerce_int (first (car index_list))))
		 (let ((ilist (car (ct_send nuval 'index_list)) ))
		   (- (coerce_int
			(second ilist))
		      (coerce_int
			(first ilist)))))))
	   (t (ada_raise '|constraint_error| "number of components not same")))
	 (let ((copylist nil))
	   (do ((i (coerce_int (first (car index_list)))(1+ i))
		(j (coerce_int
		     (first(car (ct_send  nuval 'index_list))))
		   (1+ j)))
	       ((> i (coerce_int (second (car index_list)))))
	     (ct_push (cons i
			    (ct_send
			      (ct_send nuval 'get_val (list j))
			      'current_value))
		      copylist))
	   (mapc
	     #'(lambda(pair)(ct_send self 'set_val (list (car pair)) (cdr pair)))
	     copylist)))))
     ((out_of_bounds_p path index_list)(ds_raise '|constraint_error|))
     (t
      (let ((index (apply 'plus (mapcar 
				  (function
				    (lambda(i s m)
				      (* m (- (coerce_int i) s))))
				  path starters multipliers))))
	(cond ((and (arrayp nuval); then we have to have an array of arrays
		    (typep (aref array_storage index) 'dt_array_type))	  ;it is an array
	       (let* ((dimnuval (second (arraydims nuval)))
		      (il (ct_send (aref array_storage index) 'index_list))
		      (lb (first (first il))))
		 (do ((i 0 (1+ i)))
		     ((= i dimnuval))
		   (ct_send
		     (aref array_storage index)
		     'set_val (list (+ lb i)) (aref nuval i))))
	       )
	      (t
	       #+lispm
	       (ct_send (aref array_storage index) 'set_val nil nuval)
	       #+franz
	       (ct_send (arraycall t array_storage index) 'set_val nil nuval)))))))

(ct_defmethod 
    (dt_array_type initialize_in_order_over_all_indices_to_aggregate)(ag)
;   (break take-a-look-at-ag)
    (cond
      ;; Is it a string aggregate?
      ((memq (car ag) '(lex_string lex_char))
       (cond
	 ((and (diana_nodep ag)
	       (memq (diana_nodetype_get ag)
		     '(dn_character_literal dn_string_literal)))
	  (setq ag (diana_get ag 'lx_symrep))))
       (cond
	 (array_storage			  ;array already exists - assignment!
	  ;;check that the number of components is the same!!!
	  (cond ((zerop (- (length (cadr ag))
			   (1+ (- (coerce_int (second (first index_list)))
				  (coerce_int (first (first index_list))))))))
		(t
		 (ada_raise '|constraint_error|
			    "different number of components in array assignment")))
	  (do ((ind (coerce_int (first (first index_list)))(1+ ind))
	       (comp (cadr ag)(cdr comp)))
	      ((> ind (coerce_int (second (first index_list)))))
	    (ct_send self 'set_val (list ind)
		     (convert_integer_to_char (car comp)))))
	 (t
       ;; First setup the array storage and redtape.
       (ct_send self 'set-index_list `((1 ,(length (cadr ag)))))
       (ct_send self 'set-starters '(1))
       (ct_send self 'set-multipliers '(1))
       (ct_send self 
		'set-array_storage (build_lisp_array_from index_list))
       (map_over_array_indices
	 (ct_send self 'array_storage)
	 #'(lambda(i)
	     (let ((enval (ct_make_instance 'dt_enumeration_type)))
	       (ct_send  enval 'set-ada_name nil)
	       (ct_send enval 'set-ada_index nil)
	       (ct_send enval 'initialize nil)
	       enval)))
       ;; Now initialize the parts.
       (do ((i (1- (first (first index_list))) (1+ i))
	    (aggr (cadr ag)(cdr aggr)))
	   ((= i (second (arraydims array_storage))))
	 #+lispm
	 (ct_send (aref array_storage i)
		  'set_val nil (convert_integer_to_char (car aggr)))
	 #+franz 
	 (ct_send (arraycall t array_storage i)
		  'set_val nil (convert_integer_to_char (car aggr))))
       )))
      ;; If not, it must be a regular aggregate.
      (t
       (cond ((null array_storage)
	      (ct_send self 'set-index_list
		       `(,@(cond
			     ((and
				(consp ag)
				(diana_nodep (car ag))
				(eq (diana_nodetype_get (car ag)) 'dn_aggregate))
			      (cons (diana_get (car ag) 'ct_index_list) nil)))
			 (1 ,(length ag))))
	      ;(break look-at-ag)
	      (ct_send self 'set-starters '(1))
	      (ct_send self 'set-multipliers '(1))
	      (ct_send self 
		       'set-array_storage (build_lisp_array_from index_list))
	      (map_over_array_indices ;temporary!!!
		(ct_send self 'array_storage)
		#'(lambda(i)
		    (let ((enval (ct_make_instance 'dt_enumeration_type)))
		      (ct_send  enval 'set-ada_name nil)
		      (ct_send enval 'set-ada_index nil)
		      (ct_send enval 'initialize nil)
		      enval)))))
       (cond
	 ((second index_list); If there are more than one lists in the index_list
	  ;cannot be a slice so use arraydims
	  (do ((i 0  (1+ i))
	       (aggr ag (rest_of_aggregate aggr (length index_list))))
	      ((= i (second (arraydims array_storage))))
	    ;(break look-at-aggr)
	    #+lispm
	    (ct_send (aref array_storage  i)
		     'set_val nil  (aggregate_get aggr (length index_list)))
	    #+franz
	    (ct_send (arraycall t array_storage i)
		     'set_val nil  (aggregate_get aggr (length index_list))))
	      )
	 (t ; could possibly be a slice
	  (let* ((lb (- (index_of (first (first index_list))) (first starters)))
		 (ub  (- (index_of (second (first index_list))) (first starters))))
;       (break lb_ub)
	    (do ((i lb  (1+ i))
		 (aggr ag (rest_of_aggregate aggr 1)))
		((> i ub))
;	 (break look-at-aggr)
	      #+lispm
	      (ct_send (aref array_storage  i)
		       'set_val nil  (aggregate_get aggr 1))
	      #+franz
	      (ct_send (arraycall t array_storage i)
		       'set_val nil  (aggregate_get aggr 1)))
	    )))
       )))
       ;;;;;;;;
(defun index_of (dn)
       ;;;;;;;;

  (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 dn_enum_id dn_enum_literal_s) (diana_get val 'sm_pos))
	     (otherwise
	       (lose 'be_iotl 'index_of))))
	  (t val))))

(defun aggregate_get (agg depth)
  (cond ((= depth 1)
	 (car agg))
	(t
	 (aggregate_get (car agg) (1- depth))))
 )

;just in case we wimp out
#|(cond
    ((consp (car agg))
     (cond ((memq (car (car agg))
		  '(lex_string lex_char))
	    (car agg))
	   (t (aggregate_get (car agg)))))
    (t (car agg)))|#

(defun rest_of_aggregate (agg depth)
  (cond ((null agg) nil)
	((= depth 1)(cdr agg))
	(t (let ((rest (rest_of_aggregate (car agg) (1- depth))))
	     (cond (rest (cons rest (cdr agg)))
		   (t (cdr agg)))))))


;incase we wimp out
#|(cond
    ((not (consp (car agg))) (cdr agg))
    ((and (diana_nodep (car agg))
	  (memq (diana_nodetype_get (car agg)) '(dn_enum_id dn_def_char)))
     (cdr agg))
    ((null (rest_of_aggregate (car agg)))(cdr agg))
    ((and (consp (car agg))
	  (memq (car (car agg))
		  '(lex_string lex_char)))
     (cdr agg))
    (t (cons (rest_of_aggregate (car agg))(cdr agg))))|#

(defun out_of_bounds_p(path ranges)
  (do ((ind path (cdr ind))
       (rng ranges (cdr rng))
       )
      ((or (null ind)(null rng)(< (coerce_int (car ind))(coerce_int (caar rng)))
           (> (coerce_int (car ind))(coerce_int (cadar rng))))
       (and ind rng))))

(ct_defmethod (dt_array_type attribute_handler)(at_name params)
   (cond ((null params)(setq params 1)));default to index 1.
   (ct_selectq at_name
	(|first|			  ;param if present, is the index number.
	  (first (n_th (1- params) index_list))
	  )
	(|last|			  	  ;param if present, is the index number.
	  (second (n_th (1- params) index_list))
	  )
	(|length|                         ;param if present, is the index number.
	  (1+
	    (-
	      (second (n_th (1- params) index_list))
	      (first (n_th (1- params) index_list))))
	  )
	(|range|			  ;param if present, is the index number.
	  (n_th (1- params) index_list)
	  )
	(|size|
	  (times 32
		 (apply 'times
			(mapcar
			  #'(lambda (range)
			      (let ((lb (coerce_int (first range)))
				    (ub (coerce_int (second range))))
				(1+ (- ub lb))))
			  index_list ))))
	(t (lose 'dt_taanyi 'dt_array_type
		 '("That array attribute is not yet implemented")))
	)
   )

(ct_defmethod (dt_array_type initialize)(params)
    (%= sm_defn (first params))
    (%= def_occurence (and (fourth params)
			   (cond ((eq (diana_nodetype_get (fourth params))
				      'dn_allocator)
				  (fourth params))
				 (t (diana_get (fourth params) 'sm_defn)))))
    (setq index_list nil starters nil multipliers nil array_storage nil)
    (%= ctadadt_id (and sm_defn (new_ctadadt_id '|ARRAY| sm_defn)))
    (cond ((second params)
	   (%= index_list (second params))
	   (%= multipliers (calculate_multiplier_list index_list))
	   (%= starters (mapcar #'(lambda(i)(coerce_int (car i))) index_list))
	   (%= array_storage (build_lisp_array_from index_list)))
	  ((and
	     (fourth params)
	     (eq (diana_nodetype_get (fourth params))
	       'dn_const_id))
	   (%= index_list
	       (let ((sminitexp (diana_get (fourth params) 'sm_init_exp)))
		 (ct_selectq
		   (diana_nodetype_get sminitexp)
		   (dn_aggregate
		     (diana_get sminitexp 'ct_index_list))
		   (dn_string_literal
		     (let
		       ((start
			  (|attribute_first| (first params) nil)))
		       (list
			 (list start
			       (+ (1- start)
				  (length
				    (cadr
				      (diana_get sminitexp 'lx_symrep))))))))
		   )))
					    
	   (%= multipliers (calculate_multiplier_list index_list))
	   (%= starters (mapcar #'(lambda(i)(coerce_int (car i))) index_list))
	   (%= array_storage (cond (index_list
				    (build_lisp_array_from index_list))
				   ))))
    (cond ((and index_list (third params))
	   (map_over_array_indices array_storage (third params))))
)

(ct_defmethod (dt_array_type printself) (stream)
   (ct_format stream "~A" (listarrayval (mkalist array_storage)
				     (mkdimlist index_list)
				     nil)))

(ct_defmethod (dt_array_type printvalue) ()
     (cond ((equal array_storage '*unassigned*)      ;;AM -- for sequential io
	    (ada_raise '|program_error|
		       "uninitialized integer type"))
	   (t (mkalist1 array_storage))
	   ))

(defun mkalist (arrayname)
  (let ((len #+lispm (array-length arrayname)
	     #+franz (second (arraydims arrayname))))
     (do ((ans nil)
	 (lastone len)
	 (index 0 (add1 index)))
	((eq index lastone) (reverse ans))
      (%= ans (cons (ct_send #+lispm (aref arrayname index)
			     #+franz (arraycall t arrayname index)
                      'printself nil )
	    ans)))))

(defun mkalist1 (arrayname)
  (let ((len #+lispm (array-length arrayname)
	     #+franz (second (arraydims arrayname))))
     (do ((ans nil)
	 (lastone len)
	 (index 0 (add1 index)))
	((eq index lastone) (reverse ans))
      (%= ans (cons (ct_send #+lispm (aref arrayname index)
			     #+franz (arraycall t arrayname index)
                      'printvalue )
	    ans)))))

(defun mkdimlist (l)
  (cond ((eq (length l) 1) '(0))
	( t (reverse (cdr (mapcar '(lambda (x)
				     (add1 (- (coerce_int (second x))
					      (coerce_int (first x)))))
			      l))))))

(defun listarrayval (xlist dimlist ans)
  (cond ((null dimlist) ans)
	((eq 0 (car dimlist)) (mkent xlist))
	(t (let* ((tempans (mkent (groupair xlist (car dimlist)))))
	     (listarrayval tempans (cdr dimlist ) tempans)))))
	     

(defun groupair (l n)
  (cond ((null l)l)
	((eq n 1) (mkent l))
	(t (cons (mkent (do ((count n (sub1 count))
			     (ans nil))
			    ((eq count 0) (reverse ans))
			  (cond ((eq (car l) '|,|) (setq count (add1 count)
						       l (cdr l)))
				(t (setq  ans (cons (car l) ans)
				          l (cdr l))))))
			(groupair l n)))))
				  
(defun mkent (l)
  (cond ((equal (length l)1) l)
	((eq (car l) '|,| ) (mkent (cdr l)))
	(t (append (list (car l) '|,|) (mkent (cdr l))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Record Data Types

(def_record_type ada_record_value *ada_record* (record))

(ct_defflavor dt_record_type
    (current_value)		; The current value of this object - an alist
    (ada_datatype)
    :gettable-instance-variables
    :settable-instance-variables
    :documentation); "The Ada datatype - record")

(ct_defmethod (dt_record_type copyself)()
    (ct_make_instance
	'dt_record_type
	'ada_name ada_name
	'ada_index ada_index
	'sm_defn sm_defn
	'current_value (ada_record_value
			 (copy_record_alist
			   (ada_record_value%record current_value)))))

(defun copy_record_alist(ra)
    (mapcar
	#'(lambda(pair)
	      (cons 
		  (car pair)
		  (cond
		      ((instancep (cdr pair))
		       (ct_send (cdr pair) 'copyself))
		      (t (cdr pair)))))
	ra))

(ct_defmethod (dt_record_type get_val)(path)
;;; name the component itself
   (cond
     ((null path) current_value);return the record/alist itself.
     (t
      (let ((component 
	  (cdr (assq path (ada_record_value%record current_value)))))
	(cond
	  (component
	   (ct_send  component 'set-ada_name ada_name)
	   (ct_send  component 'set-ada_index
		   (append ada_index
			   (list
			     (implode
			       (cadr (diana_get path 'lx_symrep)))))))
	  (t (ada_raise '|constraint_error| "missing component in record"))))
      (cdr (assq path (ada_record_value%record current_value))))))

(ct_defmethod (dt_record_type get_component)(path)
;;; name the component itself
   (let ((compnam `(lex_ident ,(exploden (first path)))))
     (cond
       ((null (first path)) current_value)	  ;return the record/alist itself.
       (t
	(let ((component 
		(cdr
		  (assoc_symrep compnam (ada_record_value%record current_value)))))
	  (ct_send component 'set-ada_name ada_name)
	  (ct_send component 'set-ada_index
		   (append ada_index (list (first path))))
	  )
	(assoc_symrep compnam (ada_record_value%record current_value))))))

(ct_defmethod (dt_record_type set_val)(path nuval)
;   (break look-at-me)
   (cond
     ;;assign the entire alist.
     ((instancep nuval)			  ;assignment of out parameter.
      (%= current_value (ct_send nuval 'current_value)))
     ((and
	(null path)
	(is_ada_record_value nuval))
      ;;check that disc if assigned is the same
  
      (%= current_value (ada_record_value
			  (copy_record_alist (ada_record_value%record  nuval)))))
     ((null path);it must be an Aggie!
      ;;check that disc if already assigned is the same
      (mapc
	#'(lambda(nuval recpair)
	    
	    (cond ((eq (diana_nodetype_get (car recpair))
		       'dn_dscrmt_id)
		   (let
		     ((cv (ct_send (cdr recpair) 'current_value)))
		     (cond
		       ((eq cv '*unassigned*)
			(ct_send (cdr recpair) 'set_val nil nuval))
		       ((eq (any_equal_aux cv nuval) *ct_ada_false*)
			(ada_raise '|constraint_error|
				   "attempt to change discriminant value")))))
		  (t (ct_send (cdr recpair) 'set_val nil nuval))))
	nuval (ada_record_value%record current_value)))
     ;;deposit the new value.
     (t 
      (rplacd (assq path (ada_record_value%record current_value)) nuval)))) 

(ct_defmethod (dt_record_type attribute_handler)(at_name params)
    (lose 'dt_rtahnyi 'dt_record_type
	  '("record type attribute handler NYI")))

(ct_defmethod (dt_record_type initialize)(params)
    (%= sm_defn (first params))
    (%= def_occurence (and (fourth params)
			   (cond ((eq (diana_nodetype_get (fourth params))
				      'dn_allocator)
				  (fourth params))
				 (t (diana_get (fourth params) 'sm_defn)))))
    (%= current_value (funcall (third params) nil))
    (%= ctadadt_id (and sm_defn (new_ctadadt_id '|RECORD| sm_defn)))
;    (%= current_value (make_alist_from (second params)(third params)))
)

(ct_defmethod (dt_record_type printself)(stream)
   (ct_format stream "~A" (mkent
			    (getval
			      (ada_record_value%record current_value)))))

(ct_defmethod (dt_record_type printvalue)()
   (cond ((equal current_value '*unassigned*)      ;;AM -- for sequential io
	    (ada_raise '|program_error|
		       "uninitialized record type"))
	 (t (getval1 (ada_record_value%record current_value)))
	 ))

(defun getval (xlist)
  (mapcar '(lambda (x) (ct_send (cdr x ) 'printself nil))
	  xlist ))

(defun getval1 (xlist)
  (mapcar '(lambda (x) (ct_send (cdr x ) 'printvalue))
	  xlist ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Entry Data Type

(ct_defflavor dt_entry_type
    (accesses_waiting			  ;list of processes waiting to ACCESS
     entry_waiting)			  ;task queue element of owning task if
    					  ;waiting on an entry call.(nil otherwise)
    (ada_datatype)
    :gettable-instance-variables
    :settable-instance-variables
    :documentation); "The Ada datatype - entry")

(ct_defmethod (dt_entry_type copyself)()
    (ct_make_instance
	'dt_entry_type
;	'ada_name ada_name
;	'ada_index ada_index
;	'sm_defn sm_defn
	'accesses_waiting accesses_waiting
	'entry_waiting entry_waiting))

(ct_defmethod (dt_entry_type initialize)(params)
    (%= accesses_waiting nil)		  ;start off with the access queue empty.
    (%= entry_waiting    nil)		  ;self is not waiting.
)

(ct_defmethod (dt_entry_type add_me_to_the_access_waiting_queue)(me ar)
    (setq accesses_waiting ;put requestor onto the queue (end).
	  (append1 accesses_waiting (list me ar)))
    (ct_send me 'make_unrunnable)	  ;put him into a wait state.
    (ct_send self 'check_for_rendezvous)  ;maybe I can get in a few cycles now!
)

(ct_defmethod (dt_entry_type check_for_rendezvous)()
    (cond
      (entry_waiting			  ;am I waiting to run at all?
       (cond
	 (accesses_waiting		  ;and are there any accesses queued up?
	  (ct_send entry_waiting 'make_runnable)
	  (setq entry_waiting nil)	  ;I am not waiting, rendezvous has occured
)))))	  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Access Data Types

(ct_defflavor dt_access_type
    (current_value)		; The current value of this object (a lisp
				; integer).
    (ada_datatype)
    :gettable-instance-variables
    :settable-instance-variables
    :documentation); "The Ada datatype - access")

(ct_defmethod (dt_access_type get_val)(path)
   (mapc
     #'(lambda (advice)
	 (cond ((eq (variable_advise_rec%reason advice) 'get)
		(funcall (variable_advise_rec%funfrob advice)
		ada_name current_value nil))))	       	 
     (and *not_inside_debug_ta* (get ada_name 'ada_variable_advise)))
   (cond
     ((eq current_value '*unassigned*)
      #|(ct_format *errout*
	      "~&Warning: Attempt to follow an unassigned access type on line ~A~&"
	      (source_region%linenumber (diana_get pc 'lx_srcpos)))|#      
      '*null*)
    (t
     (cond
       ((null path) current_value)
       ((eq current_value '*null*)(ada_raise '|constraint_error| "Null access"))
       (t (ct_send current_value 'get_val path))))))	  ;tarai mawasi

(ct_defmethod (dt_access_type set_val)(path nuval)
    (mapc
     #'(lambda (advice)
	 (cond ((eq (variable_advise_rec%reason advice) 'set)
		(funcall (variable_advise_rec%funfrob advice)
		 ada_name current_value nuval))))	       	 
     (and *not_inside_debug_ta*  (get ada_name 'ada_variable_advise)))
    (cond
       ((null path)(%= current_value nuval))
       ((eq current_value '*null*)(ds_raise '|program_error|))
       (t (ct_send current_value 'set_val path nuval))))

(ct_defmethod (dt_access_type attribute_handler)(at_name params)
    (lose 'dt_atahnyi 'dt_access_type
	  '("integer type attribute handler NYI")))

(ct_defmethod (dt_access_type initialize)(params)
    (%= sm_defn (first params))
    (%= def_occurence (and (fourth params)
			   (cond ((eq (diana_nodetype_get (fourth params))
				      'dn_allocator)
				  (fourth params))
				 (t (diana_get (fourth params) 'sm_defn)))))
    (%= ctadadt_id (and sm_defn (new_ctadadt_id '|ACCESS| sm_defn)))
    (%= current_value '*null*))

(ct_defmethod (dt_access_type copyself)()
   (ct_make_instance			  ;
	'dt_access_type 
	'ada_name ada_name
	'ada_index ada_index
	'sm_defn sm_defn
	'current_value
	(cond
	  ((atom current_value) current_value)
	  ((instancep current_value)
	   (ct_send current_value 'copyself))
	  (t ;(break huh)
	   current_value))))

(ct_defmethod (dt_access_type printself) (stream)
    (ct_format stream "~a" (ct_if (instancep current_value)
			       (ct_send current_value 'ctadadt_id)
			       "null"
			   )
    )
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Task Types

(ct_defflavor dt_task_type
    (current_value ;a list of entry id's.
     tqe);the task queue entry	
    (ada_datatype)
    :gettable-instance-variables
    :settable-instance-variables
    :documentation); "The Ada datatype - task")

(ct_defmethod (dt_task_type get_val)(path)
     current_value)	  

#|(ct_defmethod (dt_task_type copyself)()
    (ct_make_instance 
	'dt_task_type
;	'ada_name ada_name
;	'ada_index ada_index
;	'sm_defn sm_defn
	'current_value
	   (mapcar '(lambda (entry)
			(cons (car entry) (ct_send (cdr entry) 'copyself)))
	           current_value)
	   'tqe nil))|#

(ct_defmethod (dt_task_type set_val)(path nuval)
    (%= current_value nuval))

(ct_defmethod (dt_task_type attribute_handler)(at_name params)
    (lose 'dt_atahnyi 'dt_task_type
	  '("task type attribute handler NYI")))

(ct_defmethod (dt_task_type initialize)(params)
    (%= sm_defn (first params))
    (%= def_occurence (and (fourth params)
			   (cond ((eq (diana_nodetype_get (fourth params))
				      'dn_allocator)
				  (fourth params))
				 (t (diana_get (fourth params) 'sm_defn)))))
    (%= ctadadt_id (and sm_defn (new_ctadadt_id '|TASK| sm_defn)))
    (%= current_value '*unassigned*)
    (%= tqe nil))

(ct_defmethod (dt_task_type copyself)()
   (ct_make_instance			  ;
	'dt_task_type 
	'ada_name ada_name
	'ada_index ada_index
	'sm_defn sm_defn
	'current_value
	(cond
	  ((atom current_value) current_value)
	  ((instancep current_value)
	   (ct_send current_value 'copyself))
	  (t ;(break huh)
	   current_value))
	'tqe nil))

(ct_defmethod (dt_task_type printself) (stream)
    (ct_format stream "~a" ctadadt_id))
	
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros -- 
;;;
;;; utility function of the record type.
;;; takes a list of indicators and an initialization function.
;;; a alist is returned that contains each indicator as an indicator
;;; and the value to which each indicator is bound is generated by
;;; calling ther initialization function with the indicator as its
;;; paramater.
(defun make_alist_from(indicator_list initialization_function)
  (mapcar
    #'(lambda(ind)
	`(,ind . ,(funcall initialization_function ind)))
    indicator_list))

;;; sets each element of array arr to the result of applying form to
;;; the zero based index.
(defun map_over_array_indices(arr form)
    (do ((i 0 (1+ i)))
	((= i (second (arraydims arr))))
#+franz
	(set (arrayref arr i) (funcall form i))	  ; initialize indices.
#+lispm
	(aset (funcall form i) arr i)))

;;; returns a list of multipliers to be used to index into the array.
;;; changed 5/22/83 PR to make indices increase in the right order.
(defun calculate_multiplier_list(indexlist)
    (do ((mp '(1))
	 (i (reverse indexlist) (cdr i)))
	((null i) (cdr mp))	; return multiplier list.
      (ct_push (* (car mp)(1+ (- (coerce_int (cadar  i))
                                 (coerce_int (caar i))))) mp); next multiplier.
    )
)

;;; calculate the size of the array.
(defun calc_array_size (indexlist)
  (do ((s 1)
	       (i indexlist (cdr i)))
	      ((null i) s)		  ; return the array size
	    (%= s (times *_* (1+ (- (coerce_int (cadar i))
                                    (coerce_int (caar i))))))))

;Build an array big enough to accomodate indexlist.
(defun build_lisp_array_from (indexlist)
  (let ((array_size (calc_array_size indexlist) )
#+franz
	(arnam (gensym))		  ; name of array.
	)

#+franz
    (*array arnam t array_size)		  ; build array of appropriate size.

#+franz
    (getd arnam)			  ; return the access function.
#+lispm
    (make-array (list array_size))	  ;return the array object.
    )
  )

  
; 
; A predicate to check to see if something looks like a function.
; 

(defun ctadadt_funcp (thing)
    (and (symbolp thing) (#+franz getd #+lispm fboundp thing))
)

; 
; Try running a hooked function. If there is a simple hook and it looks
; like a function, then apply it to the args. If there is a list and the car
; is a function, then apply it to the args and the cdr of the list.
; 

(defun ctadadt_maybe_run_hook (hook &rest arg_list)
    (cond ((null hook) nil)
	  ((ctadadt_funcp hook)
	   (car (errset (apply hook arg_list) nil))
	  )
	  ((and (listp hook) (ctadadt_funcp (car hook)))
	   (car (errset (apply (car hook) (append arg_list (cdr hook))) nil))
	  )
    )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TYPE Data Types

(ct_defflavor dt_type_type
    (current_value		; The current value of this object (a lisp
				; integer).
     range)
    (ada_datatype)
    :gettable-instance-variables
    :settable-instance-variables
    :documentation); "The Ada datatype - type")

(ct_defmethod (dt_type_type copyself)()
    (ct_make_instance
	'dt_type_type
	'range range
	'ada_name ada_name
	'ada_index ada_index
	'sm_defn sm_defn
	'current_value current_value))

(ct_defmethod (dt_type_type printself) (stream)
   (ct_format stream "~D" current_value))

  
(ct_defmethod (dt_type_type get_val)(path)
   nil)

(ct_defmethod (dt_type_type set_val)(path nuval)
  nil)

(ct_defmethod (dt_type_type attribute_handler)(at_name params)
    nil)

(defun coerce_number_or_nil (num)
  (cond((numberp num) num)
       ((null num ) num)
       ((is_fixed_pt_value num)
	(fpv_to_real_conversion num))
       (t (coerce_int num))))

(defun check_range (momsrng subrng kind)
  (let ((mlb (coerce_number_or_nil (first momsrng)))
	(slb (coerce_number_or_nil (first subrng)))
	(mub (coerce_number_or_nil (second momsrng)))
	(sub (coerce_number_or_nil (second subrng)))
	(mack (coerce_number_or_nil (third momsrng)))
	(sack (coerce_number_or_nil (third subrng))))
    (cond ((and mlb slb
		(< slb mlb))
	   (ada_raise '|constraint_error| "Lower bound of subtype out of range"))
	  ((and mub sub
		(> sub mub))
	   (ada_raise '|constraint_error| "Upper bound of subtype out of range"))
	  ((and mack sack
		(eq kind 'float)
		(> sack mack))
	   (ada_raise '|constraint_error| "accuracy of subtype out of range"))
	  ((and mack sack
		(eq kind 'fixed)
		(< sack mack))
	   (ada_raise '|constraint_error| "accuracy of subtype out of range")))))

(ct_defmethod (dt_type_type initialize)(params)
    (%= sm_defn (first params))
    (%= def_occurence (fourth params))
    (%= current_value '*unassigned*)
    (%= ctadadt_id (and sm_defn (new_ctadadt_id '|TYPE| sm_defn)))
    (%= range (cond ((eq (basetype sm_defn) 'fixed)
		     (let* ((sub (cond ((consp (car (second params)))
					(cons nil (second params)))
				       (t (second params))))
			    (delta (or (first sub)
				       (third (third params))))
			   (rnge (or (second sub)
				     (list (coerce_number_or_nil
					     (first (third params)))
					   (coerce_number_or_nil
					     (second (third params))))))
			   (pp (getpointpos delta))
			   (sp (get_small_power delta))
			   (lb (real_to_fpv_conversion (first rnge) sp pp))
			   (ub (real_to_fpv_conversion (second rnge) sp pp)))
		       (list lb ub delta)))
		    ((eq (basetype sm_defn) 'float)
		     (let* ((sub (cond ((consp (car (second params)))
					(cons nil (second params)))
				       (t (second params))))
			   (digit (or (first sub)
				      (third (third params))))
			   (rnge (or (second sub)
				     (list (first (third params))
					   (second (third params)))
				     )))
		       ;(break wot-have-we-here)
		       (list (first rnge) (second rnge) digit)))
		    (t (or (first (second params))
			   (list (first (third params))
					   (second (third params)))))))
    (check_range (third params) range (basetype sm_defn)))

(ct_defmethod (dt_type_type printvalue) ()
    nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 
; Build a new uninterned symbol for the identifier of an instance of an ada
; data type. The symbol will have a print name consisting of the id for its
; diana node followed by a gensym.
; 

(defun new_ctadadt_id (type sm_defn)
#+franz
(uconcat type "_object_" (diana_get sm_defn 'ct_id) "_" (gensym))
#+lispm
(make-symbol (string-append type "_OBJECT_" (diana_get sm_defn 'ct_id)
			    "_" (gensym)))
)
	
;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;