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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                            FE_REC                                ;;;
;;;          (this name no longer fully appropriate -- ++mlm)        ;;;
;;; This file needs to be merged with be_rec or some such ++mlm      ;;;
;;;                                                                  ;;;
;;; Paul Robertson                                         30-Jan-83 ;;;
;;; Edit by MLM to add ExceptionRec                         6-May-83 ;;;
;;; Edit by MLM to fix version number stuff.                9-May-83 ;;;
;;; Edit by MLM to move fe_result record decl. here.        9-May-83 ;;;
;;;                                                                  ;;;
;;;      Records and Macros common to FrontEnd and/or BackEnd        ;;;
;;;                                                                  ;;;
;;; 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.           ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Macros.
#+franz (declare (macros t))
(declare (ct_includef 'intrpdcl))
(eval-when (compile load eval) (ct_load 'diana)); for diana_put's

;;; Shouldn't this next be in compat?  ++mlm
#+lispm (defun append1 macro (l)`(append ,(cadr l) (list ,(caddr l))))


;;; Frontend Datatype, Array, and hashtable declarations

;;; Temporary hash function lexical analyser.
(declare (*expr la_hash))		  ;Defined in LANA
;;; (defun la_hash (l) -- etc --)         ;Where l is a list of char/integers.

;;; la_rw and la_op are records for storing tables of reserved words and
;;; operators.
(eval-when (compile eval load)
    (create_hash_table 'rw)	; hashtable for reserved words.
    (create_hash_table 'op)	; hashtable for operators.
    (create_hash_table 'id)     ; identifiers.
    (def_record_type la_num lex_number (base wholepart fractpart floatp exp fdigs))
    (def_record_type la_rw nil (extname rname . intname))	; Reserved Words.
    (def_record_type la_op nil (extname rname . intname))   ; Operators.

    (def_record_type source_region nil 
	(startchar endchar linenumber column path linstart colstart))

;;; Identifier hash table contains identifiers for the default 
;;; Ada IO standard environment
;;; and also all type and other declarations from within a program. 
;;; the fields are, in order,
;;; name - a lex_ident for the identifier in question.
;;; pl   - the procedure level at which it was declared.
;;; sfn  - the srcpos at which it was declared.
;;; dn   - the diana node for the declaration of this identifier.
;;; typ  - the type definition for this identifiers type.
;;; db   - the defining block. A block id such as made by new_block.

    (def_record_type la_id nil (name pl sfn dn class typ db))      ; Identifiers.
    (def_record_type dscrmt_record *dscrec* (dscrmt record vars))
;;; Record type for nodestages slot of activation records
    (def_record_type nodestagerec nil (id stage alist caller)))

;;; Record type for description of exceptions (eg to gripe if unhandled)
    (def_record_type exceptionrec nil (type))

;;; Goto a name, a context and a diana node waiting to be fixed up.
    (def_record_type gotorec *gotorec* (gotonode labelname context))

;;; Record type for passing results from FE to BE.
;;; Formerly in fe_result, all by its lonesome.
    (def_record_type fe_result nil (runflg synerrs semerrs diana))

;;; Record typr for passing advice for variables.
;;; funfrob takes the current and new values
;;; index is a list of subscripts, list of selectors or nil
;;; reason is either set or get, initially
    (def_record_type variable_advise_rec nil (funfrob index reason))

;;; Record type for cache:
    (def_record_type cache nil (activation node . entry))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Frontend Constant Declarations.


(defconst *max_errors* 20)	; abort after this many accumulated errors.
(defconst *print_diana_tree* nil)	; if non-nil prints diana tree.
(defconst *debugparser* nil)		; if non-nil gives parse diagnostic
					; info
(defconst font_change_ch 6)  ;the character used to signal the change in font.


;;; Records used in the frontend to represent syntactic units.
(eval-when (compile load eval)
  (def_record_type subtype_ind_init *sii* (sub_ind initexp))
  (def_record_type proc_decl_bits *pdb* (header body nextdecl))
  (def_record_type funk_decl_bits *pdb* (header body nextdecl result))
  (def_record_type task_decl_bits *pdb* (header body nextdecl))
  (def_record_type pckg_decl_bits *pdb* (header body nextdecl))
  (def_record_type object_definition *od* (id_s obdef))
  (def_record_type separate_decl *sd* (other_declarations))
  (def_record_type decl_part     *dp* (body_part other_declarations))
  (def_record_type generic_decl  *gd* (generic_name generic_block generic_header))
  (def_record_type subprogdecl *sub* (head body def))
  (def_record_type body_part *bp* (declarative_part  statement_part))
  (def_record_type array_type_bits nil (comptyp ranges2 sechalf))
  (def_record_type name_cdr_bits nil  (thisname destname))
  (def_record_type dynamic_range_rec *idr* (range val))
)

;;; globally used macros.

(eval-when (compile load eval)
       ;;;;;;;;;
(defun ada_ident macro(l)
       ;;;;;;;;;
       `'(lex_ident
	  ,(uplowlist
	     (exploden (cadr l))))))


(eval-when (compile load eval)


       ;;;;;;;;;;;;
(defun sc_diana_aux (&rest template); build diana node from abstract syntax.
       ;;;;;;;;;;;;
 
  (let ((dnode (pure-list nil
		  'ct_pnl *pnl*		  ; the procedure nesting level
		  'ct_bnl *bnl*		  ; the block nesting level
		  'lx_srcpos (source_region *preparsecc* *postparsecc*
					    la_psrcpos la_plinpos
					    *path*
					    *srcposbeg* *linposbeg*)
		  'ct_generic_membership *current_generic_nestitude*
		  'lx_comments la_comments))
	(sl (cdr template)))
    (do ()
	((null sl))
      (pure-putprop dnode (cadr sl) (car sl))
      (setq sl (cddr sl)))
    (setq la_comments nil)
    		  ; prepend diana node name.
    (pure-cons (car template) dnode)
    
  )
  )

(defun sc_diana_aux2 (nodetype pairlist)
  (let* ((pairlist (append pairlist
			   (list 
			     ''ct_pnl '*pnl*; the procedure nesting level
			     ''ct_bnl '*bnl*; the block nesting level
			     ''lx_srcpos '(source_region *preparsecc* *postparsecc*
						       la_psrcpos la_plinpos
						       *path*
						       *srcposbeg* *linposbeg*)
			     ''ct_generic_membership '*current_generic_nestitude*
			     ''ct_time_stamp '(%= *time_stamp* (1+ *_*))
			     ''lx_comments 'la_comments)))
	 (slotfillers
	   (do ((pl pairlist (cddr pl))
		(sf nil))
	       ((null pl) sf)
	     (ct_push (list 'diana_put 'nunod (second pl) (first pl)) sf))))
    `(let ((nunod (diana_cons ',nodetype )))
       ,@slotfillers
       nunod)))

       ;;;;;;;;
(defun sc_diana macro (body)
       ;;;;;;;;

       (let ((indp t))
	 (selfinsertmacro
	   body
	   (sc_diana_aux2 (cadr body)
			  (mapcar
			      #'(lambda (x)
				 (cond (indp (setq indp nil) `',x)
				       (t (setq indp t) x)))
			      (cddr body)))))))

; (sc_diana dn_void)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;