;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;  $Header: /ct/interp/adas60.l,v 1.41 84/10/10 19:11:08 penny Exp $
;;;  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                            adas60.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.


;;;-- 5.  Statements
;;;-- ==============
;;;-- 5.1  Simple and Compound Statements, Sequences of Statements
;;;
;;;-- Syntax 5.1.A
;;;--  sequence_of_statements ::= statement {statement}
;;;--
;;;
;;;
;;;    STM_S ::=            stm_s;
;;;
;;;    stm_s =>             as_list          : Seq Of STM;
;;;    stm_s =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;

       ;;;;;;;;;;
(defun last_label (as)
       ;;;;;;;;;;
  (do ((frob as (cdr frob))
       (ll nil))
      ((null frob) ll)
    (cond ((eq (diana_nodetype_get (car frob)) 'dn_labeled)
	   (setq ll (car frob))
	   (diana_put (diana_get ll 'as_id) (cadr frob) 'as_stm)
	   (diana_put (diana_get ll 'as_id) (car as) 'ct_labeled)
	   (diana_put ll (cadr frob) 'as_stm)))))
	  
		;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax sequence_of_statements
		;;;;;;;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    ;;first is the labeled's.. chain them up if more than one.
	    (let ((lastlab (last_label (first as))))
	      (cond ((and
		       (diana_nodep lastlab)
		       (eq (diana_nodetype_get lastlab) 'dn_labeled))
		     (diana_put (diana_get lastlab 'as_id) (second as) 'as_stm)
		     (diana_put lastlab (second as) 'as_stm))
		    )
	    (sc_diana dn_stm_s
		      as_list
		      (append (cond (lastlab (list (car (first as))))
				    ((first as)
				     (append (first as) (list (second as))))
				    (t (list (second as))))
			      (cond
				((third as)
				 (diana_get (third as) 'as_list)))))))
	  (pr_repeat
	    nil
	    (pr_or nil 
		   (pr_and 
		     (lambda(as)
		       (sc_diana dn_labeled
				 as_id 
				 (add_name
				   (second as)
				   'label
				   (let ((lid
					   (sc_diana dn_label_id
					   lx_symrep (second as)
					   sm_stm nil  ; gets filled in later.
					   )))
				     (diana_put lid lid 'sm_defn)
				     lid)
				   nil)
				 as_stm nil	  ; gets filled in later
				 )
		       )
		     oper_mlt lex_ident oper_mgt)
		   pragma))
	  (pr_or nil 
					  ; this is an ll(2) part of the grammar.
					  ; first check for a named block or loop.
		 (pr_and2c
		   (lambda(as)
		     (popcontext)
		     (cond
		       ((null (fourth as))
			(semgripe 'missing_matching_mandatory_name
				  (implode
				    (lowuplist
				      (cadr
					(diana_get (first as) 'lx_symrep)))))))
		     (matching_ident (diana_get (first as) 'lx_symrep)
				     (fourth as))	;idents must match.
		     (diana_put (first as) (third as) 'sm_stm)
		     (sc_diana dn_named_stm
			       as_id (first as)			       
			       as_stm (third as)))
		   lex_ident oper_colon  ;ll2 symnbols
		   (pr_and
		     (lambda (as)
		       (pushcontext) ;make sure not visible outside loop or block
		       (let ((lid
			       (add_name
				 (first as)
				 'named
				 (sc_diana dn_named_stm_id
					   lx_symrep (first as)
					   sm_stm nil; gets put in later
					   ct_named_context nil);gets put in later
				 nil)))
			 (rplaca *named_stm_stack* lid)
			 (diana_put lid lid 'sm_defn)
			 lid))
		     lex_ident)
		   oper_colon
		   (pr_or nil loop_statement block_stmt)
		     lex_ident
		     		  ;idents must match.
		   oper_semicolon)
		 
		 (pr_and
		   (lambda(as)
		     (progn
		       (cond ((subprogram_call_node_p (second as))
			      (diana_put (second as)
					 (mapcan
					   #'(lambda (cand)
					       (cond ((eq (diana_nodetype_get
							    cand)
							  'dn_function_call)
						      nil)
						     (t (list cand))))
					   (find_name (first as)
						      '(procedure entry)
						      t))
					 'tp_vfuns))
			     ((second as)
			       (diana_put (second as)
				(find_name (first as) nil) 'as_name)))
		       (cond
			 ((subprogram_call_node_p (second as))
			  (let ((void
				  (sc_diana dn_void)))
			  (diana_put (second as)
				     (diana_get void 'lx_srcpos)
				     'lx_srcpos)
			  (normalize_params
			    (dissambiguate_function_reference
			      (second as)))))
			 ((and (second as)
			       (eq (diana_nodetype_get (second as)) 'dn_assign))
			  (let ((void
				  (sc_diana dn_void)))
			  (diana_put (second as)
				     (diana_get void 'lx_srcpos)
				     'lx_srcpos))
			  (cond
			    ((not
			       (assignable_p
				 (diana_get (second as) 'as_name)))
			     (semgripe 'lhs_not_assignable));ERRMSG
			    ((not
			       (assignment_compatible
				 (diana_get
				   (second as)
				   'as_exp)
				 (diana_get
				   (second as)
				   'as_name)))
			     (semgripe 'types_not_assignable)))))
		       (second as)))	; deposit the name.
		   (pr_and
		     (lambda(as)
		       (cond
			 ((name_declared_check (first as)) (first as))))
		     (pr_or nil
		       (pr_and
			 (lambda (as)
			   (second as))
			 (pr_and
			   (lambda (as)
			     (let* ((symstk
				      (do ((stk nil))
					  ((memq la_current_symbol
						 '(oper_semicolon
						    oper_assign))
					   stk)
					(ct_push la_current_symbol stk)
					(la_lex)))
				    (funcall_p
				      (eq la_current_symbol 'oper_assign)))
			       (mapc #'putback_symbol symstk)
			       (putback_symbol (first as))
			       (cond ((not funcall_p)
				      'fail))))
			   lex_ident)
			 name)
		       (no_function			 
			 name)))	; either proc.call,assignment or attribute.
		   (pr_or nil 
			  (pr_and 
			    (lambda(as)
			      (sc_diana dn_assign
					as_exp (second as)
					as_name nil	  ; Gets filled in later.
					)
			      )
			    (pr_or fortran_assignment_check oper_assign)
			    expression
			    oper_semicolon)
			  (pr_and
			    (lambda(as)
			      (sc_diana dn_code
					as_exp (second as)
					as_name nil	  ; gets filled in later.
					)
			      )
			    oper_quote
			    general_aggregate
;			    (pr_restrict agg_or_exp general_aggregate)
			    oper_semicolon)
			  procedure_or_entry_call))
		 
		 (pr_and car loop_statement oper_semicolon)
		 
		 (pr_and car block_stmt oper_semicolon)
		 
		 (pr_and
		   (lambda(as)
		     (sc_diana dn_null_stm
			       )
		     )
		   symb_null oper_semicolon)
		 
		 exit_statement
		 return_statement
		 goto_statement
		 delay_statement
		 delay_statement
		 abort_statement
		 raise_statement
		 if_statement
		 case_statement
		 accept_statement
		 select_statement)
	  
	  (pr_or nil sequence_of_statements nil)))
    
;;;-- 5.3  If Statements
;;;
;;;-- Syntax 5.3.A
;;;--  if_statement ::=
;;;--       'if' condition 'then'
;;;--           sequence_of_statements
;;;--      {'elsif' condition 'then'
;;;--           sequence_of_statements}
;;;--      ['else'
;;;--           sequence_of_statements]
;;;--       'end' 'if' ';'
;;;--
;;;
;;;
;;;    STM ::=              if;
;;;
;;;    if =>                as_list          : Seq Of COND_CLAUSE;
;;;    if =>                lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    COND_CLAUSE ::=      cond_clause;
;;;
;;;    cond_clause =>       as_exp_void      : EXP_VOID,
;;;                         as_stm_s         : STM_S;
;;;    cond_clause =>       lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- Syntax 5.3.B
;;;--  condition ::= expression
;;;--
;;;
;;;
;;;    -- condition is replaced by EXP
;;;
		;;;;;;;;;;;;
(def_ada_syntax if_statement
		;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (sc_diana dn_if
		      as_list (append (cons (first as)(second as)) (third as))))
	  (pr_and
	    (lambda(as)
	      (cond ((not (boolean_expression_p (second as)))
		     (semgripe 'not_bool_exp)))
	      (sc_diana dn_cond_clause
			as_exp_void (second as)
			as_stm_s (fourth as)))
	    symb_if
	    expression
	    (pr_and
	      (lambda (as)
		(pushcontext)
		(first as))
	      symb_then)
	    (pr_and
	      (lambda (as)
		(popcontext)
		(first as))
	      sequence_of_statements))
	  (pr_or nil
		 (pr_repeat nil
			    (pr_and
			      (lambda(as)
				(cond ((not (boolean_expression_p (second as)))
				       (semgripe 'not_bool_exp)))
				(sc_diana dn_cond_clause
					  as_exp_void (second as)
					  as_stm_s (fourth as)))
			      symb_elsif
			      expression
			      (pr_and
				(lambda (as)
				  (pushcontext)
				  (first as))
				symb_then)
			      (pr_and
				(lambda (as)
				  (popcontext)
				  (first as))
				sequence_of_statements)))
		 nil)
	  (pr_or nil 
		 (pr_and
		   (lambda(as)
		     (list
		       (sc_diana dn_cond_clause
				 as_exp_void (sc_diana dn_void)
				 as_stm_s (second as))))
		   (pr_and
		     (lambda (as)
		       (pushcontext)
		       (first as))
		     symb_else)
		   (pr_and
		     (lambda (as)
		       (popcontext)
		       (first as))
		     sequence_of_statements))
		 nil)
	  symb_end
	  symb_if
	  oper_semicolon)) 

;;;-- 5.4  Case Statements
;;;
;;;-- Syntax 5.4
;;;--  case_statement ::=
;;;--     'case' expression 'is' alternative {alternative}
;;;--     'end' 'case' ';'
;;;--  alternative ::= 'when' choice {'|' choice} '=>' sequence_of_statements
;;;--
;;;
;;;
;;;    STM ::=              case;
;;;    ALTERNATIVE_S ::=    alternative_s;
;;;    ALTERNATIVE ::=      alternative | pragma;     -- pragma allowed before
;;;                                                   -- 'when'
;;;
;;;    case =>              as_exp           : EXP,
;;;                         as_alternative_s : ALTERNATIVE_S;
;;;    case =>              lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    alternative_s =>     as_list          : Seq Of ALTERNATIVE;
;;;    alternative_s =>     lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    alternative =>       as_choice_s      : CHOICE_S,
;;;                         as_stm_s         : STM_S;
;;;    alternative =>       lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;;;;;
(def_ada_syntax case_statement
		;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (sc_diana dn_case
		      as_exp (second as)
		      as_alternative_s 
		      (sc_diana dn_alternative_s
				as_list (fourth as))))
	  symb_case
	  expression
	  symb_is
	  case_statement_naka		  ; returns a Seq of alternative
	  symb_end
	  symb_case
	  oper_semicolon))
    
		;;;;;;;;;;;;;;;;;;;
(def_ada_syntax case_statement_naka
		;;;;;;;;;;;;;;;;;;;

	(pr_and cadr
		symb_when
		(pr_or nil 
		       (pr_and 
			 (lambda(as)
			   (list
			     (sc_diana dn_alternative
				       as_choice_s
				       (sc_diana
					 dn_choice_s
					 as_list (list (sc_diana dn_others)))
				       as_stm_s (third as))))
			 symb_others
			 (pr_and
			   (lambda (as)
			     (pushcontext)
			     (first as))
			   oper_goes)
			 (pr_and
			   (lambda (as)
			     (popcontext)
			     (first as))
			   sequence_of_statements))
		       (pr_and 
			 (lambda(as)
			   (cons
			     (sc_diana dn_alternative
				       as_choice_s 
				       (sc_diana
					 dn_choice_s
					 as_list (cons (first as)(second as)))
				       as_stm_s (fourth as))
			     (fifth as)))
			 choice_range
			 (pr_repeat nil (pr_and cadr oper_bar choice_range))
			 (pr_and
			   (lambda (as)
			     (pushcontext)
			     (first as))
			   oper_goes)
			 (pr_and
			   (lambda (as)
			     (popcontext)
			     (first as))
			   sequence_of_statements)
			 (pr_or nil case_statement_naka nil)))))

;;;-- 5.5  Loop Statements
;;;
;;;-- Syntax 5.5.A
;;;--  loop_statement ::=
;;;--     [identifier ':'] [iteration_clause] basic_loop
;;;--                                  [identifier] ';'
;;;--
;;;
;;;
;;;    STM ::=              named_stm;
;;;
;;;    named_stm =>         as_id            : ID,    -- always a 'label_id'
;;;                         as_stm           : STM;   -- 'loop' or 'block'
;;;    named_stm =>         lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- Syntax 5.5.B
;;;--  basic_loop ::=
;;;--     'loop'
;;;--         sequence_of_statements
;;;--     'end' 'loop'
;;;--
;;;
;;;
;;;    STM ::=              LOOP;
;;;    LOOP ::=             loop;
;;;    ITERATION ::=        void;
;;;
;;;    loop =>              as_iteration     : ITERATION,
;;;                         as_stm_s         : STM_S;
;;;    loop =>              lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- Syntax 5.5.C
;;;--  iteration_clause ::=
;;;--     'for' loop_parameter 'in' ['reverse'] discrete_range
;;;--   | 'while' condition
;;;--  loop_parameter ::= identifier
;;;--
;;;
;;;
;;;    ITERATION ::=        for | reverse;
;;;
;;;    for =>               as_id            : ID,    -- always an 'iteration_id'
;;;                         as_dscrt_range   : DSCRT_RANGE;
;;;    for =>               lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    reverse =>           as_id            : ID,    -- always an 'iteration_id'
;;;                         as_dscrt_range   : DSCRT_RANGE;
;;;    reverse =>           lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;
;;;    DEF_ID ::=           iteration_id;
;;;
;;;    iteration_id =>      lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    iteration_id =>      sm_obj_type      : TYPE_SPEC;
;;;
;;;
;;;    ITERATION ::=        while;
;;;
;;;    while =>             as_exp           : EXP;
;;;    while =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;;;;;
(def_ada_syntax loop_statement         
		;;;;;;;;;;;;;;

     (pr_and
       (lambda(as)
	 (ct_pop  *named_stm_stack*)
	 (cond ((null (first as))) (t (popcontext)))
	 (sc_diana dn_loop
		   as_iteration 
		   (cond ((null (first as)) (sc_diana dn_void))
			 (t (first as)))
		   as_stm_s
		   (third as)))
       (pr_or
	 nil 
	 (pr_and
	   (lambda(as)
	     (pushcontext)		  ; make while loop a block.
	     
	     (cond ((not (boolean_expression_p (second as)))
		    (semgripe 'not_bool_exp)))
	     (sc_diana dn_while
		       as_exp (second as)))
	   symb_while 
	   expression)
	 (pr_and
	   (lambda(as)
	     (pushcontext)		  ; make for loop a block.
	     (let ((loop_id
		     (add_name 
		       (second as)
		       'object		  ; should distinguish iterations so
					  ; that we can check for asignments.??
		       (let ((itid
			       (sc_diana dn_iteration_id
					 lx_symrep (second as)
					 sm_obj_type nil)))	  ; not known yet.
			 (diana_put itid itid 'sm_defn)	  ;is its own definition.
			 itid)
		       nil)))
	       (cond ((car *named_stm_stack*)
		      (diana_put (car *named_stm_stack*)
				 **current_block**
				 'ct_named_context)))
	       
	       (diana_put loop_id 
			  (extract_basetype (fifth as))	  ;better check this++
			  'sm_obj_type)
	       (cond ((null (fourth as))
		      (sc_diana dn_for
				as_id loop_id
				as_dscrt_range (fifth as)))
		     (t  (sc_diana dn_reverse
				   as_id loop_id
				   as_dscrt_range (fifth as))))))
	   symb_for
	   lex_ident
	   symb_in
	   (pr_or nil symb_reverse nil)
	   index_range)
	 nil)
       (pr_and
	 (lambda (as)
	   (pushcontext)
	   (ct_push nil  *named_stm_stack*)
	   (first as))
	 symb_loop)
       (pr_and
	 (lambda (as)
	   (popcontext)
	   (first as))
	 sequence_of_statements)
       symb_end
       symb_loop))
    
;;;-- 5.6  Blocks
;;;
;;;-- Syntax 5.6
;;;--  block ::=
;;;--     [identifier ':']
;;;--     ['declare'
;;;--          declarative_part]
;;;--      'begin'
;;;--          sequence_of_statements
;;;--     ['exception'
;;;--          exception_handler {exception_handler}]
;;;--      'end' [identifier] ';'
;;;--
;;;
;;;
;;;    STM ::=              block;
;;;                                                   -- see 5.5.A for named block
;;;
;;;    block =>             as_item_s        : ITEM_S,
;;;                         as_stm_s         : STM_S,
;;;                         as_alternative_s : ALTERNATIVE_S;
;;;    block =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;
(def_ada_syntax block_stmt
		;;;;;;;;;;

	(pr_and
	  (lambda(as)			  ;(break in-block-statement)
	    (cond ((first as)(popcontext)))
	    (sc_diana dn_block
		      as_item_s (second (first as))
		      as_stm_s (first (second as))
		      as_alternative_s (second (second as))))
	  (pr_or nil 
		 (pr_and nil
			 (pr_and
			   (lambda(as)
			     (pushcontext)
			     (cond ((car *named_stm_stack*)
				    (diana_put (car *named_stm_stack*)
					       **current_block**
					       'ct_named_context)))
			     (first as))
			   symb_declare)
			 (pr_or nil declarative_part nil)) 
		 nil)
	  statement_part))

; returns a list (sequence_of_statements exception)    
		;;;;;;;;;;;;;;
(def_ada_syntax statement_part
		;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (ct_pop *named_stm_stack*)
	    (cond ((null (third as))(list (second as) nil))
		  (t (list (second as)(third as)))))
	  (pr_and
	    (lambda (as)
	      (ct_push nil *exception_handler_stack* )
	      (ct_push nil *named_stm_stack*)
	      (first as))
	    symb_begin)
	  sequence_of_statements
	  (pr_or nil 
		 (pr_and cadr
			 (pr_and
			   (lambda (as)
			     (rplaca *exception_handler_stack* t)
			     (first as))
			   symb_exception)
			 exception_part)
		 (pr_and cadr
			 (pr_and
			   (lambda(as)
			     (rplaca *exception_handler_stack* t)
			     (putback_symbol (first as))
			     (gripe '("The reserved word 'exception' was expected.")
				    '((lrmref "LRM" (lrmsec 11 2 nil) (lrmpar 4 nil))
		   (lrmref "LRM" (lrmsec 11 2 nil) (lrmpar 7 nil)))))
			   symb_when)
			 exception_part)
		 nil)
	  (pr_and
	    (lambda (as)
	      (ct_pop *exception_handler_stack* )
	      (first as))
	    symb_end)))
    
		;;;;;;;;;;;;;;
(def_ada_syntax exception_part
		;;;;;;;;;;;;;;

	(pr_or nil
	       (pr_and
		 (lambda(as)
		   (sc_diana dn_alternative_s
			     as_list (second as)))
		 symb_when
		 (pr_or
		   nil
		   (pr_and
		     (lambda(as)
		       (list
			 (sc_diana dn_alternative
				   as_choice_s
				   (list (sc_diana dn_others))
				   as_stm_s
				   (third as))))
		     symb_others
		     oper_goes
		     sequence_of_statements)
		   (pr_and
		     (lambda(as)
		       ;(break look-at-first)
		       (cons
			 (sc_diana dn_alternative
				   as_choice_s
				   (cons (find_name (first as) 'exception)
					 (second as))
				   as_stm_s
				   (fourth as))
			 (cond
			   ((fifth as)
			    (diana_get (fifth as) 'as_list))))
		       )
		     (pr_and cadr
		       (pr_and
			 (lambda (as)
			   (putback_symbol (first as)))
			 lex_ident)
		       (pr_restrict exception name))
		     (pr_repeat nil
				(pr_and (lambda(as)
					  (find_name (cadr as) 'exception))
					oper_bar
					(pr_and cadr
						(pr_and
						  (lambda (as)
						    (putback_symbol (first as)))
						  lex_ident)
						(pr_restrict exception name))
					))
		     oper_goes
		     sequence_of_statements
		     (pr_or nil exception_part nil))))
	       nil))

;;;-- 5.7  Exit Statements
;;;
;;;-- Syntax 5.7
;;;--  exit_statement ::=
;;;--     'exit' [name] ['when' condition]';'
;;;--
;;;
;;;
;;;    STM ::=              exit;
;;;    NAME_VOID ::=        NAME | void;
;;;
;;;    exit =>              as_name_void     : NAME_VOID,
;;;                         as_exp_void      : EXP_VOID;
;;;    exit =>              lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    exit =>              sm_stm           : LOOP;  -- Computed even when there
;;;                                                   -- is no name given
;;;                                                   -- in the source program.
;;;
		;;;;;;;;;;;;;;
(def_ada_syntax exit_statement
		;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (sc_diana dn_exit
		      as_name_void 
		      (cond 
			((null (second as))(sc_diana dn_void))
			(t (find_name (second as) nil)))
		      as_exp_void
		      (cond 
			((null (third as))(sc_diana dn_void))
			(t (third as)))))
	  symb_exit
	  (pr_or nil (pr_restrict named name) nil)
	  (pr_or nil 
		 (pr_and
		   (lambda(as)
		     (cond ((not (boolean_expression_p (second as)))
			    (semgripe 'not_bool_exp)))
		     (second as))
		   symb_when 
		   expression)
		 nil)
	  oper_semicolon))

;;;-- 5.8  Return Statements
;;;
;;;-- Syntax 5.8
;;;--  return_statement ::= 'return' [expression] ';'
;;;--
;;;
;;;
;;;    STM ::=              return;
;;;
;;;    return =>            as_exp_void      : EXP_VOID;
;;;    return =>            lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;;;;;;;
(def_ada_syntax return_statement
		;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)			  ;(break return)
	    (let ((rt (first *returntypestack*))
		  (re (second as)))
	      (cond
		((eq rt 'package)
		 (semgripe 'ret_st_in_package))
		((eq rt 'task)
		 (semgripe 'ret_st_in_task))
		((and (null rt) (null re)))
		((and (null rt) re)
		 (semgripe 'ret_exp_not_in_fun))
		((and rt (null re))
		 (rplaca *return_stmt_stack* t)
		 (semgripe 'ret_exp_expected))
		((and re rt)
		 (rplaca *return_stmt_stack* t)
		 (cond
		   ((assignment_compatible re rt))
		   (t (semgripe 'ret_type_not_compat))))))
	    
	    (sc_diana dn_return
		      as_exp_void
		      (cond 
			((null (second as))(sc_diana dn_void))
			(t (second as)))))
	  symb_return
	  (pr_or nil expression nil)
	  oper_semicolon))
    
;;;-- 5.9  Goto Statements
;;;
;;;-- Syntax 5.9
;;;--  goto_statement ::= 'goto' name ';'
;;;--
;;;
;;;
;;;    STM ::=              goto;
;;;
;;;    goto =>              as_name          : NAME;
;;;    goto =>              lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;;;;;
(def_ada_syntax goto_statement
		;;;;;;;;;;;;;;

	(pr_and 
	  (lambda(as)
	    (%= *goto_count* (1+ *_*))
	    (let ((goto
		    (sc_diana dn_goto
		      ;;changed as_name to sm_name ++ ct change.
		      sm_name nil)));(find_name (second as) nil))
	      (ct_push (gotorec goto (second as) **current_block**)
		       *awaiting_label_fixup*)
	      goto))
		      
	  symb_goto 
	  lex_ident;(pr_restrict label name) 
	  oper_semicolon))