src/troper.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancements.                   ;;;;;
   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))
  83       (translate `(($exp) ,(caddr form)))
  84       (let ((bas (translate (cadr form)))
  85             (exp (translate (caddr form))))
  86         (cond
  87           ((eq '$fixnum (car exp))
  88            (setq exp (cdr exp))
  89            (cond ((eq '$float (car bas))
  90                   `($float expt ,(cdr bas) ,exp))
  91                  ((and (eq (car bas) '$fixnum)
  92                        $tr_numer)
  93                   ;; when NUMER:TRUE we have 1/2 evaluating to 0.5
  94                   ;; therefore we have a TR_NUMER switch to control
  95                   ;; this form numerical hackers at translate time
  96                   ;; where it does the most good. -gjc
  97                   `($float . (expt (float ,(cdr bas)) ,exp)))
  98                  ;;It seems to me we can do this,
  99                  ;; although 2^-3 would result in a "cl rat'l number"
 100                  ((and $tr_exponent (member (car bas) '($fixnum $number) :test #'eq))
 101                   `($number expt ,(cdr bas) ,exp))
 102                  (t `($any power ,(cdr bas) ,exp))))
 103
 104           ((and (eq '$float (car bas))
 105                 (eq '$rational (car exp))
 106                 (not (atom (caddr exp)))
 107                 (cond ((equal 2 (caddr (caddr exp)))
 108                        (setq exp (cadr (caddr exp)))
 109                        (cond ((= 1 exp) `($float sqrt ,(cdr bas)))
 110                              ((= -1 exp) `($float / (sqrt ,(cdr bas))))
 111                              (t `($float expt (sqrt ,(cdr bas)) ,exp))))
 112                       ((eq 'rat (caar (caddr exp)))
 113                        `($float expt ,(cdr bas) ,($float (caddr exp)))))))
 114
 115           ;; If the exponent is a float, we can't just translate straight to a
 116           ;; float because the base might be negative. However, if the base
 117           ;; happens to be a literal then we can check its sign. If it's
 118           ;; non-negative we know that the result of calling POWER will indeed
 119           ;; be a float.
 120           ((and (eq '$float (car exp))
 121                 (or (numberp (car bas))
 122                     (and (eq '$rational (car bas))
 123                          (eq 'quote (second bas))
 124                          (not (atom (third bas)))
 125                          (eq 'rat (caar (third bas)))
 126                          (integerp (second (third bas)))
 127                          (integerp (third (third bas))))
 128                     (and (memq (car bas) '($float $fixnum))
 129                          (numberp (cdr bas)))))
 130            (let ((cl-base
 131                   (cond
 132                     ((numberp (car bas))
 133                      (car bas))
 134                     ((eq '$rational (car bas))
 135                      (/ (second (third bas)) (third (third bas))))
 136                     (t
 137                      (cdr bas)))))
 138              (if (< cl-base 0)
 139                  `($any power ,(cdr bas) ,(cdr exp))
 140                  `($float power ,(cdr bas) ,(cdr exp)))))
 141
 142           (t `($any power ,(cdr bas) ,(cdr exp)))))))
 143
 144 (def%tr rat (form)
 145   `($rational . ',form))
 146
 147 (def%tr bigfloat (form)
 148   `($any . ',form))
 149
 150 (def%tr mabs (form)
 151   (setq form (translate (cadr form)))
 152   (if (covers '$number (car form)) (list (car form) 'abs (cdr form))
 153       `($any simplify (list '(mabs) ,(dconvx form)))))
 154
 155 (def%tr %signum (form)
 156   (destructuring-let (( (mode . arg) (translate (cadr form))))
 157     (cond ((member mode '($fixnum $float) :test #'eq)
 158            `(,mode . (cl:signum ,arg)))
 159           (t
 160            ;; even in this unknown case we can do a hell
 161            ;; of a lot better than consing up a form to
 162            ;; call the macsyma simplifier. I mean, shoot
 163            ;; have a little SUBR called SIG-NUM or something.
 164            `($any simplify (list '(%signum) ,arg))))))
 165
 166 ;; The optimization of using -1.0, +1.0 and 0.0 cannot be made unless we
 167 ;; know the TARGET MODE. The action of the simplifier is that
 168 ;; SIGNUM(3.3) => 1 , SIGNUM(3.3) does not give 0.0
 169 ;; Maybe this is a bug in the simplifier, maybe not. -gjc
 170
 171 ;; There are many possible non-trivial optimizations possible involving
 172 ;; SIGNUM. MODE TARGETING must be built in to get these easily of course,
 173 ;; examples are: SIGNUM(X*Y); No need to multiple X and Y, just multiply
 174 ;; there SIGN's, which is a conditional and comparisons. However, these
 175 ;; are only optimizations if X and Y are numeric. What if
 176 ;; X:'a,Y:'B, ASSUME(A*B>0), SIGNUM(X*Y). Well, here
 177 ;; SIGNUM(X)*SIGNUM(Y) won't be the same as SIGNUM(X*Y). -gjc
 178
 179 ;; just to show the kind of brain damage...
 180 ;;(DEF%TR %SIGNUM (FORM)
 181 ;;   (SETQ FORM (TRANSLATE (CADR FORM)))
 182 ;;   (COND ((MEMber (CAR FORM)
 183 ;;        (LET   ((X (CDR FORM)) (MODE (CAR FORM))
 184 ;;                  (ONE 1) (MINUS1 -1) (ZERO 0) (VAR '%%N)
 185 ;;                  (DECLARE-TYPE 'FIXNUM) COND-CLAUSE)
 186 ;;           (IF (EQ '$FLOAT MODE) (SETQ ONE 1.0 MINUS1 -1.0 ZERO 0.0 VAR '$$X
 187 ;;                                       DECLARE-TYPE 'FLONUM))
 188 ;;           (SETQ COND-CLAUSE `(COND ((MINUSP ,X) ,MINUS1)
 189 ;;                                    ((PLUSP ,X)  ,ONE)
 190 ;;                                    (T ,ZERO)))
 191 ;;           (IF (ATOM (CDR FORM)) `(,MODE . ,COND-CLAUSE)
 192 ;;               (PUSHNEW `(,DECLARE-TYPE ,VAR) DECLARES)
 193 ;;               `(,MODE (LAMBDA (,VAR) ,COND-CLAUSE) ,X))))
 194 ;;       (T `($ANY SIMPLIFY (LIST '(%SIGNUM) ,(CDR FORM))))))
 195
 196
 197 (def%tr $entier (form)
 198   (setq form (translate (cadr form)))
 199   (cond ((eq '$fixnum (car form)) form)
 200         ((member (car form) '($float $number) :test #'eq)
 201          (if (eq 'sqrt (cadr form))
 202              `($fixnum $isqrt ,(caddr form))
 203              `($fixnum floor ,(cdr form))))
 204         (t `(,(if (eq (car form) '$rational) '$fixnum '$any)
 205              $entier ,(cdr form)))))
 206
 207 (def%tr $float (form)
 208   (setq form (translate (cadr form)))
 209   (if (covers '$float (car form))
 210       (cons '$float (dconv-$float form))
 211       `($any $float ,(cdr form))))
 212
 213 (def%tr $atan2 (form)
 214   (setq form (cdr form))
 215   (let ((x (translate (car form))) (y (translate (cadr form))))
 216     (if (eq '$float (*union-mode (car x) (car y)))
 217         `($float atan ,(dconv-$float x) ,(dconv-$float y))
 218         `($any simplify (list '($atan2) ,(cdr x) ,(cdr y))))))