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