;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 

;;;  $Header: /ct/interp/adas36.l,v 1.43 85/01/24 17:59:12 penny Exp $
;;;  


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                            adas36.l                              ;;;
;;; Paul Robertson                                  January 30, 1983 ;;;
;;;                                                                  ;;;
;;;      The C*T Ada Interpreters Syntax and Static Semantics        ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer * Thought Corporation.    ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;;   Charniak et al., 198?.  Artificial Intelligence Programming.   ;;;
;;;                                                                  ;;;
;;; The following code assumes familiarity with the above.           ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(eval-when (compile load eval) (ct_load 'aip))	      ;AIP macros pkg. 

(eval-when (compile load eval) (ct_load 'compat))     ;Franz/LM compat pkg. 

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

(eval-when (compile load eval) (ct_load 'pser))       ;parser  functions. 

(eval-when (compile load eval) (ct_load 'stdenv))     ; contains vital macro

(eval-when (compile load eval) (ct_load 'sema))     ; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 
	
#+franz (declare (macros t))
(declare (ct_includef 'intrpdcl))		; get the specials
(eval-when (compile load eval) (ct_load 'ferec))	; get the macros etc.


#|
;;; computes difference between strings.
       ;;;;;;
(defun strsim(s1 s2 maxdif)
       ;;;;;;

  (cond
    ((null s1)(length s2))
    ((null s2)(length s1))
    ((eq (first s1)(first s2))(strsim (cdr s1)(cdr s2) maxdif))
    ((zerop maxdif) 1)				;AT LEAST
    (t (1+ (min (strsim s1 (cdr s2) (1- maxdif))
		(strsim s2 (cdr s1) (1- maxdif))
		(strsim (cdr s1) (cdr s2) (1- maxdif)))))))

(defun strsimf (s1 s2 n)
  (strsim (exploden s1)(exploden s2) n))

(defun like(s)
  (let ((result nil))  
    (cond
      ((pr_or nil lex_ident)  (break result)
       (< (strsim (exploden s) (cadr result) 3)  3)))))

(defun like_procedure()
  (like '|procedure|))

(defun like_begin()
  (like '|begin|))
|#

(eval-when (compile load)
    (setq *debugparser* nil))

;;; these  macros will be replaced by mapping add_name over a list.

;;;-- Syntax 3.3.A
;;;--  type_declaration ::=
;;;--     'type' identifier [discriminant_part] 'is'
;;;--                            type_definition ';'
;;;--   | incomplete_type_declaration
;;;--
;;;
;;;
;;;    type =>              as_id            : ID,    -- a 'type_id',
;;;                                                   -- 'l_private_type_id' or
;;;                                                   -- 'private_type_id'
;;;                         as_var_s         : VAR_S, -- discriminant list,
;;;                                                   -- see 3.7.1
;;;                         as_type_spec     : TYPE_SPEC;
;;;    type =>              lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;
;;;    DEF_ID ::=           type_id;
;;;
;;;    type_id =>           lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    type_id =>           sm_type_spec     : TYPE_SPEC;
;;;
;;;				; names.
;;;
		;;;;;;;;;;;;;;;;
(def_ada_syntax type_declaration
		;;;;;;;;;;;;;;;;

	(pr_and		  
	  (lambda(as)
	    (let* ((existing_stubel (ada_declared (second as) nil 'type t))
		   (this_type_id
		     (add_name 
		       (second as)	  ; name
		       'type		  ; class
		       (cond		  ; defn.
			 ((and (diana_nodep (fourth as))
			       (eq (diana_nodetype_get (fourth as)) 'dn_private))
			  (sc_diana dn_private_type_id
				    lx_symrep  (second as) 
				    sm_type_spec (fourth as)))
			 ((and (diana_nodep (fourth as))
			       (eq (diana_nodetype_get (fourth as)) 'dn_l_private))
			  (sc_diana dn_l_private_type_id
				    lx_symrep  (second as) 
				    sm_type_spec (fourth as)))
			 (t
			  (sc_diana dn_type_id
				    lx_symrep  (second as) 
				    sm_type_spec (and (not (eq (fourth as)
							       'oper_semicolon))
						      (fourth as)))))
		       (fourth as))))
	      ;;get all matching incomplete types.
	      (setq existing_stubel
		    (mapcan
		      #'(lambda(et)
			  (cond
			    ((and
			       (null (diana_get et 'as_type_spec))
			       t)	  ;check for matching context here?
			     (list et))))
		      existing_stubel))
	      ;;check that there is at most one incomplete type with name
	      ;;and fixit up.
	      (ct_selectq
		(length existing_stubel)
		(0)
		(1 (diana_put this_type_id (first existing_stubel) 'sm_first)
		   (diana_put (first existing_stubel) (fourth as) 'sm_type_spec))
		(otherwise (semgripe 'mult_match_incomp_types)))
	      (let ((ts (fourth as))
		    (typ (sc_diana dn_type
			as_id this_type_id	
			as_dscrmt_var_s (third as)
			as_type_spec (fourth as))))
		(cond ((eq ts 'oper_semicolon)
		       (diana_put typ nil 'as_type_spec) 
		       (ct_push typ *awaiting_incomplete_type*) ))
		(cond
		  ((third as)
		   (cond ((null ts)
			  )
			 ((eq ts 'oper_semicolon)
			  )
			 ((memq (diana_nodetype_get ts)
				'(dn_private dn_l_private)))
		         ((eq (diana_nodetype_get ts) 'dn_record)
			  (diana_put ts (third as) 'sm_discriminants))
			 (t (semgripe 'non_record_discriminated_type)))))
	      typ)))
	  symb_type
	  lex_ident
	  (pr_or nil discriminant_part nil)
	  (pr_or nil
		 (pr_and cadr
			 symb_is
			 type_definition
			 oper_semicolon)
		 oper_semicolon))
    )
    
;;;-- Syntax 3.3.B
;;;--  type_definition ::=
;;;--     enumeration_type_definition | integer_type_definition
;;;--   | real_type_definition        | array_type_definition
;;;--   | record_type_definition      | access_type_definition
;;;--   | derived_type_definition     | private_type_definition
;;;--
;;;
;;;    -- see 3.5.1, 3.5.4, 3.5.6, 3.6, 3.7, 3.8, 3.4, 7.4
;;;
;;;-- 3.5.4  Integer Types
;;;
;;;-- Syntax 3.5.4
;;;--  integer_type_definition ::= range_constraint
;;;--
;;;
;;;
;;;    TYPE_SPEC ::=        integer;
;;;
;;;    integer =>           as_range         : RANGE;
;;;    integer =>           lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    integer =>           sm_size          : EXP_VOID,
;;;                         sm_type_struct   : TYPE_SPEC;
;;;    integer =>           cd_impl_size     : Integer,
;;;                         cd_alignment     : Integer;
;;;
;;;-- 3.5.1  Enumeration Types
;;;
;;;-- Syntax 3.5.1.A
;;;--  enumeration_type_definition ::=
;;;--     '(' enumeration_literal {',' enumeration_literal}')'
;;;--
;;;
;;;
;;;    TYPE_SPEC ::=        enum_literal_s;
;;;
;;;    enum_literal_s =>    as_list          : Seq Of ENUM_LITERAL;
;;;    enum_literal_s =>    lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    enum_literal_s =>    sm_size          : EXP_VOID;
;;;    enum_literal_s =>    cd_impl_size     : Integer,
;;;                         cd_alignment     : Integer;
;;;
;;;-- Syntax 3.5.1.B
;;;--  enumeration_literal ::= identifier | character_literal
;;;--
;;;
;;;
;;;    ENUM_LITERAL ::=     enum_id | def_char;
;;;    DEF_ID ::=           enum_id;
;;;    DEF_CHAR ::=         def_char;
;;;
;;;    enum_id =>           lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    enum_id =>           sm_obj_type      : TYPE_SPEC,  -- refers to the
;;;                                                        -- 'enum_literal_s'
;;;                         sm_pos           : Integer,    -- consecutive position
;;;                                                        -- (base 0)
;;;                         sm_rep           : Integer;    -- user supplied
;;;                                                        -- representation value
;;;
;;;    def_char =>          lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    def_char =>          sm_obj_type      : TYPE_SPEC,  -- refers to the
;;;                                                        -- 'enum_literal_s'
;;;                         sm_pos           : Integer,    -- consecutive position
;;;                                                        -- (base 0)
;;;                         sm_rep           : Integer;    -- user supplied
;;;                                                        -- representation value
;;;
;;;-- 3.5.6  Real Types
;;;
;;;-- Syntax 3.5.6
;;;--  real_type_definition ::= accuracy_constraint
;;;--  accuracy_constraint ::=
;;;--     floating_point_constraint | fixed_point_constraint
;;;--
;;;
;;;
;;;    TYPE_SPEC ::=        fixed;
;;;    TYPE_SPEC ::=        float;
;;;    CONSTRAINT ::=       fixed;
;;;    CONSTRAINT ::=       float;
;;;
;;;-- Syntax 3.6.C
;;;--  index_constraint ::= '('discrete_range {',' discrete_range}')'
;;;--  discrete_range ::= discrete_subtype_indication | range
;;;--
;;;
;;;
;;;    CONSTRAINT ::=       dscrt_range_s;
;;;    DSCRT_RANGE ::=      constrained | range;
;;;
		;;;;;;;;;;;;;;;;;;;
(def_ada_syntax accuracy_constraint
		;;;;;;;;;;;;;;;;;;;
 ;;cannot have a discriminant
		
	(pr_or nil floating_point_constraint fixed_point_constraint))

		;;;;;;;;;;;;;;;
(def_ada_syntax type_definition
		;;;;;;;;;;;;;;;

	(pr_or nil
	       (pr_and			  ; Enumeration type.
		 (lambda(as)
		   (let* ((els
			    (sc_diana dn_enum_literal_s
				      as_list (cons (second as)(third as))))
			  (ell (diana_get els 'as_list)))
		     (do ((el ell (cdr el))	  ;put position attributes on lits.
			  (posn 0 (1+ posn)))
			 ((null el))
		       (cond ((and (car el)
				   (neq 'nulconj (car el)))
			      (diana_put (car el) posn 'sm_pos)
			      (diana_put (car el)
					 (sc_diana dn_function
						   as_param_s nil
						   as_name_void els)
					 'sm_spec)
			      ;;what a win treat the enum as a
			      ;; function so it can be overloaded
			      (diana_put (car el) els 'sm_obj_type)) ))
		     ;; What a win! Define <,>,<=,and >= for each enum type!
		     (old_is_new_builtin_operator_internal
			  '< '|enum_less_than|
			  `((in left ,els)(in right ,els))
			  'boolean)
		     (old_is_new_builtin_operator_internal
			  '<= '|enum_less_than_or_equal|
			  `((in left ,els)(in right ,els))
			  'boolean)
		     (old_is_new_builtin_operator_internal
			  '>  '|enum_greater_than|
			  `((in left ,els)(in right ,els))
			  'boolean)
		     (old_is_new_builtin_operator_internal
			  '>= '|enum_greater_than_or_equal|
			  `((in left ,els)(in right ,els))
			  'boolean)
		     els))
		 oper_lparen
		 enumeration_literal
		 (pr_repeat nil
			    (pr_or nil
				   (pr_and ; modified to handle an easy error.
				     (lambda(as) 
				       ;;(gripe '("You forgot the comma!!"))
				       (gripe '("The components of this enumeration type must be separated by commas.")
					      '((lrmref "LRM" (lrmsec 3 5 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 3 5 1) (lrmpar 6 nil))))
				       (first as))
				     enumeration_literal)
				   (pr_and cadr	  ; this is the correct route.
					   oper_comma
					   enumeration_literal)))
		 oper_rparen)
	       (pr_and 
		 (lambda(as)
		   (sc_diana dn_integer
			     as_range (first as)))
		 range_constraint)	  ; integer type.
	       accuracy_constraint	  ; Real type.
	       array_type_definition	  ; Array type.
	       record_type_definition	  ; Record type.
	       access_type_definition	  ; Access type.
	       derived_type_definition	  ; Derived type.
	       private_type_definition	  ; Private & Limited Private type.
	       )
    )
    
;;;-- 3.4  Derived Type Definitions
;;;
;;;-- Syntax 3.4
;;;--  derived_type_definition ::= 'new' subtype_indication
;;;--
;;;
;;;
;;;    TYPE_SPEC ::=        derived;
;;;
;;;    derived =>           as_constrained   : CONSTRAINED;
;;;    derived =>           lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    derived =>           sm_size          : EXP_VOID,
;;;                         sm_actual_delta  : Rational,
;;;                         sm_packing       : Boolean,
;;;                         sm_controlled    : Boolean,
;;;                         sm_storage_size  : EXP_VOID;
;;;    derived =>           cd_impl_size     : Integer,
;;;                         cd_alignment     : Integer;

		;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax derived_type_definition
		;;;;;;;;;;;;;;;;;;;;;;;

	(pr_and  
	  (lambda(as)
	    (sc_diana dn_derived
		      as_constrained (second as)))
	  symb_new 
	  subtype_indication))
    
		;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax incomplete_type_declaration
		;;;;;;;;;;;;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (sc_diana dn_type
		      as_id
		      (add_name
			(second as)	  ; name
			'type		  ; class
			(sc_diana dn_type_id
				  lx_symrep (second as)
				  sm_type_spec (sc_diana dn_void))
			(sc_diana dn_void))
		      as_var_s (third as)
		      as_type_spec (sc_diana dn_void)))
	  symb_type
	  lex_ident
	  (pr_or nil discriminant_part nil)))		
    
		;;;;;;;;;;;;;;;;;;;
(def_ada_syntax enumeration_literal
		;;;;;;;;;;;;;;;;;;;

	 (pr_or nil 
		(pr_and 
		  (lambda(as)
		    (add_name
		      (first as)
		      'function		  ; enum is an object.
		      (sc_diana dn_enum_id
				lx_symrep (first as))
		      nil))
		  lex_ident)
		(pr_and
		  (lambda(as)
		    (do
		      ((chz la_current_symbol (la_lex)))
		      ((and (consp chz)(eq (car chz) 'oper_quote))
		       (la_lex)))
		    (cond
		      ((= (length (cadr (first as))) 1)
		       (add_name
			 `(lex_char (#/' ,(caadr (first as)) #/'))
			 'function
			 (sc_diana dn_def_char
				   lx_symrep
				   `(lex_char (#/' ,(caadr (first as)) #/')))
			 nil))
		      (t (semgripe 'character_literal_has_funny_length
				   (implode (cadr (first as))))
			 nil))
		    )
		  oper_quote)))

		     ;;;;;;;;;
;    (def_ada_syntax type_mark (pr_and car lex_ident))
		     ;;;;;;;;;

		;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax subtype_indication_init
		;;;;;;;;;;;;;;;;;;;;;;;

	(pr_and 
	  (lambda(as)
	    (subtype_ind_init (first as)(second as)))
	  subtype_indication
	  (pr_or nil (pr_and cadr oper_assign expression) nil)))

;;;-- Syntax 3.3.D
;;;--  subtype_indication ::= type_mark [constraint]
;;;--  type_mark ::= name
;;;--  constraint ::=
;;;--     range_constraint | accuracy_constraint
;;;--   | index_constraint | discriminant_constraint
;;;--
;;;
;;;
;;;    CONSTRAINED ::=      constrained;
;;;    CONSTRAINT ::=       void;
;;;
;;;    constrained =>       as_name          : NAME,
;;;                         as_constraint    : CONSTRAINT;
;;;    constrained =>       lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    constrained =>       sm_type_struct   : TYPE_SPEC,
;;;                         sm_base_type     : TYPE_SPEC,
;;;                         sm_constraint    : CONSTRAINT;
;;;    constrained =>       cd_impl_size     : Integer,
;;;                         cd_alignment     : Integer;
    
		;;;;;;;;;;;;;;;;;;
(def_ada_syntax subtype_indication
		;;;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (let ((abt (extract_basetype (first as) t)))
	      (cond ((and abt
			  (eq (diana_nodetype_get abt) 'dn_access))
		     ;This needs to be more selective
		     (cond ((and (second as)
				 (diana_nodep (second as))
				 (null (memq (diana_nodetype_get (second as))
					     '(dn_dscrmt_aggregate))))
			    (semgripe 'cant_constrain_an_access))
			   ((and
			      (diana_nodep
				(second as))
			      (memq
				(diana_nodetype_get
				  (second as))
				'(dn_dscrmt_aggregate dn_dscrt_range_s))
			      (find_constraint_for2 (first as)))
			    (semgripe 'cant_constrain_a_constr_access)))
		     (setq abt  (extract_basetype
				  (diana_get abt 'as_constrained)))))
	      (cond
		((and (second as)
			abt
			(null (eq (diana_nodetype_get abt) 'dn_array))
			(eq (diana_nodetype_get (second as)) 'dn_dscrt_range_s))
		 (semgripe 'attempt_to_constrain_non_array_type))))
	    (cond ((and (diana_nodep (second as))
			(eq (diana_nodetype_get (second as))
			    'dn_dscrmt_aggregate))
		   (diana_put (second as) (extract_basetype (first as) t)
			      'ct_base_type)))
	    (sc_diana dn_constrained
		      as_name (find_name (first as) nil)
		      as_constraint
		      (cond ((null (second as))(sc_diana dn_void))
			    (t (second as)))))
	  (pr_restrict type name)
	  (pr_or nil constraint nil)))
    
;;;-- Syntax 3.3.C
;;;--  subtype_declaration ::=
;;;--     'subtype' identifier 'is' subtype_indication ';'
;;;--
;;;
;;;
;;;    subtype =>           as_id            : ID,
;;;                         as_constrained   : CONSTRAINED;
;;;    subtype =>           lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;
;;;    DEF_ID ::=           subtype_id;
;;;
;;;    subtype_id =>        lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    subtype_id =>        sm_type_spec     : CONSTRAINED;
;;;

(defun extract_basetype_while_access (dn st)
  (let ((et (extract_basetype dn st)))
    (cond ((null et) nil)
	  ((and (diana_nodep et)
		(eq (diana_nodetype_get et)
		    'dn_access))
	   (extract_basetype_while_access
	     (diana_get et 'as_constrained) st))
	  (t et))))

		;;;;;;;;;;;;;;;;;;;
(def_ada_syntax subtype_declaration
		;;;;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (sc_diana dn_subtype
		      as_id 
		      (add_name 
			(second as)	  ; name
			'type		  ; class
			(sc_diana dn_subtype_id 
				  lx_symrep (second as)
				  sm_type_spec (fourth as))
			(fourth as))	  ; type
		      as_constrained (fourth as))); definition
	  symb_subtype
	  lex_ident
	  symb_is
	  (pr_and
	    (lambda (as)
	      (cond ((and
		       (first as)
		       (null (extract_basetype_while_access (first as) t))
		       )
		     (semgripe 'incomplete_type)))
	      (first as))
	    subtype_indication)
	  oper_semicolon))

;;;-- 3.5  Scalar Types
;;;
;;;-- Syntax 3.5
;;;--  range_constraint ::= 'range' range
;;;--  range ::= simple_expression .. simple_expression
;;;--
;;;
;;;
;;;    CONSTRAINT ::=       RANGE;
;;;    RANGE ::=            range;
;;;
;;;    range =>             as_exp1          : EXP,
;;;                         as_exp2          : EXP;
;;;    range =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    range =>             sm_base_type     : TYPE_SPEC;
;;;
		;;;;;
(def_ada_syntax range
		;;;;;

 (pr_and
	  (lambda(as)
	    (let ((dn
		    (cond ((null (second as))
			   (cond ((and (eq (diana_nodetype_get (first as))
					   'dn_attribute_call)
				       (equal (diana_get
						(diana_get
						  (diana_get (first as) 'as_name)
						  'as_id)
						'lx_symrep)
					      (ada_ident range)))
				  (first as))
				 (t (semgripe 'erroneous_range)
				    (first as))))
			  (t (sc_diana dn_range
			      as_exp1 (first as)
			      as_exp2 (second as)
			      sm_base_type (find_type_for_range
					     (first as)(second as) t)
#|			      as_param_assoc_s (sc_diana
						 dn_param_assoc_s
						 as_list (list
							   (first as)
							   (second as)))
			      tp_vfuns (ada_declared
					 (ada_ident **any_equal**)
					 nil nil t)|#)))))
;	      (ct_push dn  *awaiting_disambiguation*)
	      dn))  
	  simple_expression
	  (pr_or nil
		 (pr_and cadr
			 oper_dotdot
			 simple_expression)
		 nil))
  )
    
		;;;;;;;;;;;;;;;;
(def_ada_syntax range_constraint 
		;;;;;;;;;;;;;;;;
 (pr_and
   (lambda(as)
     (cond (*in_record* (ct_pop *disc_not_allowed*)))
     (second as))
   (pr_and
     (lambda (as)
       (cond (*in_record* (ct_push t *disc_not_allowed*)))
       (first as))
     symb_range)
   range))

;;;-- 3.5.7  Floating Point Types
;;;
;;;-- Syntax 3.5.7
;;;--  floating_point_constraint ::=
;;;--     'digits' simple_expression [range_constraint]
;;;--
;;;
;;;
;;;    RANGE_VOID ::=       RANGE | void;
;;;
;;;    float =>             as_exp           : EXP,
;;;                         as_range_void    : RANGE_VOID;
;;;    float =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    float =>             sm_size          : EXP_VOID,
;;;                         sm_type_struct   : TYPE_SPEC;
;;;    float =>             cd_impl_size     : Integer,
;;;                         cd_alignment     : Integer;
;;;
		;;;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax floating_point_constraint
		;;;;;;;;;;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (cond (*in_record* (ct_pop *disc_not_allowed*)))
	    (sc_diana dn_float
		      as_exp (second as)
		      as_range_void 
		      (cond 
			((third as)
			 ;;give it a type.
			 (let ((univ_real
				 (ada_declared
				   (ada_ident **any_float**) nil 'type)))
			   (diana_put (third as) univ_real 'sm_base_type)
			   (diana_put
			     (diana_get (third as) 'as_exp1)
			     univ_real 'sm_exp_type)
			   (diana_put
			     (diana_get (third as) 'as_exp2)
			     univ_real 'sm_exp_type))
			 (third as))
			(t (sc_diana dn_void)))))
	  (pr_and
	    (lambda (as)
	      (cond (*in_record* (ct_push t *disc_not_allowed* )))
	      (first as))
	    symb_digits)
	  simple_expression
	  (pr_or nil range_constraint nil)))

;;;-- 3.5.9  Fixed Point Types
;;;
;;;-- Syntax 3.5.9
;;;--  fixed_point_constraint  ::=
;;;--     'delta' simple_expression [range_constraint]
;;;--
;;;
;;;
;;;    fixed =>             as_exp           : EXP,
;;;                         as_range_void    : RANGE_VOID;
;;;    fixed =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    fixed =>             sm_size          : EXP_VOID,
;;;                         sm_actual_delta  : Rational,
;;;                         sm_bits          : Integer;
;;;    fixed =>             cd_impl_size     : Integer,
;;;                         cd_alignment     : Integer;
;;;
		;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax fixed_point_constraint
		;;;;;;;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (cond (*in_record* (ct_pop *disc_not_allowed*)))
	    (sc_diana dn_fixed
		      as_exp (second as)
		      as_range_void 
		      (cond
			((third as)
			 ;;give it a type.
			 (let ((univ_real
				 (ada_declared
				   (ada_ident **any_float**) nil 'type)))
			   (diana_put (third as) univ_real 'sm_base_type)
			   (diana_put
			     (diana_get (third as) 'as_exp1)
			     univ_real 'sm_exp_type)
			   (diana_put
			     (diana_get (third as) 'as_exp2)
			     univ_real 'sm_exp_type))
			 (third as))
			(t (sc_diana dn_void)))))
	  (pr_and
	    (lambda (as)
	      (cond (*in_record* (ct_push t *disc_not_allowed* )))
	      (first as))
	    symb_delta)
	  simple_expression
	  (pr_or nil range_constraint nil)))

		;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax private_type_definition
		;;;;;;;;;;;;;;;;;;;;;;;

    (pr_and
      (lambda(as)
	(cond
	  ((null (first as))		  ;not limited.
	   (sc_diana dn_private))
	  (t
	   (sc_diana dn_l_private))))
      (pr_or nil symb_limited nil)
      symb_private))