;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;  $Header: /ct/interp/adas42.l,v 1.72 84/12/04 18:48:32 penny Exp $
;;;
;;;  

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

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

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

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

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

(eval-when (compile load eval) (ct_load 'sema))     ; contains vital MACRO

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


;;;-- 4.  Names and Expressions
;;;-- =========================
;;;-- 4.1  Names
;;;
;;;-- Syntax 4.1
;;;--  name ::= identifier
;;;--   | indexed_component  | slice
;;;--   | selected_component | attribute
;;;--   | function_call      | operator_symbol
;;;--
;;;
;;;
;;;    NAME ::=             DESIGNATOR;
;;;    -- see 2.3, 4.1.1, 4.1.2, 4.1.3, 4.1.4,
;;;
;;;    USED_ID ::=          used_object_id | used_name_id | used_bltn_id;
;;;
;;;    used_object_id =>    lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    used_object_id =>    sm_exp_type      : TYPE_SPEC,
;;;                         sm_defn          : DEF_OCCURRENCE,
;;;                         sm_value         : value;
;;;
;;;    used_name_id =>      lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    used_name_id =>      sm_defn          : DEF_OCCURRENCE;
;;;
;;;    used_bltn_id =>      lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    used_bltn_id =>      sm_operator      : operator;
;;;    -- see the rationale for a discussion of built-in subprograms
;;;
;;;    USED_OP ::=          used_op | used_bltn_op;
;;;
;;;    used_op =>           lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    used_op =>           sm_defn          : DEF_OCCURRENCE;
;;;
;;;    used_bltn_op =>      lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    used_bltn_op =>      sm_operator      : operator;
;;;
;;; Name is a bit hairy.
;;; A function eats its parameters.
;;; Variuos named objects  may have parameter sequences for array indexing
;;; etc. Procedures DO NOT eat their parameters, they are eaten by 
;;; procedure_or_entry_call. Same for entry calls.

(def_ada_syntax name
		(pr_and
		  (lambda (as)
		    (setq *original_context* nil)
		    (first as))
		  name_aux))

		;;;;;;;;
(def_ada_syntax name_aux
		;;;;;;;;

	(pr_and
	  (lambda (as)
	    (ct_pop *name_communication*)
	    (first as))
	  (pr_or nil 
	       (pr_and
		 (lambda(as)
		   (let ((nam
			   (ada_declared (first as) nil 'function t)))
		     (cond
		       ((and *function_name_only* (null (second as)))
			nam)
		       ((null (second as))
			(let ((func   (sc_diana dn_function_call lx_prefix t)))
			  (diana_put func nam 'tp_vfuns)
			  (normalize_params   ;in case of defaults.
			    (dissambiguate_function_reference func))))
		       ((eq (diana_nodetype_get
				   (name_cdr_bits%thisname (second as)))
				 'dn_selected)
			(diana_put (name_cdr_bits%thisname (second as))
				   (car nam)
				   'as_name)
			(name_cdr_bits%destname (second as)))
		       (t (diana_put
			    (name_cdr_bits%thisname (second as))
			    nam
			    'tp_vfuns)
			  ;;now, if its a function call, we have to
			  ;;normalize the parameters.
			  (cond
			    ((eq (diana_nodetype_get
				   (name_cdr_bits%thisname (second as)))
				 'dn_function_call)
			     (normalize_params
			       (dissambiguate_function_reference 
			       (name_cdr_bits%thisname (second as))))))
			  (name_cdr_bits%destname (second as))))))
		 (pr_and
		   (lambda(as);(break found-function)
		     (ct_push  (first as) *name_communication*)
		     (first as))
		   (pr_or nil 
			  (pr_and
			    (lambda(as)
			      ;;if its a string, check that its not an
			      ;;enumeration literal.
			      ;;need to beware of strings that are operators
			      ;;and do the right thing
			      (let ((deff
				      (ada_declared (first as) nil 'function t)))
				(setq deff
				      (mapcan
					#'(lambda(id)
					    (cond ((eq (diana_nodetype_get id)
						       'dn_enum_id)
						   nil)
						  (t (list id))))
					deff))
				(cond (deff (first as))
				      (t (putback_symbol (first as)) ;undo parse.
					 (rplaca (first as) 'lex_string)
					 'fail))))
			    (pr_or
			      nil			      
			      (pr_and2c
				(lambda(as)
				  (first as))
				lex_string
				oper_lparen
				(pr_restrict function lex_string))
			      (pr_and
				(lambda(as)
				  (cond (*function_name_only*
					 (first as))
					(t (putback_symbol (first as))
					   (rplaca (first as) 'lex_string)
					   'fail)))
				(pr_restrict function lex_string))))
			  (pr_restrict function lex_ident)
			  ))
		 (pr_or nil 
			(pr_and
			  (lambda(as)
			    (popcontext)
			    (let* ((selid (filter_non_visible_selected
					    (second as)
					       (ada_declared
						(strip_index *name_communication*) 
						nil
						'(package function named
							  constant
							  record task
							  formal_parameter
							  procedure entry object))
					      ))
				   (nam
;				     (break above-the-dudelle)
				    (sc_diana dn_selected
					      as_name nil ; maybe later..
					      as_designator_char selid)))
;			      (break look-at-nam)
			      (ct_push nil *name_communication*) 
			      (name_cdr_bits nam nam)))
			  (pr_and
			    (lambda(as)
			      (cond ((null *original_context*)
				     (setq *original_context* **current_block**)))
			      (savecontext)	  ;remember the current context.
			      (setq **current_block**
				    (diana_get
				      (ada_declared
					(strip_index *name_communication*) 
				 	nil
					'(package function named constant
						  record task
						  formal_parameter
						  procedure entry object))
				      'ct_named_context))
;			      (break look-at-context)
			      )
			    oper_period )
			  name_aux)
			(pr_and 
			  (lambda(as)
			    (let ((nam
				    (sc_diana dn_attribute_call
					      as_name nil ;see below
					      )))
			      (diana_put
				nam
				(sc_diana
				  dn_attribute
				  as_name nil	  ; gets put in later.
				  as_id 
				  (sc_diana dn_used_name_id
					    lx_symrep (second as)
					    sm_defn
					    (ada_declared 
					      (second as)
					      nil
					      '(not_indexable_attribute
						 indexable_attribute))))
				'as_name)
			      (cond
				((null (third as))
				 (name_cdr_bits (diana_get nam 'as_name)
						nam))
				(t  
				    (diana_put
				      (name_cdr_bits%thisname 
					(third as))
				      nam
				      'as_name)
				    (name_cdr_bits 
				      nam
				      (name_cdr_bits%destname (third as)))))))
			  oper_quote
			  (pr_or nil
			    (pr_restrict indexable_attribute lex_ident)
			    (pr_restrict not_indexable_attribute lex_ident))
			  (pr_or nil
				 (pr_and
				   (lambda (as)
				     (ct_push nil  *name_communication*)
				     (first as))
				   name_cdr)
				 nil))
			(pr_and 
			  (lambda(as)
			    (let ((nam 
				    (sc_diana dn_function_call
					      as_name nil ; gets filled in later.
					      lx_prefix t
					      as_param_assoc_s
					      (sc_diana dn_param_assoc_s
							as_list (second as)))))
			      nam	  ;this will get normalized in name.
			      (cond
				((null (fifth as)); ?why not fourth?
				 (name_cdr_bits nam nam))
				(t  (diana_put 
				      (name_cdr_bits%thisname 
					(fifth as))
				      nam
				      'as_name)
				    (name_cdr_bits 
				      nam
				      (name_cdr_bits%destname
					(fifth as)))))
			      ))
			  (pr_and
			    (lambda (as)
			      (savecontext)
			      (cond (*original_context*
				     (setq **current_block** *original_context*)
				     ))
			      (rplaca *name_communication* nil);+++
			      (first as))
			    oper_lparen)
			  (pr_or nil actual_parameter_part nil)
			  (pr_and
			    (lambda (as)
			      (popcontext)
			      (first as))
			    oper_rparen)
			  (pr_or nil name_cdr nil))
			nil))
	       
	       (pr_and 
		 (lambda(as)		  ;  case for a proc or entry.
;		  (break in-name-proc-or-entry)
		   (let
		     ((this_id
			(ada_declared (first as) nil '(procedure entry) t)))
		     (cond
		       ((null (second as)) this_id)
		       (t (diana_put
			    (name_cdr_bits%thisname (second as))
			    this_id
			    'tp_vfuns)
			  (cond
			    ((eq (length this_id) 1)
			     (diana_put
			       (name_cdr_bits%thisname (second as))
			       (sc_diana dn_used_name_id
					 sm_defn (car this_id))
			       'as_name)))
			  (name_cdr_bits%destname (second as))))))
		 (pr_or nil
			(pr_and
			  (lambda(as)
			    (ct_push (first as) *name_communication*)
			    (first as))
			  (pr_restrict procedure lex_ident))
			(pr_and
			  (lambda(as)
			    (ct_push (first as) *name_communication*)
			    (first as))
			  (pr_restrict entry lex_ident))
			)
		 (pr_or nil
			(pr_and  
			  (lambda(as)(second as))
			  (pr_and
			    (lambda(as)
			      (putback_symbol 'oper_period))
			    oper_period)
			  (pr_or nil name_cdr nil))
			nil)
		 )
	       
	       (pr_and 
		 (lambda(as)	  ; last case for a  type, var.
		   (let* ((vnam
			    (first	  ;++
			      (ada_declared
				(first as)
				nil
				(or *class_restriction*
				    '(object formal_parameter number
					     constant package named
					     pragma_parameter
					     generic_unit
					     library_unit
					     task procedure entry))
				t)))
			  (tnam
			    (first	  ;++
			      (ada_declared
				(first as)
				nil
				(or *class_restriction*
				    '(type))
				t)))
			  (namdef (or vnam tnam))
			  (nam
			    (sc_diana dn_used_name_id
				      lx_symrep (first as)
				      sm_defn (or vnam tnam))))
		     (cond
		       ((and *in_record*
			     namdef
			     (eq (diana_nodetype_get namdef) 'dn_dscrmt_id))
			(setq *disc_used* t)))
		     (cond
		       ((and *disc_not_allowed*
			     namdef
			     (eq (diana_nodetype_get namdef) 'dn_dscrmt_id))
			(semgripe 'illegal_use_of_disc )))
		     (cond
		       ((null (second as)) nam)
		       (t (diana_put
			    (name_cdr_bits%thisname (second as))
			    nam
			    'as_name)
			  (name_cdr_bits%destname (second as))))
		     ))
		 (pr_and
		   (lambda(as)
		     (ct_push (first as) *name_communication*)
		     (first as))
		   lex_ident)		  ;if all else fails!
		 (pr_or nil name_cdr nil ))
	       ))
	  )

;;; find enclosed context. move this function to sema.l ++
       ;;;;;;;;;;;;;;;;;;;;;
(defun find_enclosed_context(id &optional override)
       ;;;;;;;;;;;;;;;;;;;;;
 (cond ((null id)
	nil)
       (t
     (ct_selectq
	(or override (diana_nodetype_get id))
	(dn_indexed
	  (find_enclosed_context
	    (extract_basetype
	      (diana_get
		(extract_basetype id t)
		'as_constrained))))
	((dn_used_name_id  dn_in_id dn_in_out_id dn_out_id dn_comp_id)
	 ;;dn_var_id was 'ere
	    (find_enclosed_context (extract_basetype id)))
	(dn_var_id
	  (let ((btid (extract_basetype id)))
	    (cond
	    ((and btid (eq (diana_nodetype_get btid) 'dn_record))
	     (find_enclosed_context btid))
	    ((and btid (eq (diana_nodetype_get btid) 'dn_access))
	     ;(break look-at-btid)
	     (find_enclosed_context btid))
	    ((and btid (eq (diana_nodetype_get btid) 'dn_task_spec))
	     ;(break look-at-task)
	     (find_enclosed_context btid))
	    (t (and (diana_node_accepts_attributep id 'ct_named_context)
		    (diana_get id 'ct_named_context))))))
	(dn_access
	    (find_enclosed_context
	      (extract_basetype (diana_get id 'as_constrained))))
	(dn_task_spec
	  (let ((entry (car (diana_get id 'as_decl_s))))
	       (and entry
		    (diana_get
		      (diana_get
			entry
			'as_designator)
		      'ct_st_defining_block))))
	(otherwise		; case for procedures, functions tasks
				; and packages.
	    (and (diana_node_accepts_attributep id 'ct_named_context)
		 (diana_get id 'ct_named_context)))))))

       ;;;;;;;;;;;
(defun strip_index(name_stack)
       ;;;;;;;;;;;
  (strip_index_aux (car name_stack)))

       ;;;;;;;;;;;;;;;
(defun strip_index_aux(name)
       ;;;;;;;;;;;;;;;
  (cond
    ((eq (car  name)
	 'index)
     (strip_index_aux  (cadr  name)))
    (t name)))

		;;;;;;;;
(def_ada_syntax name_cdr	;should return a name_cdr_bits
		;;;;;;;;

	(pr_and
	  (lambda (as)
	    (ct_pop  *name_communication*)
	    (first as))
	  (pr_or nil 
	       (pr_and  
		 (lambda(as)
		   ;(setq *original_context* nil)
		   (popcontext)
		   (let ((nam
			   (cond	  ; choose between selected and all.
			     ((and
				(diana_nodep (second as))
				(eq (diana_nodetype_get (second as)) 'dn_all))
			      (second as))
			     ((and (consp (second as))
				   (neq (first (second as))
					'*subprog*))
			      (second as))
			     ((and
				(diana_nodep (second as))
				(eq (diana_nodetype_get
				      (second as))
				    'dn_attribute_call))
			      (sc_diana
				dn_selected
				as_name nil	  ; gets put in by name (above).
				as_designator_char
				  (diana_get
				    (diana_get (second as) 'as_name)
					     'as_name)
				  ))
			     (t
			      (sc_diana
				dn_selected
				as_name nil	  ; gets put in by name (above).
				as_designator_char
				(filter_non_visible_selected
				  (cond ((and (consp (second as))
					      (eq (car (second as))
						  '*subprog*))
					 (second (second as)))
					(t (second as)))
				  (ada_declared 
				    (strip_index *name_communication*)
				    nil
				    '(package function record task constant
					      formal_parameter named
					      procedure entry object))
				  ))))))
		     (cond
		       ((and (consp (second as))
			     (neq (first (second as))
					   '*subprog*))
			(second as))
		       ((consp (second as)) (name_cdr_bits nam nam))
		       ((and (diana_nodep (second as))
			     (memq (diana_nodetype_get (second as))
			      '(dn_indexed dn_selected)))
			;;transform tree to get the indexed on top of the
			;;selected.
			(diana_put nam
				   (diana_get (second as)
					      'as_name)
				   'as_designator_char)
			(diana_put (second as)
				   nam
				   'as_name)
			(name_cdr_bits nam (second as))
			)
		       ((and (diana_nodep (second as))
			     (eq (diana_nodetype_get (second as))
			      'dn_attribute_call))
			(diana_put (diana_get (second as)
					      'as_name)
				   nam
				   'as_name)
			(name_cdr_bits nam (second as))
			)
		       (t (name_cdr_bits nam nam)))))
		 (pr_and
		   (lambda(as)
		     (cond ((null *original_context*)
			    (setq *original_context* **current_block**)))
		     (savecontext)	  ;save the current context
		     (ct_push (car  *name_communication*)  *name_communication*)
		     (setq **current_block** 
			   (or
			     (find_enclosed_context
			       (ada_declared 
				 (strip_index *name_communication*)
				 nil
				 '(package function record task formal_parameter
					   procedure entry object named constant))
			       (cond ((eq (caar  *name_communication*)
					  'index)
				      'dn_indexed)
				     (t nil))
			       )
			     **current_block**)))
		   oper_period)
		 (pr_or nil
			(pr_and
			  (lambda (as)
;			    (break mumble)
			    (cond ((consp (first as))
				   (list '*subprog* (first as)))
#|				  ((and (diana_nodep (first as))
					(eq (diana_nodetype_get (first as))
					    'dn_selected)
					(null
					  (diana_get (first as)
						     'as_designator_char)))
				   (diana_get (first as) 'as_name)) |#
				  (t (cond
				       ((and
					  (eq (diana_nodetype_get (first as))
					      'dn_used_name_id)
					  (null (diana_get (first as)
							   'sm_defn)))
					(semgripe
					  'undecl_id
					  (implode
					    (lowuplist
					      (cadr (diana_get
						      (first as)
						    'lx_symrep)))))))
				     (first as))))
			  name_aux)
			(pr_and
			  (lambda(as)
			    (cond ((null (second as))
				   (sc_diana dn_all
					     as_name nil)); gets filled in by name
				  (t (let ((dnall (sc_diana dn_all
							    as_name nil)))
				       (diana_put
					 (name_cdr_bits%thisname (second as))
				 	 dnall
					 'as_name)
				       (name_cdr_bits
					 dnall
					 (name_cdr_bits%destname (second as)))))))
			  symb_all
			  (pr_or nil
				 name_cdr
				 nil))))
	       (pr_and 
		 (lambda(as)
		   (let ((nam 
			   (cond
			     ((null (third as))	  ; single indexed.
			      (cond ((and
				       (diana_nodep (second as))
				       (eq (diana_nodetype_get (second as))
					   'dn_used_name_id)
				       (diana_get (second as)
							  'sm_defn)
				       (memq (diana_nodetype_get
					       (diana_get (second as)
							  'sm_defn))
					     '(dn_type_id dn_subtype_id)))
				     (semgripe
				       'array_index_cannot_be_a_type
				       (implode
					 (lowuplist
					   (cadr
					     (diana_get (second as)
							'lx_symrep)))))))
			      ;;this could be a typemark to represent a slice ++
			      (let*
				((us_id (and (diana_nodep (second  as))
					     (eq (diana_nodetype_get (second as))
					   'dn_used_name_id)
					     (second as)))
				 (sm_def (and us_id
					      (diana_get (second as)
							  'sm_defn)))
				 (discp (and sm_def
					     (eq (diana_nodetype_get sm_def)
						 'dn_dscrmt_id))))
				 (cond ((and *in_record*
					     discp)
				    (semgripe 'illegal_use_of_disc))))
			      (sc_diana dn_indexed
					as_name nil	  ; filled in by name.
					as_exp_s
					(sc_diana dn_exp_s
						  as_list (list (second as)))))
			     ((eq (car (third as)) 'oper_dotdot)  ; slice6
			      (cond ((and
				       (eq (diana_nodetype_get (second as))
					   'dn_used_name_id)
				       (diana_get (second as)
							  'sm_defn)
				       (memq (diana_nodetype_get
					       (diana_get (second as)
							  'sm_defn))
					     '(dn_type_id dn_subtype_id)))
				     (semgripe
				       'array_index_cannot_be_a_type
				       (implode
					 (lowuplist
					   (cadr
					     (diana_get (second as)
							'lx_symrep)))))))
			      (cond ((and
				       (eq (diana_nodetype_get (second (third as)))
					   'dn_used_name_id)
				       (diana_get (second (third as))
							  'sm_defn)
				       (memq (diana_nodetype_get
					       (diana_get (second (third as))
							  'sm_defn))
					     '(dn_type_id dn_subtype_id)))
				     (semgripe
				       'array_index_cannot_be_a_type
				       (implode
					 (lowuplist
					   (cadr
					     (diana_get (second as)
							'lx_symrep)))))))
			      (sc_diana dn_slice
					as_name nil	  ; filled in by name.
					as_dscrt_range
					(sc_diana dn_range
						  as_exp1 (second as)
						  as_exp2 (second (third
								    as)))))
			     ((eq (car (third as)) 'oper_comma)	  ; indexed
			      (cond ((and
				       (eq (diana_nodetype_get (second as))
					   'dn_used_name_id)
				       (diana_get (second as)
							  'sm_defn)
				       (memq (diana_nodetype_get
					       (diana_get (second as)
							  'sm_defn))
					     '(dn_type_id dn_subtype_id)))
				     (semgripe
				       'array_index_cannot_be_a_type
				       (implode
					 (lowuplist
					   (cadr
					     (diana_get (second as)
							'lx_symrep)))))))
			      (sc_diana dn_indexed
					as_name nil	  ; filled in by name.
					as_exp_s
					(sc_diana dn_exp_s
						  as_list
						  (cons (second as)
							(cons (second (third
									as))
							      (third (third
								       as)))))))
			     (t (sc_diana dn_foo)); ++
			     ) ))
		     (cond
		       ((null  (fifth as))
			(name_cdr_bits nam nam))
		       (t  (diana_put 
			     (name_cdr_bits%thisname (fifth as))
			     nam
			     'as_name)
			   (name_cdr_bits
			     nam
			     (name_cdr_bits%destname (fifth as)))))))
		 ;;dont allow success if tm ++
		 (pr_and
		   (lambda(as)
		     (let ((name
			     (first
			       (ada_declared
				 (strip_index *name_communication*)
				 nil
				 '(object formal_parameter constant
					  procedure function)
				 t))))
		     (cond
		       ((null name);(break name-not-an-array)
			(putback_symbol (first as))	  ;undo parse.
			'fail)		  ;and return nil... noparse
		      (t (savecontext)
			 (ct_push
			   (list 'index (car  *name_communication*))
			   *name_communication*)
			 (cond (*original_context*
				(setq **current_block**
				      *original_context*)
				))
			 (first as)))))
		   (pr_or pascal_bracket_check oper_lparen))
		 expression
		 (pr_or nil 
			range_constraint  ; not dotdot or comma signifies slice.
			(pr_and nil	  ; dotdot signifies slice.
				oper_dotdot
				simple_expression)
			(pr_and nil	  ; comma signifies indexed.
				oper_comma
				expression
				(pr_repeat nil
					   (pr_and cadr
						   oper_comma
						   expression)))
			nil)
		 (pr_or pascal_bracket_check
			(pr_and
			  (lambda (as)
			    (setq *original_context* **current_block**)
			    (popcontext)
			    (first as))
			  oper_rparen))
		 (pr_or nil name_cdr nil))
	       (pr_and2c
		 (lambda(as)
;		   (break in-name_cdr)
		   (second as))
		 oper_quote
		 (pr_or nil lex_ident symb_range symb_delta symb_digits)
		 ;these are the ll2 symbols.

		 oper_quote
		 (pr_or
		   nil 
		   (pr_and 
		     (lambda(as)
		       (let ((nam
			       (sc_diana dn_attribute_call
					 as_name nil	  ; see below
					 as_exp (second as))))
			 (ct_push (car  *name_communication*) *name_communication*)
			 (diana_put
			   nam
			   (sc_diana
			     dn_attribute
			     as_name nil  ; gets filled in by name
			     as_id
			     (sc_diana
			       dn_used_name_id
			       lx_symrep (first as)
			       sm_defn (ada_declared 
					 (first as)
					 nil
					 '(indexable_attribute
					    not_indexable_attribute))))
			   'as_name)
			 (cond
			   ((null (third as))
			    ;(break look-at-foo) 
			    (name_cdr_bits (diana_get nam 'as_name)
					   nam))
			   (t  
			       (cond
				 ((eq (diana_nodetype_get
					(name_cdr_bits%destname (third as)))
				      'dn_attribute_call)
				  (diana_put
				    (name_cdr_bits%thisname (third as))
				    nam
				    'as_name)
				  (let ((frob
					  (name_cdr_bits 
					    (diana_get nam 'as_name)
					    (name_cdr_bits%destname (third as)))))
				     frob))
				 (t (diana_put 
				      (name_cdr_bits%thisname (third as))
				      nam 
				      'as_name)
				    (name_cdr_bits 
				      nam 
				      (name_cdr_bits%destname
					(third as)))))))))
		     (pr_or nil
			    (pr_restrict indexable_attribute lex_ident)
			    (pr_restrict not_indexable_attribute lex_ident)
;;; This is unbelievable! range is a reserved word and also an attribute.
;;; only context can tell which. even worse so are delta and digits.
			    (pr_and
			      (lambda(as)
				(ada_ident digits))
			      symb_digits)
			    (pr_and
			      (lambda(as)
				(ada_ident delta))
			      symb_delta)
			    (pr_and
			      (lambda(as)
				(ada_ident range))
			      symb_range));crock crock 
		     (pr_or nil 
			    (pr_and cadr
				    (pr_and
				      (lambda (as)
					(savecontext)
					(cond (*original_context*
					       (setq **current_block**
						     *original_context*)
					       ))
					(first as))
				      oper_lparen)
				    expression
				    (pr_and
				      (lambda (as)
					(popcontext)
					(first as))
				      oper_rparen))
			    nil)
		     (pr_or nil name_cdr nil))
		   ))
	       nil))) 
    
		;;;;;;;;;;;;;;;
(def_ada_syntax operator_symbol
		;;;;;;;;;;;;;;;

   (pr_and
     (lambda(as)
       `(lex_ident ,(cadr (first as))))
     lex_string))

;;;-- 4.2  Literals
;;;
;;;-- Syntax 4.2
;;;--  literal  ::=
;;;--     numeric_literal | enumeration_literal | character_string
;;;--   | 'null'
;;;    -- The xcenumeration_literal is represented as a 'used_object_id' or a
;;;    --  'used_char' whose attributes point to an 'enum_id' or a 'def_char'.
;;;    -- See 2.3.
;;;--
;;;
;;;
;;;    EXP ::=              numeric_literal;
;;;
;;;    numeric_literal =>   lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_numrep        : number_rep;
;;;    numeric_literal =>   sm_exp_type      : TYPE_SPEC,
;;;                         sm_value         : value;
;;;    -- if there is implicit conversion sm_exp_type reflects conversion;
;;;    -- otherwise it references a universal type
;;;
;;;    EXP ::=              used_char;
;;;
;;;    used_char =>         lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    used_char =>         sm_defn          : DEF_OCCURRENCE,
;;;                         sm_exp_type      : TYPE_SPEC,
;;;                         sm_value         : value;
;;;
;;;
;;;    EXP ::=              null_access;
;;;
;;;    null_access =>       lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    null_access =>       sm_exp_type      : TYPE_SPEC,
;;;                         sm_value         : value;
;;;
;;;
;;;    EXP ::=              string_literal;
;;;
;;;    string_literal =>    lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    string_literal =>    sm_exp_type      : TYPE_SPEC,
;;;                         sm_constraint    : CONSTRAINT,
;;;                         sm_value         : value;
;;;
		;;;;;;;
(def_ada_syntax literal
		;;;;;;;

	(pr_or nil 
	       (pr_and 
		 (lambda(as)
		   (sc_diana dn_null_access))
		 symb_null)
	       (pr_and
		 (lambda(as)
		   (sc_diana dn_string_literal
			     lx_symrep (first as)))
		 lex_string)
		(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)
		       (dissambiguate_function_reference
			 (sc_diana dn_function_call
			      lx_symrep
			      `(lex_char (#/' ,(caadr (first as)) #/'))
			      tp_vfuns
			      (ada_declared
				`(lex_char (#/' ,(caadr (first as)) #/'))
				nil 'function t))))
		      (t (semgripe
			   'character_literal_has_funny_length
			    (implode (append (list '#/') 
					     (cadr (first as)) (list '#/'))))
			 (sc_diana dn_character_literal
			      lx_symrep
			      `(lex_char `(#/' ,(caadr (first as)) #/')))))
		    )
		  oper_quote)
					  ;	    int_const
					  ;	    real_const
	       (pr_and
		 (lambda(as)
		   (sc_diana dn_numeric_literal
			     lx_numrep (first as)))
		 lex_number)))		  ; {other_number_const}