;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; $Header: /ct/interp/incd.l,v 1.68 84/12/04 18:54:13 penny Exp $
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                              incd                                ;;;
;;; Paul Robertson                                      May-31-83    ;;;
;;;                                                                  ;;;
;;;                                                                  ;;;
;;; 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:                                             ;;;
;;;   Foderaro and Sklower, The FRANZ LISP Manual, September 1981.   ;;;
;;;   Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981.   ;;;
;;;   Charniak et al., 1980.  Artificial Intelligence Programming.   ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;                                                                  ;;;
;;;	        ASSUMES CT_LOAD AND SUITABLE FILEMAP                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(eval-when (compile load eval) (ct_load 'charmac)) ;CT char set extensions.

(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 'pser))       ;The Parser Driver

(eval-when (compile load eval) (ct_load 'lana))       ;The lexical Anal.

(eval-when (compile load eval) (ct_load 'sema))       ;The semantic support

(eval-when (compile load eval) (ct_load 'eror))       ;The error handlers

(eval-when (compile load eval) (ct_load 'adas))       ;The Ada Network

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
(declare (special *incremental_diana* *fe_timing*))
(declare (ct_includef 'intrpdcl))
(eval-when (compile load eval) (ct_load 'ferec))	; get the macros etc.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros -- 

;;; copied from fe_infc

;;;  This will perform the initialization of the 
;;;  interpreter environment, This should only be
;;;  invoked once if separate compilation is taking
;;;  place


       ;;;;;;;;;;;;;;;;;
(defun create_time_stamp ()
       ;;;;;;;;;;;;;;;;;
  (multiple-value-bind
    (a b c d e f g)
      (time:get-time)
    (plus (times a (fix 1e2))
	  (times b (fix 1e4))
	  (times c (fix 1e6))
	  (times d (fix 1e8))
	  (times e (fix 1e10))
	  (times f (fix 1e12)))))

       ;;;;;;;;;;;;;;;;;;;;;;;;
(defun diana_node_integer_array()
       ;;;;;;;;;;;;;;;;;;;;;;;;
  (do ((i *diana_nodetypes* (cdr i))
       (n 0 (1+ n))
       (r (make-array (length *diana_nodetypes*))))
      ((null i) (setq *index_diana_nodes* r))
    (putprop (car i) n 'index_node)
    (aset (car i) r n))
  )

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun incremental_build_diana_init()
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (setq			; initialize all the specials!!
        *time_stamp* (create_time_stamp)
	*disc_not_allowed* nil
	*disc_list* nil
	*disc_used* nil
	*in_record* nil
	*function_name_only* nil
	*infrontend* t
	*debugdriver* nil
	*debugscheduler* nil
	*debugparser* nil
        *not_inside_debug_ta* t
	*range_checking* t
        *incremental_diana* nil
	*current_generic_nestitude* nil
	*generic_nestitude_stack* nil
	*return_stmt_stack* nil
        *in_attribute_value* nil
	*exception_handler_stack* nil
	*named_stm_stack* nil
	*exception_name* nil
	*exception_reason* nil
	*current_non_terminal* nil
	*symbolstack* nil
	*original_context* nil
	*name_communication* nil
	*seen_assistance_1*    nil
	*seen_assistance_2*    nil
	*seen_assistance_3*    nil
	*pnl*	0		; The procedure nesting level.
	*bnl*   0		; The Block nesting level.
	*path* "wazzoo"         ; sets the path for the wazzoo
	la_comments nil
	*charcount* 0
	*pcharcount* 0
	*ppcharcount* 0
	la_plinpos 0
	la_psrcpos 0
	la_pplinpos 0
	la_ppsrcpos 0
	la_srcpos 0
	la_linpos 0
	*srcposbeg* 0
	*linposbeg* 0
	*preparsecc* 0
	*postparsecc* 0
	res     nil
	la_this_symbols_pos 0
	*identstack* nil	; the stack used for comparing tags.
	*returntypestack* nil   ; stack of func return types
	*goto_count* 0
	*awaiting_parameter_normalization* nil
	*awaiting_aggregate_normalization* nil
	*awaiting_aggregate_disambiguation* nil
	*awaiting_deferred_value* nil
	*awaiting_disambiguation* nil
	*awaiting_incomplete_type* nil
	*awaiting_label_fixup* nil
	*produce_listing* t
	*tracedfunctions* nil	; a list of functions being traced.
	*class_restriction* nil
	*no_function* nil	; if t, don't allow a function call.
	*eof_count* 0		; How many times has the end of file been
				; read?
	*parse_errors* 0	; how many syntax errors were there?
	*semantic_errors* 0	; how many semantic errors were there?
	*error_status* 0	; how many semantic errors were there?
	**text_file_list** (list nil nil)

				;; list of the text opened by user
        **text_file_num**  3    ; next file descriptor
	                        ; the first position will be reserved for 
	                        ; the default standard input and output
        **standard_input** 1
        **default_input** 1
	**standard_output** 2
	**default_output** 2
	**sequen_file_list** nil ; list of the sequen files opened
	                                    ; by user
        **sequen_file_num**  1   ; next file descriptor
	**direct_file_list** nil ; list of the direct files opened
	                                    ; by user
        **direct_file_num**  1   ; next file descriptor

	*textio_temp_file_list*  nil
	*seqio_temp_file_list*   nil
	*dirio_temp_file_list*   nil
	*io_get_integer* nil
	*io_get_float* nil
	*io_get_fixed* nil
	*io_get_enum* nil
	
    )
    (cond
	((status feature fe_initialized)
	 (setq *diana_internp* nil))	; initialization already done!
					;turn off intern gensym
	(t				     ; Initialize the code
	    (sstatus feature fe_initialized)
	    (setq *diana_internp* t)	; turn on intern gensym
	    (la_init)			; initialize the lexical analyser.
	    (diana_node_integer_array)
	    (initialize_nonterminals)
	    (init_syntax)		; initialise the syntax network.
	    (init_ssemantics)))		; initialize the error handlers.
    (setq **current_block** **standard_env**)
    (setq **current_block** 
	  (new_block)));new block which inherits the standard env.


;;; This builds the diana tree, does not use initialization

       ;;;;;;;;;;;;;
(defun different_pnl(label goto)
       ;;;;;;;;;;;;;
  (cond ((equal (diana_get label 'ct_pnl) (diana_get goto 'ct_pnl)) t)
	(t nil)))

       ;;;;;;;;;;;;;;;;;;;;;;;
(defun incremental_build_diana (*srcin* *listout* *errin* *errout* *userin* *userout*)
       ;;;;;;;;;;;;;;;;;;;;;;;

    (la_startup)

; Do the work.
    (let ((*diana_tree* (*catch nil (parserd 'compilation))))
;      (freshline *listout*)
;      (print_gripes)
      ;;now check that all the labels are fixed up.
      (mapc
	#'(lambda(fix)
	    (let* ((**current_block** (gotorec%context fix))
		   (label (ada_declared (gotorec%labelname fix) nil 'label t)))
              ;(break what-have-I-got)
	      (cond ((null label)
		     (semgripe 'missing_label_for_goto
			       (implode (cadr (gotorec%labelname fix)))
			       (diana_get (gotorec%gotonode fix) 'lx_srcpos)))
		    ((> (length label) 1)
		     (semgripe 'ambiguous_label_for_goto
			       (implode (cadr (gotorec%labelname fix)))
			       (diana_get (gotorec%gotonode fix) 'lx_srcpos)))
#|		    ((not
		       (strictly_enclosing (first label)(gotorec%gotonode fix)))
		     (semgripe 'structure_entering_goto
			       (implode (cadr (gotorec%labelname fix)))
			       (diana_get (gotorec%gotonode fix) 'lx_srcpos)))|#
		    ;;jumps out of procs and accepts not allowed
		    ((not
		       (different_pnl (first label)(gotorec%gotonode fix)))
		     (semgripe 'goto_inside_a_program_unit
			       (implode (cadr (gotorec%labelname fix)))
			       (diana_get (gotorec%gotonode fix) 'lx_srcpos)))
		    (t (diana_put
			 (gotorec%gotonode fix)
			 (sc_diana dn_used_name_id
				   sm_defn (first label)
				   lx_symrep (gotorec%labelname fix))
			 'sm_name)))));ct_change was as_name
	      
	*awaiting_label_fixup*)
      (setq *awaiting_label_fixup* nil)      
      (la_finale)
      (cond
	((eq *diana_tree* 'cant_continue)
	 (generic_gripe '("~%Your program's analysis has been terminated.~%~
			       The interpreter is unable to continue its analysis.")))
	((eq *diana_tree* 'too_many_errors)
	 (generic_gripe '("~%Your program's analysis has been terminated.~%~
			       Too many errors have occurred for the analysis to continue."))
	 nil)
	((eq *diana_tree* 'lex_eof)
	 (generic_gripe '("Unexpected end of file encountered"))
	 nil)
	((and (not (diana_nodep *diana_tree*)) *diana_tree*)
	 (generic_gripe '("The interpreter is unable to begin executing your program.~%~
A complete representation of your program could not be constructed.")))
	(t 
	 (cond
	   (*incremental_diana*
	    ;;merge compilation units to make a single tree.
	    (%= *incremental_diana* (merge_diana_trees *_* *diana_tree*)))
	   (t   (%= *incremental_diana* *diana_tree*)))
	    *incremental_diana*))))


;;;  This is not used at this time.
       ;;;;;;;;;
(defun adafe_int (srcin listout errin errout userin userout)
       ;;;;;;;;;

   (let ((*diana_tree* (incremental_build_diana	;Do the REAL work.
			   srcin listout	; source => listing
			   errin errout		; errors and correction
			   userin userout)))	; standard interaction
       (cond ((greaterp *parse_errors* 0)	;Cleanup after FE.
	      (greaterp *semantic_errors* 0)
	      (skipline listout)))
       (fe_result (and *diana_tree*		;Run-p Flag.
 		       (lessp *parse_errors* 1.)
		       (lessp *semantic_errors* 1.))
	          *parse_errors*
		  *semantic_errors*
		  *diana_tree*)))


;;;S-IF-PLURAL: Returns "s" if N is zero or > 1.  Useful for messages 
;;;involving numbers of items.

(defun s-if-plural (n)
  (if (or (zerop n)
	  (> n 1)) "s" ""))

;;;  This is used instead of ada_int, since it contains two extra
;;;  lines of code (setq *incremental_diana* nil) on errors

       ;;;;;;;;;;;
(defun ada_int_inc (srcin listout errin errout userin userout)
       ;;;;;;;;;;;

  " The C*T Ada Interpreter Top Level. "
  ;(time_line listout)
  (ada_version_msg listout)
  (*catch 'lossage
   (let* ((base 10.) (ibase 10.) (*nopoint t) (*lossage* t)
	 (t1 #+lispm (multiple-value-bind
		       (a b c d e f g)(time:get-time)
		       (list a b c d e f g))
	     #+franz  (status localtime))	          ;;Start FE timing.
	 (*function_name_only* nil)
	 (*in_record* nil)
	 (*disc_not_allowed* nil)
	 (*disc_list* nil)
	 (*disc_used* nil)
	 (*produce_listing* t)
	 (*generic_nestitude_stack* nil)
	 (*exception_handler_stack* nil)
	 (*named_stm_stack* nil)
	 (*return_stmt_stack* nil)
	 (*current_generic_nestitude* nil)
	 (*parse_errors* 0)
	 (*semantic_errors* 0)
	 (*error_statustmp* 0)
	 (*eof_count* 0)
	 (fe_res (adafe_int srcin listout	          ;;Run the Front End.
			errin errout userin userout))
	 (t2 #+lispm (multiple-value-bind
		       (a b c d e f g)(time:get-time)
		       (list a b c d e f g))
	     #+franz (status localtime))	          ;;Stop FE timing.
	 (runflg  (fe_result%runflg  fe_res))	  ;;Extract FE results.
	 (synerrs (fe_result%synerrs fe_res))
	 (semerrs (fe_result%semerrs fe_res))
	 (diana   (fe_result%diana   fe_res))
	 (fe_timing  (elapsed_time t2 t1))
	 (be_result nil)
	 (*infrontend* nil))
     
    (setq be_result diana)
    (freshline listout)
    (cond ((or runflg (> synerrs 0) (> semerrs 0))
	     (ct_format listout "A total of ~a syntax error~a and ~a static semantic error~a were detected.~%"
		        synerrs (s-if-plural synerrs)
			semerrs (s-if-plural semerrs))
	     (cond
	       ((and (status feature debugging)
		     (> *goto_count* 0))
		(ct_format listout "Warning: Your program uses ~A 'goto' ~A~%"
			   *goto_count*
			   (cond
			     ((= *goto_count* 1) "statement.")
			     (t "statements.")))
		  (ct_format
		  listout
		  "Warning: 'goto' is an obsolete statement.  Use structured constructs if possible.~%")))))
    (setq *fe_timing* fe_timing)
    (cond ((status feature qawimps)
	   (print_elapsed listout "Elapsed time  =  " fe_timing)))
    (cond  (runflg)
	   ((greaterp synerrs 0)
           (skipline listout)
           (setq *incremental_diana* nil)
	   (ct_format userout "Your program's execution has been cancelled due to syntax errors. ~%")
	   (%= *error_statustmp* 2)
	    #+franz
	     (%= *error_status* (boole 7 *error_statustmp* *error_status*)))
	  ((greaterp semerrs 0)
           (setq *incremental_diana* nil)
	   (skipline listout)
	   (ct_format userout
		      "Your program's execution has been cancelled due to static semantic errors. ~%")
	   (%= *error_statustmp* 4)
	     #+franz
	     (%= *error_status* (boole 7 *error_statustmp* *error_status*)))
	  (t (ct_format listout "~%Your input was probably not an Ada program.~%")
	     (ct_format listout "Program execution has ended.~%")
	     (%= *error_statustmp* 8)
	     #+franz
	     (%= *error_status* (boole 7 *error_statustmp* *error_status*))))
    (cond (runflg
	    (time_line listout)
	    be_result)
          ;;; if the runflg is false then the compilation
          ;;; will not be run, however wish to continue compiling
          ;;; any other segments. If the diana-tree is in a bad
          ;;; state then the compilation must be abandon.
	  (t (ct_format listout "~%Code will not be generated for ~S.~%" *path*)
	     (cond ((not (diana_nodep be_result))
		     (setq *not_wffp_diana* nil)
		     (%= *error_statustmp* 16)
	             #+franz
	             (%= *error_status* (boole 7 *error_statustmp* *error_status*))
		     (*throw '*not_wffp_diana* *not_wffp_diana*))
		   (t  (%= *error_statustmp* 32)
	   	     #+franz
		     (%= *error_status* (boole 7 *error_statustmp* *error_status*))
		    (setq *continue_inc_diana* nil))))))
   ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros -- 

;;; This is used to merge two diana trees

       ;;;;;;;;;;;;;;;;;
(defun merge_diana_trees(previous_tree latest_tree)
       ;;;;;;;;;;;;;;;;;

  (cond
    ((null previous_tree) latest_tree)
    ((null latest_tree) previous_tree)
    (t
     (diana_put
       previous_tree
       (append
	 (diana_get previous_tree 'as_list)
	 (diana_get latest_tree   'as_list))
       'as_list)
     previous_tree)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Edit History:
;;;
;;;  o  17-May-83, MLM:  Add edit history page to templates.
;;;
;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;