;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; $Header: /ct/interp/operators.l,v 1.53 84/10/16 16:45:39 penny Exp $
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                              OPERATORS                           ;;;
;;; Penny Muncaster-Jewell                                14-July-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 'bifmacs)) 

(eval-when (compile load eval) (ct_load 'diana))

(eval-when (compile load eval) (ct_load 'ctadadt))

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

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

#+franz (declare (macros t))
(declare (ct_includef 'intrpdcl))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros -- 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Builds the correct operator functions for the ada interpreter     ;;;
;;; it will replace the hacked versions of the operator functions in  ;;;
;;; the standard package.They are called from stdenv                  ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; And, or, xor and not take boolean args and return boolean.        ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

       ;;;;;;;;;;
(defun |bool_not| (ar)
       ;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 right))
		       (cond
			 ((eq arg1 *ct_ada_true*) *ct_ada_false*)
			 ((eq arg1 *ct_ada_false*) *ct_ada_true*)
			 (t (lose 'bop_natv 'bool_not
				  "not an ada truth value")))))

       ;;;;;;;;;;
(defun |bool_and| (ar)
       ;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		(cond ((and (eq arg1 *ct_ada_true*) 
			   	  (eq arg2 *ct_ada_true*)) *ct_ada_true* )
		     ((and (or (eq arg1 *ct_ada_true*) 
	        	       (eq arg1 *ct_ada_false*))
			   (or (eq arg2 *ct_ada_true*) 
			       (eq arg2 *ct_ada_false*)))
						*ct_ada_false*)
		      (t (lose 'bop_natv 'bool_and
				  "not an ada truth value")))))
			      

       ;;;;;;;;;
(defun |bool_or| (ar)
       ;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		(cond ((or (eq arg1 *ct_ada_true*) 
			   	  (eq arg2 *ct_ada_true*)) *ct_ada_true* )
		     ((and (or (eq arg1 *ct_ada_true*) 
	        	       (eq arg1 *ct_ada_false*))
			   (or (eq arg2 *ct_ada_true*) 
			       (eq arg2 *ct_ada_false*)))
						*ct_ada_false*)
		      (t (lose 'bop_natv 'bool_or
				  "not an ada truth value")))))


       ;;;;;;;;;;
(defun |bool_xor| (ar)
       ;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		(cond ((or (and (eq arg1 *ct_ada_false*) 
			   	  (eq arg2 *ct_ada_false*))
			   (and (eq arg1 *ct_ada_true*) 
			   	  (eq arg2 *ct_ada_true*))) *ct_ada_false* )
		     ((and (or (eq arg1 *ct_ada_true*) 
	        	       (eq arg1 *ct_ada_false*))
			   (or (eq arg2 *ct_ada_true*) 
			       (eq arg2 *ct_ada_false*)))
						*ct_ada_true*)
		      (t (lose 'bop_natv 'bool_xor
				  "not an ada truth value")))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Equal, not_equal, less_than, less_than_or_equal, greater_than and    ;;;
;;; greater_than_or_equal functions can take boolean, integers, floats,  ;;;
;;; and strings arguments they all return a boolean value.               ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; function less_than, less_than_or_equal, greater_than,		 ;;;
;;; greater_than_or_equal for enumeration types			         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun |enum_less_than| (ar)
  (with_quick_ada_parameters
    ((arg1 left) (arg2 right))
    (cond ((or (eq arg1 '*unassigned*)
	       (eq arg2 '*unassigned*))
	   (ada_raise '|program_error|
		      "Unassigned enum type variable to <")))
    (or (and (< (diana_get arg1 'sm_pos)
		(diana_get arg2 'sm_pos))
	     *ct_ada_true*)
	*ct_ada_false*)))

(defun |enum_less_than_or_equal| (ar)
  (with_quick_ada_parameters
    ((arg1 left) (arg2 right))
    (cond ((or (eq arg1 '*unassigned*)
	       (eq arg2 '*unassigned*))
	   (ada_raise '|program_error|
		      "Unassigned enum type variable to <")))
    (or (and (<= (diana_get arg1 'sm_pos)
		 (diana_get arg2 'sm_pos))
	     *ct_ada_true*)
	*ct_ada_false*)))

(defun |enum_greater_than| (ar)
  (with_quick_ada_parameters
    ((arg1 left) (arg2 right))
    (cond ((or (eq arg1 '*unassigned*)
	       (eq arg2 '*unassigned*))
	   (ada_raise '|program_error|
		      "Unassigned enum type variable to <")))
    (or (and (> (diana_get arg1 'sm_pos)
		(diana_get arg2 'sm_pos))
	     *ct_ada_true*)
	*ct_ada_false*)))

(defun |enum_greater_than_or_equal| (ar)
  (with_quick_ada_parameters
    ((arg1 left) (arg2 right))
    (cond ((or (eq arg1 '*unassigned*)
	       (eq arg2 '*unassigned*))
	   (ada_raise '|program_error|
		      "Unassigned enum type variable to <")))
    (or (and (>= (diana_get arg1 'sm_pos)
		 (diana_get arg2 'sm_pos))
	     *ct_ada_true*)
	*ct_ada_false*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; function int_equal,float_equal, bool_equal string_equal              ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

       ;;;;;;;;;;;
(defun |int_equal| (ar)
       ;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (or (and (equal arg1 arg2) *ct_ada_true* )
			   *ct_ada_false*)))
       ;;;;;;;;;;;;;;;;;;;
(defun multi_dimensional_p (arr)
       ;;;;;;;;;;;;;;;;;;;
  ;(break look-at-arr)
  (let ((il (ct_send arr 'index_list)))
    (cond ((second il) t))))

       ;;;;;;;;;;;
(defun |any_equal| (ar)
       ;;;;;;;;;;;
  (with_ada_parameters ((arg1 left) (arg2 right))
		       (any_equal_aux arg1 arg2)))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compare_rec_type_and_aggie (rec aggie)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;
  (let ((comp1 (ada_record_value%record rec))
	(aggicomps aggie))
    (do ((c1 (ada_record_value%record rec) (cdr c1))
	 (c2 aggie (cdr c2)))
	((or (null c1) (null c2))
	 (cond (c1 *ct_ada_false*)
	       (c2 *ct_ada_false*)
	       (t *ct_ada_true*)))
      (cond ((eq  (any_equal_aux (ct_send (cdar c1) 'current_value) (car c2))
		  *ct_ada_false*)
	     (return *ct_ada_false*))))))

(defun compare_dt_array_types(arg1 arg2)
  (cond
	   ((multi_dimensional_p arg1)
	    (do ((index 0 (1+ index))
		 (as1 (ct_send arg1 'array_storage))
		 (as2 (ct_send arg2 'array_storage))
		 (ubound (second (arraydims
				   (ct_send arg1 'array_storage))))
		 (succeed *ct_ada_true*))
		((or (eq succeed *ct_ada_false*)
		     (= index ubound)) succeed)
	      (setq
		succeed
		(any_equal_aux		  ;++
		    (ct_send (aref as1 index) 'current_value)
		    (ct_send (aref as2 index)
			     'current_value)))))
	   (t				  ;(break foo-cant-compare-slices-yet)
					  ;get upper and lower bounds for both arrays
	    (let*
	      ((ilarg1 (first
			 (ct_send arg1 'index_list)))
	       (ilarg2 (first
			 (ct_send arg2 'index_list)))
	       (lb1 (-
		      (index_of (first ilarg1))
		      (first (ct_send arg1 'starters))))
	       (ub1 (-
		      (index_of (second ilarg1))
		      (first (ct_send arg1 'starters))))
	       (lb2 (-
		      (index_of (first ilarg2))
		      (first (ct_send arg2 'starters))))
	       (ub2  (-
		       (index_of (second ilarg2))
		       (first (ct_send arg2 'starters)))))
	      (cond
		((neq (- ub1 lb1) (- ub2 lb2))
		 (ada_raise
		   '|constraint_error|
		   "arrays not the same size in any_equal"))) 
	      (do ((i1 lb1  (1+ i1))
		   (i2 lb2  (1+ i2))
		   (as1 (ct_send arg1 'array_storage))
		   (as2 (ct_send arg2 'array_storage))
		   (succeed *ct_ada_true*))
		  ((or (equal succeed *ct_ada_false*)
		       (> i1 ub1))
		   succeed)
		(setq
		  succeed
		  (any_equal_aux	  ;++
		      (ct_send (aref as1 i1) 'current_value)
		      (ct_send (aref as2 i2)
			       'current_value)))
		))
	    )))

       ;;;;;;;;;;;;;
(defun any_equal_aux (arg1 arg2)
       ;;;;;;;;;;;;;

  (cond ((and (consp arg1) (eq (first arg1) 'lex_string))
	 (setq arg1
	       (convert_lexstr_to_obj arg1))))
  (cond ((and (consp arg2) (eq (first arg2) 'lex_string))
	 (setq arg2
	       (convert_lexstr_to_obj arg2))))
  ;(break look-at-arg-2)
  (cond ((and (eq (typep arg1) 'dt_access_type)
	      (eq (typep arg2) 'dt_access_type))
	 (cond ((eq (ct_send arg1 'current_value)
		    (ct_send arg2 'current_value))
		*ct_ada_true*)
	       (t *ct_ada_false*)))
	((and (eq (typep arg1) 'dt_array_type)
	      (arrayp arg2))
	 (let* ((arg
		 (ct_make_instance 'dt_array_type
				   'array_storage arg2
				   'index_list (ct_send arg1 'index_list)
				   'starters (ct_send arg1 'starters)
				   )))
	 (compare_dt_array_types arg1 arg)))
	((and (arrayp arg1)
	      (eq (typep arg2) 'dt_array_type))
	 (let* ((arg
		 (ct_make_instance 'dt_array_type
				   'array_storage arg1
				   'index_list (ct_send arg2 'index_list)
				   'starters (ct_send arg2 'starters)
				   )))
	 (compare_dt_array_types arg arg2)))
	((and (eq (typep arg1) 'dt_array_type)
	      (eq (typep arg2) 'dt_array_type))
	 (compare_dt_array_types arg1 arg2))
	((and (arrayp arg2 )
	      (consp arg1))
	 (compare_artq_and_aggie arg1 arg2))
	((and (arrayp arg1)
	      (consp arg2))
	 (compare_artq_and_aggie arg2 arg1))
	((and (typep arg1 'dt_array_type)
	      (consp arg2))
	 (compare_array_type_and_aggie arg2 arg1))
	((and (typep arg1 'dt_array_type)
	      (consp arg2))
	 (compare_array_type_and_aggie arg2 arg1))
	((and (arrayp arg1) (arrayp arg2)
	      (null (diana_nodep arg1))
	      (null (diana_nodep arg2)))
	 (compare_artq_to_artq arg1 arg2))
	#|((and (typep arg1 'dt_enumeration_type)
	      (typep arg2 'dt_enumeration_type))
	 (cond ((eq (ct_send arg1 'current_value)
		   (ct_send arg2 'current_value))
		*ct_ada_true*)
	       (t *ct_ada_false*)))
	((and (typep arg1 'dt_floating_type)
	      (typep arg2 'dt_floating_type))
	 (cond ((= (ct_send arg1 'current_value)
		   (ct_send arg2 'current_value))
		*ct_ada_true*)
	       (t *ct_ada_false*)))
	((and (typep arg1 'dt_integer_type)
	      (typep arg2 'dt_integer_type))
	 (cond ((= (ct_send arg1 'current_value)
		   (ct_send arg2 'current_value))
		*ct_ada_true*)
	       (t *ct_ada_false*)))|#
	((and (typep arg1 'dt_record_type)
	      (typep arg2 'dt_record_type))
	 (let ((comp1 (ct_send arg1 'current_value))
	       (comp2 (ct_send arg2 'current_value)))
	   (any_equal_aux comp1 comp2)
	   ))
	((and (consp arg1)
	      (eq (car arg1) '*ada_record*)
	      (consp arg2)
	      (eq (car arg2) '*ada_record*))
	 (let ((comp1 (ada_record_value%record arg1))
	       (comp2 (ada_record_value%record arg2)))
	 (cond ((memq *ct_ada_false*
			(mapcar #'(lambda (c1)
				    (let* ((id (car c1))
					   (val1 (cdr c1) )
					   (val2 (cdr (assq id comp2))))
				      (cond (val2
					     (any_equal_aux
					       val1 val2))
					    (t *ct_ada_false*))))
				comp1))
		  *ct_ada_false*)
		 (t *ct_ada_true*))))
	((and (consp arg1)
	      (eq (car arg1) '*ada_record*)
	      (consp arg2))
	 (compare_rec_type_and_aggie arg1 arg2))
	((and (consp arg2)
	      (eq (car arg2) '*ada_record*)
	      (consp arg1))
	 (compare_rec_type_and_aggie arg2 arg1))
	(t
	 (or (and (equal arg1 arg2) *ct_ada_true* )
	     *ct_ada_false*))))

;;; Possible bugs:
;;;    1. off by 1 error (last element not included)
;;;    2. Constraint error not raised when supposed to (size difference)
;;;    3. Multi-d array

       ;;;;;;;;;;;;;;;;;;;;
(defun compare_artq_to_artq (a1 a2)
       ;;;;;;;;;;;;;;;;;;;;
  
  (cond ((null (= (second (arraydims a1)) (second (arraydims a2))))
	 *ct_ada_false*)
	(t
	 (do ((index 0 (1+ index))
	      (ubound (second (arraydims a1))))
	     ((eq index ubound) *ct_ada_true*)
	   (cond ((eq (any_equal_aux (aref a1 index) (aref a2 index))
		      *ct_ada_false*) (return *ct_ada_false*)))))))


       ;;;;;;;;;;;;;;;;;;;;;;
(defun compare_artq_and_aggie (agg ar)
       ;;;;;;;;;;;;;;;;;;;;;;

  (do ((index 0 (1+ index))
       (shrinking_aggie agg (cdr shrinking_aggie))
       (ubound (second (arraydims ar))))
      ((eq index ubound)
       (cond (shrinking_aggie *ct_ada_false*)
	     (t *ct_ada_true*)))
    (cond ((null shrinking_aggie) (return *ct_ada_false*))
	  ((eq (any_equal_aux (ct_send (aref ar index) 'current_value)
			      (car shrinking_aggie))
	       *ct_ada_false*) (return *ct_ada_false*)))))

;(defun compare_array_type_and_aggie_not_necessarily_in_that_order? (agg ar)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compare_array_type_and_aggie (agg ar)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  (cond
    ((multi_dimensional_p ar)
     (cond ((neq (1+ (second (arraydims (ct_send ar 'array_storage))))
		 (length agg))
	    (ada_raise
	      '|constraint_error|
	      "arrays not the same size in any_equal")))
     (do ((index 0 (1+ index))
	  (as (ct_send ar 'array_storage))
	  (succeed *ct_ada_true*)
	  (shrinking_aggie agg (cdr shrinking_aggie))
	  (ubound (second (arraydims
			    (ct_send ar 'array_storage)))))
	 ((or (eq succeed *ct_ada_false*)
	      (= index ubound)) succeed)
       (setq
	 succeed
	 (any_equal_aux
	   (ct_send (aref as index) 'current_value)
	   (car shrinking_aggie)))))
    (t					  ;(break foo-cant-compare-slices-yet)
					  ;get upper and lower bounds for both arrays
     (let*
       ((ilarg (first
		 (ct_send ar 'index_list)))
	(lb (-
	      (index_of (first ilarg))
	      (first (ct_send ar 'starters))))
	(ub (-
	      (index_of (second ilarg))
	      (first (ct_send ar 'starters)))))
       (cond ((neq (1+ (- ub lb))
		   (length agg))
	      (ada_raise
		'|constraint_error|
		"arrays not the same size in any_equal")))
       (do ((i lb  (1+ i))
	    (as (ct_send ar 'array_storage))
	    (succeed *ct_ada_true*)
	    (shrinking_aggie agg (cdr shrinking_aggie)))
	   ((or (eq succeed *ct_ada_false*)
		(> i ub)) succeed)
	 (setq
	   succeed
	   (any_equal_aux
	     (ct_send (aref as i) 'current_value)
	     (car shrinking_aggie)))
	 ))
     )))

       ;;;;;;;;;;;;;
(defun |float_equal| (ar)
       ;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (or (and (equal arg1 arg2) *ct_ada_true* )
			   *ct_ada_false*)))


       ;;;;;;;;;;;;
(defun |bool_equal| (ar)
       ;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		(cond ((and (eq arg1 *ct_ada_true*) 
			   	  (eq arg2 *ct_ada_true*)) *ct_ada_true* )
		     ((and (eq arg1 *ct_ada_false*) 
	        	       (eq arg2 *ct_ada_false*)) *ct_ada_true*)
		     ((and (or (eq arg1 *ct_ada_true*) 
	        	       (eq arg1 *ct_ada_false*))
			   (or (eq arg2 *ct_ada_true*) 
			       (eq arg2 *ct_ada_false*)))
						*ct_ada_false*)
		      (t (lose 'bop_natv 'bool_equal
				  "not an ada truth value")))))



       ;;;;;;;;;;;;;;
(defun |string_equal| (ar)
       ;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (let ((x (second (convert_strrep_to_lexstr arg1)))
			     (y (second (convert_strrep_to_lexstr arg2))))
			 (or (and (equal x y) *ct_ada_true*)
			      *ct_ada_false*))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; function int_not_equal, float_not_equal, bool_not_equal              ;;;
;;;string_not_equal                                                      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

       ;;;;;;;;;;;;;;;
(defun |int_not_equal| (ar)
       ;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (or (and (not (equal arg1 arg2)) *ct_ada_true*)
			    *ct_ada_false*)))

       ;;;;;;;;;;;;;;;
(defun |any_not_equal| (ar)
       ;;;;;;;;;;;;;;;
  (with_ada_parameters ((arg1 left) (arg2 right))
		       (or (and (not (equal arg1 arg2)) *ct_ada_true*)
			    *ct_ada_false*)))


       ;;;;;;;;;;;;;;;;;
(defun |float_not_equal| (ar)
       ;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (or (and (not (equal arg1 arg2)) *ct_ada_true*)
			   *ct_ada_false*)))


       ;;;;;;;;;;;;;;;;
(defun |bool_not_equal| (ar)
       ;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		(cond ((and (eq arg1 *ct_ada_true*) 
			   	  (eq arg2 *ct_ada_false*)) *ct_ada_true* )
		     ((and (eq arg1 *ct_ada_false*) 
	        	       (eq arg2 *ct_ada_true*)) *ct_ada_true*)
		     ((and (or (eq arg1 *ct_ada_true*) 
	        	       (eq arg1 *ct_ada_false*))
			   (or (eq arg2 *ct_ada_true*) 
			       (eq arg2 *ct_ada_false*)))
						*ct_ada_false*)
		      (t (lose 'bop_natv 'bool_not_equal
				  "not an ada truth value")))))


       ;;;;;;;;;;;;;;;;;;
(defun |string_not_equal| (ar)
       ;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (let ((x (second (convert_strrep_to_lexstr arg1)))
			     (y (second (convert_strrep_to_lexstr arg2))))
			 (or (and (not (equal x y)) *ct_ada_true*)
			     *ct_ada_false*))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; function int_less_than, float_less_than, bool_less_than              ;;;
;;; string_less_than                                                     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

       ;;;;;;;;;;;;;;;
(defun |int_less_than| (ar)
       ;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (or (and (lessp arg1 arg2) *ct_ada_true*)
			   *ct_ada_false*)))

       ;;;;;;;;;;;;;;;;;
(defun |float_less_than| (ar)
       ;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (or (and (lessp arg1 arg2) *ct_ada_true*)
			   *ct_ada_false*)))

       ;;;;;;;;;;;;;;;;
(defun |bool_less_than| (ar)
       ;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		(cond ((and (eq arg1 *ct_ada_false*) 
			   	  (eq arg2 *ct_ada_true*)) *ct_ada_true* )
		     ((and (or (eq arg1 *ct_ada_true*) 
	        	       (eq arg1 *ct_ada_false*))
			   (or (eq arg2 *ct_ada_true*) 
			       (eq arg2 *ct_ada_false*)))
						*ct_ada_false*)
		      (t (lose 'bop_natv 'bool_less_than
				  "not an ada truth value")))))
  
       ;;;;;;;;;;;;;;;;;;
(defun |string_less_than| (ar)
       ;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (string_lt arg1 arg2)))

       ;;;;;;;;;
(defun string_lt (arg1 arg2)
       ;;;;;;;;;
  
  (let ((x (second (convert_strrep_to_lexstr arg1)))
	(y (second (convert_strrep_to_lexstr arg2))))
    (do ((rx x (cdr rx))
	 (ry y (cdr ry)))
	((and (null rx) (null ry)) (return *ct_ada_false*))
      (cond((null ry)(return *ct_ada_false*))
	   ((null rx) (return *ct_ada_true*))
	   ((lessp (car rx) (car ry)) (return *ct_ada_true*))
	   ((greaterp (car rx)(car ry))
	    (return *ct_ada_false*))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; function int_greater_than, float_greater_than, bool_greater_than,;;;
;;; string_greater_than                                              ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
       ;;;;;;;;;;;;;;;;;;
(defun |int_greater_than| (ar)
       ;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (or (and (greaterp arg1 arg2) *ct_ada_true* )
			   *ct_ada_false*)))

       ;;;;;;;;;;;;;;;;;;;;
(defun |float_greater_than| (ar)
       ;;;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (or (and (greaterp arg1 arg2) *ct_ada_true* )
			   *ct_ada_false*)))
  
       ;;;;;;;;;;;;;;;;;;;
(defun |bool_greater_than| (ar)
       ;;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		(cond ((and (eq arg1 *ct_ada_true*) 
			   	  (eq arg2 *ct_ada_false*)) *ct_ada_true* )
		     ((and (or (eq arg1 *ct_ada_true*) 
	        	       (eq arg1 *ct_ada_false*))
			   (or (eq arg2 *ct_ada_true*) 
			       (eq arg2 *ct_ada_false*)))
						*ct_ada_false*)
		      (t (lose 'bop_natv 'bool_greater_than
				  "not an ada truth value")))))  
  
       ;;;;;;;;;;;;;;;;;;;;;
(defun |string_greater_than| (ar)
       ;;;;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (string_gt arg1 arg2)))

       ;;;;;;;;;
(defun string_gt (arg1 arg2)
       ;;;;;;;;;

  (let ((x (second (convert_strrep_to_lexstr arg1)))
	(y (second (convert_strrep_to_lexstr arg2))))
    (do ((rx x (cdr rx))
	 (ry y (cdr ry)))
	((and (null rx) (null ry)) (return *ct_ada_false*))
      (cond((null rx)(return *ct_ada_false*))
	   ((null ry) (return *ct_ada_true*))
	   ((lessp (car rx) (car ry))
	    (return *ct_ada_false*))
	   ((greaterp (car rx)(car ry))
	    (return *ct_ada_true* ))))))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; function int_less_than_or_eq, float_less_than_or_eq,            ;;;
;;; bool_less_than_or_eq, string_less_than_or_eq                    ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
       ;;;;;;;;;;;;;;;;;;;;;
(defun |int_less_than_or_eq| (ar)
       ;;;;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
   (or (and (or (equal arg1 arg2)(lessp arg1 arg2)) *ct_ada_true* )
			   *ct_ada_false*)))
  
  
       ;;;;;;;;;;;;;;;;;;;;;;;
(defun |float_less_than_or_eq| (ar)
       ;;;;;;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
   (or (and (or (equal arg1 arg2) (lessp arg1 arg2)) *ct_ada_true* )
       *ct_ada_false*)))
  
  
       ;;;;;;;;;;;;;;;;;;;;;;
(defun |bool_less_than_or_eq| (ar)
       ;;;;;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		(cond ((and (eq arg1 *ct_ada_true*) 
			   	  (eq arg2 *ct_ada_true*)) *ct_ada_true* )
		     ((and (eq arg1 *ct_ada_false*) 
	        	       (eq arg2 *ct_ada_false*)) *ct_ada_true*)
		     ((and (eq arg1 *ct_ada_false*) 
	        	       (eq arg2 *ct_ada_true*)) *ct_ada_true*)
		     ((and (or (eq arg1 *ct_ada_true*) 
	        	       (eq arg1 *ct_ada_false*))
			   (or (eq arg2 *ct_ada_true*) 
			       (eq arg2 *ct_ada_false*)))
						*ct_ada_false*)
		      (t (lose 'bop_natv 'bool_less_than_eq
				  "not an ada truth value")))))
  
  
       ;;;;;;;;;;;;;;;;;;;;;;;;
(defun |string_less_than_or_eq| (ar)
       ;;;;;;;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
    (or (and (equal *ct_ada_false* (string_gt arg1 arg2))
	     *ct_ada_true* )
			   *ct_ada_false*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; function int_greater_than_or_eq, float_greater_than_or_eq,  ;;;
;;; bool_greater_than_or_eq, string_greater_than_or_eq          ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
       ;;;;;;;;;;;;;;;;;;;;;;;;
(defun |int_greater_than_or_eq| (ar)
       ;;;;;;;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
   (or (and (or (equal arg1 arg2)(greaterp arg1 arg2)) *ct_ada_true* )
       *ct_ada_false*)))
  
  
       ;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun |float_greater_than_or_eq| (ar)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
   (or (and (or (equal arg1 arg2)(greaterp arg1 arg2)) *ct_ada_true* )
       *ct_ada_false*)))
  
  
       ;;;;;;;;;;;;;;;;;;;;;;;;;
(defun |bool_greater_than_or_eq| (ar)
       ;;;;;;;;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		(cond ((and (eq arg1 *ct_ada_true*) 
			   	  (eq arg2 *ct_ada_true*)) *ct_ada_true* )
		     ((and (eq arg1 *ct_ada_false*) 
	        	       (eq arg2 *ct_ada_false*)) *ct_ada_true*)
		     ((and (eq arg1 *ct_ada_true*) 
	        	       (eq arg2 *ct_ada_false*)) *ct_ada_true*)
		     ((and (or (eq arg1 *ct_ada_true*) 
	        	       (eq arg1 *ct_ada_false*))
			   (or (eq arg2 *ct_ada_true*) 
			       (eq arg2 *ct_ada_false*)))
						*ct_ada_false*)
		      (t (lose 'bop_natv 'bool_greater_than_or_eq
				  "not an ada truth value")))))
  
  
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun |string_greater_than_or_eq| (ar)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
   (or (and (equal *ct_ada_false* (string_lt arg1 arg2)) *ct_ada_true* )
       *ct_ada_false*)))
  
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;The Arithmetic functions, +, -, *, /, rem, mod, abs, uplus,    ;;;
;;;uminus, expt, these only operate on integers and floats.       ;;;
;;; there has to be acheck for overflow or underflow during the   ;;;
;;; computation, these will be checked against two constants,     ;;;
;;; *integer_first* and *integer_last*.                           ;;;
;;; These represent the target machines overflow values and if    ;;;
;;; exceeded raise the exception numeric_error.                   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst *targetval* (expt 2 32))  
(defconst *integer_first*  (- *targetval*))
(defconst *integer_last*    (1- *targetval*))
(defconst *fltval* (times 3.4028103 (expt 10. 38)))
(defconst *float_first* (- *fltval*))
(defconst *float_last* (1- *fltval*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; functions int_plus, int_minus, int_divide, int_times, int_rem,;;;
;;; int_ mod, int_exp, int_uplus, int_uminus                      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
       ;;;;;;;;;;
(defun |int_plus| (ar)
       ;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (let ((val (plus arg1 arg2)))
			 (cond ((and (lessp val *integer_last*)
				     (greaterp val *integer_first*)
				     val))
			       (t (ada_raise '|numeric_error| "int_plus"))))))
  
       ;;;;;;;;;;;
(defun |int_minus| (ar)
       ;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (let ((val (difference arg1 arg2)))
			 (cond ((and (lessp val *integer_last*)
				     (greaterp val *integer_first*)
				     val))
			       (t (ada_raise '|numeric_error| "int_minus"))))))

       ;;;;;;;;;;;;
(defun |int_divide| (ar)
  ;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
   (cond ((zerop arg2)
	  (ada_raise '|numeric_error| "int_divide_by_zero"))
	 (t (let ((val (quotient arg1 arg2)))
	      (cond ((and (lessp val *integer_last*)
			  (greaterp val *integer_first*)
			  val))
		    (t (ada_raise '|numeric_error| "int_divide"))))))))
  
  
       ;;;;;;;;;;;
(defun |int_times| (ar)
       ;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (let ((val (times arg1 arg2)))
			 (cond ((and (lessp val *integer_last*)
				     (greaterp val *integer_first*)
				     val))
			       (t (ada_raise '|numeric_error| "int_times"))))))
  
       ;;;;;;;;;
(defun |int_abs| (ar)
       ;;;;;;;;;
  (with_quick_ada_parameters ((arg1 right) )
		       (cond
			 ((minusp arg1) (minus arg1))
			 (t arg1))))

       ;;;;;;;;;;;
(defun |int_uplus| (ar)
       ;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 right) )
		       arg1))

       ;;;;;;;;;
(defun |int_rem| (ar)
       ;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (remainder arg1 arg2)))

       ;;;;;;;;;
(defun |int_mod| (ar)
       ;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (modp arg1 arg2)))

       ;;;;;;;;;;;;
(defun |int_uminus| (ar)
       ;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 right) )
		       (minus arg1)))
  
       ;;;;;;;;;
(defun |int_exp| (ar)
       ;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (let ((val (expt arg1 arg2)))
			 (cond
			   ((or (lessp *integer_last* val)
				(greaterp *integer_first* val))
			    (ada_raise '|numeric_error| "overflow in int_exp"))
			   ((or (plusp arg2)(zerop arg2))(expt arg1 arg2))
			   (t (ada_raise '|numeric_error|
					 "negative exponent in int_exp"))))))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; functions float_plus, float_minus, float_divide, float_times,   ;;;
;;; float_exp,  float_uplus, float_uminus                           ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
       ;;;;;;;;;;;;
(defun |float_plus| (ar)
       ;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (let* ((zunderflow t)
			      (val (car (errset (plus arg1 arg2) nil))))
			 (cond ((and val
				     (lessp val *float_last*)
				     (greaterp val *float_first*)
				     val))
			       (t (ada_raise '|numeric_error| "float_plus"))))))

  
       ;;;;;;;;;;;;;
(defun |float_minus| (ar)
       ;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (let* ((zunderflow t)
			      (val (car (errset (difference arg1 arg2) nil))))
			 (cond ((and val
				     (lessp val *float_last*)
				     (greaterp val *float_first*)
				     val))
			       (t (ada_raise '|numeric_error| "float_minus"))))))

  
       ;;;;;;;;;;;;;;
(defun |float_divide| (ar)
       ;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
   (cond ((zerop arg2)
	  (ada_raise '|numeric_error| "float_divide_by_zero"))
	 (t
	  (let* ((zunderflow t)
		 (val (car (errset (quotient arg1 arg2) nil))))
			 (cond ((and val
				     (lessp val *float_last*)
				     (greaterp val *float_first*)
				     val))
			       (t (ada_raise '|numeric_error| "float_quotient"))))))))
  
  
       ;;;;;;;;;;;;;
(defun |float_times| (ar)
       ;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (let* ((zunderflow t)
			      (val (car (errset (times arg1 arg2) nil))))
			 (cond ((and val
				     (lessp val *float_last*)
				     (greaterp val *float_first*)
				     val))
			       (t (ada_raise '|numeric_error| "float_times"))))))

  
       ;;;;;;;;;;;
(defun |float_abs| (ar)
       ;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 right) )
		       (cond
			 ((minusp arg1) (minus arg1))
			 (t arg1))))
  
       ;;;;;;;;;;;;;
(defun |float_uplus| (ar)
       ;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 right))
		       arg1))
  
       ;;;;;;;;;;;;;;
(defun |float_uminus| (ar)
       ;;;;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 right) )
		       (minus arg1)))
  
       ;;;;;;;;;;;
(defun |float_exp| (ar)
       ;;;;;;;;;;;
  (with_quick_ada_parameters ((arg1 left) (arg2 right))
		       (let* ((zunderflow t)
			      (val (car (errset (expt arg1 arg2) nil))))
			 (cond ((and val
				     (lessp val *float_last*)
				     (greaterp val *float_first*)
				     val))
			       (t (ada_raise '|numeric_error| "float_expt"))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string and character ampersand(&) functions works for all  ;;;
;;; combinations and returns a string                          ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
       ;;;;;;;;;;;;;;;;
(defun assigned_stringp (arraytype)
       ;;;;;;;;;;;;;;;;
  (cond ((and (consp arraytype)
	      (eq (car arraytype) 'lex_string)) )
	(t
	 (let* ((dim (car (ct_send arraytype 'index_list)))
		(len (add1 (- (second dim) (first dim))))
		(arr (ct_send arraytype 'array_storage)))
	   (do ((i 0 (add1 i))
		(state t))
	       ((= i len) state)
	     (cond
	       ((eq
		  (ct_send (aref arr i) 'current_value)
		  '*unassigned*)
		(setq state nil))))))))


       ;;;;;;;;;;;;
(defun |string_&ss| (ar)
       ;;;;;;;;;;;;
  (with_quick_ada_parameters
    ((arg1 left) (arg2 right))
    (cond ((not
	     (and (assigned_stringp arg1)
		  (assigned_stringp arg2)))
	   (ada_raise '|program_error|
	     "An unassigned string in string &")))
		       (let ((x (second (convert_strrep_to_lexstr arg1)))
			     (y (second (convert_strrep_to_lexstr arg2))))
			 (cons 'lex_string (list (append x y))))))

       ;;;;;;;;;;;;
(defun |string_&sc| (ar)
       ;;;;;;;;;;;;
  (with_quick_ada_parameters
    ((arg1 left) (arg2 right))
    (cond ((eq arg2 '*unassigned*)
	   (ada_raise '|program_error|
	     "An unassigned character in string character &"))
	  ((not (assigned_stringp arg1))
	   (ada_raise '|program_error|
	     "An unassigned string in string character &")))
		       (let ((x (second (convert_strrep_to_lexstr arg1)))
			     (y (second (convert_chrrep_to_lexchar arg2))))
			 (cons 'lex_string (list (append x y))))))

       ;;;;;;;;;;;;
(defun |string_&cs| (ar)
       ;;;;;;;;;;;;
  (with_quick_ada_parameters
    ((arg1 left) (arg2 right))
    (cond ((eq arg1 '*unassigned*)
	   (ada_raise '|program_error|
	     "An unassigned character in character string &"))
	  ((not (assigned_stringp arg2))
	   (ada_raise '|program_error|
	     "An unassigned string in character string &")))
		       (let ((x (second (convert_chrrep_to_lexchar arg1)))
			     (y (second (convert_strrep_to_lexstr arg2))))
			 (cons 'lex_string (list (append x y))))))

       ;;;;;;;;;;;;
(defun |string_&cc| (ar)
       ;;;;;;;;;;;;
  (with_quick_ada_parameters
    ((arg1 left) (arg2 right))
    (cond ((or (eq arg1 '*unassigned*)(eq arg2 '*unassigned*))
	   (ada_raise '|program_error|
	     "An unassigned character in character character &")))
		       (let ((x (second (convert_chrrep_to_lexchar arg1)))
			     (y (second (convert_chrrep_to_lexchar arg2))))
			 (cons 'lex_string (list (append x y))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fixed point arithemetic :                                      ;; 
;;       fixed_point_plus, fixed_point_minus, fixed_point_divide  ;;
;;       fixed_point_times, fixed_point_abs, fixed_point_uplus,   ;;
;;       fixed_point_uminus                                       ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	;;;;;;;;;;;;;;;;
(defun |fixed_point_plus| (ar)
	;;;;;;;;;;;;;;;;

  (with_ada_parameters ((arg1 left) (arg2 right))
   (let ((s1 (fixed_pt_value%small_power arg1))
	 (s2 (fixed_pt_value%small_power arg2)))
     (cond ((< s1 s2)
	    (fpv_plus
	      arg1
	      (real_to_fpv_conversion (fpv_to_real_conversion arg2)
				      s1
				      (fixed_pt_value%pointpos arg1))))
	   ((< s2 s1)
	    (fpv_plus
	      (real_to_fpv_conversion (fpv_to_real_conversion arg1)
				      s2
				      (fixed_pt_value%pointpos arg2))
	      arg2))
	   (t (fpv_plus arg1 arg2))
	   )
     )))
       ;;;;;;;;
(defun fpv_plus (f1 f2)
       ;;;;;;;;

  (let* ((f1sn (fixed_pt_value%sign f1))
	 (f2sn (fixed_pt_value%sign f2))
	 (pointpos (fixed_pt_value%pointpos f2))
	 (f1val (ct_if f1sn (fixed_pt_value%mantissa f1)
		       (minus (fixed_pt_value%mantissa f1))))
	 (f2val (ct_if f2sn (fixed_pt_value%mantissa f2)
		       (minus (fixed_pt_value%mantissa f2))))
	 (val (plus f1val f2val))
	 (sn (get-sign val))
         (val (abs val))
         )
    (fixed_pt_value sn val (fixed_pt_value%small_power f1) pointpos)))


	;;;;;;;;;;;;;;;;;
(defun |fixed_point_minus| (ar)
	;;;;;;;;;;;;;;;;;

  (with_ada_parameters ((arg1 left) (arg2 right))
   (let ((s1 (fixed_pt_value%small_power arg1))
	 (s2 (fixed_pt_value%small_power arg2)))
     (cond ((< s1 s2)
	    (fpv_minus
	      arg1
	      (real_to_fpv_conversion (fpv_to_real_conversion arg2)
				      s1
				      (fixed_pt_value%pointpos arg1))))
	   ((< s2 s1)
	    (fpv_minus
	      (real_to_fpv_conversion (fpv_to_real_conversion arg1)
				      s2
				      (fixed_pt_value%pointpos arg2))
	      arg2))
	   (t (fpv_minus arg1 arg2 ))
	   )
     )))
       ;;;;;;;;;
(defun fpv_minus (f1 f2)
       ;;;;;;;;;

  (let* ((f1sn (fixed_pt_value%sign f1))
	 (f2sn (fixed_pt_value%sign f2))
	 (pointpos (fixed_pt_value%pointpos f2))
	 (f1val (CT_IF f1sn (fixed_pt_value%mantissa f1)
		       (minus (fixed_pt_value%mantissa f1))))
	 (f2val (ct_if f2sn (fixed_pt_value%mantissa f2)
		       (minus (fixed_pt_value%mantissa f2))))
	 (val (difference f1val f2val))
	 (sn (get-sign val))
	 (val (ABS VAL))
         )
    (fixed_pt_value sn val (fixed_pt_value%small_power f1) pointpos)))

(defun |fixed_point_divide| (ar)
  (with_ada_parameters ((arg1 left) (arg2 right))
   (cond ((zerop (fixed_pt_value%mantissa arg2))
	  (ada_raise '|numeric_error| "fixed_point_divide_by_zero")))
   (let ((s1 (fixed_pt_value%small_power arg1))
	 (s2 (fixed_pt_value%small_power arg2)))
     (cond ((< s1 s2)
	    (fpv_divide
	      arg1
	      (real_to_fpv_conversion (fpv_to_real_conversion arg2)
				      s1
				      (fixed_pt_value%pointpos arg1))))
	   ((< s2 s1)
	    (fpv_divide
	      (real_to_fpv_conversion (fpv_to_real_conversion arg1)
				      s2
				      (fixed_pt_value%pointpos arg2))
	      arg2))
	   (t (fpv_divide arg1 arg2 ))
	   )
     )))

   ;;;;;;;;;;
(defun fpv_divide (f1 f2)
  ;;;;;;;;;;
  
  (let* ((f1sn (fixed_pt_value%sign f1))
	 (f2sn (fixed_pt_value%sign f2))
	 (pointpos (fixed_pt_value%pointpos f2))
	 (f1val (ct_if f1sn (fixed_pt_value%mantissa f1)
		       (minus (fixed_pt_value%mantissa f1))))
	 (f2val (ct_if f2sn (fixed_pt_value%mantissa f2)
		       (minus (fixed_pt_value%mantissa f2))))
	 (fval (real_to_fpv_conversion (float (quotient (float f1val) f2val))
				       (fixed_pt_value%small_power f1)	       
				       pointpos))
	 (val (fixed_pt_value%mantissa fval))
	 (sn (fixed_pt_value%sign fval))
	 ) 
    (fixed_pt_value sn val (fixed_pt_value%small_power f1) pointpos)))

	;;;;;;;;;;;;;;;;;
(defun |fixed_point_times| (ar)
	;;;;;;;;;;;;;;;;;

  (with_ada_parameters ((arg1 left) (arg2 right))
   (let ((s1 (fixed_pt_value%small_power arg1))
	 (s2 (fixed_pt_value%small_power arg2)))
     (cond ((< s1 s2)
	    (fpv_times
	      arg1
	      (real_to_fpv_conversion (fpv_to_real_conversion arg2)
				      s1
				      (fixed_pt_value%pointpos arg1))))
	   ((< s2 s1)
	    (fpv_times
	      arg1
	      (real_to_fpv_conversion (fpv_to_real_conversion arg1)
				      s2
				      (fixed_pt_value%pointpos arg2))))
	   (t (fpv_times arg1 arg2))
	   )
     )))

       ;;;;;;;;;
(defun fpv_times (f1 f2)
       ;;;;;;;;;

  (let* ((f1sn (fixed_pt_value%sign f1))
	 (f2sn (fixed_pt_value%sign f2))
	 (pointpos (fixed_pt_value%pointpos f2))
	 (f1val (fixed_pt_value%mantissa f1))
	 (f2val (fixed_pt_value%mantissa f2))
	 (val #+franz (lsh (times f1val f2val) (times -2 pointpos))
	      #+lispm (lsh (times f1val f2val)
			   (fixed_pt_value%small_power f2)))
	 (sn (and f1sn f2sn))
	 (val (ct_if sn val (minus val))))
    (fixed_pt_value sn val (fixed_pt_value%small_power f1) pointpos)))

	;;;;;;;;;;;;;;;
(defun |fixed_point_abs| (ar)
	;;;;;;;;;;;;;;;

  (with_ada_parameters ((arg1 right) )
   (fixed_pt_value t
		   (fixed_pt_value%mantissa arg1)
		   (fixed_pt_value%small_power arg1)
		   (fixed_pt_value%pointpos arg1))))

	;;;;;;;;;;;;;;;;;
(defun |fixed_point_uplus| (ar)
	;;;;;;;;;;;;;;;;;

  (with_ada_parameters ((arg1 right) )
		        arg1))

	;;;;;;;;;;;;;;;;;;
(defun |fixed_point_uminus| (ar)
	;;;;;;;;;;;;;;;;;;

  (with_ada_parameters ((arg1 right) ) 
   (fixed_pt_value nil
		   (fixed_pt_value%mantissa arg1)
		   (fixed_pt_value%small_power arg1)
		   (fixed_pt_value%pointpos arg1))))


;;
;; fixed point relational operators:
;;       fixed_point_equal, fixed_point_not_equal, fixed_point_less_than,
;;       fixed_point_less_than_or_equal, fixed_point_greater_than,
;;       fixed_point_greater_than_or_equal
;;

	;;;;;;;;;;;;;;;;;
(defun |fixed_point_equal| (ar)
	;;;;;;;;;;;;;;;;;

    (with_ada_parameters ((arg1 left) (arg2 right))
     (let ((s1 (fixed_pt_value%small_power arg1))
	   (s2 (fixed_pt_value%small_power arg2)))
       (cond ((= s1 s2)
	      (ct_if (fpv_equal arg1 arg2)
		     *ct_ada_true*
		     *ct_ada_false*))
	     (t (ct_if (= (fpv_to_real_conversion arg1)
			  (fpv_to_real_conversion arg2))
		       *ct_ada_true*
		       *ct_ada_false*))
	     ))))
	;;;;;;;;;
(defun  fpv_equal (f1 f2)
	;;;;;;;;;

  (and (equal (fixed_pt_value%sign f1) (fixed_pt_value%sign f2))
       (equal (fixed_pt_value%mantissa f1) (fixed_pt_value%mantissa f2))))

	;;;;;;;;;;;;;;;;;;;;;
(defun |fixed_point_not_equal| (ar)
	;;;;;;;;;;;;;;;;;;;;;

    (with_ada_parameters ((arg1 left) (arg2 right))
     (let ((s1 (fixed_pt_value%small_power arg1))
	   (s2 (fixed_pt_value%small_power arg2)))
       (cond ((= s1 s2)
	      (ct_if (not (fpv_equal arg1 arg2))
		     *ct_ada_true*
		     *ct_ada_false*))
	     (t (ct_if (not (= (fpv_to_real_conversion arg1)
			  (fpv_to_real_conversion arg2)))
		       *ct_ada_true*
		       *ct_ada_false*))
	     ))))

	;;;;;;;;;;;;;;;;;;;;;
(defun |fixed_point_less_than| (ar)
	;;;;;;;;;;;;;;;;;;;;;

    (with_ada_parameters ((arg1 left) (arg2 right))
     (let ((s1 (fixed_pt_value%small_power arg1))
	   (s2 (fixed_pt_value%small_power arg2)))
       (cond ((= s1 s2)
	      (ct_if (fpv_lessp arg1 arg2)
		     *ct_ada_true*
		     *ct_ada_false*))
	     (t (ct_if (< (fpv_to_real_conversion arg1)
			  (fpv_to_real_conversion arg2))
		       *ct_ada_true*
		       *ct_ada_false*))
	     ))))
       ;;;;;;;;;
(defun fpv_lessp (f1 f2)
       ;;;;;;;;;

  (let ((f1sn (fixed_pt_value%sign f1))
	(f2sn (fixed_pt_value%sign f2)))
    (cond ((eq f1sn f2sn)
	   (ct_if f1sn (lessp (fixed_pt_value%mantissa f1)
			      (fixed_pt_value%mantissa f2))
		  (lessp (fixed_pt_value%mantissa f2)
			      (fixed_pt_value%mantissa f1))))
	  (t (ct_if f1sn nil t)))))

	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun |fixed_point_less_than_or_equal| (ar)
	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (with_ada_parameters ((arg1 left) (arg2 right))
     (let ((s1 (fixed_pt_value%small_power arg1))
	   (s2 (fixed_pt_value%small_power arg2)))
       (cond ((= s1 s2)
	      (ct_if (or (fpv_lessp arg1 arg2)
			 (fpv_equal arg1 arg2))
		     *ct_ada_true*
		     *ct_ada_false*))
	     (t (ct_if (not (> (fpv_to_real_conversion arg1)
			  (fpv_to_real_conversion arg2)))
		       *ct_ada_true*
		       *ct_ada_false*))
	     ))))

	;;;;;;;;;;;;;;;;;;;;;;;;
(defun |fixed_point_greater_than| (ar)
	;;;;;;;;;;;;;;;;;;;;;;;;

    (with_ada_parameters ((arg1 left) (arg2 right))
     (let ((s1 (fixed_pt_value%small_power arg1))
	   (s2 (fixed_pt_value%small_power arg2)))
       (cond ((= s1 s2)
	      (ct_if (fpv_lessp arg2 arg1)
		     *ct_ada_true*
		     *ct_ada_false*))
	     (t (ct_if (> (fpv_to_real_conversion arg1)
			  (fpv_to_real_conversion arg2))
		       *ct_ada_true*
		       *ct_ada_false*))
	     ))))

	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun |fixed_point_greater_than_or_equal| (ar)
	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (with_ada_parameters ((arg1 left) (arg2 right))
     (let ((s1 (fixed_pt_value%small_power arg1))
	   (s2 (fixed_pt_value%small_power arg2)))
       (cond ((= s1 s2)
	      (ct_if (or (fpv_lessp arg2 arg1)
			 (fpv_equal arg1 arg2))
		     *ct_ada_true*
		     *ct_ada_false*))
	     (t (ct_if (not (< (fpv_to_real_conversion arg1)
			       (fpv_to_real_conversion arg2)))
		       *ct_ada_true*
		       *ct_ada_false*))
	     ))))

;;;;;;

;;;These are the special operators for universal integer times 
;;; universal_real and universal real times universal integer,
;;;and universal real divided by universal integer.

	;;;;;;;;;;;;;;;;;;
(defun |uni_real_int_times| (ar)
	;;;;;;;;;;;;;;;;;;

  (with_ada_parameters ((arg1 left) (arg2 right))
		       (let ((x (float arg1))
			     (y (float arg2)))
			 (times x y))))
	;;;;;;;;;;;;;;;;;;
(defun |uni_int_real_times| (ar)
	;;;;;;;;;;;;;;;;;;

  (with_ada_parameters ((arg1 left) (arg2 right))
		       (let ((x (float arg1))
			     (y (float arg2)))
			 (times x y))))
	;;;;;;;;;;;;;;;;;;;
(defun |uni_real_int_divide| (ar)
	;;;;;;;;;;;;;;;;;;;

  (with_ada_parameters
    ((arg1 left) (arg2 right))
    (cond ((zerop arg2)
	   (ada_raise
	     '|numeric_error|
	     "universal_real_divided_by_universal_integer_zero"))
	  (t (let ((x (float arg1))
		  (y (float arg2)))
	      (quotient x y))))))

;;;;;;
	;;;;;;;;;;
(defun |char_equal| (ar)
	;;;;;;;;;;

    (with_quick_ada_parameters ((arg1 left) (arg2 right))
			 (cond
			   ((eq arg1 arg2) *ct_ada_true*)
			   (t *ct_ada_false*))))
	;;;;;;;;;;;;;;
(defun |char_not_equal| (ar)
	;;;;;;;;;;;;;;

    (with_quick_ada_parameters  ((arg1 left) (arg2 right))
			 (cond
			   ((eq arg1 arg2) *ct_ada_false*)
			   (t *ct_ada_true*))))









;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; internal Use Only Functions/Macros -- 

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