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-let (((mode . body) (translate `((mprogn) . ,(cdr form)))))
 152     `(,mode . ((lambda (mcatch)
 153                  (prog1
 154                    (catch 'mcatch ,body)
 155                    (errlfun1 mcatch)))
 156                (cons bindlist loclist)))))
 157
 158 (def%tr $throw (form)
 159   (destructuring-let (((mode . exp) (translate (cadr form))))
 160     `(,mode . ((lambda (x)
 161                  (when (null mcatch)
 162                    (merror (intl:gettext "throw: not within 'catch'; expression: ~M") x))
 163                  (throw 'mcatch x))
 164                ,exp))))
 165
 166 ;;; Makelist is a very sorry FSUBR. All these FSUBRS are just to avoid
 167 ;;; writing LAMBDA. But lots of users use MAKELIST now.
 168 ;;; MAKELIST(EXP,X,0,N) with 4 args it is an iteration, with three it
 169 ;;; is a mapping over a list (the third argument).
 170
 171 (def%tr $makelist (form)
 172   (setq form (cdr form))
 173   (cond
 174     ((= (length form) 0) '($any . '((mlist))))
 175     ((= (length form) 1)
 176      (destructuring-let
 177       (((exp) form))
 178       `($any . (list '(mlist) ,(cdr (tr-local-exp exp))))))
 179     ((= (length form) 2)
 180      (destructuring-let
 181       (((exp n) form) (sum (tr-gensym)) (nn (tr-gensym)) (|0| (tr-gensym)))
 182       (setq n (dtranslate n))
 183       `($any .
 184              ((lambda (,nn)
 185                 (setq ,nn ($float ,nn))
 186                 (if (numberp ,nn)
 187                     (do ((,|0| 1 (add 1 ,|0|)) (,sum nil))
 188                         ((> ,|0| ,nn) (cons '(mlist) ,sum))
 189                       (setq ,sum
 190                             (cons ,(cdr (tr-local-exp exp)) ,sum)))
 191                     (merror
 192                      (intl:gettext "makelist: second argument must evaluate to a number; found: ~M") ,nn)))
 193               ,n))))
 194     ((= (length form) 3)
 195      (destructuring-let
 196       (((exp x n) form) (sum (tr-gensym)) (nn (tr-gensym)) (lil (tr-gensym)))
 197       (setq n (dtranslate n))
 198       `($any .
 199              ((lambda (,nn)
 200                 (if ($listp ,nn)
 201                    (do ((,lil (cdr ,nn) (cdr ,lil))
 202                         (,sum nil) (,x))
 203                        ((null ,lil) (cons '(mlist) (nreverse ,sum)))
 204                      (setq
 205                       ,x (car ,lil)
 206                       ,sum
 207                       (cons ,(cdr (tr-local-exp exp x (value-mode x))) ,sum)))
 208                    (progn
 209                      (setq ,nn ($float ,nn))
 210                      (if (numberp ,nn)
 211                          (do ((,x 1 (add 1 ,x))
 212                               (,sum nil
 213                                     (cons
 214                                      ,(cdr (tr-local-exp exp x (value-mode x)))
 215                                      ,sum)))
 216                              ((> ,x ,nn)
 217                               (cons '(mlist) (nreverse ,sum)))
 218                            (declare (special ,x)))
 219                          (merror
 220                           (intl:gettext "makelist: third argument must be a number or a list; found: ~M") ,nn)))))
 221               ,n))))
 222     ((= (length form) 4)
 223      (destructuring-let
 224       (((exp x |0| n) form) (|00| (tr-gensym)) (nn (tr-gensym))
 225        (sum (tr-gensym)) (ii (tr-gensym)))
 226       (setq |0| (dtranslate |0|) n (dtranslate n))
 227       `($any .
 228              ((lambda (,|00| ,nn)
 229                 (setq ,nn ($float (sub ,nn ,|00|)))
 230                 (if (numberp ,nn)
 231                     (do ((,x ,|00| (add 1 ,x)) (,ii 0 (add 1 ,ii))
 232                          (,sum nil
 233                                (cons
 234                                 ,(cdr (tr-local-exp exp x (value-mode x)))
 235                                 ,sum)))
 236                         ((> ,ii ,nn) (cons '(mlist) (nreverse ,sum)))
 237                       (declare (special ,x)))
 238                     (merror
 239                      (intl:gettext "makelist: the fourth argument minus the third one must evaluate to a number; found: ~M")
 240                      ,nn)))
 241               ,|0| ,n))))
 242     ((= (length form) 5)
 243      (destructuring-let
 244       (((exp x |0| n s) form) (|00| (tr-gensym)) (nn (tr-gensym))
 245        (ss (tr-gensym)) (sum (tr-gensym)) (ii (tr-gensym)))
 246       (setq |0| (dtranslate |0|) n (dtranslate n) s (dtranslate s))
 247       `($any .
 248              ((lambda (,|00| ,nn ,ss)
 249                 (setq ,nn ($float (div (sub ,nn ,|00|) ,ss)))
 250                 (if (numberp ,nn)
 251                     (do ((,x ,|00| (add ,ss ,x)) (,ii 0 (add 1 ,ii))
 252                          (,sum nil
 253                                (cons
 254                                 ,(cdr (tr-local-exp exp x (value-mode x)))
 255                                 ,sum)))
 256                         ((> ,ii ,nn) (cons '(mlist) (nreverse ,sum)))
 257                       (declare (special ,x)))
 258                     (merror
 259                      (intl:gettext "makelist: the fourth argument minus the third one, divided by the fifth one must evaluate to a number; found: ~M")
 260                      ,nn)))
 261               ,|0| ,n ,s))))
 262     (t
 263      (tr-format (intl:gettext "makelist: maximum 5 arguments allowed; found: ~M.~%makelist: to create a list with sublists, use nested makelist commands.~%")
 264                 (length form))
 265      (setq tr-abort t)
 266      '($any . '$**error**))))
 267
 268 (def%tr $kill (form)
 269   `($any . (mapply '$kill ',(cdr form) nil)))
 270
 271 ;;; Macsyma arrays are the biggest crock since STATUS PUNT NIL days.
 272 ;;; The basic idea of ARRAY(<frob>,type,dims...) is that
 273 ;;; if type is of
 274 ;;; (ASSoc (CADR X) '(($COMPLETE . T) ($INTEGER . FIXNUM) ($FIXNUM . FIXNUM)
 275 ;;;                       ($FLOAT . FLONUM) ($FLONUM . FLONUM)))
 276 ;;; then the dims are evaluated. But, if type is not one of those,
 277 ;;; it "must" be a dim spec! Of course, I must make this "analysis"
 278 ;;; at translate time, in order to preserve referential transparency
 279 ;;; in compiled code.
 280
 281 (def%tr $array (form)
 282   (setq form (cdr form))
 283   (let ((name (car form))
 284         (specp (assoc (cadr form)
 285                      '(($complete . t) ($integer . fixnum) ($fixnum . fixnum)
 286                        ($float . flonum) ($flonum . flonum)) :test #'eq)))
 287     (cond
 288       (specp
 289         `($any . (mapply
 290                    '$array
 291                    (list ',name ',(cadr form) ,@(tr-args (cddr form)))
 292                    '$array)))
 293           (t
 294         `($any . (mapply
 295                    '$array
 296                    (list ',name ,@(tr-args (cdr form)))
 297                    '$array))))))
 298
 299
 300 ;;; it seems TRANSL has all sorts of code for hacking some kind of
 301 ;;; $CRE mode. somehow there is no translate property for MRAT. who
 302 ;;; knows. anyway here is something in the mean time before this
 303 ;;; I have time to do up TRANSL correctly.
 304 ;;;(DEFUN MRATEVAL (X)
 305 ;;; ((LAMBDA (VARLIST)
 306 ;;;   (COND (EVP (MEVAL ($RATDISREP X)))
 307 ;;;      ((OR (AND $FLOAT $KEEPFLOAT) (NOT (ALIKE VARLIST (MAPCAR 'MEVAL VARLIST))))
 308 ;;;       (RATF (MEVAL ($RATDISREP X))))
 309 ;;;      (T X)))
 310 ;;;  (CADDAR X)))
 311 ;;; EVP is a hack for $EV I think. The MEVAL down the varlist is to see if the
 312 ;;; variables have any values, if not, then the result of (ratf (meval ($ratdisrep)))
 313 ;;; will be alike to what you started with, so it is an efficiency hack! What a
 314 ;;; joke!
 315 ;;;(DEFPROP MRAT (LAMBDA (X) (MRATEVAL X)) MFEXPR*)
 316
 317 (def%tr mrat (form)
 318   (let ((t-form (translate ($ratdisrep form))))
 319     (cond ((member (car t-form) '($float $fixnum $number) :test #'eq) t-form)
 320           (t `($any . (ratf ,(cdr t-form)))))))
 321
 322
 323 ;;; The following special forms do not call the evaluator.
 324
 325 (def%tr $alias (form)
 326   `($any . (meval ',form)))
 327 ;;most of these will lose in common since a local variable will not
 328 ;;have its value accessible to the mfexpr*.  They should
 329 ;;be redone as macros with any necessary info passed along.
 330
 331 (def%tr $batch $alias)
 332 (def%tr $batchload $alias)
 333 (def%tr $closefile $alias)
 334 (def%tr $compfile $alias)
 335 (def%tr $demo $alias)
 336 (def%tr $dependencies $alias)
 337 (def%tr $describe $alias)
 338 (def%tr $dispfun $alias)
 339 (def%tr $disprule $alias)
 340 (def%tr $fundef $alias)
 341 (def%tr $gradef $alias)
 342 (def%tr $labels $alias)
 343 (def%tr $loadarrays $alias)
 344 (def%tr $loadfile $alias)
 345 (def%tr $numerval $alias)
 346 (def%tr $options $alias)
 347 (def%tr $ordergreat $alias)
 348 (def%tr $orderless $alias)
 349 (def%tr $printfile $alias)
 350 (def%tr $printprops $alias)
 351 (def%tr $product $alias)
 352 (def%tr %product $alias)
 353 (def%tr $properties $alias)
 354 (def%tr $propvars $alias)
 355 (def%tr $rearray $alias)
 356 (def%tr $remarray $alias)
 357 (def%tr $remfunction $alias)
 358 (def%tr $remove $alias)
 359 (def%tr $remvalue $alias)
 360 (def%tr $setup_autoload $alias)
 361 (def%tr $sum $alias)
 362 (def%tr %sum $alias)
 363 (def%tr $translate $alias)
 364 (def%tr $writefile $alias)
 365
 366 ;; Local Modes:
 367 ;; Mode: LISP
 368 ;; Comment Col: 40
 369 ;; END:
 370