src/trans2.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 ;;;            Please do not modify this file.         See GJC           ;;;
  10 ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12
  13 (in-package :maxima)
  14
  15 ;;; TRANSLATION PROPERTIES FOR MACSYMA OPERATORS AND FUNCTIONS.
  16
  17 ;;; This file is for list and array manipulation optimizations.
  18
  19 (macsyma-module trans2)
  20
  21
  22 (def%tr $random (form) `($fixnum . ($random ,@(tr-args (cdr form)))))
  23
  24 (def%tr mequal (form)
  25   `($any . (simplify (list '(mequal) ,@(tr-args (cdr form))))))
  26
  27 (def%tr mcall (form)
  28   (setq form (cdr form))
  29   (let ((mode (cond ((atom (car form))
  30                      (function-mode (car form)))
  31                     (t '$any))))
  32     (setq form (tr-args form))
  33     (let ((op (car form)))
  34       (call-and-simp mode 'mcall `(,op . ,(cdr form))))))
  35
  36 ;;; Meaning of the mode properties: most names are historical.
  37 ;;; (GETL X '(ARRAY-MODE)) means it is an array callable by the
  38 ;;; old maclisp style. This is unfortunately still useful to
  39 ;;; avoid indirection through the property list to get to the
  40 ;;; array.
  41
  42 (defvar $translate_fast_arrays nil)
  43 ;;When $translate_fast_arrays and $use_fast_arrays are true
  44 ;;there should only be two types of arrays and they should be stored on
  45 ;;the value cell of the symbol.  These should be the equivalent of the
  46 ;;zetalisp art-q and the si:equal-hash-table. Note that maxima lists
  47 ;;and maxima $matrices are also allowed for setting.  Note also that
  48 ;;because of some hokey things like mqapply etc, if you want
  49 ;;fast referenceing use a[i], or b[i]:..., ie use variables,
  50 ;;since if you try something complicated it may not translate as
  51 ;;simply.
  52 ;;Idea of these is for the lispm to store the array in the value cell
  53 ;;to use equal-hash-tables, and to clean up the local variable
  54 ;;in translated code for an array.
  55 ;;txx(i,j):=block([hl],hl[i]:j,hl[i]); should leave hl unbound, after creating
  56 ;;a  hash table for hl, There should be a resource of these.
  57
  58 (defun tr-maset (ar val  inds)
  59   ;; Top-level forms need to define the variable first.
  60   (if *macexpr-top-level-form-p*
  61       `(nil progn (defvar ,ar ',ar) (maset ,val ,ar  ,@ inds))
  62       `(nil maset ,val ,ar  ,@ inds)))
  63
  64 (defun maset1 (val ar &rest inds)
  65   (cond
  66     ((and (typep ar 'cl:array)
  67           (= (length inds) (cl:array-rank ar)))
  68      (setf (apply #'aref ar inds)  val))
  69     ((typep ar 'cl:hash-table)
  70      (setf (gethash (if (cdr inds) (copy-list inds) (car inds))
  71                     ar)
  72            val))
  73     ((symbolp ar)
  74      (error "MASET1: first argument must not be a symbol; found: ~A" ar))
  75     ((and (= (length inds) 1)
  76           (or ($listp ar) ($matrixp ar)))
  77      (setf (nth (car inds) ar) val))
  78     ((and ($matrixp ar)
  79           (= (length inds) 2))
  80      (setf (nth (second inds) (nth  (car inds) ar)) val))
  81     (t (error "MASET1: invalid array reference: ~A" ar))))
  82
  83
  84 ;;apply is too expensive for a simple array reference.  The time
  85 ;;is increased by a factor of 6.  Note we use the locf form to get at
  86 ;;the local variable of the function calling maset in order to be able
  87 ;;to store a hash-table there in the case that the variable was not an
  88 ;;array
  89
  90 ;;COULD USE THE FOLLOWING TO handle fast_arrays:true.
  91 ;;(defun set-up-hash-table (&optional val key &aux tab)
  92 ;;  (setq tab (make-hash-table :test 'equal)) ;alike?
  93 ;;  (setf (gethash key tab) val) tab)
  94 ;;
  95 ;;(defun maset-help1 ( val ar  &rest inds &aux  )
  96 ;;  "returns t if it set and nil if what went in could not be set but is a variable that
  97 ;;    should be set to hash array"
  98 ;;  (cond ((hash-table-p ar)
  99 ;;       (setf (gethash (car inds) ar) val))
 100 ;;      ((symbolp ar) nil)
 101 ;;      (($listp ar)
 102 ;;       (setf (nth (car inds) ar) val)  t)
 103 ;;      (($matrixp ar) (setf (nth (second inds) (nth  (car inds) ar)) val) t)
 104 ;;      (t (error "not valid place ~A to put an array" ar))))
 105 ;;
 106 ;;
 107 ;;;;doesn't prevent multiple evaluation of inds val and ar.. but doesn't use locf
 108 ;;(defmacro maset (val ar &rest  inds )
 109 ;;  `(cond
 110 ;;     ((arrayp ar) (setf (aref ar ,@ inds) ,val))
 111 ;;     ((maset-help1 ,val ,ar ,@ inds) ,val)
 112 ;;      (t (setf ,ar (set-up-hash-table ,val (car ,ind))),val)))
 113 ;;
 114 ;;(defmacro maref ( ar &rest inds)
 115 ;;  `(cond ((arrayp ,ar) (aref ,ar ,@ inds))
 116 ;;       ((hash-table-p ,ar) (gethash ,ar (car ,inds)))
 117 ;;       ((symbolp ,ar)`((,ar ,@ (copy-list ,inds))))))
 118
 119 ;;in maref in transl now
 120
 121 (defun tr-maref (ar inds)
 122   `(nil maref , ar ,@ (copy-list inds)))
 123
 124 (defun maref1 (ar &rest inds)
 125   (cond
 126     ((and (typep ar 'cl:array)
 127           (= (length inds) (cl:array-rank ar)))
 128      (apply #'aref ar inds))
 129     ((typep ar 'cl:hash-table)
 130      (gethash (if (cdr inds) inds (car inds)) ar))
 131     ((symbolp ar)
 132      (cond ((mget ar 'hashar)
 133             (harrfind `((,ar array) ,@(copy-list inds))))
 134            (t
 135             `((,ar array) ,@(copy-list inds)))))
 136     ((and (= (length inds) 1)
 137           (or ($listp ar) ($matrixp ar)))
 138      (nth (first inds) ar))
 139     ((and ($matrixp ar) (= (length inds) 2))
 140      (nth (second inds) (nth (first inds) ar)))
 141     (t
 142      (merror (intl:gettext "Wrong number of array indices: ~M") (cons '(mlist) inds)))))
 143
 144
 145 (defun tr-arraycall (form &aux all-inds)
 146   (cond
 147         ($translate_fast_arrays (setq all-inds (mapcar 'dtranslate (cdr form)))
 148                                 ;;not apply changed 'tr-maref
 149                                 (funcall 'tr-maref (cdr (translate (caar form)))   all-inds))
 150         (t
 151          (translate `((marrayref)
 152                       ,(if $tr_array_as_ref (caar form)
 153                            `((mquote) ,(caar form)))
 154                       ,@(cdr form))))))
 155
 156
 157
 158 (defun tr-arraysetq (array-ref value)
 159   ;; actually an array SETF, but it comes from A[X]:FOO
 160   ;; which is ((MSETQ) ... ...)
 161   (cond
 162         ($translate_fast_arrays
 163          (funcall 'tr-maset (caar array-ref) (dtranslate value)
 164                   (mapcar 'dtranslate (copy-list (cdr array-ref)))))
 165         (t
 166          ;; oops. Hey, I switch around order of evaluation
 167          ;; here. no need to either man. gee.
 168          (translate `((marrayset) ,value
 169                       ,(if $tr_array_as_ref (caar array-ref)
 170                            `((mquote) ,(caar array-ref)))
 171                       ,@(cdr array-ref))))))
 172
 173
 174 (def%tr marrayref (form)
 175   (setq form (cdr form))
 176   (let ((mode (cond ((atom (car form))
 177                      (get (car form) 'array-mode)))))
 178     (cond ((null mode) (setq mode '$any)))
 179     (setq form (tr-args form))
 180     (let ((op (car form)))
 181       `(,mode . (,(if (and (= (length form) 2)
 182                            (eq mode '$float))
 183                       (progn (push-autoload-def 'marrayref '(marrayref1$))
 184                              'marrayref1$)
 185                       'marrayref)
 186                  ,op . ,(cdr form))))))
 187
 188 (def%tr marrayset (form)
 189   (setq form (cdr form))
 190   (let ((mode (cond ((atom (cadr form))
 191                      (get (cadr form) 'array-mode)))))
 192     (when (null mode) (setq mode '$any))
 193     (setq form (tr-args form))
 194     (destructuring-let (((val aarray . inds) form))
 195       `(,mode . (,(if (and (= (length inds) 1)
 196                            (eq mode '$float))
 197                       (progn
 198                         (push-autoload-def 'marrayset '(marrayset1$))
 199                         'marrayset1$)
 200                       'marrayset)
 201                   ,val ,aarray . ,inds)))))
 202
 203 (def%tr mlist (form)
 204   (if (null (cdr form)) ;;; []
 205       '($any . '((mlist)))
 206       `($any . (list '(mlist) . ,(tr-args (cdr form))))))
 207
 208 (def%tr $first (form)
 209   (setq form (translate (cadr form)))
 210   (call-and-simp '$any (if (eq '$list (car form))
 211                            'cadr
 212                            '$first)
 213                  (list (cdr form))))
 214
 215 ;; Local Modes:
 216 ;; Mode: LISP
 217 ;; Comment Col: 40
 218 ;; END: