;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;  $Header: /ct/interp/adas100.l,v 1.28 85/06/21 12:27:32 bill Exp $
;;;
;;;  

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


;;;-- 7.  Packages
;;;-- ============
;;;-- 7.1  Package Structure
;;;
;;;-- Syntax 7.1.A
;;;--  package_declaration ::= package_specification ';'
;;;--   | generic_package_instantiation
;;;--
;;;
;;;
;;;    package_decl =>      as_id            : ID,    -- always 'package_id'
;;;                         as_package_def   : PACKAGE_DEF;
;;;    package_decl =>      lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;
;;;    DEF_ID ::=           package_id;
;;;
;;;    package_id =>        lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    package_id =>        sm_spec          : PACKAGE_SPEC,
;;;                         sm_body          : PACK_BODY_DESC,
;;;                         sm_address       : EXP_VOID;
;;;
;;;    PACK_BODY_DESC::=    block | stub | rename | instantiation | void;
;;;
;;;-- Syntax 7.1.B
;;;--  package_specification ::=
;;;--     'package' identifier 'is'
;;;--        declarative_item {declarative_item}
;;;--    ['private'
;;;--        declarative_item {declarative_item}
;;;--     'end' [identifier]
;;;--
;;;
;;;
;;;    PACKAGE_SPEC ::=     package_spec;
;;;    PACKAGE_DEF ::=      package_spec;
;;;
;;;    package_spec =>      as_decl_s1       : DECL_S,     -- visible declarations
;;;                         as_decl_s2       : DECL_S;     -- private declarations
;;;    package_spec =>      lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;
;;;    DECL_S ::=           decl_s;
;;;
;;;    decl_s =>            as_list          : Seq Of DECL;
;;;    decl_s =>            lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- Syntax 7.1.C
;;;--  package_body ::=
;;;--     'package' 'body' simple_name 'is'
;;;--         declarative_part
;;;--    ['begin'
;;;--         sequence_of_statements
;;;--    ['exception'
;;;--        exception_handler {exception_handler}]]
;;;--     'end' [identifier]';'
;;;--
;;;
;;;
;;;    package_body =>      as_id            : ID,    -- always 'package_id'
;;;                         as_block_stub    : BLOCK_STUB;
;;;    package_body =>      lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;;;;;;;;
(def_ada_syntax package_spec_part
		;;;;;;;;;;;;;;;;;

	(pr_and 
	  (lambda(as)
	    (sc_diana dn_package_spec
		      as_decl_s1 
		      (sc_diana dn_decl_s
				as_list (first as))
		      as_decl_s2
		      (sc_diana dn_decl_s
				as_list (second as)))) 
	  (pr_repeat nil declarative_item)
	  (pr_or nil 
		 (pr_and ;cadr
		   (lambda(as)
		     (let* ((this_ctx **current_block**)
			    (home_ctx (diana_get this_ctx 'ct_is_enclosed_by)))
		       (diana_put home_ctx this_ctx 'ct_hidden_context)
;		       (diana_put this_ctx nil 'ct_is_enclosed_by)
		       (popcontext)
		     (second as)))
		   (pr_and
		     (lambda(as)
		       (pushcontext)	  ;make hidden context.
		       (first as))
		     symb_private)
		   (pr_repeat nil declarative_item))
;		    (pr_repeat nil  ; is this real?? I think not.
;			representation_specification))
		 nil)
	  symb_end))

;;;-- 8.  Visibility Rules
;;;-- ====================
;;;-- 8.4  Use Clauses
;;;
;;;-- Syntax 8.4
;;;--  use_clause ::= 'use' name {',' name} ';'
;;;--
;;;
;;;
;;;    NAME_S ::=           name_s;
;;;
;;;    name_s =>            as_list          : Seq Of NAME;
;;;    name_s =>            lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    use =>               as_list          : Seq Of NAME;
;;;    use =>               lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;
(def_ada_syntax use_clause
		;;;;;;;;;;
     (pr_and
       (lambda(as)
	 ;; The three steps in processing a use clause are.
	 ;; For each package specified.
	 ;; (1) get the named package.
	 ;; (2) get its blockcontext
	 ;; (3) add as a mixin to the current block_context
	 (do ((pckgs (filter_real_packages_and_bitch
		       (cons (find_name (second as) 'package) (third as)))
		     (cdr pckgs))
	      (mixins nil))
	     ((null pckgs) (install_mixins (reverse mixins)))
	   
	   (let* ((ctx (diana_get (find_selected (car pckgs)) 'sm_defn))
		  (mix (and ctx (diana_get ctx 'ct_named_context))))
	     (ct_push mix mixins)))
	 (sc_diana dn_use
		   as_list (cons (find_name (second as) 'package)
				 (third as))))
       symb_use
       (pr_restrict package name)
       (pr_repeat nil
		  (pr_and 
		    (lambda(as)(find_name (cadr as) 'package))
		    oper_comma 
		    (pr_restrict package name)))
       oper_semicolon
       )
  )

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun filter_real_packages_and_bitch (pkgs)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (mapcan
    #'(lambda (pkg)
	(cond ((and (not (consp pkg))
		    (null (diana_get (find_selected pkg) 'sm_defn)))
	       (semgripe 'obj_expected '"LIBRARY_UNIT or PACKAGE")
	       nil)
	      ((or (consp pkg)
		   (neq (diana_nodetype_get
			  (diana_get (find_selected pkg) 'sm_defn))
			'dn_package_id))
	       (semgripe 'only_packages_allowed_in_use_clauses)
	       nil)
	      (t (list pkg))))
    pkgs))

;;; add the specified mixins to the current context.
       ;;;;;;;;;;;;;;
(defun install_mixins (mixins)
       ;;;;;;;;;;;;;;

  (diana_put
    **current_block**		;add to the current context.
    (append
      (diana_get **current_block** 'ct_mixin_s)
      mixins)
    'ct_mixin_s))

;;;-- 9.  Tasks
;;;-- =========
;;;-- 9.1  Task Specifications and Task Bodies
;;;
;;;-- Syntax 9.1.A
;;;--  task_declaration ::= task_specification
;;;--  task_specification ::=
;;;--     'task' ['type'] identifier ['is'
;;;--         {entry_declaration}
;;;--         {representation_specification}
;;;--     'end' [identifier]]';'
;;;--
;;;
;;;
;;;                                          -- see 3.3 for task type declaration
;;;    TASK_DEF ::=         task_spec;
;;;
;;;    task_decl =>         as_id            : ID,    --always a var_id
;;;                         as_task_def      : TASK_DEF;
;;;    task_decl =>         lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    TYPE_SPEC ::=        task_spec;
;;;
;;;    task_spec =>         as_decl_s        : DECL_S;
;;;    task_spec =>         lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    task_spec =>         sm_body          : BLOCK_STUB_VOID, -- Void only
;;;                                                   -- in the presence
;;;                                                   -- of separate compilation.
;;;                                                   -- See the rationale.
;;;                         sm_address       : EXP_VOID,
;;;                         sm_storage_size  : EXP_VOID;
;;;
;;;    BLOCK_STUB_VOID ::=  block | stub | void;
;;;
;;;-- Syntax 9.1.B
;;;--  task_body ::=
;;;--     'task' 'body' identifier 'is'
;;;--        [declarative_part]
;;;--     'begin'
;;;--         sequence_of_statements
;;;--    ['exception'
;;;--        exception_handler {exception_handler}]
;;;--     'end' [identifier]';'
;;;--
;;;
;;;
;;;    task_body =>         as_id            : ID,    -- always 'task_body_id'
;;;                         as_block_stub    : BLOCK_STUB;
;;;    task_body =>         lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;
;;;    DEF_ID ::=           task_body_id;
;;;
;;;    task_body_id =>      lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    task_body_id =>      sm_type_spec     : TYPE_SPEC,
;;;                         sm_body          : BLOCK_STUB_VOID;
;;;
		;;;;;;;;;;;;;;
(def_ada_syntax task_spec_part
		;;;;;;;;;;;;;;
		
		(pr_and 
		  (lambda(as)
		    (sc_diana dn_task_spec
			      as_decl_s (append (first as)(second as))
			      sm_body nil))
;	    (pr_repeat nil pragma) ; this is probably wrong so whip it out.
		  (pr_repeat
		    nil
		    (pr_and
		      (lambda(as)
			(popcontext)
			(sc_diana dn_subprogram_decl
				  as_designator 
				  (add_name
				    (second as)
				    'entry
				    (let ((eid (sc_diana dn_entry_id
					      lx_symrep (second as)
					      sm_spec 
					      (sc_diana
						dn_entry
						as_dscrt_range_void 
						(cond 
						  ((first (third as))
						   (first (third as)))
						  (t (sc_diana dn_void)))  
						as_param_s (second (third as))))))
				      (diana_put eid eid 'sm_defn)
				      eid)
				    nil)
				  as_header (second (third as))
				  as_subprogram_def (sc_diana dn_void))
			)
		      
		      symb_entry
		      (pr_and
			(lambda(as)
			  (pushproccontext)
			  (first as))
			lex_ident)
		      (pr_or nil 
			     (pr_and cadr				
				     oper_lparen
				     (pr_or nil
					    (pr_and2c 
					      (lambda(as)
						(list nil 
						      (first as)))
					      lex_ident oper_colon
					      proc_param_decl_s
					      oper_rparen
					      )
					    (pr_and2c 
					      (lambda(as)
						(list nil 
						      (first as)))
					      lex_ident oper_comma
					      proc_param_decl_s
					      oper_rparen
					      )
					    (pr_and 
					      (lambda(as)
						(list (first as)(third as)))
					      index_range
					      oper_rparen
					      (pr_or nil 
						     (pr_and 
						       (lambda(as)
							 (second as))
						       oper_lparen
						       proc_param_decl_s
						       oper_rparen
						       )
						     nil))
					    
					    )
				     (pr_and 
				       (lambda(as)
					 nil)
				       oper_semicolon
				       ))
			     (pr_and
			       (lambda(as) nil)
			       oper_semicolon))))
		  (pr_and (lambda(as) nil)
			  
			  ;;   (pr_repeat nil representation_specification)
			  symb_end)))
    
		;;;;;;;;;;;;;;;;;
(def_ada_syntax proc_param_decl_s
		;;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (cons (first as)(second as))) ; make into a list.
	  proc_param_decl
	  (pr_repeat nil
		     (pr_and cadr oper_semicolon proc_param_decl))))
    
;;;-- 9.5  Entries and Accept Statements
;;;
;;;-- Syntax 9.5.A
;;;--  entry_declaration ::=
;;;--     'entry' identifier ['('discrete_range')'] [formal_part]';'
;;;--
;;;
;;;
;;;
;;;    HEADER ::=           entry;
;;;    DSCRT_RANGE_VOID ::= DSCRT_RANGE | void;
;;;
;;;    entry =>             as_dscrt_range_void       : DSCRT_RANGE_VOID,
;;;                         as_param_s       : PARAM_S;
;;;    entry =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;
;;;    DEF_ID ::=           entry_id;
;;;
;;;    entry_id =>          lx_srcpos        : source_position,
;;;                         lx_comments      : comments,
;;;                         lx_symrep        : symbol_rep;
;;;    entry_id =>          sm_spec          : HEADER,
;;;                         sm_address       : EXP_VOID;
;;;
;;;-- Syntax 9.5.C
;;;--  accept_statement ::=
;;;--     'accept' name [formal_part] ['do'
;;;--         sequence_of_statements
;;;--     'end' [identifier]]';'
;;;--
;;;
;;;
;;;    STM ::=              accept;
;;;
;;;    accept =>            as_name          : NAME,
;;;                         as_param_s       : PARAM_S,
;;;                         as_stm_s         : STM_S;
;;;    accept =>            lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;;;;;;;
(def_ada_syntax accept_statement
		;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as);(break  accept_statement)
	    (popcontext)
   	    (matching_ident (diana_get (car (second as)) 'lx_symrep)
			    (fourth (fourth as)))
#|	    (compare parameter lists for sameness
	       (second (third as))
	       (diana_get (diana_get (car (second as)) 'sm_spec) 'as_param_s))|#
	    (diana_put (diana_get (car (second as))  'sm_spec)
		       (second (third as))
		       'as_param_s)
	    (sc_diana dn_accept
		      as_name
		      (let ((esn (sc_diana dn_used_name_id
					lx_symrep
					(diana_get (car (second as)) 'lx_symrep)
					sm_defn (car (second as)))))
			(cond ((null (first (third as))) esn)
			      (t (sc_diana dn_indexed
					   as_name esn
					   as_exp_s
					   (list (first (third as)))))))
		      as_param_s (second (third as))
		      as_stm_s (second (fourth as))))
	  (pr_and
	    (lambda (as)
	      (pushcontext)
	      (first as))
	    symb_accept)
	  (pr_restrict entry name)
	  (pr_or nil accept_statement_naka nil)
	  (pr_or
	    nil
	    (pr_and nil
		    symb_do
		    sequence_of_statements
		    symb_end
		    (pr_or nil lex_ident nil))
	    nil)
	  oper_semicolon))

    
		;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax accept_statement_naka
		;;;;;;;;;;;;;;;;;;;;;

	(pr_or nil 
	       (pr_and cadr				
		       oper_lparen
		       (pr_or nil
			      (pr_and2c 
				(lambda(as)
				  (list nil 
					(first as)))
				lex_ident oper_colon
				proc_param_decl_s
				oper_rparen
				)
			      (pr_and2c 
				(lambda(as)
				  (list nil 
					(first as)))
				lex_ident oper_comma
				proc_param_decl_s
				oper_rparen
				)
			      (pr_and 
				(lambda(as)
				  (list (first as)(third as)))
				expression
				oper_rparen
				(pr_or nil 
				       (pr_and 
					 (lambda(as)
					   (second as))
					 oper_lparen
					 proc_param_decl_s
					 oper_rparen
					 )
				       nil))
			      
			      )
		       )
	       nil))

;;;-- 9.6  Delay Statements, Duration and Time
;;;
;;;-- Syntax 9.6
;;;--  delay_statement ::= 'delay' simple_expression';'
;;;--
;;;
;;;
;;;    STM ::=              delay;
;;;
;;;    delay =>             as_exp           : EXP;
;;;    delay =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;;;;;;
(def_ada_syntax delay_statement
		;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (sc_diana dn_delay
		      as_exp (second as)))
	  symb_delay 
	  simple_expression 
	  oper_semicolon))

;;;-- 9.7  Select Statements
;;;
;;;-- Syntax 9.7
;;;--  select_statement ::= selective_wait
;;;--   | conditional_entry_call | timed_entry_call
;;;--
;;;
;;;                         -- see below
;;;
;;;-- 9.7.1  Selective Wait Statements
;;;
;;;-- Syntax 9.7.1.A
;;;--  selective_wait ::=
;;;--     'select'
;;;--        ['when' condition '=>']
;;;--             select_alternative
;;;--    {'or'['when' condition '=>']
;;;--             select_alternative}
;;;--    ['else'
;;;--             sequence_of_statements]
;;;--     'end' 'select' ';'
;;;--
;;;
;;;
;;;    STM ::=              select;
;;;
;;;    select =>            as_select_clause_s        : SELECT_CLAUSE_S,
;;;                         as_stm_s         : STM_S;
;;;    select =>            lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;
;;;    SELECT_CLAUSE_S ::=  select_clause_s;
;;;    select_clause_s =>   as_list          : Seq Of SELECT_CLAUSE;
;;;    select_clause_s =>   lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    SELECT_CLAUSE ::=    select_clause | pragma;   -- pragma allowed before
;;;                                                   -- 'when'
;;;
;;;    select_clause =>     as_exp_void      : EXP_VOID,
;;;                         as_stm_s         : STM_S;
;;;    select_clause =>     lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- Syntax 9.7.1.B
;;;--  select_alternative ::=
;;;--     accept_statement [sequence_of_statements]
;;;--   | delay_statement  [sequence_of_statements]
;;;--   | 'terminate' ';'
;;;--
;;;
;;;
;;;    STM ::=              terminate;
;;;
;;;    terminate =>         lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- 9.7.2  Conditional Entry Calls
;;;
;;;-- Syntax 9.7.2
;;;--  conditional_entry_call ::=
;;;--     'select'
;;;--         entry_call [sequence_of_statements]
;;;--     'else'
;;;--         sequence_of_statements
;;;--     'end' 'select' ';'
;;;--
;;;
;;;
;;;    STM ::=              cond_entry;
;;;
;;;    cond_entry =>        as_stm_s1        : STM_S,
;;;                         as_stm_s2        : STM_S;
;;;    cond_entry =>        lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- 9.7.3  Timed Entry Calls
;;;
;;;-- Syntax 9.7.3
;;;--  timed_entry_call ::=
;;;--     'select'
;;;--         entry_call [sequence_of_statements]
;;;--     'or'
;;;--         delay_statement [sequence_of_statements]
;;;--     'end' 'select' ';'
;;;--
;;;
;;;
;;;    STM ::=              timed_entry;
;;;
;;;    timed_entry =>       as_stm_s1        : STM_S,
;;;                         as_stm_s2        : STM_S;
;;;    timed_entry =>       lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;

(def_record_type selective_wait *selwt* (clauses stms))

		;;;;;;;;;;;;;;;;
(def_ada_syntax select_statement
		;;;;;;;;;;;;;;;;

	(pr_and cadr
		symb_select
		(pr_or nil 
		       (pr_and (lambda(as)
				 (sc_diana dn_select
					   as_select_clause_s
					   (selective_wait%clauses (first as))
					   as_stm_s
					   (selective_wait%stms (first as))))
			       select_statement_naka)
		       (pr_and 
			 (lambda(as)
			   (cond	  ; is it a cond_entry or a timed_entry?
			     ((eq (first (fourth as)) 'symb_or); timed entry call 
			      (sc_diana dn_timed_entry
					as_stm_s1 (list (first as)(second as)
							(third as))	  ; ??
					as_stm_s2 (second (fourth as))))
			     (t		  
			      (sc_diana
				dn_cond_entry
				as_stm_s1
				(let ((call (second as)))
				  (diana_put
				    call
				    (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)
				  (normalize_params
				    (dissambiguate_function_reference
				      call))
				  (cond ((third as)
					 (diana_put
					   (third as)
					   (cons call
						 (diana_get (third as) 'as_list))
					   'as_list)
					 (third as))
					(t (sc_diana dn_stm_s
						     as_list (list call)))))
				  as_stm_s2 (second (fourth as))))))	  ;
			 name;(pr_restrict entry name)
			 procedure_or_entry_call
			 (pr_or nil sequence_of_statements nil)
			 (pr_or nil 
				(pr_and nil 
					symb_else
					sequence_of_statements)
				(pr_and nil 
					symb_or
					delay_statement
					(pr_or nil sequence_of_statements nil)))))
		symb_end
		symb_select
		oper_semicolon))
    
;;;selective wait.
		;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax select_statement_naka
		;;;;;;;;;;;;;;;;;;;;;

	(pr_and (lambda(as)
		  (let* ((this_alt
			   (sc_diana dn_select_clause
			      as_exp_void
			      (cond ((null (first as))(sc_diana dn_void))
				    (t (first as)))
			      as_stm_s
			      (sc_diana dn_stm_s
				 as_list (second as)))))
		    (selective_wait
			(cons this_alt
			      (cond
				((eq (car (third as)) 'symb_else) nil)
				(t (selective_wait%clauses
				     (second (third as))))))
			(cond
			  ((eq (car (third as)) 'symb_else)(second (third as)))
			  (t (selective_wait%stms (second (third as))))))))
		    
		(pr_or nil 
		       (pr_and cadr 
			       symb_when 
			       expression #+later (pr_restrict boolean expression) 
			       oper_goes)
		       nil)
		(pr_or nil 
		       (pr_and 
			 (lambda(as)
			   (cons (first as)
				 (and
				   (second as)
				   (diana_get (second as) 'as_list))))
			 (pr_or nil 
				accept_statement
				delay_statement)
			 (pr_or nil sequence_of_statements nil))
		       (pr_and 
			 (lambda(as)
			   (list (sc_diana dn_terminate)))
			 symb_terminate 
			 oper_semicolon))
		(pr_or nil 
		       (pr_and nil 
			       symb_else
			       sequence_of_statements)
		       (pr_and nil 
			       symb_or 
			       select_statement_naka)
		       nil)))
    
;;;-- 9.10  Abort Statements
;;;
;;;-- Syntax 9.10
;;;--  abort_statement ::= 'abort' name {',' name} ';'
;;;--
;;;
;;;
;;;    STM ::=              abort;
;;;
;;;    abort =>             as_name_s        : NAME_S;
;;;    abort =>             lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;;;;;;
(def_ada_syntax abort_statement
		;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (sc_diana dn_abort
		      as_name_s (cons (find_name (second as) nil) (third as))))
	  symb_abort
	  (pr_restrict task name)
	  (pr_repeat nil 
		     (pr_and 
		       (lambda(as)(find_name (cadr as) nil))
		       oper_comma  
		       (pr_restrict task name)))
	  oper_semicolon))