src/troper.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module troper)
  14
  15 ;;; The basic OPERATORS properties translators.
  16
  17 (def%tr mminus (form)
  18   (setq form (translate (cadr form)))
  19   (cond ((numberp (cdr form))
  20          `(,(car form) . ,(- (cdr form))))
  21         ((eq '$fixnum (car form)) `($fixnum - ,(cdr form)))
  22         ((eq '$float (car form)) `($float - ,(cdr form)))
  23         ((eq '$number (car form)) `($number - ,(cdr form)))
  24         ((eq '$rational (car form))
  25          (cond ((and (not (atom (caddr form))) (eq 'rat (caar (caddr form))))
  26                 (setq form (cdaddr form))
  27                 `($rational quote ((rat) ,(- (car form)) ,(cadr form))))
  28                (t `($rational rtimes -1 ,(cdr form)))))
  29         (t `($any . (*mminus ,(cdr form))))))
  30
  31 (def%tr mplus (form)
  32   (let   (args mode)
  33     (do ((l (cdr form) (cdr l))) ((null l))
  34       (setq args (cons (translate (car l)) args)
  35             mode (*union-mode (car (car args)) mode)))
  36     (setq args (nreverse args))
  37     (cond ((eq '$fixnum mode) `($fixnum + . ,(mapcar #'cdr args)))
  38           ((eq '$float mode) `($float + . ,(mapcar #'dconv-$float args)))
  39           ((eq '$rational mode) `($rational rplus . ,(mapcar #'cdr args)))
  40           ((eq '$number mode) `($number + . ,(mapcar #'cdr args)))
  41           (t `($any add* . ,(mapcar #'dconvx args))))))
  42
  43 (def%tr mtimes (form)
  44   (let (args mode)
  45     (cond ((equal -1 (cadr form))
  46            (translate `((mminus) ((mtimes) . ,(cddr form)))))
  47           (t
  48            (do ((l (cdr form) (cdr l)))
  49                ((null l))
  50              (setq args (cons (translate (car l)) args)
  51                    mode (*union-mode (car (car args)) mode)))
  52            (setq args (nreverse args))
  53            (cond ((eq '$fixnum mode) `($fixnum * . ,(mapcar #'cdr args)))
  54                  ((eq '$float mode) `($float * . ,(mapcar #'dconv-$float args)))
  55                  ((eq '$rational mode) `($rational rtimes . ,(mapcar #'cdr args)))
  56                  ((eq '$number mode) `($number * . ,(mapcar #'cdr args)))
  57                  (t `($any mul* . ,(mapcar #'dconvx args))))))))
  58
  59
  60 (def%tr mquotient (form)
  61   (let (arg1 arg2 mode)
  62     (setq arg1 (translate (cadr form))
  63           arg2 (translate (caddr form))
  64           mode (*union-mode (car arg1) (car arg2))
  65           arg1 (dconv arg1 mode)
  66           arg2 (dconv arg2 mode))
  67     (cond ((eq '$float mode)
  68            (setq arg1 (if (member arg1 '(1 1.0) :test #'equal)
  69                           (list arg2)
  70                           (list arg1 arg2)))
  71            `($float / . ,arg1))
  72           ((and (eq mode '$fixnum) $tr_numer)
  73            `($float . (/ (float ,arg1) (float ,arg2))))
  74           ((member mode '($fixnum $rational) :test #'eq)
  75            `($rational rremainder ,arg1 ,arg2))
  76           (t `($any div ,arg1 ,arg2)))))
  77
  78 (defvar $tr_exponent nil
  79   "If True it allows translation of x^n to generate (expt $x $n) if $n is fixnum and $x is fixnum, or number")
  80
  81 (def%tr mexpt (form)
  82   (if (eq '$%e (cadr form)) (translate `(($exp) ,(caddr form)))
  83       (let   (bas exp)
  84         (setq bas (translate (cadr form)) exp (translate (caddr form)))
  85         (cond ((eq '$fixnum (car exp))
  86                (setq exp (cdr exp))
  87                (cond ((eq '$float (car bas))
  88                       `($float expt ,(cdr bas) ,exp))
  89                      ((and (eq (car bas) '$fixnum)
  90                            $tr_numer)
  91                       ;; when NUMER:TRUE we have 1/2 evaluating to 0.5
  92                       ;; therefore we have a TR_NUMER switch to control
  93                       ;; this form numerical hackers at translate time
  94                       ;; where it does the most good. -gjc
  95                       `($float . (expt (float ,(cdr bas)) ,exp)))
  96                      ;;It seems to me we can do this,
  97                      ;; although 2^-3 would result in a "cl rat'l number"
  98                      ((and $tr_exponent (member (car bas) '($fixnum $number) :test #'eq))
  99                       `($number expt ,(cdr bas) ,exp))
 100                      (t `($any power ,(cdr bas) ,exp))))
 101               ((and (eq '$float (car bas))
 102                     (eq '$rational (car exp))
 103                     (not (atom (caddr exp)))
 104                     (cond ((equal 2 (caddr (caddr exp)))
 105                            (setq exp (cadr (caddr exp)))
 106                            (cond ((= 1 exp) `($float sqrt ,(cdr bas)))
 107                                  ((= -1 exp) `($float / (sqrt ,(cdr bas))))
 108                                  (t `($float expt (sqrt ,(cdr bas)) ,exp))))
 109                           ((eq 'rat (caar (caddr exp)))
 110                            `($float expt ,(cdr bas) ,($float (caddr exp)))))))
 111               (t `($any power ,(cdr bas) ,(cdr exp)))))))
 112
 113 (def%tr rat (form)
 114   `($rational . ',form))
 115
 116 (def%tr bigfloat (form)
 117   `($any . ',form))
 118
 119 (def%tr %sqrt (form)
 120   (setq form (translate (cadr form)))
 121   (if (eq '$float (car form)) `($float sqrt ,(cdr form))
 122       `($any simplify (list '(%sqrt) ,(cdr form)))))
 123
 124 (def%tr mabs (form)
 125   (setq form (translate (cadr form)))
 126   (if (covers '$number (car form)) (list (car form) 'abs (cdr form))
 127       `($any simplify (list '(mabs) ,(dconvx form)))))
 128
 129 (def%tr %signum (form)
 130   (destructuring-let (( (mode . arg) (translate (cadr form))))
 131     (cond ((member mode '($fixnum $float) :test #'eq)
 132            (let ((temp (tr-gensym)))
 133              `($fixnum . ((lambda (,temp)
 134                             (declare (,(if (eq mode '$float)
 135                                            'flonum
 136                                            'fixnum)
 137                                        ,temp))
 138                             (cond ((minusp ,temp) -1)
 139                                   ((plusp ,temp) 1)
 140                                   (t 0)))
 141                           ,arg))))
 142           (t
 143            ;; even in this unknown case we can do a hell
 144            ;; of a lot better than consing up a form to
 145            ;; call the macsyma simplifier. I mean, shoot
 146            ;; have a little SUBR called SIG-NUM or something.
 147            `($any simplify (list '(%signum) ,arg))))))
 148
 149 ;; The optimization of using -1.0, +1.0 and 0.0 cannot be made unless we
 150 ;; know the TARGET MODE. The action of the simplifier is that
 151 ;; SIGNUM(3.3) => 1 , SIGNUM(3.3) does not give 0.0
 152 ;; Maybe this is a bug in the simplifier, maybe not. -gjc
 153
 154 ;; There are many possible non-trivial optimizations possible involving
 155 ;; SIGNUM. MODE TARGETTING must be built in to get these easily of course,
 156 ;; examples are: SIGNUM(X*Y); No need to multiple X and Y, just multiply
 157 ;; there SIGN's, which is a conditional and comparisons. However, these
 158 ;; are only optimizations if X and Y are numeric. What if
 159 ;; X:'a,Y:'B, ASSUME(A*B>0), SIGNUM(X*Y). Well, here
 160 ;; SIGNUM(X)*SIGNUM(Y) won't be the same as SIGNUM(X*Y). -gjc
 161
 162 ;; just to show the kind of brain damage...
 163 ;;(DEF%TR %SIGNUM (FORM)
 164 ;;   (SETQ FORM (TRANSLATE (CADR FORM)))
 165 ;;   (COND ((MEMber (CAR FORM)
 166 ;;        (LET   ((X (CDR FORM)) (MODE (CAR FORM))
 167 ;;                  (ONE 1) (MINUS1 -1) (ZERO 0) (VAR '%%N)
 168 ;;                  (DECLARE-TYPE 'FIXNUM) COND-CLAUSE)
 169 ;;           (IF (EQ '$FLOAT MODE) (SETQ ONE 1.0 MINUS1 -1.0 ZERO 0.0 VAR '$$X
 170 ;;                                       DECLARE-TYPE 'FLONUM))
 171 ;;           (SETQ COND-CLAUSE `(COND ((MINUSP ,X) ,MINUS1)
 172 ;;                                    ((PLUSP ,X)  ,ONE)
 173 ;;                                    (T ,ZERO)))
 174 ;;           (IF (ATOM (CDR FORM)) `(,MODE . ,COND-CLAUSE)
 175 ;;               (PUSHNEW `(,DECLARE-TYPE ,VAR) DECLARES)
 176 ;;               `(,MODE (LAMBDA (,VAR) ,COND-CLAUSE) ,X))))
 177 ;;       (T `($ANY SIMPLIFY (LIST '(%SIGNUM) ,(CDR FORM))))))
 178
 179
 180 (def%tr $entier (form)
 181   (setq form (translate (cadr form)))
 182   (cond ((eq '$fixnum (car form)) form)
 183         ((member (car form) '($float $number) :test #'eq)
 184          (if (eq 'sqrt (cadr form))
 185              `($fixnum $isqrt ,(caddr form))
 186              `($fixnum floor ,(cdr form))))
 187         (t `(,(if (eq (car form) '$rational) '$fixnum '$any)
 188              $entier ,(cdr form)))))
 189
 190 (def%tr $float (form)
 191   (setq form (translate (cadr form)))
 192   (if (covers '$float (car form))
 193       (cons '$float (dconv-$float form))
 194       `($any $float ,(cdr form))))
 195
 196 (def%tr %exp (form)
 197   (setq form (translate (cadr form)))
 198   (if (eq '$float (car form))
 199       `($float exp ,(cdr form))
 200       `($any simplify (list '(%exp) ,(cdr form)))))
 201
 202 (def%tr $atan2 (form)
 203   (setq form (cdr form))
 204   (let ((x (translate (car form))) (y (translate (cadr form))))
 205     (if (eq '$float (*union-mode (car x) (car y)))
 206         `($float atan ,(cdr x) ,(cdr y))
 207         `($any simplify (list '($atan2) ,(cdr x) ,(cdr y))))))
 208
 209 (def%tr %atan (form)
 210   (setq form (cdr form))
 211   (let ((x (translate (car form))))
 212     (if (eq '$float (car x))
 213         `($float atan ,(cdr x))
 214         `($any simplify (list '(%atan) ,(cdr x))))))