src/trans1.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 ;;; This file handles System FSUBR translation properties that were not handled in TRANSL.
  17
  18 (macsyma-module trans1)
  19
  20 ;;;;;;;; THE FOLLOWING ARE MOSTLY FROM JPG MLISP ;;;;;;;;;;;;;;;;;;;;;
  21
  22 ;;; APPLY(F,[X]) is an idiom for funcall.
  23
  24 (defun quoted-symbolp (form)
  25   (and (consp form)
  26      (eq 'quote (car form))
  27      (symbolp (cadr form))))
  28
  29 (def%tr $apply (form)
  30   (let* ((fun (dtranslate (cadr form)))
  31          (mode (cond ((symbolp fun)
  32                       (function-mode-@ fun))
  33                      ((quoted-symbolp fun)
  34                       (function-mode (cadr fun)))
  35                      ('else
  36                       '$any))))
  37     (cond (($listp (caddr form))
  38            (let ((args (tr-args (cdr (caddr form)))))
  39              (call-and-simp mode
  40                             'mfuncall
  41                             `(,fun ,@args))))
  42           (t
  43            (let ((arg (dtranslate (caddr form))))
  44              (call-and-simp mode 'mapply-tr
  45                             `(,fun ,arg)))))))
  46
  47 (def%tr $map (form)
  48   (destructuring-let (((fun . args) (tr-args (cdr form))))
  49     (call-and-simp '$any 'map1 `((getopr ,fun) . ,args))))
  50
  51 (def%tr $maplist (form)
  52   (destructuring-let (((fun . args) (tr-args (cdr form))))
  53     `($any . (maplist_tr ,fun ,@args))))
  54
  55 (def%tr $fullmap (form)
  56   (destructuring-let (((fun . args) (tr-args (cdr form))))
  57     (call-and-simp '$any 'fmap1 `((getopr ,fun) (list . ,args) nil))))
  58
  59 (def%tr $matrixmap (form)
  60   (destructuring-let (((fun . args) (tr-args (cdr form))))
  61     (call-and-simp '$any `(lambda (fmaplvl)
  62                            (fmapl1 (getopr ,fun) . ,args))
  63                    '(2))))
  64
  65 (def%tr $fullmapl (form)
  66   (destructuring-let (((fun . args) (tr-args (cdr form))))
  67     (call-and-simp '$any 'fmapl1 `((getopr ,fun) . ,args))))
  68
  69 (def%tr $outermap (form)
  70   (destructuring-let (((fun . args) (tr-args (cdr form))))
  71     (call-and-simp '$any (cond ((= (length args) 1) 'fmapl1)
  72                                (t 'outermap1))
  73                    `((getopr ,fun)  ,@args))))
  74
  75
  76 (def%tr $scanmap (form)
  77   (destructuring-let (((fun . args) (tr-args (cdr form))))
  78     (call-and-simp '$any 'scanmap1 `((getopr ,fun) ,@args))))
  79
  80 (def%tr $qput (form)
  81   `($any $put ',(cadr form) ',(caddr form) ',(cadddr form)))
  82
  83 (def%tr $subvar (form)
  84   (translate (cons '(mqapply array) (cdr form))))
  85
  86 ;;; If the evaluation of the first argument does not depend on the
  87 ;;; setting of the special variable PIECE, then it need not be
  88 ;;; evaluated inside of PART1. If the PIECE feature is used, then
  89 ;;; we must send down an expression to PART1 which when evaluated has
  90 ;;; the proper environment for the compiled-away variable names in the
  91 ;;; environment of the calling function.
  92 ;;; It is possible to get unbelivebly strange results from the order of
  93 ;;; evaluation of the arguments to $SUBSTPART, these crocks shall not
  94 ;;; be supported.
  95 ;;; The PIECE feature is not as often used as say,
  96 ;;; SUBSTPART("*",EXP,0) is.
  97
  98 (def%tr $substpart (form)
  99   (substpart-translation form t nil '$inflag '$substpart))
 100
 101 (def%tr $substinpart (form)
 102   (substpart-translation form t nil t '$substinpart))
 103
 104 (defun for-eval-then-mquote-simp-argl (l)
 105   ;;       (MAPCAR #'(LAMBDA (U) ;;; consing not important here.
 106   ;;                     `(LIST '(MQUOTE SIMP) ,U))
 107   ;;           L)
 108   ;; JONL broke the fucking compiler. So I re-write this as=>
 109   (prog (v)
 110    loop
 111    (if (null l) (return (nreverse v)))
 112    (push `(list '(mquote simp) ,(pop l)) v)
 113    (go loop)))
 114
 115 (defun substpart-translation (form flag1 flag2 flag3 fn)
 116   (let* ((subst-item (dtranslate (cadr form)))
 117          (freevars (free-lisp-vars subst-item))
 118          (argl (tr-args (cddr form))))
 119     (cond ((null (assoc '$piece freevars :test #'eq))
 120                                         ; this code is just to screw the people who
 121                                         ; would use $PIECE non lexicaly. Not really, the
 122                                         ; closure hacking is a lot slower at run time than
 123                                         ; this easy case, so no sense screwing the people who
 124                                         ; don't use $PIECE in foolish ways.
 125            `($any . (simplify
 126                      (part1
 127                       (list  ,@(for-eval-then-mquote-simp-argl
 128                                 (cons subst-item argl)))
 129
 130                       ,flag1 ,flag2 ,flag3 ',fn))))
 131           (t
 132            (setq freevars (tbound-free-vars freevars))
 133            (side-effect-free-check (cadr freevars) (cadr form))
 134            `($any . (simplify
 135                      (part1 (list (fungen&env-for-meval
 136                                    ,(delete '$piece (car freevars) :test #'equal)
 137                                    ($piece) ,subst-item)
 138                                   ,@(for-eval-then-mquote-simp-argl argl))
 139                       ,flag1 ,flag2 ,flag3 ',fn)))))))
 140
 141 (def%tr $errcatch (form)
 142   (destructuring-bind (mode . body) (translate `((mprogn) ,@(cdr form)))
 143     (declare (ignore mode))
 144     (cons '$any `(cons '(mlist) (errcatch ,body)))))
 145
 146 ;;; The MODE of a CATCH could either be the MODE of the last of the PROGN
 147 ;;; or the mode of the THROW. The THROW may be hard to find, so this goes
 148 ;;; on the assumption that the mode of the PROGN is enough to tell.
 149
 150 (def%tr $catch (form)
 151   (destructuring-bind (mode . body) (translate `((mprogn) . ,(cdr form)))
 152     (cons mode `(mcatch ,body))))
 153
 154 (def%tr $throw (form)
 155   (destructuring-bind (mode . body) (translate (cadr form))
 156     (cons mode `($throw ,body))))
 157
 158 ;;; Makelist is a very sorry FSUBR. All these FSUBRS are just to avoid
 159 ;;; writing LAMBDA. But lots of users use MAKELIST now.
 160 ;;; MAKELIST(EXP,X,0,N) with 4 args it is an iteration, with three it
 161 ;;; is a mapping over a list (the third argument).
 162
 163 (def%tr $makelist (form)
 164   (setq form (cdr form))
 165   (cond
 166     ((= (length form) 0) '($any . '((mlist))))
 167     ((= (length form) 1)
 168      (destructuring-let
 169       (((exp) form))
 170       `($any . (list '(mlist) ,(cdr (tr-local-exp exp))))))
 171     ((= (length form) 2)
 172      (destructuring-let
 173       (((exp n) form) (sum (tr-gensym)) (nn (tr-gensym)) (|0| (tr-gensym)))
 174       (setq n (dtranslate n))
 175       `($any .
 176              ((lambda (,nn)
 177                 (setq ,nn ($float ,nn))
 178                 (if (numberp ,nn)
 179                     (do ((,|0| 1 (add 1 ,|0|)) (,sum nil))
 180                         ((> ,|0| ,nn) (cons '(mlist) ,sum))
 181                       (setq ,sum
 182                             (cons ,(cdr (tr-local-exp exp)) ,sum)))
 183                     (merror
 184                      (intl:gettext "makelist: second argument must evaluate to a number; found: ~M") ,nn)))
 185               ,n))))
 186     ((= (length form) 3)
 187      (destructuring-let
 188       (((exp x n) form) (sum (tr-gensym)) (nn (tr-gensym)) (lil (tr-gensym)))
 189       (setq n (dtranslate n))
 190       `($any .
 191              ((lambda (,nn)
 192                 (if ($listp ,nn)
 193                    (do ((,lil (cdr ,nn) (cdr ,lil))
 194                         (,sum nil) (,x))
 195                        ((null ,lil) (cons '(mlist) (nreverse ,sum)))
 196                      (setq
 197                       ,x (car ,lil)
 198                       ,sum
 199                       (cons ,(cdr (tr-local-exp exp x (value-mode x))) ,sum)))
 200                    (progn
 201                      (setq ,nn ($float ,nn))
 202                      (if (numberp ,nn)
 203                          (do ((,x 1 (add 1 ,x))
 204                               (,sum nil
 205                                     (cons
 206                                      ,(cdr (tr-local-exp exp x (value-mode x)))
 207                                      ,sum)))
 208                              ((> ,x ,nn)
 209                               (cons '(mlist) (nreverse ,sum)))
 210                            (declare (special ,x)))
 211                          (merror
 212                           (intl:gettext "makelist: third argument must be a number or a list; found: ~M") ,nn)))))
 213               ,n))))
 214     ((= (length form) 4)
 215      (destructuring-let
 216       (((exp x |0| n) form) (|00| (tr-gensym)) (nn (tr-gensym))
 217        (sum (tr-gensym)) (ii (tr-gensym)))
 218       (setq |0| (dtranslate |0|) n (dtranslate n))
 219       `($any .
 220              ((lambda (,|00| ,nn)
 221                 (setq ,nn ($float (sub ,nn ,|00|)))
 222                 (if (numberp ,nn)
 223                     (do ((,x ,|00| (add 1 ,x)) (,ii 0 (add 1 ,ii))
 224                          (,sum nil
 225                                (cons
 226                                 ,(cdr (tr-local-exp exp x (value-mode x)))
 227                                 ,sum)))
 228                         ((> ,ii ,nn) (cons '(mlist) (nreverse ,sum)))
 229                       (declare (special ,x)))
 230                     (merror
 231                      (intl:gettext "makelist: the fourth argument minus the third one must evaluate to a number; found: ~M")
 232                      ,nn)))
 233               ,|0| ,n))))
 234     ((= (length form) 5)
 235      (destructuring-let
 236       (((exp x |0| n s) form) (|00| (tr-gensym)) (nn (tr-gensym))
 237        (ss (tr-gensym)) (sum (tr-gensym)) (ii (tr-gensym)))
 238       (setq |0| (dtranslate |0|) n (dtranslate n) s (dtranslate s))
 239       `($any .
 240              ((lambda (,|00| ,nn ,ss)
 241                 (setq ,nn ($float (div (sub ,nn ,|00|) ,ss)))
 242                 (if (numberp ,nn)
 243                     (do ((,x ,|00| (add ,ss ,x)) (,ii 0 (add 1 ,ii))
 244                          (,sum nil
 245                                (cons
 246                                 ,(cdr (tr-local-exp exp x (value-mode x)))
 247                                 ,sum)))
 248                         ((> ,ii ,nn) (cons '(mlist) (nreverse ,sum)))
 249                       (declare (special ,x)))
 250                     (merror
 251                      (intl:gettext "makelist: the fourth argument minus the third one, divided by the fifth one must evaluate to a number; found: ~M")
 252                      ,nn)))
 253               ,|0| ,n ,s))))
 254     (t
 255      (tr-format (intl:gettext "makelist: maximum 5 arguments allowed; found: ~M.~%makelist: to create a list with sublists, use nested makelist commands.~%")
 256                 (length form))
 257      (setq tr-abort t)
 258      '($any . '$**error**))))
 259
 260 (def%tr $kill (form)
 261   `($any . (mapply '$kill ',(cdr form) nil)))
 262
 263 ;;; Macsyma arrays are the biggest crock since STATUS PUNT NIL days.
 264 ;;; The basic idea of ARRAY(<frob>,type,dims...) is that
 265 ;;; if type is of
 266 ;;; (ASSoc (CADR X) '(($COMPLETE . T) ($INTEGER . FIXNUM) ($FIXNUM . FIXNUM)
 267 ;;;                       ($FLOAT . FLONUM) ($FLONUM . FLONUM)))
 268 ;;; then the dims are evaluated. But, if type is not one of those,
 269 ;;; it "must" be a dim spec! Of course, I must make this "analysis"
 270 ;;; at translate time, in order to preserve referential transparency
 271 ;;; in compiled code.
 272
 273 (def%tr $array (form)
 274   (setq form (cdr form))
 275   (let ((name (car form))
 276         (specp (assoc (cadr form)
 277                      '(($complete . t) ($integer . fixnum) ($fixnum . fixnum)
 278                        ($float . flonum) ($flonum . flonum)) :test #'eq)))
 279     (cond
 280       (specp
 281         `($any . (mapply
 282                    '$array
 283                    (list ',name ',(cadr form) ,@(tr-args (cddr form)))
 284                    '$array)))
 285           (t
 286         `($any . (mapply
 287                    '$array
 288                    (list ',name ,@(tr-args (cdr form)))
 289                    '$array))))))
 290
 291
 292 ;;; it seems TRANSL has all sorts of code for hacking some kind of
 293 ;;; $CRE mode. somehow there is no translate property for MRAT. who
 294 ;;; knows. anyway here is something in the mean time before this
 295 ;;; I have time to do up TRANSL correctly.
 296 ;;;(DEFUN MRATEVAL (X)
 297 ;;; ((LAMBDA (VARLIST)
 298 ;;;   (COND (EVP (MEVAL ($RATDISREP X)))
 299 ;;;      ((OR (AND $FLOAT $KEEPFLOAT) (NOT (ALIKE VARLIST (MAPCAR 'MEVAL VARLIST))))
 300 ;;;       (RATF (MEVAL ($RATDISREP X))))
 301 ;;;      (T X)))
 302 ;;;  (CADDAR X)))
 303 ;;; EVP is a hack for $EV I think. The MEVAL down the varlist is to see if the
 304 ;;; variables have any values, if not, then the result of (ratf (meval ($ratdisrep)))
 305 ;;; will be alike to what you started with, so it is an efficiency hack! What a
 306 ;;; joke!
 307 ;;;(DEFPROP MRAT (LAMBDA (X) (MRATEVAL X)) MFEXPR*)
 308
 309 (def%tr mrat (form)
 310   (let ((t-form (translate ($ratdisrep form))))
 311     (cond ((member (car t-form) '($float $fixnum $number) :test #'eq) t-form)
 312           (t `($any . (ratf ,(cdr t-form)))))))
 313
 314
 315 ;;; The following special forms do not call the evaluator.
 316
 317 (def%tr $alias (form)
 318   (punt-to-meval form))
 319
 320 ;;most of these will lose in common since a local variable will not
 321 ;;have its value accessible to the mfexpr*.  They should
 322 ;;be redone as macros with any necessary info passed along.
 323
 324 (def%tr $batch $alias)
 325 (def%tr $batchload $alias)
 326 (def%tr $closefile $alias)
 327 (def%tr $compfile $alias)
 328 (def%tr $declare $alias)
 329 (def%tr $defstruct $alias)
 330 (def%tr $demo $alias)
 331 (def%tr $dependencies $alias)
 332 (def%tr $describe $alias)
 333 (def%tr $dispfun $alias)
 334 (def%tr $disprule $alias)
 335 (def%tr $fundef $alias)
 336 (def%tr $gradef $alias)
 337 (def%tr $labels $alias)
 338 (def%tr $loadarrays $alias)
 339 (def%tr $loadfile $alias)
 340 (def%tr $new $alias)
 341 (def%tr $numerval $alias)
 342 (def%tr $options $alias)
 343 (def%tr $ordergreat $alias)
 344 (def%tr $orderless $alias)
 345 (def%tr $printfile $alias)
 346 (def%tr $printprops $alias)
 347 (def%tr $product $alias)
 348 (def%tr %product $alias)
 349 (def%tr $properties $alias)
 350 (def%tr $propvars $alias)
 351 (def%tr $rearray $alias)
 352 (def%tr $remarray $alias)
 353 (def%tr $remfunction $alias)
 354 (def%tr $remove $alias)
 355 (def%tr $remvalue $alias)
 356 (def%tr $setup_autoload $alias)
 357 (def%tr $sum $alias)
 358 (def%tr %sum $alias)
 359 (def%tr $translate $alias)
 360 (def%tr $writefile $alias)
 361
 362 ;; Local Modes:
 363 ;; Mode: LISP
 364 ;; Comment Col: 40
 365 ;; END:
 366