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