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 trans5) 14 15;;; these are TRANSLATE properies for the FSUBRS in JPG;COMM > 16 17;;; LDISPLAY is one of the most beastly of all macsyma idiot 18;;; constructs. First of all it makes a variable name and sets it, 19;;; but it evaluates its argument such that 20;;; x:10, LDISPLAY(F(X)) gives (E1) F(10)= ... 21;;; LDISPLAY(X) gives X=10 of course. Sometimes it evaluates to get 22;;; the left hand side, and sometimes it doesn't. It has its own 23;;; private fucking version of the macsyma evaluator. 24;;; To see multiple evaluation lossage in the interperter, try 25;;; these: LDISPLAY(F(PRINT("FOOBAR")))$ 26 27 28(def%tr $disp (form) 29 `($any . (display-for-tr ,(eq (caar form) '$ldisp) 30 nil ; equationsp 31 ,@(tr-args (cdr form))))) 32 33(def-same%tr $ldisp $disp) 34 35(def%tr $display (form) 36 `($any . (display-for-tr ,(eq (caar form) '$ldisplay) 37 t 38 ,@(mapcar #'tr-exp-to-display (cdr form))))) 39 40(def-same%tr $ldisplay $display) 41 42;;; DISPLAY(F(X,Y,FOO())) 43;;; (F X Y (FOO)) => (LET ((&G1 (FOO))) (list '(mequal) (LIST '(F) X Y &G1) 44;;; (F X Y &G1))) 45;;; DISPLAY(X) => (LIST '(MEQUAL) '$X $X) 46;;; DISPLAY(Q[I]) => (LIST '(MEQUAL) (LIST '(Q ARRAY) $I) ...) 47 48;;; Ask me why I did this at lisp level, this should be able 49;;; to be hacked as a macsyma macro. the brain damage I get 50;;; into sometimes... 51 52;;; This walks the translated code attempting to come up 53;;; with a reasonable object for display, expressions which 54;;; might have to get evaluated twice are pushed on the 55;;; VALUE-ALIST (<expression> . <gensym>) 56;;; This is incompatible with the interpreter which evaluates 57;;; arguments to functions twice. Here I only evaluate non-atomic 58;;; things once, and make sure that the order of evaluation is 59;;; pretty much correct. I say "pretty much" because MAKE-VALUES 60;;; does the optmization of not generating a temporary for a variable. 61;;; DISPLAY(FOO(Z,Z:35)) will loose because the second argument will 62;;; be evaluated first. I don't seriously expect anyone to find this 63;;; bug. 64 65(defvar value-alist nil) 66 67(defun make-values (expr-args) 68 (mapcar #'(lambda (arg) 69 (cond ((or (atom arg) 70 (member (car arg) '(trd-msymeval quote) :test #'eq)) 71 arg) 72 (t 73 (let ((sym (gensym))) 74 (push (cons arg sym) value-alist) 75 sym)))) 76 expr-args)) 77 78(defstruct (disp-hack-ob (:conc-name nil) (:type list)) 79 left-ob right-ob) 80 81(defun object-for-display-hack (exp) 82 (if (atom exp) 83 (make-disp-hack-ob :left-ob `',exp :right-ob exp) 84 (case (car exp) 85 (simplify 86 (let ((v (object-for-display-hack (cadr exp)))) 87 (make-disp-hack-ob :left-ob (left-ob v) 88 :right-ob `(simplify ,(right-ob v))))) 89 (marrayref 90 (let ((vals (make-values (cdr exp)))) 91 (make-disp-hack-ob :left-ob `(list (list* ,(car vals) '(array)) ,@(cdr vals)) 92 :right-ob `(marrayref ,@vals)))) 93 (mfunction-call 94 ;; assume evaluation of arguments. 95 (let ((vals (make-values (cddr exp)))) 96 (make-disp-hack-ob :left-ob `(list '(,(cadr exp)) ,@vals) 97 :right-ob `(mfunction-call ,(cadr exp) ,@vals)))) 98 (list 99 (let ((obs (mapcar #'object-for-display-hack (cdr exp)))) 100 (make-disp-hack-ob :left-ob `(list ,@(mapcar #'(lambda (u) (left-ob u)) obs)) 101 :right-ob `(list ,@(mapcar #'(lambda (u) (right-ob u)) obs))))) 102 (quote (make-disp-hack-ob :left-ob exp :right-ob exp)) 103 (trd-msymeval 104 (make-disp-hack-ob :left-ob `',(cadr exp) :right-ob exp)) 105 (t 106 (cond ((or (not (atom (car exp))) 107 (getl (car exp) '(fsubr fexpr macro))) 108 (make-disp-hack-ob :left-ob `',exp :right-ob exp)) 109 (t 110 (let ((vals (make-values (cdr exp)))) 111 (make-disp-hack-ob :left-ob `(list '(,(untrans-op (car exp))) ,@vals) 112 :right-ob `(,(car exp) ,@vals))))))))) 113 114(defun tr-exp-to-display (exp) 115 (let* ((lisp-exp (dtranslate exp)) 116 (value-alist nil) 117 (ob (object-for-display-hack lisp-exp)) 118 (disp `(list '(mequal) ,(left-ob ob) ,(right-ob ob)))) 119 (setq value-alist (nreverse value-alist)) 120 (if value-alist 121 `((lambda ,(mapcar #'cdr value-alist) ,disp) 122 ,@(mapcar #'car value-alist)) 123 disp))) 124 125(defun untrans-op (op) 126 (or (cdr (assoc op '((add* . mplus) 127 (sub* . mminus) 128 (mul* . mtimes) 129 (div* . mquotient) 130 (power* . mexpt)) :test #'equal)) 131 op)) 132 133 134;;; From COMBIN > 135 136(def%tr $cf (form) 137 (setq form (car (tr-args (cdr form)))) 138 (push-autoload-def '$cf '(cfeval)) 139 `($any . (let (($listarith nil)) 140 (cfeval ,form)))) 141 142;;; from TRGRED > 143 144(def%tr $apply1 (form &aux (expr (tr-gensym)) (rules (tr-gensym))) 145 (push-autoload-def '$apply1 '(apply1)) 146 `($any . (do ((,expr ,(dtranslate (cadr form)) 147 (apply1 ,expr (car ,rules) 0)) 148 (,rules ',(cddr form) (cdr ,rules))) 149 ((null ,rules) ,expr)))) 150 151(def%tr $apply2 (form) 152 `($any . ((lambda (*rulelist) 153 (declare (special *rulelist)) 154 (apply2 ,(dtranslate (cadr form)) 0)) 155 ',(cddr form)))) 156 157(def%tr $applyb1 (form &aux (expr (tr-gensym)) (rules (tr-gensym))) 158 (push-autoload-def '$applyb1 '(apply1hack)) 159 `($any . (do ((,expr ,(dtranslate (cadr form)) 160 (car (apply1hack ,expr (car ,rules)))) 161 (,rules ',(cddr form) (cdr ,rules))) 162 ((null ,rules) ,expr)))) 163 164(def%tr $applyb2 (form) 165 (push-autoload-def '$applyb2 '(apply2hack)) 166 `($any . ((lambda (*rulelist) 167 (declare (special *rulelist)) 168 (apply2hack ,(dtranslate (cadr form)))) 169 ',(cddr form)))) 170 171;;; this nice translation property written by REH. 172;;; He is the first macsyma system program to ever 173;;; write the translation property for his own special form! 174 175(def%tr $buildq (form) 176 (let ((alist ;would be nice to output 177 (mapcar ;backquote instead of list/cons 178 #'(lambda (var) ;but I'm not sure if things get 179 (cond ((atom var) ;macroexpanded. -REH 180 ; Well, any macros are o.k. They 181 ; get expanded "at the right time". -gjc 182 183 `(cons ',var ,(dtranslate var))) 184 ((eq (caar var) 'msetq) 185 `(cons ',(cadr var) ,(dtranslate (caddr var)))) 186 (t (setq tr-abort t) 187 (tr-format (intl:gettext "error: found unhandled variable ~:M in 'buildq'.~%") var)))) 188 ;right thing to do here?? 189 ;how much error checking does transl do now? 190 ; Yes. Not as much as it should! -GJC 191 192 (cdr (cadr form))))) 193 (cond ((null alist) 194 `($any quote ,(caddr form))) 195 (t `($any mbuildq-subst (list ,@alist) ',(caddr form)))))) 196