;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; $Header: /ct/interp/pnorms.l,v 1.8 84/05/16 19:32:30 penny Exp $
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                            pnorms.l                              ;;;
;;; Paul Robertson                                  October 18, 1983 ;;;
;;;                                                                  ;;;
;;;       The C*T Ada Interpreters Static Semantic support           ;;;
;;;                                                                  ;;;
;;; 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 'charmac))

(eval-when (compile load eval) (ct_load 'time))       ;Timing functions. 

(eval-when (compile load eval) (ct_load 'diana))      ; Diana tools.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros -- 

;;; Static semantic code schemas are structured as follows.
;;; Body contains lisp code that returns a piece of diana tree or nil.
;;; The main way of building a diana tree is with the sc_diana functon.
;;; Simple node will consist only of these nodes. sc_diana looks like this...
;;; (sc_diana dn_foo slotname code slotname code slotname code .. .. .. ..)
;;; The above example creates a diana node with the names slots, and calls the
;;; appropriate code to fill the slots. One reason why this function should be
;;; used is that it hides the internal representation of a diana node making
;;; future modifications easy (which would be necessary for say a production
;;; compiler.
;;; The abstract syntax is available for inclusion in  the diana tree or
;;; other in a free variable called *abstract_syntax*. This variable may be
;;; altered by the code for effeciency reasons without intefering with the
;;; parsing process. Syntax nodes that do not have ssemantics code will
;;; produce abstract syntax subtree's. To return a null node have a ssemantic
;;; property that returns nil.

;;; takes a diana node dn that must be a subprogram call. Combines the
;;; definition with the actuals to provide a list of normalized parameters.
;;; the normalized parameters are added to the diana node dn as the semantic
;;; attribute sm_normalized_param_s.
       ;;;;;;;;;;;;;;;;
(defun normalize_params(dn) 	; normalize parameters for dn.
       ;;;;;;;;;;;;;;;;

    (let ((actuals
	    (let ((apas (diana_get dn 'as_param_assoc_s)))
		     (and apas (diana_get apas 'as_list))))
          (formals (let* ((asnam  (diana_get dn 'as_name))
			  (smdef (and asnam (subprog_bit
					      (diana_get 
					      asnam 'sm_defn)))) ; definition's
			  (smsp (and smdef (diana_get smdef	 
						      'sm_spec))); spec's
			  (apas (and smsp (diana_get smsp 'as_param_s))))
		   apas))		     
	  (parampos 1)
	  (unsequenced nil)
          (normalized nil))
      (cond
	;; if formals is nil and actuals non nil, delay normalization until
	;; later because we haven't got a spec installed for this function yet.
	(
	 ;;(and actuals (null formals)) -- putback when operators interned.
	 (and actuals (null formals)
	      (not (let ((nm (diana_get dn 'as_name)))
		     (and nm (eq (diana_nodetype_get nm) 'dn_used_bltn_op)))))
	 (ct_push dn *awaiting_parameter_normalization*)
	 dn)
	(t ;;otherwise go ahead and normalize it.
	 (do ((aps actuals (cdr aps))
	      (fps (extract_formal_id_s formals)));returns a list of pairs.
	     ((null aps) 
	      (prog1 dn
		     (let ((nparams (append (reverse normalized)
					 (sequence_kwp unsequenced
						       fps
						       parampos
						       t))))
		       (check_assignable_out_parameters
			  (extract_formal_id_s formals)
			 nparams)
		       (diana_put 
		       dn 
		       (sc_diana dn_exp_s
				 as_list nparams)
		       'sm_normalized_param_s))))
	   (ct_selectq (diana_nodetype_get (first aps))
		       (dn_assoc
			 (let ((formpos (find_formal
					  (first aps) fps parampos)))
			   (cond
			     ((zerop formpos)	  ;(break unmatched-keyword)
			      (comment (semgripe `unmatch_keyword_param)))
			     (t (ct_push `(,formpos ,(first aps))
					 unsequenced)))))
		       (otherwise
			 (%= fps (cdr fps))	  ; this formal is accounted for.
			 (%= parampos (1+ *_*))
;			 (ct_push (copy_dn (car aps)) normalized)
			 (ct_push  (car aps) normalized))))))))

(defun check_assignable_out_parameters (fpl al)
  (mapc #'(lambda (f a)
	    (cond ((eq (diana_nodetype_get (car f)) 'dn_in_id))
		  ((assignable_p a) )
		  (t (semgripe
		       'actual_parameter_out_formal_not_assignable
		       (implode (lowuplist
				  (cadr (diana_get (car f) 'lx_symrep))))))))
	fpl al))

       ;;;;;;;;;;;;;;;;;;;
(defun extract_formal_id_s(fpl)
       ;;;;;;;;;;;;;;;;;;;

  (do ((fpg fpl (cdr fpg))
       (fpids nil))
      ((null fpg) (reverse fpids))
    (do ((fpid (diana_get (car fpg) 'as_id_s) (cdr fpid))
	 (default (diana_get (car fpg) 'as_exp_void)))
	((null fpid))
      (ct_push (list (car fpid) default) fpids))))

;;; finds the position of keyword parameter asp in formal list fpl + pp
       ;;;;;;;;;;;
(defun find_formal(asp fpl pp)
       ;;;;;;;;;;;

  (*catch
    'pos
    (let ((desig (diana_get asp 'as_designator)))
      (do ((afp fpl (cdr afp)))
	  ((null afp)			  ;(break keyword-doesnt-match)
	   (semgripe 'keyword_not_match_formal
		     (implode (lowuplist (cadr desig))))
	   (*throw 'pos 0))
	(cond
	  ((param_matches asp (caar afp))
	   (*throw 'pos pp))
	  (t (%= pp (1+ *_*)))))
      )
    ))
	  
;;; Also finds the position of keyword parameter asp in formal list fpl + pp,
;;; but doesn't die when "keyword doesnt match formal"...
       ;;;;;;;;;;;;
(defun find_formal2(asp fpl pp)
       ;;;;;;;;;;;;

    (let ((desig (diana_get asp 'as_designator)))
      (do ((afp fpl (cdr afp)))
	  ((null afp)			  ;(break keyword-doesnt-match)
	      (return 0))
	(cond
	  ((param_matches asp (caar afp))
	   (return pp))
	  (t (%= pp (1+ *_*)))))))


       ;;;;;;;;;;;;;
(defun param_matches(x y)	; ++ should be made into a macro.
       ;;;;;;;;;;;;;

    (equal (diana_get x 'as_designator)(diana_get y 'lx_symrep))
)

       ;;;;;;;;;;;;
(defun sequence_kwp(lkwp fps pp gripe_p)
       ;;;;;;;;;;;;

    (do ((srtd nil)		; sorted keyword parameters.
	 (kwps lkwp)			  ; actual keyword parameters remaining.
	 (rfps fps (cdr rfps))		  ; remaining formals.
	 (fp pp)			  ;the first keyword.
	 )
	((null rfps) (nreverse srtd))
      (let ((np (assq pp kwps)))	  ; get next parameter.
	(cond
	  ((null np)			  ; named parameter missing?
	   (let ((np (n_th (- pp fp) fps)))	  ;(break default-param?)
	     (cond
	       ((second np)		  ;is there a default?
		(ct_push (diana_copy (second np)) srtd)
		(%= pp (1+ *_*))
		(%= kwps (delq np kwps)))
	       (t
		(%= pp (1+ *_*))
		(ct_push nil srtd)
		(cond (gripe_p
		       (semgripe 'missing_actual
			  (implode
			     (lowuplist
			       (cadr (diana_get (first np) 'lx_symrep))))))
		      (t (*throw '*unmatched_keyword* nil)))))))
	  (t (ct_push (diana_copy (diana_get (second np) 'as_actual)) srtd)
	     (%= pp (1+ *_*))
	     (%= kwps (delq np kwps))))))
)

       ;;;;;;;
(defun copy_dn(dn)
       ;;;;;;;

    (cond ((null dn) nil)
	  (t (cons (car dn)(copy_dn (cdr dn))))))
		
       ;;;;;;;;;;;
(defun find_needed(syn)     	; find first 'wanted' thing from syntax.
       ;;;;;;;;;;;

    (cond 
      ((get syn 'syntax_type) syn)
;;;	(t (find_needed (third syn)))
      ))


       ;;;;;;;
(defun sc_uop? (a)
       ;;;;;;;

    (memq a '(oper_plus oper_minus symb_abs symb_not)))

       ;;;;;;;;;;;;;;;;;;;;;;;;
(defun eat_and_spit_thing_after (symb refvar)
       ;;;;;;;;;;;;;;;;;;;;;;;;

    (uci_let (rl (set refvar (find_cdr symb (eval refvar)))); delete leading dross
	     (cond ((null rl) rl)(t (car rl)))))
    
	  ;;;;;;;;;;;;;;;;;;;;;;;
;;;(defun sc_build_rel_op_rel_rep (exp)
	  ;;;;;;;;;;;;;;;;;;;;;;;

;;;	(cond
;;;	    ((null (cdadr exp)) (sc_build_binary_op exp))
;;;	    (t (sc_build_binary_op `(,(car exp) (( ,(caadr exp)
;;;			(sc_build_rel_op_rel_rep `(,(c****))))))))))
;;;
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun sc_build_seq_of_name_for_use (as)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (uci_let (firstname (caddr as)
			othernames (mapcar '(lambda(e) (cadr e)) (cadddr as)))
	     (cons firstname othernames)))

       ;;;;;;;;
(defun find_cdr (key lst)
       ;;;;;;;;

    (cond ((null lst) nil)
	  ((eq (car lst) key) lst)
	  (t (find key (cdr lst)))))


(defun try_to_normalize() ;(break in-try_to_normalize)
  (let ((apn *awaiting_parameter_normalization*))
    (setq *awaiting_parameter_normalization* nil)
	(mapc
	  #'(lambda(call)
	      (normalize_params call))  ;if so normalize it
	  apn))
  (let ((aan *awaiting_aggregate_normalization*))
    (setq *awaiting_aggregate_normalization* nil)
	(mapc
	  #'(lambda(agg)
	      (normalize_aggregate agg))  ;if so normalize it
	  aan))
  (let ((defcons *awaiting_deferred_value*))
    (setq *awaiting_deferred_value* nil)
    (mapc
	  #'(lambda(const)
	      ;(break look-at-deferredconst)
	      nil)  ;do later, 
	  defcons))
  
    )


(defun with_library_units (lus);(break with_library_units )
  (diana_put
    **current_block**
    (append
      (diana_get **current_block** 'ct_mixin_s)
      (mapcar
	#'(lambda(lu)
	    (let* ((definition (diana_get lu 'sm_defn))
		   (embeddedcontext
		     (and definition (diana_get definition 'ct_named_context)))
		   (context
		     (and embeddedcontext
			  (diana_get embeddedcontext 'ct_is_enclosed_by))))
	      context))
	lus))
    'ct_mixin_s))