;;; -*- Mode: Lisp; Package: Macsyma -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;          Compilation environment for TRANSLATED MACSYMA code.        ;;;
;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; this are COMPILE-TIME macros for TRANSLATE MACSYMA code.
;;; these guys are either SUBR's LSUBR's or FEXPRS in the interpreter.
;;; (ask me about why I used FEXPRS sometime ok.) -gjc.

(macsyma-module transq macro)
(load-macsyma-macros transm defopt)

;;; Already defined in transl module.
#-LispM
(DEFVAR $TR_SEMICOMPILE NIL) ; T if expanding for expr code.

;;; function for putting good info in the UNFASL file.

#+PDP10

(PROGN 'COMPILE

(DECLARE (SPECIAL CMSGFILES))

(DEFVAR MACRO-FILES NIL)

(DEFUN UNFASL-ANNOTATE-VERSIONS ()
  (LET ((UNFASL (IF (EQ (CAAR (NAMELIST (CAR CMSGFILES))) 'DSK)
		    (CAR CMSGFILES)
		    (CADR CMSGFILES))))
       (FORMAT UNFASL '|~%;; Compilation by ~A~%|
	       (STATUS UNAME))
       (FORMAT UNFASL '|;; ~15A~A~%|
	       '|Prelude file:|
	       (LET ((X (TRUENAME INFILE)))
		    (NAMESTRING (CONS (CDAR X) (CDR X)))))
       (FORMAT UNFASL '|;; ~15A| '|Macro files:|)
       (FORMAT UNFASL '|~{~<~%;; ~15X~:;~A ~A~>~^, ~}~%|
	       (DO ((L NIL (CONS (GET (CAR X) 'VERSION) (CONS (CAR X) L)))
		    (X MACRO-FILES (CDR X)))
		   ((NULL X) (NREVERSE L))))))
;; END of #+PDP10
)

(defmacro def-mtrvar (v a &optional (priority 1))
  priority
  ;; ignored variable around for TRANSLATED files pre 
  ;; 3:03pm  Thursday, 11 March 1982 -gjc
  `(progn 'compile
	  (declare (special ,v))
	  (if (or (not (boundp ',v))
		  ;; a SYMBOL SET to ITSELF is considered to be
		  ;; UNBOUND for our purposes in Macsyma.
		  (eq ,v ',v))
	      (setq ,v ,a))))

(DEFOPT TRD-MSYMEVAL (VAR &rest ignore)
  VAR)

(DEFVAR *MAX-EXPT$-EXPAND* 7)

(DEFOPT EXPT$ (BAS EXP)
  (if (not (fixp exp))
      (ERROR `(|Internal TRANSL error. Call GJC| ,BAS ,EXP)))
  (LET* ((ABS-EXP (ABS EXP))
	 (FULL-EXP (COND ((NOT (> EXP *MAX-EXPT$-EXPAND*))
			  `(INTERNAL-EXPT$ ,BAS ,ABS-EXP))
			 (T
			  `(^$ ,BAS ,ABS-EXP)))))
    (COND ((MINUSP EXP)
	   `(//$ ,FULL-EXP))
	  (T FULL-EXP))))

(DEFOPT INTERNAL-EXPT$ (EXP-BASE POS-EXP)
  (COND ((= POS-EXP 0)
	 ;; BROM  wrote X^0 for symmetry in his code, and this
	 ;; macro did some infinite looping! oops.
	 ;; X^0 can only happen in hand-written code, in macros
	 ;; the general-representation simplifier will get rid
	 ;; of it.
	 1.0)
	((= POS-EXP 1)
	 EXP-BASE)
	((NOT (ATOM EXP-BASE))
	 (LET ((SYM (GENSYM)))
	   `(LET ((,SYM ,EXP-BASE))
	      (DECLARE (FLONUM ,SYM))
	      (INTERNAL-EXPT$ ,SYM ,POS-EXP))))
	((= POS-EXP 2)
	 `(*$ ,EXP-BASE ,EXP-BASE))
	((= POS-EXP 3) `(*$ (*$ ,EXP-BASE ,EXP-BASE) ,EXP-BASE))
	((= POS-EXP 4)
	 `(INTERNAL-EXPT$ (INTERNAL-EXPT$ ,EXP-BASE 2) 2))
	((= pos-EXP 5)
	 `(*$ (INTERNAL-EXPT$ ,EXP-BASE 4) ,EXP-BASE))
	((= pos-exp 6)
	 `(internal-expt$ (internal-expt$ ,EXP-BASE 3) 2))
	((= pos-exp 7)
	 `(*$ ,EXP-BASE (internal-expt$ ,EXP-BASE 6)))
	(T
	 `(*$ ,@(LISTN EXP-BASE POS-EXP)))))

;;; There is a real neat and fancy way to do the above for arbitrary N
;;; repeated squaring in a recrusive fashion.  It is trivial to do
;;; and should be done at some point.

;; (LISTN 'A 3) --> (A A A)

(DEFUN LISTN (X N)
  (DO ((L NIL (CONS X L)))
      ((MINUSP (SETQ N (1- N))) L)))

#+PDP10
(PROGN 'COMPILE

(DEFVAR *KNOWN-FUNCTIONS-INFO-STACK* NIL
	"When MDEFUN expands it puts stuff here for MFUNCTION-CALL
	to use.")
(DEFVAR *UNKNOWN-FUNCTIONS-INFO-STACK* NIL
	"When MFUNCTION-CALL expands without info from
	*KNOWN-FUNCTIONS-INFO-STACK* it puts stuff here to be barfed
	at the end of compilation.")

(DEFOPT MFUNCTION-CALL (F &REST ARGL
			  &AUX (INFO (GET-INFO F *KNOWN-FUNCTIONS-INFO-STACK*)))
  (COND ((OR (MEMQ INFO '(LEXPR EXPR))
	     (GETL F '(*EXPR *LEXPR)))
	 `(,F ,@ARGL))
	((GET F '*FEXPR)
	 (FORMAT MSGFILES
		 "~&(COMMENT *MACSYMA* unhandled FEXPR ~S may barf)~%"
		 F)
	 `(,F ,@ARGL))
	((EQ INFO 'LUSER)
	 (COMMENT ???)
	 `(APPLY ',F ',ARGL))
	(T
	 (PUSH-INFO F ARGL *UNKNOWN-FUNCTIONS-INFO-STACK*)
	 `(funcall (progn ',f) ,@argl))))

;;; A call to this macro is pushed onto the EOF-COMPILE-QUEUE
(DECLARE (SPECIAL TTYNOTES))
(DEFMACRO UNKNOWN-FUNCTIONS-COMMENT ()
  (LET ((UNKNOWNS (RESOLVE-KNOWN-AND-UNKNOWN-FUNCTIONS))
	(M1 "*MACSYMA* ")
	(M2 "
        -are user functions used but not defined in this file."))
    (COND (UNKNOWNS
	   (SETQ UNKNOWNS
		 `(COMMENT ,M1 ,UNKNOWNS ,M2))
	   (COND (TTYNOTES
		  (TERPRI TYO)
		  (PRINT UNKNOWNS TYO)
		  (TERPRI TYO)))
	   UNKNOWNS))))

(DEFUN RESOLVE-KNOWN-AND-UNKNOWN-FUNCTIONS ()
  (DO ((UN))
      ((NULL *UNKNOWN-FUNCTIONS-INFO-STACK*)
       UN)
    (LET ((IND (TOP-IND *UNKNOWN-FUNCTIONS-INFO-STACK*)))
      (POP-INFO IND *UNKNOWN-FUNCTIONS-INFO-STACK*)
      (COND ((POP-INFO IND *KNOWN-FUNCTIONS-INFO-STACK*))
	    (T
	     (PUSH IND UN))))))
;; END OF #+PDP10
)

#-PDP10
(DEFOPT MFUNCTION-CALL (F &REST L)
  (CONS F L))

;;; macros for compiled environments.

;;; (FUNGEN&ENV-for-meval <eval vars list> <late eval vars list> .  <EXP>)
;;; will define a function globally with a unique name
;;; (defun <name> <list of variables> <exp>). And return
;;; `((<name>) ,@<eval>> . <late eval>). The resulting expression may
;;; then be passed to a function which will bind variables from
;;; the <late eval vars list> and possibly other variables free in
;;; <exp> and then call MEVAL on the expression.
;;; FUNGEN&ENV-FOR-MEVALSUMARG will also make sure that the <name>
;;; has an mevalsumarg property of T.
;;; the expression was translated using TR-LAMBDA.

(DEFVAR *INFILE-NAME-KEY* '||
  "This is a key gotten from the infile name, in the interpreter
  other completely hackish things with FSUBRS will go on.")

#+Maclisp
(DEFUN GEN-NAME ( &OPTIONAL K &AUX (N '#,(*ARRAY NIL 'FIXNUM 1)))
  (STORE (ARRAYCALL FIXNUM N 0) (1+ (ARRAYCALL FIXNUM N 0)))
  (AND K (STORE (ARRAYCALL FIXNUM N 0) K))
  (IMPLODE (APPEND (EXPLODEN *INFILE-NAME-KEY*)
		   (EXPLODEN '|-tr-gen-|)
		   (EXPLODEN (ARRAYCALL FIXNUM N 0)))))

#+LISPM
(PROGN 'COMPILE
(defvar a-random-counter-for-gen-name 0)
(DEFUN GEN-NAME (&OPTIONAL IGNORE) 
  (intern (format nil "~A ~A #~D"
		  (status site)
		  (time:print-current-time ())
		  (setq a-random-counter-for-gen-name
			(1+ a-random-counter-for-gen-name)))))
)

(DEFUN ENSURE-A-CONSTANT-FOR-MEVAL (EXP)
  (COND ((OR (NUMBERP EXP) (MEMQ EXP '(T NIL)))
	 EXP)
	(T
	 `(LET ((VAL ,EXP))
	    (COND ((OR (NUMBERP VAL) (MEMQ VAL '(T NIL)))
		   VAL)
		  (T (LIST '(MQUOTE SIMP) VAL)))))))

(DEFMACRO PROC-EV (X)
  `(MAPCAR #'ENSURE-A-CONSTANT-FOR-MEVAL ,X))

(defvar forms-to-compile-queue ())

(defmacro compile-forms-to-compile-queue ()
  (IF FORMS-TO-COMPILE-QUEUE
      (NCONC (LIST 'PROGN ''COMPILE)
	     (PROG1 FORMS-TO-COMPILE-QUEUE
		    (SETQ FORMS-TO-COMPILE-QUEUE NIL))
	     '((COMPILE-FORMS-TO-COMPILE-QUEUE)))))

(DEFUN EMIT-DEFUN (EXP)
  (IF $TR_SEMICOMPILE (SETQ EXP `(PROGN ,EXP)))
  #-LISPM
  (SETQ FORMS-TO-COMPILE-QUEUE (NCONC FORMS-TO-COMPILE-QUEUE (LIST EXP)))
  #+LISPM
  (let ((default-cons-area working-storage-area))
      (SETQ FORMS-TO-COMPILE-QUEUE (NCONC FORMS-TO-COMPILE-QUEUE (LIST (COPYTREE EXP))))))

(DEFOPT FUNGEN&ENV-FOR-MEVAL (EV EV-LATE EXP
				   &AUX (NAME (GEN-NAME)))
  (EMIT-DEFUN `(DEFUN ,NAME (,@EV ,@EV-LATE) ,EXP))
  `(LIST* '(,NAME) ,@(PROC-EV EV)
	  ',EV-LATE))

(DEFOPT FUNGEN&ENV-FOR-MEVALSUMARG (EV EV-LATE TR-EXP MAC-EXP
					 &AUX (NAME (GEN-NAME)))
  (EMIT-DEFUN
   `(DEFUN ,NAME (,@EV-LATE)
      (LET ((,EV (GET ',NAME 'SUMARG-ENV)))
	,TR-EXP)))
  
  (EMIT-DEFUN
   `(DEFUN (,NAME MEVALSUMARG-MACRO) (*IGNORED*)
      (MBINDING (',EV (GET ',NAME 'SUMARG-ENV))
		(MEVALATOMS ',MAC-EXP))))
  
  `(PROGN (PUTPROP ',NAME (LIST ,@EV) 'SUMARG-ENV)
	  (LIST '(,NAME) ',@EV-LATE)))

;;; the lambda forms.

(DEFOPT M-TLAMBDA (&REST L &AUX (NAME (GEN-NAME)))
  (EMIT-DEFUN `(DEFUN ,NAME ,@L))
  
  ;; just in case this is getting passed in as
  ;; SUBST(LAMBDA([U],...),"FOO",...)
  ;; this little operator property will make sure the right thing
  ;; happens!
  
  (EMIT-DEFUN
    `(DEFPROP ,NAME APPLICATION-OPERATOR OPERATORS))
  ;; must be 'NAME since #'NAME doesn't point to the operators
  ;; property.
  `',NAME)

(defmacro pop-declare-statement (l)
  `(and (not (atom (car ,l)))
	(eq (caar ,l) 'declare)
	(pop ,l)))
       
(DEFOPT M-TLAMBDA& (ARGL &REST BODY &AUX (NAME (GEN-NAME)))
  (EMIT-DEFUN
   `(DEFUN ,NAME (,@(REVERSE (CDR (REVERSE ARGL)))
		  &REST ,@(LAST ARGL))
      ,(pop-declare-statement body)
      (SETQ ,(CAR (LAST ARGL))
	    (CONS '(MLIST) ,(CAR (LAST ARGL))))
      ,@BODY))

  (EMIT-DEFUN `(DEFPROP ,NAME APPLICATION-OPERATOR OPERATORS))
  `',NAME)

(DEFUN FOR-EVAL-THEN-QUOTE (VAR)
  `(list 'QUOTE ,VAR))

(DEFUN FOR-EVAL-THEN-QUOTE-ARGL (ARGL)
  (MAPCAR 'FOR-EVAL-THEN-QUOTE ARGL))

;; Problem: You can pass a lambda expression around in macsyma
;; because macsyma "general-rep" has a CAR which is a list.
;; Solution: Just as well anyway.

(DEFOPT M-TLAMBDA&ENV ((REG-ARGL ENV-ARGL) &REST BODY
					     &AUX (NAME (GEN-NAME)))
  (EMIT-DEFUN `(DEFUN ,NAME (,@ENV-ARGL ,@REG-ARGL)
		 ,@BODY))
  
  
  `(MAKE-ALAMBDA ',REG-ARGL
	 (LIST* ',NAME ,@(FOR-EVAL-THEN-QUOTE-ARGL ENV-ARGL) ',REG-ARGL)))

(DEFOPT M-TLAMBDA&ENV& ((REG-ARGL ENV-ARGL) &REST BODY &AUX (NAME (GEN-NAME)))
  (EMIT-DEFUN `(DEFUN ,NAME (,@ENV-ARGL ,@REG-ARGL) ,@BODY))
  `(MAKE-ALAMBDA '*N*
	 (LIST* ',NAME ,@(FOR-EVAL-THEN-QUOTE-ARGL ENV-ARGL)
		',(DO ((N (LENGTH REG-ARGL))
		       (J 1 (1+ J))
		       (L NIL))
		      ((= J N)
		       (PUSH `(CONS '(MLIST) (LISTIFY (- ,(1- N) *N*))) L)
		       (NREVERSE L))
		    (PUSH `(ARG ,J) L)))))

;;; this is the important case for numerical hackery.

(DEFUN DECLARE-SNARF (BODY)
  (COND ((AND (NOT (ATOM (CAR BODY)))
	      (EQ (CAAR BODY) 'DECLARE))
	 (LIST (CAR BODY)))
	(T NIL)))


;;; I will use the special variable given by the NAME as a pointer to
;;; an environment.

(DEFOPT M-TLAMBDA-I (MODE ENV ARGL &REST BODY
			    &AUX (NAME (GEN-NAME))
			    (DECLAREP (DECLARE-SNARF BODY)))
  (cond ((eq mode '$float)
	 (EMIT-DEFUN `(DECLARE (FLONUM (,NAME ,@(LISTN NIL (LENGTH ARGL))))))
	 (EMIT-DEFUN `(DEFPROP ,NAME T FLONUM-COMPILED))))
  (EMIT-DEFUN
   `(DEFUN ,NAME ,ARGL
      ,@DECLAREP
      (LET ((,ENV ,NAME))
	,@(COND (DECLAREP (CDR BODY))
		(T BODY)))))
  (EMIT-DEFUN `(SETQ ,NAME ',(LISTN NIL (LENGTH ENV))))
  `(PROGN (SET-VALS-INTO-LIST ,ENV ,NAME)
	  (QUOTE ,NAME)))

;;; This is not optimal code.
;;; I.E. IT SUCKS ROCKS.

(DEFMACRO SET-VALS-INTO-LIST (ARGL VAR)
  (DO ((J 0 (1+ J))
       (ARGL ARGL (CDR ARGL))
       (L NIL
	  `((SETF (NTH ,J ,VAR) ,(CAR ARGL)) ,@L)))
      ((NULL ARGL) `(PROGN ,@L))))