;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;  $Header: /ct/interp/adas130.l,v 1.36 84/12/26 16:43:00 penny Exp $
;;;
;;;  


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


;;;-- 12.  Generic Program Units
;;;-- ==========================
;;;-- 12.1  Generic Declarations
;;;
;;;-- Syntax 12.1.A
;;;--  generic_declaration ::=
;;;--     generic_part subprogram_specification';'
;;;--   | generic_part package_specification';'
;;;--
;;;
;;;
;;;    GENERIC_HEADER ::=   procedure | function | package_spec;
;;;
;;;    generic =>           as_id            : ID,    -- 'generic_id'
;;;                         as_generic_param_s        : GENERIC_PARAM_S,
;;;                         as_generic_header         : GENERIC_HEADER;
;;;    generic =>           lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    DEF_ID ::=           generic_id;
;;;
;;;    generic_id =>        lx_symrep        : symbol_rep,
;;;                         lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    generic_id =>        sm_generic_param_s        : GENERIC_PARAM_S,
;;;                         sm_spec          : GENERIC_HEADER,
;;;                         sm_body          : BLOCK_STUB_VOID;
;;;
;;;-- Syntax 12.1.B
;;;--  generic_part ::= 'generic' {generic_parameter_declaration}
;;;--
;;;
;;;
;;;    GENERIC_PARAM_S ::=  generic_param_s;
;;;
;;;    generic_param_s =>   as_list          : Seq Of GENERIC_PARAM;
;;;    generic_param_s =>   lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- Syntax 12.1.C
;;;--  generic_parameter_declaration ::=
;;;--     identifier_list : ['in'['out']] type_mark [':=' expression]
;;;--   | 'type' identifier 'is' generic_type_definition';'
;;;--   | 'type' identifier [discriminant_part] 'is'
;;;--                                     private_type_definition';'
;;;--   | 'with' subprogram_specification ['is' name]';'
;;;--   | 'with' subprogram_specification 'is' '<>' ';'
;;;--
;;;
;;;
;;;    GENERIC_PARAM ::=    in | in_out | subprogram_decl | type | pragma;
;;;                         -- pragma allowed as declaration
;;;    SUBPROGRAM_DEF ::=   FORMAL_SUBPROG_DEF;
;;;    FORMAL_SUBPROG_DEF ::=                NAME | box | no_default;
;;;
;;;    box =>               lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    no_default =>        lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;-- Syntax 12.1.D
;;;--  generic_type_definition ::=
;;;--     '(' '<>' ')' | 'range' '<>' | 'delta' '<>' | 'digits' '<>'
;;;--   | array_type_definition       | access_type_definition
;;;--
;;;
;;;
;;;    TYPE_SPEC ::=        FORMAL_TYPE_SPEC;
;;;    FORMAL_TYPE_SPEC ::= formal_dscrt | formal_fixed
;;;                         | formal_float | formal_integer;
;;;
;;;    formal_dscrt =>      lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    formal_fixed =>      lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    formal_float =>      lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    formal_integer =>    lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
		;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax generic_specification
		;;;;;;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (let ((this_header (sc_diana dn_generic_param_s
					 as_list (second as)))
		  (this_context **current_block**))
	      (popcontext)		  ;out of generic unit context.
;	      (popcontext)		  ;out of parameters context.
;	      (break in-generic_specification)
	      (sc_diana dn_generic
			as_id
			(add_name
			  (generic_decl%generic_name (third as))
			  'generic_unit
			  (sc_diana dn_generic_id
				  ct_named_context this_context
				  lx_symrep (generic_decl%generic_name (third as))
				  sm_generic_param_s this_header
				  sm_spec (generic_decl%generic_header (third as))
				  sm_body (generic_decl%generic_block (third as)))
			  nil)
			as_generic_param_s this_header
			as_generic_header
			(generic_decl%generic_header (third as)))))
	  (pr_and
	    (lambda(as)
	      (pushproccontext)	  ;context for generic_unit
	      (ct_push (gensym)  *current_generic_nestitude*)
	      (first as))
	    symb_generic)
	  (pr_repeat nil generic_formal_parameter)
	  (pr_or nil 
		 (pr_and
		   (lambda(as)
		     (ct_pop *returntypestack*)
		     (generic_decl
		       (second as)
		       (sc_diana dn_stub)
		       (third as)))
		   symb_procedure
		   (pr_and
		     (lambda(as)
		       (ct_push nil *returntypestack*)
		       ;(pushproccontext)
		       (first as))
		     lex_ident)
		   (pr_or nil proc_formal_part nil))
		 (pr_and
		   (lambda(as)
		     (generic_decl
		       (second as)
		       (sc_diana dn_stub)
		       (progn (diana_put (third as) (fifth as) 'as_name_void)
			      (third as))))
		   symb_function
		   (pr_and
		     (lambda(as)
		       ;(pushproccontext)
		       `(lex_ident ,(cadr (first as))))
		     (pr_or nil lex_ident lex_string))
		   (pr_or nil funct_formal_part nil)
		   symb_return
		   subtype_indication)
		 (pr_and
		   (lambda(as)
		     (ct_pop *returntypestack*)
		     (matching_ident (second as)(fifth as))	  ;see below . . .
		     (generic_decl (second as) nil (fourth as)))
		   (pr_and
		     (lambda (as)
		       (ct_push 'package *returntypestack*)
		       (first as))
		     symb_package)
		   (pr_and
		     (lambda(as)
		       ;(pushcontext)
		       (setq *pnl* (1- *pnl*))	  ;step back proc context
		       (diana_put **current_block**
				  (1- (diana_get **current_block** 'ct_pnl))
				  'ct_pnl)
		       (first as))
		     lex_ident)
		   symb_is
		   package_spec_part
		   (pr_or nil lex_ident nil)))))  ;if specified, must match.
    
		;;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax generic_formal_parameter
		;;;;;;;;;;;;;;;;;;;;;;;;

	(pr_or nil 
	       (pr_and
		 (lambda(as)
		   (let* ((id_s (cons (first as)(second as))))
		     (ct_selectq
		       (first (fourth as))
		       (dn_in
			 (sc_diana dn_in
				   as_id_s
				   (mapcar
				     #'(lambda(inid)
					 (add_name
					   inid
					   'formal_parameter
					   (sc_diana dn_in_id
						     lx_symrep inid
						     sm_obj_type
						     (subtype_ind_init%sub_ind
						       (second (fourth as))))
					   nil))
				     id_s)
				   as_name (subtype_ind_init%sub_ind
						       (second (fourth as)))))
		       (dn_out
			 (sc_diana dn_out
				   as_id_s
				   (mapcar
				     #'(lambda(inid)
					 (add_name
					   inid
					   'formal_parameter
					   (sc_diana dn_out_id
						     lx_symrep inid
						     sm_obj_type
						     (second (fourth as)))
					   nil))
				     id_s)
				   as_name (second (fourth as))))
		       (dn_in_out
			 (sc_diana dn_in_out
				   as_id_s
				   (mapcar
				     #'(lambda(inid)
					 (add_name
					   inid
					   'formal_parameter
					   (sc_diana dn_in_out_id
						     lx_symrep inid
						     sm_obj_type
						     (second (fourth as)))
					   nil))
				     id_s)
				   as_name (second (fourth as)))))))
		 lex_ident
		 (pr_repeat nil (pr_and cadr oper_comma lex_ident))
		 oper_colon
		 (pr_or nil
			(pr_and cadr
				symb_in
				(pr_or nil
				       (pr_and
					 (lambda(as)
					   (cond ((and
						    (first as)
						    (null (extract_basetype
							    (second as))))
						  (semgripe 'incomplete_type)))
					   (list 'dn_in_out (second as)))
					 symb_out
					 subtype_indication)
				       (pr_and
					 (lambda(as)
					   (cond
					     ((and
						(subtype_ind_init%sub_ind
						  (first as))
						(null (extract_basetype
							(subtype_ind_init%sub_ind
							  (first as)))))
					      (semgripe 'incomplete_type)))
					   (list 'dn_in (first as)))
					 subtype_indication_init)))
			(pr_and
			  (lambda(as)
			    (cond
			      ((and
				 (subtype_ind_init%sub_ind
				   (first as))
				 (null (extract_basetype
					 (subtype_ind_init%sub_ind
					   (first as)))))
			       (semgripe 'incomplete_type)))
			    (list 'dn_in (first as)))
			  subtype_indication_init))
		 oper_semicolon)
	       (pr_and cadr
		       symb_with
		       (pr_or nil
			      (pr_and
				(lambda(as)
				  (diana_put (second as)
					     (third as)
					     'sm_spec)
				  (diana_put (second as)
					     (fourth as)
					     'sm_body)
				  (sc_diana dn_subprogram_decl
					    as_designator (second as)
					    as_header (third as)
					    as_subprogram_def (fourth as)))
				symb_procedure
				(pr_and 
				  (lambda(as)
				    (let*
				      ((this (add_name
					       (first as) ; name
					       'procedure
					       (sc_diana dn_proc_id
							 lx_symrep (first as)
							 sm_spec nil
							 sm_body (sc_diana dn_stub)
							 sm_location nil
							 sm_stub nil
							 sm_first nil)
					       nil)))
				      this));we always return the current one
				  lex_ident)
				(pr_or nil proc_formal_part nil)
				(pr_or
				  nil
				  (pr_and
				    (lambda(as)
				      (cond
					((second as)(second as))
					(t (sc_diana dn_no_default))))
				    symb_is
				    (pr_or nil 
					   (pr_and
					     (lambda(as)
					       (sc_diana dn_box))
					     oper_ltgt)
					   (pr_restrict procedure name)))
				  nil))
			      (pr_and
				(lambda(as)
				  (ct_pop *returntypestack*)
				  (let ((this (second as))
					(spec (cond ((third as)
						     (third as))
						    (t
						     (sc_diana dn_function)))))
				    (diana_put this
					       spec
					       'sm_spec)
				    (diana_put spec
					       (fifth as)
					       'as_name_void)
				    (diana_put this
					       (sixth as)
					       'sm_body)
				    (sc_diana dn_subprogram_decl
					      as_designator (second as)
					      as_header spec
					      as_subprogram_def (sixth as))))
				symb_function
				(pr_and
				  (lambda(as)
				    (rplacd (first as)
					    (list (uplowlist (cadr (first as)))))
				    (let*
				      ((this (add_name
					       `(lex_ident ,(cadr (first as)))
					       'function
					       (sc_diana dn_function_id
							 lx_symrep (first as)
							 sm_body (sc_diana dn_stub) )
					       nil)))
				      this));we always return the current one!
				  (pr_or
				    nil
				    (pr_and
				      (lambda(as)
					(cond
					  ((not (user_definable_function_p as))
					   (semgripe 'not_user_definable_operator
						     (implode (cadr (first as))))))
					(first as))
				      lex_string)
				    lex_ident))
				(pr_or nil funct_formal_part nil)
				symb_return
				(pr_and
				  (lambda (as)
				    (ct_push (first as) *returntypestack*)
				    (first as))
				  subtype_indication)
				(pr_or nil 
				       (pr_and
					 (lambda(as)
					   (setq *function_name_only* nil)
					   (cond
					     ((second as)(second as))
					     (t (sc_diana dn_no_default))))
					 (pr_and
					   (lambda(as)
					     (setq *function_name_only* t)
					     (first as))
					   symb_is)
					 (pr_or nil 
						(pr_and
						  (lambda(as)
						    (sc_diana dn_box))
						  oper_ltgt)
						(pr_restrict function name)))
				       nil)))
		       oper_semicolon)
	       (pr_and
		 (lambda(as)
		   (let ((typid (sc_diana dn_type_id
			       lx_symrep (second as)
			       sm_type_spec (third as))))
		   (add_name
		     (second as)
		     'generic_formal_parameter
		     typid
		     nil)
		   (sc_diana dn_type
			     as_id (add_name
				     (second as)
				     'type
				     typid
				     nil)
			     as_dscrmt_var_s nil
			     as_type_spec (third as))))
		 symb_type
		 lex_ident
		 (pr_or nil
			(pr_and
			  cadr
			  symb_is
			  (pr_or nil 
				 (pr_and
				   (lambda(as)(sc_diana dn_formal_dscrt))
				   oper_lparen
				   oper_ltgt
				   oper_rparen)
				 (pr_and
				   (lambda(as)
				     (sc_diana dn_formal_integer))
				   symb_range
				   oper_ltgt)
				 (pr_and
				   (lambda(as)
				     (sc_diana dn_formal_float))
				   symb_digits
				   oper_ltgt)
				 (pr_and
				   (lambda(as)
				     (sc_diana dn_formal_fixed))
				   symb_delta
				   oper_ltgt)
				 (pr_and
				   (lambda(as)
				     (sc_diana
				       dn_access
				       as_constrained
				       (cadr as)))
				   symb_access
				   subtype_indication)
				 array_type_definition
				 (pr_and
				   (lambda(as)
				     (cond
				       ((null (first as))
					(sc_diana dn_private))
				       (t
					(sc_diana dn_l_private))))
				   (pr_or nil
					  symb_limited
					  nil)
				   symb_private)))
			(pr_and
			  (lambda(as)
			    (cond
			      ((null (third as))
			       (sc_diana dn_private
					 sm_discriminants (first as)))
			      (t
			       (sc_diana dn_l_private
					 sm_discriminants (first as)))))
			  discriminant_part
			  symb_is
			  (pr_or nil symb_limited nil)
			  symb_private))
		 oper_semicolon)))
    
;;;-- 12.3  Generic Instantiation
;;;
;;;-- Syntax 12.3.A
;;;--  generic_subprogram_instantiation ::=
;;;--     'procedure' identifier 'is' generic_instantiation';'
;;;--   | 'function' designator 'is' generic_instantiation';'
;;;--
;;;
;;;
;;;    SUBPROGRAM_DEF ::=   instantiation;
;;;
;;;-- Syntax 12.3.B
;;;--  generic_package_instantiation ::=
;;;--     'package' identifier 'is' generic_instantiation ';'
;;;--
;;;
;;;
;;;    PACKAGE_DEF ::=      instantiation;
;;;
;;;-- Syntax 12.3.C
;;;--  generic_instantiation ::=
;;;--     'new' name ['('generic_association
;;;--                        {',' generic_association } ')' ]
;;;--
;;;
;;;
;;;    GENERIC_ASSOC_S ::=  generic_assoc_s;
;;;
;;;    generic_assoc_s =>   as_list          : Seq Of GENERIC_ASSOC;
;;;    generic_assoc_s =>   lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;
;;;    DECL_EXP ::=         DECL | EXP;
;;;    DECL_EXP_S ::=       decl_exp_s;
;;;
;;;    decl_exp_s =>        as_list          : Seq Of DECL_EXP;
;;;
;;;    instantiation =>     as_name          : NAME,
;;;                         as_generic_assoc_s        : GENERIC_ASSOC_S;
;;;    instantiation =>     lx_srcpos        : source_position,
;;;                         lx_comments      : comments;
;;;    instantiation =>     sm_decl_exp_s    : DECL_EXP_S;
;;;
;;;-- Syntax 12.3.D
;;;--  generic_association ::=
;;;--     [generic_formal_parameter '=>'] generic_actual_parameter
;;;--  generic_formal_parameter ::=
;;;--     simple_name | operator_symbol
;;;--
;;;
;;;
;;;    GENERIC_ASSOC ::=    assoc;
;;;
;;;-- Syntax 12.3.E
;;;--  generic_actual_parameter ::=
;;;--     expression | name | subtype_indication
;;;--
;;;
;;;
;;;    GENERIC_ASSOC ::=    ACTUAL;
;;;    ACTUAL ::=           CONSTRAINED;
;;;

       ;;;;;;;;;;;;;;;;;;
(defun extract_generic_id (gen_units)
       ;;;;;;;;;;;;;;;;;;

  (let ((units nil))
    (mapc
      #'(lambda (gu)
	  (cond (gu
		 (let* ((fs (find_selected gu))
			(gu1 (and fs (diana_get fs 'sm_defn))))
		   (cond
		     ((or (memq gu1 units)(memq gu units)))
		     (t
		      (cond
			((eq (diana_nodetype_get gu) 'dn_generic_id)
			 (ct_push gu units))
			((and gu1
			      (eq (diana_nodetype_get gu1) 'dn_generic_id))
			 (ct_push gu1 units))
			((eq (diana_nodetype_get gu) 'dn_selected)
			 (let ((g (diana_get
				    (find_selected gu)
				    'sm_defn)))
			   (cond ((eq (diana_nodetype_get g) 'dn_generic_id)
				  (ct_push g units)
				  ))))
			((and (diana_get gu 'sm_first)
			      (eq (diana_nodetype_get
				    (diana_get gu 'sm_first))
				  'dn_generic_id))
			 (ct_push (diana_get gu 'sm_first) units))
			((and gu1
			      (diana_get gu1 'sm_first)
			      (eq (diana_nodetype_get
				    (diana_get gu1 'sm_first))
				  'dn_generic_id))
			 (ct_push (diana_get gu1 'sm_first) units)))))))))
      gen_units)
    (car units)))

		;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax generic_instantiation
		;;;;;;;;;;;;;;;;;;;;;

	(pr_and
	  (lambda(as)
	    (popcontext)
	    (let* ((gen_units
		    ;(ada_declared (second as) nil
		    ;		  '(library_unit generic_unit) t)
		    (list (second as)))
		   (gen_unit (extract_generic_id gen_units))
		  (gen_pars (third as)))
	    (sc_diana dn_instantiation
		      as_name gen_unit
		      as_generic_assoc_s gen_pars
		      sm_decl_s
		      (normalize_generic_parameters
			gen_unit gen_pars))))
	  symb_new
	  (pr_and
	    (lambda (as)
	      (savecontext)
	      (new_block)
	      (let* ((thingy (extract_generic_id
			       (cond ((consp (first as)) (first as))
				     (t (list (first as))))))
		     (fs (find_selected thingy))
		     (smdef
		       (and fs (diana_get
				 fs
				 'sm_defn)))
		     (ctn (and smdef (diana_get smdef 'ct_named_context)))
		     (ct (and ctn (list ctn))))
		(diana_put
		  **current_block**
		  ct
		  'ct_mixin_s)
		thingy))
	    (pr_or nil
		   ;(pr_restrict generic_unit name)
		   name;(pr_restrict library_unit name)
		   )) ;name ;lex_ident  ;(pr_restrict generic_unit name)++
	  (pr_or nil
		 (pr_and
		   cadr
		   oper_lparen
		   generic_instantiation_naka
		   oper_rparen)
		 nil)))
    
		;;;;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax generic_instantiation_naka
		;;;;;;;;;;;;;;;;;;;;;;;;;;

	(pr_or nil
	       generic_instantiation_cdr
	       (pr_and
		 (lambda(as)
		   (cons
		     
		     (cond
		       ((null (second as))(first as))
		       (t (sc_diana dn_constrained
				    as_name (first as)
				    as_constraint (second as))))
		     (third as)))
		 expression
		 (pr_or nil constraint nil)
		 (pr_or nil
			(pr_and cadr
				oper_comma
				generic_instantiation_naka)
			nil))
	       ))
    
		;;;;;;;;;;;;;;;;;;;;;;;;;
(def_ada_syntax generic_instantiation_cdr
		;;;;;;;;;;;;;;;;;;;;;;;;;

	(pr_and2c
	  (lambda(as)
	    (cons
	      (sc_diana dn_assoc
			as_designator (first as)
			as_actual 
			(cond ((null (fourth as))(third as))
			      (t (sc_diana dn_constrained
					   as_name (third as)
					   as_constraint (fourth as)))))
	      (fifth as)))
	  lex_ident oper_goes
	  (pr_and
	    (lambda (as)
	      (first as))
	    lex_ident ) ;(pr_restrict generic_formal_parameter lex_ident)
	  oper_goes
	  expression
	  (pr_or nil constraint nil)
	  (pr_or nil
		 (pr_and cadr
			 oper_comma
			 generic_instantiation_cdr)
		 nil)))