src/trans4.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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;;;       1001 TRANSLATE properties for everyone.                        ;;;
  10 ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  11 ;;;       Maintained by GJC                                              ;;;
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13
  14 (in-package :maxima)
  15
  16 (macsyma-module trans4)
  17
  18 ;;; These are translation properties for various operators.
  19
  20 (def%tr mnctimes (form)
  21   (setq form (tr-args (cdr form)))
  22   (cond ((= (length form) 2)
  23          `($any ncmul2 . ,form))
  24         (t
  25          `($any ncmuln (list . ,form) nil))))
  26
  27 (def%tr mncexpt (form)
  28   `($any . (ncpower ,@(tr-args (cdr form)))))
  29
  30 (def%tr $remainder (form)
  31   (let ((n (tr-nargs-check form '(2 . nil)))
  32         (tr-args (mapcar 'translate (cdr form))))
  33     (cond ((and (= n 2)
  34                 (eq (caar tr-args) '$fixnum)
  35                 (eq (car (cadr tr-args)) '$fixnum))
  36            `($fixnum . (rem ,(cdr (car tr-args))
  37                         ,(cdr (cadr tr-args)))))
  38           (t
  39            (call-and-simp '$any '$remainder (mapcar 'cdr tr-args))))))
  40
  41 (def%tr $beta (form)
  42   `($any . (simplify (list '($beta) ,@(tr-args (cdr form))))))
  43
  44 (def%tr mfactorial (form)
  45   (setq form (translate (cadr form)))
  46   (cond ((eq (car form) '$fixnum)
  47          `($number . (factorial ,(cdr form))))
  48         (t
  49          `($any . (simplify  `((mfactorial) ,,(cdr form)))))))
  50
  51 ;; Kill off the special code for translating sum and product.
  52
  53 (def%tr %sum $batcon)
  54 (def%tr %product $batcon)
  55
  56
  57 ;; From MATCOM.
  58 ;; Temp autoloads needed for pdp-10. There is a better way
  59 ;; to distribute this info, too bad I never implemented it.
  60
  61 (mapc #'(lambda (x)
  62           (let ((old-prop (get (cdr x) 'autoload)))
  63             (if (not (null old-prop))
  64                 (putprop (car x) old-prop 'autoload))))
  65       '((proc-$matchdeclare . $matchdeclare)
  66         (proc-$defmatch .     $defmatch)
  67         (proc-$defrule . $defrule)
  68         (proc-$tellsimpafter . $tellsimpafter)
  69         (proc-$tellsimp  . $tellsimp    )))
  70
  71 (defun yuk-su-meta-prop (f form)
  72   (let ((meta-prop-p t)
  73         (meta-prop-l nil))
  74     (funcall f (cdr form))
  75     `($any . (progn ,@(mapcar #'patch-up-meval-in-fset (nreverse meta-prop-l))))))
  76
  77 (def%tr $matchdeclare (form)
  78   (do ((l (cdr form) (cddr l))
  79        (vars ()))
  80       ((null l)
  81        `($any . (progn
  82                   ,@(mapcar #'(lambda (var)
  83                                 (dtranslate `(($define_variable)
  84                                               ,var
  85                                               ((mquote) ,var)
  86                                               $any)))
  87                             vars)
  88                   ,(dtranslate `((sub_$matchdeclare) ,@(cdr form))))))
  89     (cond ((atom (car l))
  90            (push (car l) vars))
  91           ((eq (caaar l) 'mlist)
  92            (setq vars (append (cdar l) vars))))))
  93
  94 (def%tr sub_$matchdeclare (form)
  95   (yuk-su-meta-prop 'proc-$matchdeclare `(($matchdeclare) ,@(cdr form))))
  96
  97 (def%tr $defmatch (form)
  98   (yuk-su-meta-prop 'proc-$defmatch form))
  99
 100 (def%tr $tellsimp (form)
 101   (yuk-su-meta-prop 'proc-$tellsimp form))
 102
 103 (def%tr $tellsimpafter (form)
 104   (yuk-su-meta-prop 'proc-$tellsimpafter form))
 105
 106 (def%tr $defrule (form)
 107   (yuk-su-meta-prop 'proc-$defrule form))
 108
 109 (defun patch-up-meval-in-fset (form)
 110   (cond ((not (eq (car form) 'fset))
 111          form)
 112
 113         (t
 114          ;; FORM is always generated by META-FSET
 115          (destructuring-let ((((nil ssymbol) (nil (nil definition) nil)) (cdr form)))
 116            (unless (eq (car definition) 'lambda)
 117              (tr-format
 118               "PATCH-UP-MEVAL-IN-FSET: not a lambda expression: ~A~%"
 119               definition)
 120              (barfo))
 121            (tr-format (intl:gettext "note: translating rule or match ~:M ...~%") ssymbol)
 122            (setq definition (lisp->lisp-tr-lambda definition))
 123            (if (null definition)
 124                form
 125                ;; If the definition is a lambda form, just use defun
 126                ;; instead of fset.
 127                (if (eq (car definition) 'lambda)
 128                    `(defun ,ssymbol ,@(cdr definition))
 129                    `(fset ',ssymbol ,definition)))))))
 130
 131 (defvar lisp->lisp-tr-lambda t)
 132
 133 (defun lisp->lisp-tr-lambda (l)
 134   ;; basically, a lisp->lisp translation, setting up
 135   ;; the proper lambda contexts for the special forms,
 136   ;; and calling TRANSLATE on the "lusers" generated by
 137   ;; Fateman braindamage, (MEVAL '$A), (MEVAL '(($F) $X)).
 138   (if lisp->lisp-tr-lambda
 139       (catch 'lisp->lisp-tr-lambda
 140         (tr-lisp->lisp l))
 141       ()))
 142
 143 (defun tr-lisp->lisp (exp)
 144   (if (atom exp)
 145       (cdr (translate-atom exp))
 146       (let ((op (car exp)))
 147         (if (symbolp op)
 148             (funcall (or (get op 'tr-lisp->lisp) #'tr-lisp->lisp-default)
 149                      exp)
 150             (progn (tr-format (intl:gettext "error: found a non-symbolic operator; I give up.~%"))
 151                    (throw 'lisp->lisp-tr-lambda ()))))))
 152
 153 (defun tr-lisp->lisp-default (exp)
 154   (cond ((macsyma-special-op-p (car exp))
 155          (tr-format (intl:gettext "error: unhandled special operator ~:@M~%") (car exp))
 156          (throw 'lisp->lisp-tr-lambda ()))
 157         ('else
 158          (tr-lisp->lisp-fun exp))))
 159
 160 (defun tr-lisp->lisp-fun (exp)
 161   (cons (car exp) (maptr-lisp->lisp (cdr exp))))
 162
 163 (defun maptr-lisp->lisp (l)
 164   (mapcar #'tr-lisp->lisp l))
 165 (defun-prop (declare tr-lisp->lisp) (form)
 166   form)
 167
 168 (defun-prop (lambda tr-lisp->lisp) (form)
 169   (destructuring-let (((() arglist . body) form))
 170     (mapc #'tbind  arglist)
 171     (setq body (maptr-lisp->lisp body))
 172     `(lambda ,(tunbinds arglist) ,@body)))
 173
 174 (defun-prop (prog tr-lisp->lisp) (form)
 175   (destructuring-let (((() arglist . body) form))
 176     (mapc #'tbind arglist)
 177     (setq body (mapcar #'(lambda (x)
 178                            (if (atom x) x
 179                                (tr-lisp->lisp x)))
 180                        body))
 181     `(prog ,(tunbinds arglist) ,@body)))
 182
 183 ;;(DEFUN RETLIST FEXPR (L)
 184 ;;  (CONS '(MLIST SIMP)
 185 ;;       (MAPCAR #'(LAMBDA (Z) (LIST '(MEQUAL SIMP) Z (MEVAL Z))) L)))
 186
 187 (defun-prop (retlist tr-lisp->lisp) (form)
 188   (push-autoload-def 'marrayref '(retlist_tr))
 189   `(retlist_tr ,@(mapcan #'(lambda (z)
 190                              (list `',z (tr-lisp->lisp z)))
 191                          (cdr form))))
 192
 193 (defun-prop (quote tr-lisp->lisp) (form) form)
 194 (defprop catch tr-lisp->lisp-fun tr-lisp->lisp)
 195 (defprop throw tr-lisp->lisp-fun tr-lisp->lisp)
 196 (defprop return tr-lisp->lisp-fun tr-lisp->lisp)
 197 (defprop function tr-lisp->lisp-fun tr-lisp->lisp)
 198
 199 (defun-prop (setq tr-lisp->lisp) (form)
 200   (do ((l (cdr form) (cddr l))
 201        (n ()))
 202       ((null l) (cons 'setq (nreverse n)))
 203     (push (car l) n)
 204     (push (tr-lisp->lisp (cadr l)) n)))
 205
 206 (defun-prop (msetq tr-lisp->lisp) (form)
 207   (cdr (translate `((msetq) ,@(cdr form)))))
 208
 209 (defun-prop (cond tr-lisp->lisp) (form)
 210   (cons 'cond (mapcar #'maptr-lisp->lisp (cdr form))))
 211
 212 (defprop not tr-lisp->lisp-fun tr-lisp->lisp)
 213 (defprop and tr-lisp->lisp-fun tr-lisp->lisp)
 214 (defprop or tr-lisp->lisp-fun tr-lisp->lisp)
 215
 216 (defvar unbound-meval-kludge-fix t)
 217
 218 (defun-prop (meval tr-lisp->lisp) (form)
 219   (setq form (cadr form))
 220   (cond ((and (not (atom form))
 221               (eq (car form) 'quote))
 222          (cdr (translate (cadr form))))
 223         (unbound-meval-kludge-fix
 224          ;; only case of unbound MEVAL is in output of DEFMATCH,
 225          ;; and appears like a useless double-evaluation of arguments.
 226          form)
 227         ('else
 228          (tr-format (intl:gettext "error: found unbound MEVAL; I give up.~%"))
 229          (throw 'lisp->lisp-tr-lambda ()))))
 230
 231 (defun-prop (is tr-lisp->lisp) (form)
 232   (setq form (cadr form))
 233   (cond ((and (not (atom form))
 234               (eq (car form) 'quote))
 235          (cdr (translate `(($is) ,(cadr form)))))
 236         ('else
 237          (tr-format (intl:gettext "error: found unbound IS; I give up.~%"))
 238          (throw 'lisp->lisp-tr-lambda ()))))