src/trans4.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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   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 (list '(mfactorial) ,(cdr form)))))))
  50
  51 (defun yuk-su-meta-prop (f form)
  52   (let ((meta-prop-p t)
  53         (meta-prop-l nil))
  54     (funcall f (cdr form))
  55     `($any . (progn ,@(mapcar #'patch-up-meval-in-fset (nreverse meta-prop-l))))))
  56
  57 (def%tr $matchdeclare (form)
  58   (do ((l (cdr form) (cddr l))
  59        (vars ()))
  60       ((null l)
  61        `($any . (progn
  62                   ,@(mapcar #'(lambda (var)
  63                                 (dtranslate `(($define_variable)
  64                                               ,var
  65                                               ((mquote) ,var)
  66                                               $any)))
  67                             vars)
  68                   ,(dtranslate `((sub_$matchdeclare) ,@(cdr form))))))
  69     (cond ((atom (car l))
  70            (push (car l) vars))
  71           ((eq (caaar l) 'mlist)
  72            (setq vars (append (cdar l) vars))))))
  73
  74 (def%tr sub_$matchdeclare (form)
  75   (yuk-su-meta-prop 'proc-$matchdeclare `(($matchdeclare) ,@(cdr form))))
  76
  77 (def%tr $defmatch (form)
  78   (yuk-su-meta-prop 'proc-$defmatch form))
  79
  80 (def%tr $tellsimp (form)
  81   (yuk-su-meta-prop 'proc-$tellsimp form))
  82
  83 (def%tr $tellsimpafter (form)
  84   (yuk-su-meta-prop 'proc-$tellsimpafter form))
  85
  86 (def%tr $defrule (form)
  87   (yuk-su-meta-prop 'proc-$defrule form))
  88
  89 (defun patch-up-meval-in-fset (form)
  90   (cond ((not (eq (car form) 'fset))
  91          form)
  92
  93         (t
  94          ;; FORM is always generated by META-FSET
  95          (destructuring-let ((((nil ssymbol) (nil (nil definition) nil)) (cdr form)))
  96            (unless (eq (car definition) 'lambda)
  97              (barfo
  98                (format nil
  99                 "PATCH-UP-MEVAL-IN-FSET: not a lambda expression: ~A"
 100                 definition)))
 101            (tr-format (intl:gettext "note: translating rule or match ~:M ...~%") ssymbol)
 102            (setq definition (lisp->lisp-tr-lambda definition))
 103            (if (null definition)
 104                form
 105                ;; If the definition is a lambda form, just use defun
 106                ;; instead of fset.
 107                (if (eq (car definition) 'lambda)
 108                    `(defun ,ssymbol ,@(cdr definition))
 109                    `(fset ',ssymbol ,definition)))))))
 110
 111 (defvar lisp->lisp-tr-lambda t)
 112
 113 (defun lisp->lisp-tr-lambda (l)
 114   ;; basically, a lisp->lisp translation, setting up
 115   ;; the proper lambda contexts for the special forms,
 116   ;; and calling TRANSLATE on the "lusers" generated by
 117   ;; Fateman braindamage, (MEVAL '$A), (MEVAL '(($F) $X)).
 118   (if lisp->lisp-tr-lambda
 119       (catch 'lisp->lisp-tr-lambda
 120         (tr-lisp->lisp l))
 121       ()))
 122
 123 (defun tr-lisp->lisp (exp)
 124   (if (atom exp)
 125       (cdr (translate-atom exp))
 126       (let ((op (car exp)))
 127         (if (symbolp op)
 128             (funcall (or (get op 'tr-lisp->lisp) #'tr-lisp->lisp-default)
 129                      exp)
 130             (progn (tr-format (intl:gettext "error: found a non-symbolic operator; I give up.~%"))
 131                    (throw 'lisp->lisp-tr-lambda ()))))))
 132
 133 (defun tr-lisp->lisp-default (exp)
 134   (cond ((macsyma-special-op-p (car exp))
 135          (tr-format (intl:gettext "error: unhandled special operator ~:@M~%") (car exp))
 136          (throw 'lisp->lisp-tr-lambda ()))
 137         ('else
 138          (tr-lisp->lisp-fun exp))))
 139
 140 (defun tr-lisp->lisp-fun (exp)
 141   (cons (car exp) (maptr-lisp->lisp (cdr exp))))
 142
 143 (defun maptr-lisp->lisp (l)
 144   (mapcar #'tr-lisp->lisp l))
 145 (defun-prop (declare tr-lisp->lisp) (form)
 146   form)
 147
 148 (defun-prop (lambda tr-lisp->lisp) (form)
 149   (destructuring-let (((() arglist . body) form))
 150     (mapc #'tbind  arglist)
 151     (setq body (maptr-lisp->lisp body))
 152     `(lambda ,(tunbinds arglist) ,@body)))
 153
 154 (defun-prop (prog tr-lisp->lisp) (form)
 155   (destructuring-let (((() arglist . body) form))
 156     (mapc #'tbind arglist)
 157     (setq body (mapcar #'(lambda (x)
 158                            (if (atom x) x
 159                                (tr-lisp->lisp x)))
 160                        body))
 161     `(prog ,(tunbinds arglist) ,@body)))
 162
 163 ;;(DEFUN RETLIST FEXPR (L)
 164 ;;  (CONS '(MLIST SIMP)
 165 ;;       (MAPCAR #'(LAMBDA (Z) (LIST '(MEQUAL SIMP) Z (MEVAL Z))) L)))
 166
 167 (defun-prop (retlist tr-lisp->lisp) (form)
 168   `(retlist_tr ,@(mapcan #'(lambda (z)
 169                              (list `',z (tr-lisp->lisp z)))
 170                          (cdr form))))
 171
 172 (defun-prop (quote tr-lisp->lisp) (form) form)
 173 (defprop catch tr-lisp->lisp-fun tr-lisp->lisp)
 174 (defprop throw tr-lisp->lisp-fun tr-lisp->lisp)
 175 (defprop return tr-lisp->lisp-fun tr-lisp->lisp)
 176 (defprop function tr-lisp->lisp-fun tr-lisp->lisp)
 177
 178 (defun-prop (setq tr-lisp->lisp) (form)
 179   (do ((l (cdr form) (cddr l))
 180        (n ()))
 181       ((null l) (cons 'setq (nreverse n)))
 182     (push (car l) n)
 183     (push (tr-lisp->lisp (cadr l)) n)))
 184
 185 (defun-prop (msetq tr-lisp->lisp) (form)
 186   (cdr (translate `((msetq) ,@(cdr form)))))
 187
 188 (defun-prop (cond tr-lisp->lisp) (form)
 189   (cons 'cond (mapcar #'maptr-lisp->lisp (cdr form))))
 190
 191 (defprop not tr-lisp->lisp-fun tr-lisp->lisp)
 192 (defprop and tr-lisp->lisp-fun tr-lisp->lisp)
 193 (defprop or tr-lisp->lisp-fun tr-lisp->lisp)
 194
 195 (defvar unbound-meval-kludge-fix t)
 196
 197 (defun-prop (meval tr-lisp->lisp) (form)
 198   (setq form (cadr form))
 199   (cond ((and (not (atom form))
 200               (eq (car form) 'quote))
 201          (cdr (translate (cadr form))))
 202         (unbound-meval-kludge-fix
 203          ;; only case of unbound MEVAL is in output of DEFMATCH,
 204          ;; and appears like a useless double-evaluation of arguments.
 205          form)
 206         ('else
 207          (tr-format (intl:gettext "error: found unbound MEVAL; I give up.~%"))
 208          (throw 'lisp->lisp-tr-lambda ()))))
 209
 210 (defun-prop (is tr-lisp->lisp) (form)
 211   (setq form (cadr form))
 212   (cond ((and (not (atom form))
 213               (eq (car form) 'quote))
 214          (cdr (translate `(($is) ,(cadr form)))))
 215         ('else
 216          (tr-format (intl:gettext "error: found unbound IS; I give up.~%"))
 217          (throw 'lisp->lisp-tr-lambda ()))))