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