;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; $Header: /ct/interp/stateval.l,v 1.30 84/10/24 17:47:41 penny Exp $

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                           stateval.l                             ;;;
;;; pOzsvath                                               26-Aug-83 ;;;
;;;                    C*T Ada Static Evaluator                      ;;;
;;;                                                                  ;;;
;;; 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. ;;;
;;;   AJPO, Feb 1983.  ANSI/MIL-STD-1815A  Ada Reference Manual.     ;;;
;;; 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 'diana)) ;for diana_nodetype_get

;(eval-when (compile load eval) (ct_load 'dynsem)) ;For `numval'

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

#+franz (declare (macros t))

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

;;; Apply an operator to its diana if it is a legal static operator
(eval-when (compile load eval)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun apply_static_function macro (body)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (selfinsertmacro
    body
    `(cond
       ((get ,(cadr body) 'static_function_name)
	(apply
	  (get ,(cadr body) 'static_function_name)
	  (mapcar #'(lambda (arg) (static_eval arg throw_dn))
		  (diana_get ,(caddr body) 'as_list))))
       (t
	(stat_throw '*diana_node_not_static_expression*
		,(cadddr body)
		throw_dn))))))

       ;;;;;;;;;;;;;;
(defun be_static_eval (die_anna)
       ;;;;;;;;;;;;;;
  (let ((res (*catch '*diana_node_not_static_expression* (static_eval die_anna))))
    (cond ((eq res '*diana_node_not_static_expression*)
	   (cond ((not *infrontend*)
		  (lose 'be_dnnse 'be_static_eval))
		 (t (*throw
		      '*diana_node_not_static_expression*
		      '*diana_node_not_static_expression* )))))
    res))

(defun fe_static_eval (die_anna)
  (*catch '*diana_node_not_static_expression* (static_eval die_anna)))

(defun stat_throw (x y throw_dn)
  (cond (throw_dn (*throw x y))
	(t (*throw x x))))

;;; The Static Evaluator Proper
(defun static_eval (dn &optional (throw_dn nil))
  (cond
    ((null (diana_nodep dn))
     (stat_throw '*diana_node_not_static_expression*
	     dn throw_dn))
    (t
     (let ((res (and (not (eq (diana_nodetype_get dn) 'dn_slice))
		     (diana_node_accepts_attributep dn 'sm_value)
		     (diana_get dn 'sm_value))))
       (cond (res res)
	     (t
;	      (princ (diana_nodetype_get dn))
	      (setq
		res
		(ct_selectq
		  (diana_nodetype_get dn)
		  (dn_attribute_call
		    (let* ((arg (and (diana_get dn 'as_exp)
				    (static_eval (diana_get dn 'as_exp) throw_dn)))
			  (attr (diana_get dn 'as_name))
			  (attr_id
			    (diana_get attr 'as_name))
			  (smdef (or
				   (and
				     (diana_nodep attr_id)
				     (diana_node_accepts_attributep
				       attr_id 'sm_defn)
				     (diana_get attr_id
						'sm_defn))
				   (and (setq attr_id
					      (static_eval attr_id throw_dn))
					(and
					  (diana_nodep attr_id)
					  (diana_node_accepts_attributep
					    attr_id 'sm_defn)
					  (diana_get (diana_get attr_id 'sm_defn)))))))
		      (cond ((and smdef
				  (memq (diana_nodetype_get
					  smdef)
				   '(dn_type_id dn_subtype_id)))
			     (funcall (implode
					(append (exploden "attribute_")
						(cadr
						  (diana_get
						    (diana_get attr 'as_id)
						    'lx_symrep))))
				      (diana_get attr 'as_name)
				      arg))
			    (t 
			       (stat_throw '*diana_node_not_static_expression*
					   dn throw_dn)))))
		  (dn_attribute
		    (let* ((arg nil)
			  (attr dn)
			  (smdef (or
				   (and
				     (diana_nodep attr)
				     (diana_node_accepts_attributep attr 'sm_defn)
				     (diana_get attr 'sm_defn))
				   (and (setq attr
					      (static_eval attr throw_dn))
					(and
					  (diana_nodep attr)
					  (diana_node_accepts_attributep
					    attr 'sm_defn)
					  (diana_get attr 'sm_defn))))))
		      (cond ((and smdef
				  (memq (diana_nodetype_get
					  smdef)
				   '(dn_type_id dn_subtype_id)))
			     (funcall (implode
					(append (exploden "attribute_")
						(cadr
						  (diana_get
						    (diana_get attr 'as_id)
						    'lx_symrep))))
				      (diana_get attr 'as_name)
				      arg))
			    (t 
			       (stat_throw '*diana_node_not_static_expression*
				       dn throw_dn)))))
		  (dn_parenthesized
		    (static_eval (diana_get dn 'as_exp) throw_dn))
		  (dn_var_id
		    (cond
		      ((and (diana_get dn 'sm_obj_def)
			    (eq (diana_nodetype_get (diana_get dn 'sm_obj_def))
				'dn_rename))
		       (static_eval (diana_get dn 'sm_obj_def) throw_dn))
		      (t
		       (stat_throw '*diana_node_not_static_expression*
			       dn throw_dn))))
		  (dn_qualified (static_eval (diana_get dn 'as_exp) throw_dn))
		  (dn_conversion (static_eval (diana_get dn 'as_exp) throw_dn))
		  (dn_used_name_id
		    (static_eval (diana_get dn 'sm_defn) throw_dn))
		  (dn_enum_id
		    dn)
		  (dn_def_char
		    dn)
		  (dn_rename (static_eval (diana_get dn 'as_name) throw_dn))
		  (dn_number_id
		    (static_eval (diana_get dn 'sm_init_exp) throw_dn))
		  (dn_selected
		    (static_eval (diana_get dn 'as_designator_char)))
		  (dn_void
		    nil)
		  (dn_string_literal
		    (diana_get dn 'lx_symrep))
		  (dn_character_literal
		    (convert_integer_to_char (caadr (diana_get dn 'lx_symrep))))
		  (dn_numeric_literal
		    (numval (diana_get dn 'lx_numrep)))
		  #|(dn_const_id
		    (static_eval (diana_get dn 'sm_init_exp) throw_dn))|#
		  (dn_function_call
		    (let ((name (diana_get dn 'as_name)))
		      (cond ((and (diana_get dn 'sm_normalized_param_s) name)
			     (apply_static_function
			       (implode (cadr (diana_get name 'lx_symrep)))
			       (diana_get dn 'sm_normalized_param_s)
			       dn))
			    (t		  ;not normalized yet
			     (stat_throw '*diana_node_not_static_expression*
					 dn throw_dn)))))
		  (otherwise		  ;(break in-stat-eval)
		    ;(break)
		    (stat_throw '*diana_node_not_static_expression*
				dn throw_dn))))
	      (cond ((diana_node_accepts_attributep dn 'sm_value)
		     (diana_put dn res 'sm_value)))
	      res))))))

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

(eval-when (compile load eval)
(defun def_static_function macro (body)
       (selfinsertmacro
	 body
	 `(progn 'compile
		 (defun
		   ,(concat 'static_function_ (cadr body))
		   ,(caddr body)
		   (let ((val . ,(cdddr body)))
		     (cond ((is_in_bound val) val)
			   ((null *infrontend*)
			    (ada_raise '|numeric_error|
				       (format nil
					       "Static universal_~A !"~A!""
					       (cond ((floatp val)
						      "float")
						     ((fixp val)
						      "integer")
						     (t "number"))
					       ,(get_pname (cadr body)))))
			   (t (semwarn 'will_raise_exception '|numeric_error|)
			      (*throw '*diana_node_not_static_expression*
				      '*static_value_not_in_range*)))))
		 (putprop
		   ',(cadr body)
		   ',(concat 'static_function_ (cadr body))
		   'static_function_name)))))


(defun is_in_bound (x)
  (cond ((fixp x) (and (<= *integer_first* x)
		       (>= *integer_last* x)))
	((floatp x) (and (<= *float_first* x)
		         (>= *float_last* x)))
	(t t)))
	
;;; mod not defined on lm

(defun modp  (n m)
   (cond ((zerop m) n)
	 (t (- n (* m (fix (!/ (float n) m)))))))


;;; The unary operators

(eval-when (compile load eval)
(def_static_function |abs| (num) (abs num)))

;;; The binary operators

(eval-when (compile load eval)
(def_static_function |mod| (left right) (modp (fix left) (fix right))))

(eval-when (compile load eval)
(def_static_function |rem| (left right) (remainder (fix left) (fix right))))

(eval-when (compile load eval)
(def_static_function * (left right) (times left right)))

(eval-when (compile load eval)
(def_static_function ** (left right) (expt left right)))

(eval-when (compile load eval)
(def_static_function !/ (left right) (quotient left right)))

(eval-when (compile load eval)
(def_static_function !& (left right)
  `(lex_string
     ,(append
	(cond ((diana_nodep left)
	       (list (convert_char_to_integer left)))
	      (t (cadr left)))
	(cond ((diana_nodep right)
	       (list (convert_char_to_integer right)))
	      (t (cadr right)))))))

;;;Wierd operator
(eval-when (compile load eval)
(def_static_function - (&rest args)
  (cond ((cdr args) (apply (function difference) args))
	(t (minus (car args))))))

(eval-when (compile load eval)
(def_static_function + (&rest args)
  (cond ((cdr args) (apply (function plus) args))
	(t  (car args)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;				  eof				     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;