;;; -*- mode:lisp;package:user;base:10.;fonts: cptfontb -*- 
;;; 
;;; $Header: /ct/interp/attribute.l,v 1.51 84/12/26 16:48:13 penny Exp $
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                              ATTRIBUTE.L                         ;;;
;;; Paul Robertson                                         15-Nov-83 ;;;
;;;                                                                  ;;;
;;;                                                                  ;;;
;;; 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. ;;;
;;;   AJPO, Feb 1983.  ANSI/MIL-STD-1815A  Ada Reference Manual.     ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;                                                                  ;;;
;;;	        ASSUMES CT_LOAD AND SUITABLE FILEMAP                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(eval-when (compile load eval) (ct_load 'charmac)) ;CT char set extensions.

(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 'diana))  ;diana functions

(eval-when (compile load eval) (ct_load 'sema))   ;gets types etc

(eval-when (compile load eval) (ct_load 'ferec))

(eval-when (compile load eval) (ct_load 'stateval)) ;static evaluator

(eval-when (compile load eval) (ct_load 'ctadadt)) ;for fixed point rec
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
(declare (ct_includef 'intrpdcl))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros --
       ;;;;;;;;;;;
(defun is_subtypep(dn)
       ;;;;;;;;;;;

  (and dn
       (diana_nodep dn)
       (memq (diana_nodetype_get dn)
	     '(dn_type_id dn_subtype_id dn_predefined_type
	       dn_derived dn_access dn_task_spec dn_private_type_id
	       dn_l_private_type_id dn_formal_dscrt dn_formal_integer
	       dn_formal_fixed dn_formal_float))))


       ;;;;;;;;;;;;;;
(defun is_array_typep (dn bast)
       ;;;;;;;;;;;;;;

  (eq bast '|ARRAY|)) 

       ;;;;;;;;;;;;;;;;
(defun is_private_typep (dn)
       ;;;;;;;;;;;;;;;;

   (let ((bt (extract_basetype dn t)))
     (and bt
	  (diana_nodep bt)
	  (memq (diana_nodetype_get bt)
		'(dn_private dn_l_private)))))

       ;;;;;;;;;;;;
(defun is_disc_objp (dn bast)
       ;;;;;;;;;;;;

  (and (eq bast '|RECORD|)
       (diana_nodep dn)
       (extract_basetype dn t)
       (diana_node_accepts_attributep (extract_basetype dn t) 'sm_discriminants)
       (diana_get (extract_basetype dn t) 'sm_discriminants)))

       ;;;;;;;;;;;;;;;;;;;;;
(defun is_constrained_arrayp (dn)
       ;;;;;;;;;;;;;;;;;;;;;

  (and dn
       (arrayp dn)
       (let ((indices (find_constraint_for2 dn)))
	 (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)))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun is_constrained_array_typep (dn bast)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;

  (and (eq bast '|ARRAY|)
       (or
	 (memq (diana_nodetype_get dn)
	       '(dn_in_out_id dn_out_id dn_in_id))
	 (and
	   (memq (diana_nodetype_get dn)
	       '(dn_var_id dn_const_id))	   
	   (diana_get dn 'sm_obj_type)
	   (is_constrained_arrayp (diana_get dn 'sm_obj_type)))
	 (is_constrained_arrayp dn))))

       ;;;;;;;;;;;;;;;
(defun is_scalar_typep (dn bast)
       ;;;;;;;;;;;;;;;

  (and dn
       (diana_nodep dn)
       (is_subtypep dn)
       (or (memq bast
		 '(|**any_integer**| |**any_fixed**|
				     |**any_float**| |**any_real**|
				     |INTEGER| |ENUMERATION|
				     |FLOAT| |FIXED| 
				     |CHARACTER|))
	   (memq (diana_nodetype_get
		   (extract_basetype dn t))
		 '(dn_formal_integer dn_formal_fixed
				     dn_formal_dscrt dn_formal_float)))))
       ;;;;;;;
(defun is_objp (dn)
       ;;;;;;;

  t)
       ;;;;;;;;;;;;;;;;;
(defun check_not_subtype (dn attrib bast)
       ;;;;;;;;;;;;;;;;;

  (cond ((is_subtypep dn)
	 (semgripe 'prefix_cannot_be_a_type (string-upcase attrib)))))


       ;;;;;;;;;;;;;;;;;;;;;;
(defun check_fixed_pt_subtype (dn attrib bast)
       ;;;;;;;;;;;;;;;;;;;;;;

  (cond ((and dn
	      (diana_nodep dn)
	      (null
		(memq bast
		      '(|**any_fixed**|  |FIXED|)))
	      (null (memq (diana_nodetype_get
			    (extract_basetype dn t))
			  '(dn_formal_fixed
			     ))))
	 (semgripe 'attribute_needs_type
		   (string-upcase attrib)
		   '|a FIXED point type|))))

       ;;;;;;;;;;;;;
(defun check_subtype (dn attrib bast)
       ;;;;;;;;;;;;;

  (cond ((null (is_subtypep dn))
	 (semgripe 'attribute_needs_type (string-upcase attrib)
		   '|a TYPE|))))

       ;;;;;;;;;;;;;;;;;;
(defun check_task_subtype (dn attrib bast)
       ;;;;;;;;;;;;;;;;;;

  (cond ((neq bast '|TASK|)
	 (semgripe 'attribute_needs_type
		   (string-upcase attrib)
		   '|a TASK type|))))
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

		   
       ;;;;;;;;;;;;;;;
(defun check_for_entry (dn attrib bast)
       ;;;;;;;;;;;;;;;

  (cond ((null (and dn
		    (diana_nodep dn)
		    (eq (diana_nodetype_get dn ) 'dn_entry_id)))
	 (semgripe 'attribute_needs_type
		   (string-upcase attrib)
		   '|an ENTRY|))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;
(defun check_floating_pt_subtype (dn attrib bast)
       ;;;;;;;;;;;;;;;;;;;;;;;;;

  (cond ((and dn
	      (diana_nodep dn)
	      (null
		(memq bast
		      '(|**any_float**|  |FLOAT| |**any_real**|)))
	      (null (memq (diana_nodetype_get
			    (extract_basetype dn t))
			  '(dn_formal_float
			     ))))
	 (semgripe 'attribute_needs_type
		   (string-upcase attrib)
		   '|a FLOATING point type|))))

       ;;;;;;;;;;;;;;;;;;;;;
(defun check_record_obj_comp (dn attrib bast)
       ;;;;;;;;;;;;;;;;;;;;;

  (cond ((null (and dn
		    (diana_nodep dn)
		    (eq (diana_nodetype_get dn ) 'dn_comp_id)))
	 (semgripe 'attribute_needs_type
		   (string-upcase attrib)
		   '|a RECORD object|))))

       ;;;;;;;;;;;;;;;;;;;
(defun is_discrete_subtype (dn bast)
       ;;;;;;;;;;;;;;;;;;;

  (and dn
       (diana_nodep dn)
       (or
	 (memq bast
	       '(|**any_integer**| 
		  |INTEGER| |ENUMERATION|
		  |CHARACTER|))
	 (memq (diana_nodetype_get
		 (extract_basetype dn t))
	       '(dn_formal_integer dn_integer dn_enum_literal_s
		  dn_formal_dscrt))
	 (eq (extract_basetype dn t) *universal_integer*)
	      )))

       ;;;;;;;;;;;;;;;;;;
(defun check_real_subtype (dn attrib bast)
       ;;;;;;;;;;;;;;;;;;

  (cond ((and dn
	      (diana_nodep dn)
	      (null
		(memq bast
		      '(|**any_float**|  |FLOAT|
					 |**any_fixed**| |FIXED|
					 |**any_real**|)))
	      (null (memq (diana_nodetype_get
			    (extract_basetype dn t))
			  '(dn_formal_float
			     dn_formal_fixed))))
	 (semgripe 'attribute_needs_type
		   (string-upcase attrib)
		   '|a REAL type|))))

       ;;;;;;;;;;;;;;;;;;;;;;
(defun check_discrete_subtype (dn attrib bast)
       ;;;;;;;;;;;;;;;;;;;;;;

  (cond ((null (is_discrete_subtype dn bast))
	 (semgripe 'attribute_needs_type
		   (string-upcase attrib)
		   '|a DISCRETE type|))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun check_array_type_or_constrained_array_subtype (dn attrib bast)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (cond ((null (is_constrained_array_typep dn bast))
	 (semgripe 'attribute_needs_type
		   (string-upcase attrib)
		   '|a CONSTRAINED ARRAY type|))))

       ;;;;;;;;;;;;;;;;;;;;
(defun check_obj_or_subtype (dn attrib bast)
       ;;;;;;;;;;;;;;;;;;;;

  (cond ((null (or
		 (is_subtypep dn)
		 (is_objp dn)))
	 (semgripe 'attribute_needs_type
		   (string-upcase attrib)
		   '|a TYPE or OBJECT|))))
		   
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun check_access_subtype_or_task_type_or_task_obj (dn attrib bast)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (cond ((null (or
		 (eq bast '|ACCESS|)
		 (eq bast '|TASK|)))
	 (semgripe 'attribute_needs_type
		   (string-upcase attrib))
	 '|a TASK object, or TASK or ACCESS type|)))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun check_scalar_subtype_array_type_or_constrained_array_subtype
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

       (dn attrib bast)
  (cond ((null (or
		 (is_constrained_array_typep dn bast)
		 (is_scalar_typep dn bast)))
	 (semgripe 'attribute_needs_type
		   (string-upcase attrib)
		   '|a CONSTRAINED ARRAY or SCALAR type|))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun check_priv_subtype_or_disc_obj (dn attrib bast)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (cond ((null (or
		 (is_private_typep dn)
		 (is_disc_objp dn bast)))
	 (semgripe 'attribute_needs_type
		   (string-upcase attrib)
		   '|a PRIVATE type or DISCRIMINANT object|))))

       ;;;;;;;;;;;;;;;;
(defun check_static_arg (arg attrib)
       ;;;;;;;;;;;;;;;;

  (cond ((eq (fe_static_eval arg)
	     '*diana_node_not_static_expression*)
	 (semgripe 'arg_must_be_static (string-upcase attrib)))))

       ;;;;;;;;;;;;;;;;;;;;
(defun hunky_attribute_call (prefix attrib arg bast stat_exp)
       ;;;;;;;;;;;;;;;;;;;;

  ;;test legal prefix and also if arg allowed
  (cond ((and
	   prefix
	   (diana_nodep prefix)
	   (eq (diana_nodetype_get prefix) 'dn_used_name_id))
	 (setq prefix (diana_get prefix 'sm_defn))))
  (ct_selectq attrib
	      (|address|
		(cond (arg (semgripe 'no_arg_allowed (string-upcase attrib))))
		;prefix can be object,prog unit, label or entry
		(check_not_subtype prefix attrib bast))
	      ((|aft| |delta| |fore|) 
		(cond (arg (semgripe 'no_arg_allowed (string-upcase attrib))))
		(check_fixed_pt_subtype prefix attrib bast))
	      (|base|
		(cond (arg (semgripe 'no_arg_allowed (string-upcase attrib))))
		(check_subtype prefix attrib bast))
	      ((|callable| |terminated|)
		(cond (arg (semgripe 'no_arg_allowed (string-upcase attrib))))
		(check_task_subtype prefix attrib bast))
	      (|constrained|
		(cond (arg (semgripe 'no_arg_allowed (string-upcase attrib))))
		(check_priv_subtype_or_disc_obj prefix attrib bast))
	      (|count|
		(cond (arg (semgripe 'no_arg_allowed (string-upcase attrib))))
		(check_for_entry prefix attrib bast))
	      ((|digits| |emax| |machine_emax|
		|machine_emin| |machine_mantissa| |machine_radix|
		|safe_emax| |epsilon|)
		(cond (arg (semgripe 'no_arg_allowed (string-upcase attrib))))
		(check_floating_pt_subtype prefix attrib bast))
	      ((|first| |last|)
	       (cond
		 (arg
		  (check_static_arg arg attrib)
		  (check_array_type_or_constrained_array_subtype
		    prefix attrib bast))
		 (t (check_scalar_subtype_array_type_or_constrained_array_subtype
			     prefix attrib bast))))
	      ((|first_bit| |last_bit| |position|)
		(cond (arg (semgripe 'no_arg_allowed (string-upcase attrib))))
		(check_record_obj_comp prefix attrib bast))
	      (|image|
		(cond ((null arg)
		       (semgripe 'must_have_a_parameter (string-upcase attrib))))
		(check_discrete_subtype prefix attrib bast))
	      ((|large| |machine_overflows| |machine_rounds| |mantissa|
		|safe_large| |safe_small| |small| )
		(cond (arg (semgripe 'no_arg_allowed (string-upcase attrib))))
		(check_real_subtype prefix attrib bast))
	      (|value|
		(cond ((null arg)
		       (semgripe 'must_have_a_parameter (string-upcase attrib))))
		(check_discrete_subtype prefix attrib bast))
	      ((|length| |range|)
		(cond (arg (check_static_arg arg (string-upcase attrib))))
		(check_array_type_or_constrained_array_subtype prefix attrib bast))
	      ((|pos| |pred| |succ| |val|)
		(cond ((null arg)
		       (semgripe 'must_have_a_parameter (string-upcase attrib))))
		(check_discrete_subtype prefix attrib bast))
	      (|size|
		(cond (arg (semgripe 'no_arg_allowed (string-upcase attrib))))
		(check_obj_or_subtype prefix attrib bast))
	      (|storage_size|
		(cond (arg (semgripe 'no_arg_allowed (string-upcase attrib))))
		(check_access_subtype_or_task_type_or_task_obj prefix attrib bast))
	      (|width|
		(cond (arg (semgripe 'no_arg_allowed (string-upcase attrib))))
		(check_discrete_subtype prefix attrib bast))
	      (otherwise
		nil)))

(defun check_legal_index (sarg len attrib )
  (cond ((or (> sarg len)
	     (< sarg 1))
	 (semgripe 'index_out_range 
		   (string-upcase attrib) sarg len)
	 nil)
	(t sarg)))

       ;;;;;;;;;;;;;;;;;;;
(defun find_type_attribute (prefix type attrib arg)
       ;;;;;;;;;;;;;;;;;;;
  (let ((sarg arg))
    (cond (arg
	 (let ((stat_exp (fe_static_eval arg)))
	       (cond
		 ((neq stat_exp
		       '*diana_node_not_static_expression*)
		  (setq sarg stat_exp))))))
	(let ((attrib (intern (implode
				(cadr
				  (diana_get attrib 'lx_symrep)))
			      'user))
	      (bast (and type (car (errset (basetype type) nil)))))
	  (hunky_attribute_call prefix attrib arg bast sarg)
	  (cond (type
		 (ct_selectq attrib
		      
		      ;; fixed for array types only, needs altering to work
		      ;; for enumeration types, derived types user defined types.
		      ((|first| |last| |range|);scalar or arrays only
		       ;;if there is an arg it must be an integer
		       (cond
			 ((and sarg
			       (not (assignment_compatible
				      arg *universal_integer*)))
			  (semgripe 'attribute_arg_is_of_the_wrong_type
				    (string-upcase attrib))
			      (extract_basetype type))
			 (t
			  (cond
			    ((and type (eq (basetype type) 'array))
			     (let*
			       ((indices
				  (let*
				    ((adrs
				       (and
					 (diana_node_accepts_attributep
					   type 'as_dscrt_range_s)
					 (diana_get
					   type 'as_dscrt_range_s))))
				    (and adrs
					 (diana_get adrs
						    'as_list)))))
			       (extract_basetype
				 (n_th
				   (1-
				     (or
				       (and (numberp sarg)
					    (check_legal_index
					      sarg (length indices) attrib)
					    sarg) 1))
				   indices))))
				(type
				 (ct_selectq
				   (diana_nodetype_get
				     (extract_basetype type))
				   (dn_enum_literal_s
				     (extract_basetype type))
				   (dn_derived
				     (extract_basetype type))
				   (dn_integer (extract_basetype type))
				   (dn_fixed (extract_basetype type))
				   (dn_float (extract_basetype type))
				   (otherwise	  ;(break fff)
				     (let
				       ((indices
					  (let*
					    ((adrs
					       (and
						 (diana_node_accepts_attributep
						   type 'as_dscrt_range_s)
						 (diana_get
						   type 'as_dscrt_range_s))))
					    (and adrs
						 (diana_get adrs
							    'as_list)))))
				       (extract_basetype
					 (n_th
					   (1- (or (and (numberp sarg)
							(check_legal_index
							  sarg (length indices)
							  attrib)
							sarg) 1))
					   indices))))))))))
		      (|fore| ;check a fixed
			*universal_integer*)
		      (|aft|  ;check a fixed
			*universal_integer*)
		      (|digits|  ;check a float
			*universal_integer*)
		      (|mantissa|  ;check a float
			*universal_integer*)
		      (|emax|  ;check a float
			*universal_integer*)
		      (|epsilon| ;check a float
			*universal_real*)
		      (|small|  ;check a real
			*universal_real*)
		      (|delta|   ;check a fixed
			*universal_real*)
		      (|large|   ;check a real
			*universal_real*)
		      (|safe_small|  ;check a real
			*universal_real*)
		      (|safe_large|  ;check a real
			*universal_real*)
		      (|safe_emax|  ;check a float
			*universal_integer*)
		      (|size|  ;can be any type
			*universal_integer*)
		      (|address| ;can be an object, program unit, label entry
			*address_type*)
		      (|base| ;can be any type
			(extract_basetype type))
		      ;;added
		      (|callable| ;check a task
			(extract_basetype *ct_ada_false*)
			)
		      (|constrained| ;check priv or disc rec
			(semgripe 'warn_attr_not_implemted
				  (string-upcase attrib))
			(extract_basetype *ct_ada_false*))
		      (|count| ;check an entry
			*universal_integer*)
		      (|first_bit| ;need check a rec component
			(semgripe 'warn_attr_not_implemted
				  (string-upcase attrib))
			*universal_integer*)
		      (|last_bit| ;need check a rec comp
			(semgripe 'warn_attr_not_implemted
				  (string-upcase attrib))
			*universal_integer*)
		      (|machine_emax| ;check a float
			(semgripe 'warn_attr_not_implemted
				  (string-upcase attrib))
			*universal_integer*)
		      (|machine_mantissa| ;check a float
			*universal_integer*)
		      (|machine_emin| ;check a float
			(semgripe 'warn_attr_not_implemted
				  (string-upcase attrib))
			*universal_integer*)
		      (|machine_overflows| ;check a real
			(semgripe 'warn_attr_not_implemted
				  (string-upcase attrib))
			(extract_basetype *ct_ada_false*))
		      (|machine_radix| ;check a float   
			*universal_integer*)
		      (|machine_rounds| ;check a real
			(semgripe 'warn_attr_not_implemted
				  (string-upcase attrib))
			(extract_basetype *ct_ada_false*))
		      (|position| ;check a record
			(semgripe 'warn_attr_not_implemted
				  (string-upcase attrib))
			*universal_integer*)
		      (|storage_size| ;check an access or task
			(semgripe 'warn_attr_not_implemted
				  (string-upcase attrib))
			*universal_integer*)
		      (|terminated|; check a task
			(extract_basetype *ct_ada_false*))
		      (|length|;must be an array type
			;;;the sarg must be a integer, if it exists
			(cond ((null sarg) *universal_integer*)
			      ((and  sarg
				     (numberp sarg)
				     (check_legal_index
				       sarg
				       (length
					 (let*
					   ((adrs
					      (and
						(diana_node_accepts_attributep
						  type 'as_dscrt_range_s)
						(diana_get
						  type 'as_dscrt_range_s))))
					   (and adrs
						(diana_get adrs
							   'as_list))))
				       attrib)
				     (assignment_compatible
				       arg *universal_integer*))
			       *universal_integer*)
			      (t
			       (semgripe 'attribute_arg_is_of_the_wrong_type
					 (string-upcase attrib))
			       *universal_integer*)))
		      (|succ| ;;arg and type must match type must be discrete
			(cond ((assignment_compatible arg type)
			       (extract_basetype type))
			      (t
			       (semgripe 'attribute_arg_is_of_the_wrong_type
					 (string-upcase attrib))
			       (extract_basetype type))))
		      (|pred| ;;arg and type must match,type must be discrete
			(cond ((assignment_compatible arg type)
			       (extract_basetype type))
			      (t
			       (semgripe 'attribute_arg_is_of_the_wrong_type
					 (string-upcase attrib))
			       (extract_basetype type))))
		      (|val|
			;;;the sarg must be a integer and type a discrete
			(cond ((assignment_compatible
				 arg *universal_integer*)
			       (extract_basetype type))
			      (t
			       (semgripe 'preattribute_arg_is_of_the_wrong_type
					 (string-upcase attrib))
			       (extract_basetype type))))
		      (|value|
			;;;the arg must be a string,a character is nogood 
			(cond ((and (consp sarg)
				    (eq (car sarg)
					'lex_string))
			       (extract_basetype type))
			      ((and (consp sarg)
				    (eq (car sarg)
					'lex_char))
			       (semgripe 'attribute_arg_is_of_the_wrong_type
					 attrib)
			       (extract_basetype type))
			      ((memq
				     (diana_nodetype_get arg)
				     '(dn_def_char dn_character_literal))
			       (semgripe 'attribute_arg_is_of_the_wrong_type
					 (string-upcase attrib))
			       (extract_basetype type))
			      ((eq
				 (diana_nodetype_get
				   (extract_basetype arg t))
				 'dn_enum_literal_s)
			       (semgripe 'attribute_arg_is_of_the_wrong_type
					 (string-upcase attrib))
			       (extract_basetype type))
			      ((assignment_compatible				 
				   arg
				   (ada_declared (ada_ident string) nil 'type))
			       (extract_basetype type))
			      (t
			       (semgripe 'attribute_arg_is_of_the_wrong_type
					 (string-upcase attrib))
			       (extract_basetype type))))
		      (|width| ;type must be discrete
			*universal_integer*)
		      (|image| ;;arg and type must match type must be disrete
			(cond ((assignment_compatible arg type)
			       (extract_basetype
				 (ada_declared (ada_ident string) nil 'type)))
			      (t
			       (semgripe 'preattribute_arg_is_of_the_wrong_type
					 (string-upcase attrib))
			       (extract_basetype
				 (ada_declared (ada_ident string) nil 'type)))))
		      (|pos| ;;arg and type must match
			(cond ((assignment_compatible arg type)
			       	 *universal_integer*)
			      (t
			       (semgripe 'preattribute_arg_is_of_the_wrong_type
					 (string-upcase attrib))
			       *universal_integer*)))
		#|	(let ((fred (extract_basetype type)))
			  (cond ((memq (diana_nodetype_get fred)
				       '(dn_enum_literal_s dn_integer))		  
				  *integer_type*)
				((eq fred
				     *universal_integer*)
				  *integer_type*)
				(t (lose 'fe_cfat 'find_type_attribute))))
|#
		      (otherwise	  ;(lose 'ss_ani 'find_type_attribute )
			(semgripe 'attribute_not_implemented
				  (string-upcase attrib) )
			(extract_basetype type))))
		(t (cond (*infrontend*
			  (semgripe 'attribute_failure_type_nil)
			  nil
			  )
			 (t (lose 'be_mfa 'attribute_safe_small))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Attributes

  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Attribute Handlers


        ;;;;;;;;;;;;;;;
(defun |attribute_large|(thing arg)
        ;;;;;;;;;;;;;;;
  
  (cond
    ((diana_nodep thing)
       (ct_selectq (diana_nodetype_get thing)
		   (dn_float
		     (let ((emax (|attribute_emax| thing arg))
			   (mantissa (|attribute_mantissa| thing arg)))
		       (times
			 (expt 2.0 emax)
			 (difference 1 (expt 2.0 (minus mantissa))))))
		   (dn_fixed
		     (let* ((left (|attribute_first| thing arg))
			    (right (|attribute_last| thing arg))
			    (lb (fixed_pt_value%mantissa left))
			    (rb (fixed_pt_value%mantissa right))
			    (small_power (fixed_pt_value%small_power left))
			    )
		       (cond ((< lb rb)
			      (* rb (expt 2.0 small_power)))
			     (t (* lb (expt 2.0 small_power)))
			     )
		       ));;++pointpos,lbound rbound+++
		   (dn_predefined_type
		     (cond
		       ((consistant_types
			  thing
			  *universal_real*)
			(let ((emax (|attribute_emax| thing arg))
			      (mantissa (|attribute_mantissa| thing arg)))
			  (times
			    (expt 2.0 emax)
			    (difference 1 (expt 2.0 (minus mantissa))))))
		       ((consistant_types
			  thing
			  *universal_fixed*)
			(let* ((left (|attribute_first| thing arg))
			       (right (|attribute_last| thing arg))
			       (lb (fixed_pt_value%mantissa left))
			       (rb (fixed_pt_value%mantissa right))
			       (small_power (fixed_pt_value%small_power left))
			       )
			  (cond ((< lb rb)
				 (* rb (expt 2.0 small_power)))
				(t (* lb (expt 2.0 small_power)))
				)
			  ))));;++pointpos,lbound rbound+++
		   (dn_derived 
			       (|attribute_large|
				 (extract_basetype thing t) arg))
		   (dn_used_name_id
		     (|attribute_large| (diana_get thing 'sm_defn) arg))
		   ((dn_subtype_id dn_type_id)
		    (|attribute_large| (diana_get thing 'sm_type_spec) arg))
		   (dn_constrained
		     (|attribute_large| (diana_get thing 'as_name) arg))
		   (dn_selected
		     (|attribute_large|
		       (diana_get thing 'as_designator_char) arg))
		   (otherwise
		     (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_large))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|LARGE|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_large))))))

       ;;;;;;;;;;;;;;;;;;;;;;
(defun |attribute_safe_large|(thing arg)
       ;;;;;;;;;;;;;;;;;;;;;;
  
  (cond
    ((diana_nodep thing)
       (ct_selectq (diana_nodetype_get thing)
		   (dn_float
		     (let ((emax (|attribute_emax| thing arg))
			   (mantissa (|attribute_mantissa| thing arg)))
		       (times
			 (expt 2.0 emax)
			 (difference 1 (expt 2.0 (minus mantissa))))))
		   (dn_fixed
		     (|attribute_large| thing arg));;++pointpos,lbound rbound+++
		   (dn_predefined_type
		     (cond
		       ((consistant_types
			  thing
			  *universal_real*)
			(let ((emax (|attribute_emax| thing arg))
			      (mantissa (|attribute_mantissa| thing arg)))
			  (times
			    (expt 2.0 emax)
			    (difference 1 (expt 2.0 (minus mantissa))))))
		       ((consistant_types
			  thing
			  *universal_fixed*)
			(|attribute_large| thing arg))));;++pointpos,lbound rbound+++
		   (dn_derived 
			       (|attribute_safe_large|
				 (extract_basetype thing t) arg))
		   (dn_used_name_id
		     (|attribute_safe_large| (diana_get thing 'sm_defn) arg))
		   ((dn_subtype_id dn_type_id)
		    (|attribute_safe_large|
		      (diana_get thing 'sm_type_spec) arg))
		   (dn_selected
		     (|attribute_safe_large|
		       (diana_get thing 'as_designator_char) arg))(dn_constrained
		     (|attribute_safe_large| (diana_get thing 'as_name) arg))
		   (otherwise
		     (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_safe_large))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|SAFE_LARGE|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_safe_large))))))

        ;;;;;;;;;;;;;;;
(defun |attribute_small|(thing arg)
        ;;;;;;;;;;;;;;;
  
  (cond
    ((diana_nodep thing)
     (let*
       ((typespec (extract_basetype thing))
	(smsmall (and (diana_node_accepts_attributep
			typespec 'sm_actual_delta)
		      (diana_get typespec 'sm_actual_delta))))
       (cond
	 (smsmall (static_eval smsmall))
	 (t
	  (ct_selectq
	    (diana_nodetype_get thing)
	    (dn_float
	      (let ((emax (|attribute_emax| thing arg)))
		
		(expt 2.0 (difference 1 (minus emax)))))
	    (dn_fixed
	      (let ((small_power (fixed_pt_value%small_power
					  (|attribute_first| thing arg))))
		       (expt 2.0 small_power))
	      ) ;;++ pointpos 
	    (dn_predefined_type
	      (cond
		((consistant_types
		   thing
		   *universal_real*)
		 (let ((emax (|attribute_emax| thing arg)))
		   
		   (expt 2.0 (difference 1 (minus emax)))))
		((consistant_types
		   thing
		   *universal_fixed*)
		 (let ((small_power (fixed_pt_value%small_power
					  (|attribute_first| thing arg))))
		       (expt 2.0 small_power)));;++pointpos,lbound rbound+++
		))
	    (dn_derived 
	      (|attribute_small|
		(extract_basetype thing t) arg))
	    (dn_used_name_id
	      (|attribute_small| (diana_get thing 'sm_defn) arg))
	    ((dn_subtype_id dn_type_id)
	     (|attribute_small| (diana_get thing 'sm_type_spec) arg))
	    (dn_constrained
	      (|attribute_small| (diana_get thing 'as_name) arg))
	    (dn_selected
		     (|attribute_small|
		       (diana_get thing 'as_designator_char) arg))
	    (otherwise (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_small)))))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|SMALL|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_small))))))

        ;;;;;;;;;;;;;;;;;;;;
(defun |attribute_safe_small|(thing arg)
        ;;;;;;;;;;;;;;;;;;;;
  
  (cond
    ((diana_nodep thing)
            (ct_selectq (diana_nodetype_get thing)
		   (dn_float
		     (let ((emax (|attribute_emax| thing arg)))
		       
		       (expt 2.0 (difference 1 (minus emax)))))
		   (dn_fixed
		     (|attribute_small| thing arg)) ;;++ pointpos 
		   (dn_predefined_type
		     (cond
		       ((consistant_types
			  thing
			  *universal_real*)
			(let ((emax (|attribute_emax| thing arg)))
			  
			  (expt 2.0 (difference 1 (minus emax)))))
		       ((consistant_types
			  thing
			  *universal_fixed*)
			(|attribute_small| thing arg)
			)
		       ))
		   ;;++pointpos,lbound rbound+++
		   (dn_derived 
			       (|attribute_safe_small|
				 (extract_basetype thing t) arg))
		   (dn_used_name_id
		     (|attribute_safe_small| (diana_get thing 'sm_defn) arg))
		   ((dn_subtype_id dn_type_id)
		    (|attribute_safe_small| (diana_get thing 'sm_type_spec) arg))
		   (dn_selected
		     (|attribute_safe_small|
		       (diana_get thing 'as_designator_char) arg))
		   (dn_constrained
		     (|attribute_safe_small| (diana_get thing 'as_name) arg))
		   (otherwise (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_safe_small))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|SAFE_SMALL|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_safe_small))))))

        ;;;;;;;;;;;;;;
(defun |attribute_emax|(thing arg)
        ;;;;;;;;;;;;;;
  
  (cond
    ((diana_nodep thing)
            (ct_selectq (diana_nodetype_get thing)
		   ((dn_float dn_predefined_type)
		     (let ((mantissa (|attribute_mantissa| thing arg)))
		       (times 4 mantissa)))
		   (dn_used_name_id
		     (|attribute_emax| (diana_get thing 'sm_defn) arg))
		   (dn_derived
		   (|attribute_emax| (diana_get thing 'as_constrained) arg))
		   ((dn_subtype_id dn_type_id)
		    (|attribute_emax| (diana_get thing 'sm_type_spec) arg))
		   (dn_selected
		     (|attribute_emax|
		       (diana_get thing 'as_designator_char) arg))
		   (dn_constrained
		     (|attribute_emax| (diana_get thing 'as_name) arg))
		   (otherwise
		     (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_cfah 'attribute_emax))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|EMAX|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_emax))))))

        ;;;;;;;;;;;;;;;;;;
(defun |attribute_epsilon|(thing arg)
        ;;;;;;;;;;;;;;;;;;
  
  (cond
    ((diana_nodep thing)
            (ct_selectq (diana_nodetype_get thing)
		   (dn_float
		     (let ((mantissa (|attribute_mantissa| thing arg)))
		       (expt 2.0 (difference 1 mantissa))))
		   (dn_used_name_id
		     (|attribute_epsilon| (diana_get thing 'sm_defn) arg))
		   (dn_derived
		   (|attribute_epsilon| (diana_get thing 'as_constrained) arg))
		   ((dn_subtype_id dn_type_id)
		    (|attribute_epsilon| (diana_get thing 'sm_type_spec) arg))
		   (dn_selected
		     (|attribute_epsilon|
		       (diana_get thing 'as_designator_char) arg))
		   (dn_constrained
		     (|attribute_epsilon| (diana_get thing 'as_name) arg))
		   (otherwise
		     (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_epsilon))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|EPSILON|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_epsilon))))))

        ;;;;;;;;;;;;;;;
(defun |attribute_fore|(thing arg)
        ;;;;;;;;;;;;;;;
  
  (cond
    ((diana_nodep thing)
       (ct_selectq (diana_nodetype_get thing)
		   (dn_fixed
		     (let* ((left (|attribute_first| thing arg))
			    (lb (fixed_pt_value%mantissa left))
			    (rb   (fixed_pt_value%mantissa
				    (|attribute_last| thing arg)));;++lbound rbound
			    (small_power (fixed_pt_value%small_power left))
			    (*nopoint t))
		       (cond ((< lb rb)
			      (add1 (length
				      (exploden
					(fix
					  (* rb (expt 2.0 small_power)))))))
			     (t (add1 (length
				      (exploden
					(fix
					  (* lb (expt 2.0 small_power)))))))
			     )
		       ))
		   (dn_used_name_id
		     (|attribute_fore| (diana_get thing 'sm_defn) arg))
		   (dn_derived
		   (|attribute_fore| (diana_get thing 'as_constrained) arg))
		   ((dn_subtype_id dn_type_id)
		    (|attribute_fore| (diana_get thing 'sm_type_spec) arg))
		   (dn_selected
		     (|attribute_fore|
		       (diana_get thing 'as_designator_char) arg))
		   (dn_constrained
		     (|attribute_fore| (diana_get thing 'as_name) arg))
		   (otherwise (lose 'be_cfah 'attribute_fore))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|FORE|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_fore))))))		

        ;;;;;;;;;;;;;;		
(defun |attribute_aft|(thing arg)
        ;;;;;;;;;;;;;;
  
  (cond
    ((diana_nodep thing)
    
       (ct_selectq (diana_nodetype_get thing)
		   (dn_fixed
		     (getpointpos (|attribute_delta| thing arg)));;++*D*
		   (dn_used_name_id
		     (|attribute_aft| (diana_get thing 'sm_defn) arg))
		   (dn_derived
		   (|attribute_aft| (diana_get thing 'as_constrained) arg))
		   ((dn_subtype_id dn_type_id)
		    (|attribute_aft| (diana_get thing 'sm_type_spec) arg))
		   (dn_selected
		     (|attribute_aft|
		       (diana_get thing 'as_designator_char) arg))
		   (dn_constrained
		     (|attribute_aft| (diana_get thing 'as_name) arg))
		   (otherwise
		     (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_aft))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|AFT|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_aft))))))

        ;;;;;;;;;;;;;;;
(defun |attribute_delta|(thing arg)
        ;;;;;;;;;;;;;;;
  
  (cond
    ((diana_nodep thing)
    
       (ct_selectq (diana_nodetype_get thing)
		   (dn_fixed
		     (static_eval (diana_get thing 'as_exp)));;++*D*
		   (dn_derived
		   (|attribute_delta| (diana_get thing 'as_constrained) arg))
		   (dn_used_name_id
		     (|attribute_delta| (diana_get thing 'sm_defn) arg))
		   ((dn_subtype_id dn_type_id)
		    (cond ((and (null *infrontend*)
				(null (memq (diana_nodetype_get
					      (extract_basetype thing))
					    '(dn_record dn_array))))
			   (let ((nam (assq
					thing
					(ct_send
					  (follow_alink_n_times *activation*
								(type_depth thing))
					  'locals))))
			     (cond (nam (third (ct_send (cdr nam) 'range)))
				   (t (|attribute_delta|
					(diana_get thing 'sm_type_spec) arg)))))
			  (t
			   (|attribute_delta|
			     (diana_get thing 'sm_type_spec) arg))))
		   (dn_constrained
		     (let ((delta (|attribute_delta|
				    (diana_get thing 'as_constraint) arg)))
		       (cond (delta delta)
			     (t
			      (|attribute_delta|
				(diana_get thing 'as_name) arg)))))
		   (dn_predefined_type 0.0001)
		   (dn_selected
		     (|attribute_delta|
		       (diana_get thing 'as_designator_char) arg))
		   (dn_void nil)
		   (otherwise
		     (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_delta))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|DELTA|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_delta))))))		
		

        ;;;;;;;;;;;;;;;;;;
(defun |attribute_mantissa|(thing arg)
        ;;;;;;;;;;;;;;;;;;
  
  (cond
    ((diana_nodep thing)
            (ct_selectq (diana_nodetype_get thing)
		   (dn_float
		     (let ((digits (|attribute_digits| thing arg)))
		     (1+ (fix
			   (plus 0.5
			      (times digits
				     (quotient (log 10) (log 2))))))))
		   (dn_fixed
		     (let ((lb (fixed_pt_value%mantissa
				 (|attribute_first| thing arg)))
			   (rb (fixed_pt_value%mantissa
				 (|attribute_last| thing arg)))
			   )
		       #+lispm (cond ((> lb rb)
				      (get_B_digit lb))
				     (t (get_B_digit rb)))
		       #+franz (get-mantissa
				 (max (fixed_pt_value%value
					  (|attribute_first| thing arg))
				      (fixed_pt_value%value
					  (|attribute_last| thing arg))
				 ppos))
		       ));;++pointpos lbound rbound++
		   (dn_derived
		   (|attribute_mantissa| (diana_get thing 'as_constrained) arg))
		   (dn_predefined_type
		     (cond
		       ((consistant_types
			  thing
			  *universal_real*)
			(let ((digits (|attribute_digits| thing arg)))
		       (1+ (fix
			     (plus 0.5
				   (times digits
					  (quotient (log 10) (log 2))))))))
		       ((consistant_types
			  thing
			  *universal_fixed*)
			(let ((ppos (getpointpos (|attribute_delta| thing arg))))
			  #+lispm (fix (quotient
					 (log (fpv_to_real_conversion
						(|attribute_last| thing arg)))
					 (log 2)))
			  #+franz (get-mantissa
				    (max (fixed_pt_value%value
					   (|attribute_first| thing arg))
					 (fixed_pt_value%value
					   (|attribute_last| thing arg))
					 ppos)  )))))		  
		   (dn_used_name_id
		     (|attribute_mantissa| (diana_get thing 'sm_defn) arg))
		   ((dn_subtype_id dn_type_id)
		    (|attribute_mantissa| (diana_get thing 'sm_type_spec) arg))
		   (dn_constrained
		     (|attribute_mantissa| (diana_get thing 'as_name) arg))
		   (dn_selected
		     (|attribute_mantissa|
		       (diana_get thing 'as_designator_char) arg))
		   (otherwise
		     (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_safe_large))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|SAFE_MANTISSA|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_mantissa))))))

       ;;;;;;;;;;;
(defun get_B_digit (n)
       ;;;;;;;;;;;

  (let ((m (fix (// (log (float n)) (log 2.0)))))
    (ct_if (< (expt 2 (1+ m)) n)
	   (+ m 2)
	   (1+ m))
    ))					  ;alex

        ;;;;;;;;;;;;;;;;;
(defun |attribute_digits|(thing arg)
        ;;;;;;;;;;;;;;;;;
  
  (cond
    ((diana_nodep thing)
     (ct_selectq (diana_nodetype_get thing)
		 (dn_float 
		   (be_static_eval
		     (diana_get
		       (extract_basetype thing )
		       'as_exp)))
		 (dn_derived
		   (|attribute_digits| (diana_get thing 'as_constrained) arg))
		 (dn_predefined_type 5)
		 (dn_used_name_id
		   (|attribute_digits| (diana_get thing 'sm_defn) arg))
		 ((dn_subtype_id dn_type_id)
		   (|attribute_digits| (diana_get thing 'sm_type_spec) arg))
		 (dn_constrained
		   (|attribute_digits| (diana_get thing 'as_name) arg))
		 (dn_selected
		     (|attribute_digits|
		       (diana_get thing 'as_designator_char) arg))
		 (otherwise
		   (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_digits))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|DIGITS|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_digits))))))

        ;;;;;;;;;;;;;;;;;
(defun |attribute_address|(thing arg)
        ;;;;;;;;;;;;;;;;;
  
  (cond
    ((instancep   thing)
     #+franz(maknum thing)
     #+lispm(%pointer thing))
    (t ;(lose 'be_mfa 'attribute_address)
     (semgripe 'can't_find_address_of_that ))))

        ;;;;;;;;;;;;;;
(defun |attribute_base|(thing arg)
        ;;;;;;;;;;;;;;
  
  (extract_basetype thing))

        ;;;;;;;;;;;;;;;
(defun |attribute_width|(thing arg)
        ;;;;;;;;;;;;;;;
  
  (cond
    ((diana_nodep thing)
     (ct_selectq (diana_nodetype_get (extract_basetype thing t))
		 (dn_enum_literal_s
		   (let ((lits (extract_basetype thing t))
			 (flitpos
			   (diana_get (|attribute_first| thing nil) 'sm_pos))
			 (llitpos
			   (diana_get (|attribute_last| thing nil) 'sm_pos)))
		     (do ((widest 0)
			  (litpos 0 (1+ litpos)))
			  ((greaterp  litpos llitpos) widest)
			  (cond ((lessp litpos flitpos) nil)
				(t (let ((newwidth
					   (length
					     (cadr
					       (diana_get
						 (|attribute_val| lits litpos )
						 'lx_symrep)))))
				     (cond ((greaterp newwidth widest)
					    (setq widest newwidth)))))))))
		 (dn_derived
		   (|attribute_width| (diana_get thing 'as_constrained) arg))
		 (dn_integer
		   (let* ((smallest (|attribute_first| thing nil))
			 (largest (|attribute_last| thing nil))
			 (lensmall (1- (length (explode smallest))))
			 (lenlarge (1- (length (explode largest)))))
		     (max lensmall lenlarge)))			 
		 (dn_predefined_type;must be an integer
		   (let* ((smallest *integer_first*)
			 (largest *integer_last*)
			 (lensmall (1- (length (explode smallest))))
			 (lenlarge (1- (length (explode largest)))))
		     (max lensmall lenlarge)))
		 (t			  ;
		       (semgripe 'can't_find_width_of_that ))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|WIDTH|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_width))))))

        ;;;;;;;;;;;;;;;
(defun |attribute_size|(thing arg)
        ;;;;;;;;;;;;;;;
  
  (cond
    ((instancep   thing)
     (ct_send thing 'attribute_handler '|size| arg))
    ((string_aggregate_p thing)
     (times (length (cadr thing)) 8))
    ((diana_nodep thing)
     (let* ((typespec (extract_basetype thing))
	    (smsize (and (diana_node_accepts_attributep
			   typespec 'sm_size)
			 (diana_get typespec 'sm_size))))
       (cond
	 (smsize (static_eval smsize))
	 (t	  
	  (ct_selectq
	    (diana_nodetype_get (extract_basetype thing t))
	    (dn_enum_literal_s 32)
	    (dn_derived
	      (|attribute_size| (diana_get thing 'as_constrained) arg))
	    (dn_array
	      (times
		(apply 'times
		       (mapcar
			 #'(lambda (range)
			     (let ((lb (be_static_eval
					 (diana_get
					   range
					   'as_exp1)))
				   (ub (be_static_eval
					 (diana_get
					   range
					   'as_exp2))))
			       (1+ (- ub lb))))
			 (diana_get
			   (diana_get
			     (extract_basetype thing t)
			     'as_dscrt_range_s)
			   'as_list)))
		32))
	    (dn_record 0)
	    (dn_access 0)
	    (dn_predefined_type 32)
	    (dn_integer 32)
	    (dn_float 64)
	    (dn_fixed 32)
	    (otherwise
	      (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_size)))))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|SIZE|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_size))))))

	;;;;;;;;;;;;;;;
(defun |attribute_first|(thing arg)
	;;;;;;;;;;;;;;;

  (cond
    ((instancep   thing)
     (ct_send thing 'attribute_handler '|first| arg))
    ((string_aggregate_p thing)
     (convert_integer_to_char (caadr thing)))
    ((diana_nodep thing)
     (ct_selectq (diana_nodetype_get thing)
		 (dn_enum_literal_s
		   (n_th 0
			 (diana_get
			   (extract_basetype thing t)
			   'as_list)))
		 (dn_integer
		   (be_static_eval
		     (diana_get
		       (diana_get
			 (extract_basetype thing )
			 'as_range)
		       'as_exp1)))
		 (dn_float
		   (be_static_eval
		     (diana_get
		       (diana_get
			 (extract_basetype thing )
			 'as_range_void)
		       'as_exp1)))
		 (dn_fixed
		   (let ((small_power (get_small_power
					(|attribute_delta| thing arg)))
			 (pointpos (getpointpos (|attribute_delta| thing arg)))
			 )
		   (real_to_fpv_conversion
		     (be_static_eval
		       (diana_get
			 (diana_get
			   (extract_basetype thing )
			   'as_range_void)
			 'as_exp1))
		     small_power
		     pointpos
		     )
		   ))
		 (dn_derived
		   (|attribute_first| (diana_get thing 'as_constrained) arg))
		 (dn_dscrt_range_s
		   (|attribute_first| (car (diana_get thing 'as_list)) arg))
		 (dn_array
		   (|attribute_first|
		       (n_th
			 (1- (or arg 1))
			 (diana_get
			   (diana_get
			     (extract_basetype thing t)
			     'as_dscrt_range_s)
			   'as_list))
		       nil))
		 (dn_used_name_id
		   (|attribute_first| (diana_get thing 'sm_defn) arg))
		 ((dn_subtype_id dn_type_id)
		   (cond ((and (null *infrontend*)
			       (null (memq (diana_nodetype_get
					     (extract_basetype thing))
					   '(dn_record dn_array))))
			  (let ((nam (assq
				       thing
				       (ct_send
					 (follow_alink_n_times *activation*
							       (type_depth thing))
					 'locals))))
			    (cond (nam (first (ct_send (cdr nam) 'range)))
				  (t (|attribute_first|
				       (diana_get thing 'sm_type_spec) arg)))))
			 (t
			  (|attribute_first|
			    (diana_get thing 'sm_type_spec) arg))))
		 (dn_constrained
		   (let ((constr (diana_get thing 'as_constraint)))
		     (cond ((null constr)
			    (|attribute_first|
			      (diana_get thing 'as_name) arg))
			   ((eq (diana_nodetype_get constr) 'dn_void)
			    (|attribute_first|
			      (diana_get thing 'as_name) arg))
			   (t (|attribute_first| constr arg)))))
		 (dn_index
		   (|attribute_first| (diana_get thing 'as_name) arg))
		 (dn_range
		   (be_static_eval (diana_get thing 'as_exp1)))
		 (dn_formal_dscrt
		   (cond (*infrontend*
			  (throw '*diana_node_not_static_expression*
				 '*diana_node_not_static_expression*))))
		 (dn_predefined_type
		   (cond ((eq thing *universal_float*)
			  *float_first*)
			 ((eq thing *universal_integer*)
			  *integer_first*)
			 (t (lose 'be_nfff 'attribute_first))))
		 (dn_selected
		     (|attribute_first|
		       (diana_get thing 'as_designator_char) arg))
		 (otherwise
		   (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_first))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|FIRST|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_first))))))

	;;;;;;;;;;;;;;;
(defun |attribute_last|(thing arg)
	;;;;;;;;;;;;;;;
  (cond
    ((instancep   thing)
     (ct_send thing 'attribute_handler '|last| arg))
    ((string_aggregate_p thing)
     (convert_integer_to_char (car (last (cadr thing)))))
    ((diana_nodep thing)
     (ct_selectq (diana_nodetype_get thing)
		 (dn_enum_literal_s
		   (n_th (1-
			   (length
			     (diana_get
			       (extract_basetype thing t) 'as_list)))
			 (diana_get
			   (extract_basetype thing t) 'as_list)))
		 (dn_integer
		   (be_static_eval
		     (diana_get
		       (diana_get
			 (extract_basetype thing )
			 'as_range)
		       'as_exp2)))
		 (dn_float
		   (be_static_eval
		     (diana_get
		       (diana_get
			 (extract_basetype thing )
			 'as_range_void)
		       'as_exp2)))
		 (dn_fixed
		   (let ((small_power (get_small_power
					(|attribute_delta| thing arg)))
			 (pointpos (getpointpos (|attribute_delta| thing arg)))
			 )
		   (real_to_fpv_conversion
		     (be_static_eval
		       (diana_get
			 (diana_get
			   (extract_basetype thing )
			   'as_range_void)
			 'as_exp2))
		     small_power
		     pointpos
		     )
		   ))
		 (dn_derived
		   (|attribute_last| (diana_get thing 'as_constrained) arg))
		 (dn_dscrt_range_s
		   (|attribute_last| (car (diana_get thing 'as_list)) arg))
		 (dn_array
		     (|attribute_last|
		       (n_th
			 (1- (or arg 1))
			 (diana_get
			   (diana_get
			     (extract_basetype thing t)
			     'as_dscrt_range_s)
			   'as_list))
		       nil))
		 (dn_used_name_id
		   (|attribute_last| (diana_get thing 'sm_defn) arg))
		 ((dn_subtype_id dn_type_id)
		   (cond ((and (null *infrontend*)
			       (null (memq (diana_nodetype_get
					     (extract_basetype thing))
					   '(dn_record dn_array))))
			  (let ((nam (assq
				       thing
				       (ct_send
					 (follow_alink_n_times *activation*
							       (type_depth thing))
					 'locals))))
			    (cond (nam (second (ct_send (cdr nam) 'range)))
				  (t (|attribute_last|
				       (diana_get thing 'sm_type_spec) arg)))))
			 (t
			  (|attribute_last|
			    (diana_get thing 'sm_type_spec) arg))))
		 (dn_constrained
		   (let ((constr (diana_get thing 'as_constraint)))
		     (cond ((null constr)
			    (|attribute_last|
			      (diana_get thing 'as_name) arg))
			   ((eq (diana_nodetype_get constr) 'dn_void)
			    (|attribute_last|
			      (diana_get thing 'as_name) arg))
			   (t (|attribute_last| constr arg)))))
		 (dn_index
		   (|attribute_last| (diana_get thing 'as_name) arg))
		 (dn_range
		   (be_static_eval (diana_get thing 'as_exp2)))
		 (dn_formal_dscrt
		   (cond (*infrontend*
			  (throw '*diana_node_not_static_expression*
				 '*diana_node_not_static_expression*))))
		 (dn_predefined_type
		   (cond ((eq thing *universal_integer*)
			  *integer_last*)
			 ((eq thing *universal_float*)
			  *float_last*)
			 (t (lose 'be_nlff 'attribute_last))))
		 (dn_selected
		     (|attribute_last|
		       (diana_get thing 'as_designator_char) arg))
		 (otherwise
		   (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_last))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|LAST|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_last))))))



	;;;;;;;;;;;;;;;;
(defun |attribute_range| (thing arg)
	;;;;;;;;;;;;;;;;
  (list (|attribute_first| thing arg) (|attribute_last| thing arg)))

	;;;;;;;;;;;;;;;;
(defun |attribute_length|(thing arg)
	;;;;;;;;;;;;;;;;
  
  (cond
    ((instancep   thing)
     (ct_send thing 'attribute_handler '|length| arg))
    ((string_aggregate_p thing)
     (length (cadr thing)))
    ((diana_nodep thing)
     (ct_selectq (diana_nodetype_get (extract_basetype thing t))
		 (dn_enum_literal_s
		   (length (diana_get (extract_basetype thing t) 'as_list)))
		 (dn_derived
		   (|attribute_range| (diana_get thing 'as_constrained) arg))
		 (dn_array
		   (let ((aslist (diana_get
			       (diana_get
				 (extract_basetype thing t)
				 'as_dscrt_range_s)
			       'as_list)))
		     (1+
		       (-
			 (be_static_eval
			   (diana_get
			     (n_th
			       (1- (or arg 1))
			       aslist)
			     'as_exp2))
			 (be_static_eval
			   (diana_get
			     (n_th
			       (1- (or arg 1))
			       aslist)
			     'as_exp1))))))
		 (otherwise
		   (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_length))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|LENGTH|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_length))))))

	;;;;;;;;;;;;;
(defun |attribute_pos|(thing arg)
	;;;;;;;;;;;;;

  (cond
    ((instancep   thing)
     (ct_send thing 'attribute_handler '|pos| arg))
    ((diana_nodep thing)
     (ct_selectq (diana_nodetype_get (extract_basetype thing t))
		 (dn_enum_literal_s
		   ;(break look-at-me)
		   (cond ((numberp arg)
			  arg)
			 ((diana_nodep arg)
			  (diana_get arg 'sm_pos))))
		 (dn_derived
		   (|attribute_pos| (diana_get thing 'as_constrained) arg))
		 ((dn_integer dn_predefined_type)
		   (difference arg
			       (|attribute_first| (extract_basetype thing) nil)))
		 (otherwise
		   (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_pos))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|POS|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_pos))))))

	;;;;;;;;;;;;;;;
(defun |attribute_succ|(thing arg)
	;;;;;;;;;;;;;;;

  (cond
    ((diana_nodep thing)
     (let ((succ (ada_succ arg))
	   (last (|attribute_last| (extract_basetype thing ) nil))
	   (selecti (do ((typthing (extract_basetype thing t)
				   (extract_basetype typthing t)))
			((null (memq (diana_nodetype_get typthing)
				     '(dn_access dn_derived))) typthing))))
       (ct_selectq (diana_nodetype_get selecti)
		 (dn_enum_literal_s
		   ;(break look-at-me)
		   (cond ((=  (cond ((numberp arg) arg)
				    ((diana_nodep arg) (diana_get arg 'sm_pos)))
		       (diana_get last 'sm_pos))
			  (ada_raise '|constraint_error| "attribute succ"))))
		 ((dn_integer dn_predefined_type)
		   (cond ((= arg last)
			  (ada_raise '|constraint_error| "attribute succ"))))
		 (dn_used_name_id
		   (cond ((= (coerce_int arg) (coerce_int last))
			  (ada_raise '|constraint_error| "attribute succ"))))
		 (otherwise
		   (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_succ)))))
       succ))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|SUCC|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_succ))))))

	;;;;;;;;;;;;;;;
(defun |attribute_pred|(thing arg)
        ;;;;;;;;;;;;;;;
  (cond
    ((diana_nodep thing)
     (let ((pred (ada_pred arg))
	   (first (|attribute_first| (extract_basetype thing ) nil))
	   (selecti (do ((typthing (extract_basetype thing t)
				   (extract_basetype typthing t)))
			((null (memq (diana_nodetype_get typthing)
				     '(dn_access dn_derived ))) typthing))))
       (ct_selectq (diana_nodetype_get selecti)
		 (dn_enum_literal_s
		   ;(break look-at-me)
		   (cond ((=  (cond ((numberp arg) arg)
				    ((diana_nodep arg) (diana_get arg 'sm_pos)))
		       (diana_get first 'sm_pos))
			  (ada_raise '|constraint_error| "attribute pred"))))
		 ((dn_integer dn_predefined_type)
		   (cond ((= arg first)
			  (ada_raise '|constraint_error| "attribute pred"))))
		 (dn_used_name_id
		   (cond ((= (coerce_int arg) (coerce_int first))
			  (ada_raise '|constraint_error| "attribute pred"))))
		 (otherwise
		   (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_pred)))))
       pred))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|PRED|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_pred))))))

	;;;;;;;;;;;;;;;
(defun |attribute_image|(thing arg)
        ;;;;;;;;;;;;;;;
  (cond
    ((diana_nodep thing)
     (ct_selectq (diana_nodetype_get (extract_basetype thing t))
		 (dn_enum_literal_s
		   (enumeration_image arg))
		 (dn_predefined_type
		   (integer_image arg))  ;assume integer++
		 (dn_integer
		   (integer_image arg))
		 (dn_float
		   (float_image arg))
		 (dn_fixed
		   (fixed_image arg))
		 (dn_array
		   (semgripe 'cannot_take_image_of_this_type
			     'array)
		   nil)
		 (dn_record
		   (semgripe 'cannot_take_image_of_this_type
			     'record)
		   nil)
		 (dn_derived
		   (|attribute_image| (diana_get thing 'as_constrained) arg))
		 (otherwise
		   (cond (*infrontend*
			    (throw '*diana_node_not_static_expression*
				   '*diana_node_not_static_expression*))
			   (t 
			    (lose 'be_mfa 'attribute_image))))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|IMAGE|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_image))))))

	;;;;;;;;;;;;;;;
(defun |attribute_val|(thing arg)
	;;;;;;;;;;;;;;;

  (cond
    ((diana_nodep thing)
     (ct_selectq (diana_nodetype_get (extract_basetype thing t))
		 (dn_enum_literal_s 
		   (n_th (plus (fix arg) (diana_get
				     (|attribute_first| thing nil ) 'sm_pos))
			 (diana_get (extract_basetype thing t) 'as_list)))
		 (otherwise arg)))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|VAL|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_val))))))

	;;;;;;;;;;;;;;;
(defun |attribute_value|(thing arg)
	;;;;;;;;;;;;;;;
  (cond
    ((instancep arg)(setq arg (convert_strrep_to_lexstr arg))))
  (cond
    ((diana_nodep thing)
     (let ((thing (extract_basetype thing t)))
     (ct_selectq (diana_nodetype_get thing)
		 (dn_enum_literal_s 
		   ;; take the lex_string and an enumeration type
		   ;; and check that the string matches a enum id
		   ;; need to determine if it is a character type
		   ;;or subtype and just return arg
		   (let* ((arglow (uplowlist (cadr arg)))
			  (arglowsp
			    (mapcan
			      #'(lambda (ch)
				  (cond ((neq ch 32.) (list ch))))
			      arglow))
			  (res
			    (car
			      (mapcan
				#'(lambda (enum) 
				    (let* ((lxsym (diana_get enum 'lx_symrep))
					   (etype
					     (car lxsym))
					   (lex (cadr
						 lxsym))
					   ;;should determine if
					   ;;it is a character type
					   (argcomp (cond ((eq etype 'lex_ident)
						       arglowsp)
						      (t (cadr arg)))))
				      (cond ((equal argcomp lex)
					     (list enum)))))
				(diana_get thing 'as_list)))))
		     (cond ((null res)
			    (ada_raise
			      '|constraint_error|
			      "in |attribute_value|"))
			   (t res))))
		   (dn_integer 
		     (let ((*in_attribute_value* t))
		       
		     ;;make it an integer and check constraints
		     (str_fsm *integer_table* (append (cadr arg) (list #\space)))
		     ))
		   (dn_predefined_type
		     (cond ((eq thing *universal_integer*)
			    (let ((*in_attribute_value* t))
			      (str_fsm
			      *integer_table*
			      (append (cadr arg) (list #\space)))))
			   (t (lose 'be_nv 'attribute_value ))))
		   (dn_derived
		   (|attribute_value| (diana_get thing 'as_constrained) arg))
		   (otherwise  arg))))
    (t (cond (*infrontend*
	      (semgripe 'attribute_failure '|VALUE|)
	      nil
	      (throw '*diana_node_not_static_expression*
		     '*diana_node_not_static_expression*))
	     (t (lose 'be_mfa 'attribute_value))))))

	;;;;;;;;;;;;;;;;;;
(defun |attribute_callable| (thing arg)
	;;;;;;;;;;;;;;;;;;

  ;check a task already done
  (let* ((tqe (ct_send thing 'tqe))
	 (term (ct_send tqe 'terminated))
	 (comp (ct_send tqe 'waiting_for_inferiors_to_finish)))
	
    (cond ((or term comp)
	   *ct_ada_false*)
	  (t  *ct_ada_true*)))
  ) ;returns true or false

	;;;;;;;;;;;;;;;;;;;;;		      
(defun |attribute_constrained| (thing arg)
	;;;;;;;;;;;;;;;;;;;;;

  ;check priv or disc
  *ct_ada_true*);returns true or false

	;;;;;;;;;;;;;;;		      
(defun |attribute_count| (thing arg)
	;;;;;;;;;;;;;;;

  1);check an entry returns an integer

	;;;;;;;;;;;;;;;;;;;		      
(defun |attribute_first_bit| (thing arg)
	;;;;;;;;;;;;;;;;;;;

  ;need check a  rec component
  1) ;return integer

	;;;;;;;;;;;;;;;;;;		      
(defun |attribute_last_bit| (thing arg)
	;;;;;;;;;;;;;;;;;;

  ;need check a  rec comp
  1);return integer

	;;;;;;;;;;;;;;;;;;;;;;		      
(defun |attribute_machine_emax| (thing arg)
	;;;;;;;;;;;;;;;;;;;;;;

  ;check a float
  1);return an integer

	;;;;;;;;;;;;;;;;;;;;;;;;;;		      
(defun |attribute_machine_mantissa| (thing arg)
	;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;check a float
  1) ;return an integer
		      
	;;;;;;;;;;;;;;;;;;;;;;
(defun |attribute_machine_emin| (thing arg)
	;;;;;;;;;;;;;;;;;;;;;;

 ;check a float
  1) ;return an integer
		     
	;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun |attribute_machine_overflows| (thing arg)
	;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;check a real
  *ct_ada_true*) ;return a boolean

	;;;;;;;;;;;;;;;;;;;;;;;	      
(defun |attribute_machine_radix| (thing arg)
	;;;;;;;;;;;;;;;;;;;;;;;

  ;check a float   
  2) ;return an integer

	;;;;;;;;;;;;;;;;;;;;;;;;		      
(defun |attribute_machine_rounds| (thing arg)
	;;;;;;;;;;;;;;;;;;;;;;;;

  ;check a real
  *ct_ada_true*) ;return a boolean

	;;;;;;;;;;;;;;;;;;		      
(defun |attribute_position| (thing arg)
	;;;;;;;;;;;;;;;;;;
  ;check a record
  1) ;return an integer

	;;;;;;;;;;;;;;;;;;;;;;		      
(defun |attribute_storage_size| (thing arg)
	;;;;;;;;;;;;;;;;;;;;;;
;check an access or task
    1) ;return an integer

	;;;;;;;;;;;;;;;;;;;;		      
(defun |attribute_terminated| (thing arg)
	;;;;;;;;;;;;;;;;;;;;
  ; check a task
  (let* ((tqe (ct_send thing 'tqe))
	 (term (ct_send tqe 'terminated)))
	
    (cond (term *ct_ada_true*)
	  (t *ct_ada_false*)))
  ) ;return a boolean

       ;;;;;;;;;;;;;;;;;
(defun enumeration_image (arg)
       ;;;;;;;;;;;;;;;;;
  (let ((rep (cond ((eq (diana_nodetype_get arg) 'dn_def_char)
		    (cadr (diana_get arg 'lx_symrep)))
		   (t (lowuplist (cadr (diana_get arg 'lx_symrep)))))))
    `(lex_string ,rep)))

       ;;;;;;;;;;;;;;
(defun integer_image(arg)
       ;;;;;;;;;;;;;;
  (let ((rep (exploden (format nil "~D" arg))))
    (cond ((< arg 0))(t (setq rep (cons #\space rep))))
    `(lex_string ,rep)))

;;;these are not legal
       ;;;;;;;;;;;;;;
(defun fixed_image(arg)  ;++ needs to use correct format
       ;;;;;;;;;;;;;;
  (let* ((arg1 (fpv_to_real_conversion arg))
	 (rep (exploden (format nil "~F" arg1))))
    (cond ((< arg1 0))(t (setq rep (cons #\space rep))))
    `(lex_string ,rep)))

       ;;;;;;;;;;;;;;
(defun float_image(arg) ;++ needs to use correct format
       ;;;;;;;;;;;;;;
  (let ((rep (exploden (format nil "~F" arg))))
    (cond ((< arg 0))(t (setq rep (cons #\space rep))))
    `(lex_string ,rep)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros -- 

;;; None presently.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;				  eof				     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;