src/trans5.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 trans5)
  14
  15 ;;; these are TRANSLATE properties 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 interpreter, 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 optimization 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   `($any . (let (($listarith nil))
 139              (cfeval ,form))))
 140
 141 ;;; from TRGRED >
 142
 143 (def%tr $apply1 (form &aux (expr (tr-gensym)) (rules (tr-gensym)))
 144   `($any  . (do ((,expr ,(dtranslate (cadr form))
 145                         (apply1 ,expr (car ,rules) 0))
 146                  (,rules ',(cddr form) (cdr ,rules)))
 147                 ((null ,rules) ,expr))))
 148
 149 (def%tr $apply2 (form)
 150   `($any . (apply2 ',(cddr form) ,(dtranslate (cadr form)) 0)))
 151
 152 (def%tr $applyb1 (form &aux (expr (tr-gensym)) (rules (tr-gensym)))
 153   `($any . (do ((,expr ,(dtranslate (cadr form))
 154                        (car (apply1hack ,expr (car ,rules))))
 155                 (,rules ',(cddr form) (cdr ,rules)))
 156                ((null ,rules) ,expr))))
 157
 158 (def%tr $applyb2 (form)
 159   `($any . (car (apply2hack ',(cddr form) ,(dtranslate (cadr form))))))
 160
 161 ;;; this nice translation property written by REH.
 162 ;;; He is the first macsyma system program to ever
 163 ;;; write the translation property for his own special form!
 164
 165 (def%tr $buildq (form)
 166   (let ((alist                          ;would be nice to output
 167          (mapcar                       ;backquote instead of list/cons
 168           #'(lambda (var)              ;but I'm not sure if things get
 169               (cond ((atom var)         ;macroexpanded.  -REH
 170                                         ; Well, any macros are o.k. They
 171                                         ; get expanded "at the right time". -gjc
 172
 173                      `(cons ',var ,(dtranslate var)))
 174                     ((eq (caar var) 'msetq)
 175                      `(cons ',(cadr var) ,(dtranslate (caddr var))))
 176                     (t (tr-abort)
 177                        (tr-format (intl:gettext "error: found unhandled variable ~:M in 'buildq'.~%") var))))
 178                                         ;right thing to do here??
 179                                         ;how much error checking does transl do now?
 180                                         ; Yes. Not as much as it should! -GJC
 181
 182           (cdr (cadr form)))))
 183     (cond ((null alist)
 184            `($any quote ,(caddr form)))
 185           (t `($any mbuildq-subst (list ,@alist) ',(caddr form))))))