;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(macsyma-module nummac macro)

;;; macros for "numerical" code.


(DEFVAR *FLOAT-GENCALL-STACK* NIL "set up by GCALL-LET")

#+Multics
(defmacro flonum-identity (x)
  `(+$ ,x))
#+Multics
(defmacro fixnum-identity (x)
  `(+ ,x))

(DEFUN GET-S (IND V)
       (CDR (ASSQ V (CDR (ASSQ IND *FLOAT-GENCALL-STACK*)))))
(DEFUN PUT-S (IND VAL V)
       (LET ((FRAME (ASSQ IND *FLOAT-GENCALL-STACK*)))
	    (COND (FRAME
		   (SETF (CDR FRAME)
			 (CONS (CONS V VAL) (CDR FRAME))))
		  (T
		   (PUSH `(,IND  (,V . ,VAL)) *FLOAT-GENCALL-STACK*)))))

(comment '|
;What you do is
(gcall-bind (f g h) ...
 ; and then inside the body of this form you can do
 (gcall f x)
 ; which will be a fast call like (funcall f x)
 ; but with hacks.
 )
|)

(DEFMACRO GCALL (F X &optional (erst nil erst-p))
  `(#+maclisp
    FLONUM-IDENTITY
    #+lispm
    PROGN
    (COND #+maclisp
	  (,(GET-S F 'SUBRCALL-FLONUMP)
	   (SUBRCALL FLONUM ,F ,X))
	  #+maclisp
	  (,(GET-S F 'SUBRCALLP)
	   (SUBRCALL T ,F ,X))
	  (,(GET-S F 'LISPCALLP)
	   (FUNCALL ,F ,X))
	  (T (FMAPPLY ,F (LIST ,X)
		      ,@(if erst-p (list erst) nil))))))

(EVAL-WHEN (COMPILE EVAL)
	   (DEFMACRO CONCAT (A B)
		     `(IMPLODE (APPEND (EXPLODEN ,A) (EXPLODEN ,B)))))

(DEFMACRO GCALL-BIND (FUNLIST &REST BODY)
  `(LET* (,@(APPLY 'APPEND
		  (MAPCAR #'(LAMBDA (FUN)
				    (AND (ATOM FUN) (SETQ FUN (LIST FUN FUN)))
				    (LET* ((FF (CAR FUN))
					   (FS (CADR FUN))
					   #+maclisp
					   (SUBRCALL-FLONUMP
					    (CONCAT '|subr$p~| FS))
					   
					   #+maclisp
					   (SUBRCALLP (CONCAT '|subrp~| FS))
					   (LISPCALLP (CONCAT '|lispp~| FS)))
					 #+maclisp
					 (PUT-S FF SUBRCALL-FLONUMP
						'SUBRCALL-FLONUMP)
					 #+maclisp
					 (PUT-S FF SUBRCALLP 'SUBRCALLP)
					 (PUT-S FF LISPCALLP 'LISPCALLP)
					 `(#+maclisp
					   (,SUBRCALL-FLONUMP (SUBRCALL$P ,FS))
					   #+maclisp
					   (,SUBRCALLP (SUBRCALLP ,FS))
					   (,LISPCALLP (NOT (MACSYMACALLP ,FS)))
					   #+maclisp
					   (,FF (COND (,SUBRCALLP ,SUBRCALLP)
						      (T ,FS)))
					   #+lispm
					   (,FF ,FS))))
			  FUNLIST)))
	 ,@BODY))


#+maclisp
(DEFMACRO AREF$ (&REST ARGS)
	  `(ARRAYCALL FLONUM ,@ARGS))
#+maclisp
(DEFMACRO ASET$ (VAL &REST ARGS)
	  `(STORE (ARRAYCALL FLONUM ,@ARGS) ,VAL))