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