home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / trans2.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  8.3 KB  |  243 lines
  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. ;;; TRANSLATION PROPERTIES FOR MACSYMA OPERATORS AND FUNCTIONS.
  15.  
  16. ;;; This file is for list and array manipulation optimizations.
  17.  
  18. (macsyma-module trans2)
  19.  
  20.  
  21. (TRANSL-MODULE TRANS2)
  22.  
  23. (DEF%TR $RANDOM (FORM) `($FIXNUM . (RANDOM ,@(TR-ARGS (CDR FORM)))))
  24.  
  25. (DEF%TR MEQUAL (FORM)
  26.     `($ANY . (SIMPLIFY (LIST '(MEQUAL) ,@(TR-ARGS (CDR FORM))))))
  27.  
  28. (DEF%TR MCALL (FORM)
  29.     (SETQ FORM (CDR FORM))
  30.     (LET ((MODE (COND ((ATOM (CAR FORM))
  31.                (FUNCTION-MODE (CAR FORM)))
  32.               (T '$ANY))))
  33.          (SETQ FORM (TR-ARGS FORM))
  34.          (LET ((OP (CAR FORM)))
  35.           (CALL-AND-SIMP MODE 'MCALL `(,OP . ,(CDR FORM))))))
  36.  
  37. ;;; Meaning of the mode properties: most names are historical.
  38. ;;; (GETL X '(ARRAY-MODE)) means it is an array callable by the
  39. ;;; old maclisp style. This is unfortunately still useful to
  40. ;;; avoid indirection through the property list to get to the
  41. ;;; array.
  42.  
  43. #+cl
  44. (defvar $translate_fast_arrays t )
  45. ;;When $translate_fast_arrays and $use_fast_arrays are true
  46. ;;there should only be two types of arrays and they should be stored on
  47. ;;the value cell of the symbol.  These should be the equivalent of the
  48. ;;zetalisp art-q and the si:equal-hash-table. Note that maxima lists
  49. ;;and maxima $matrices are also allowed for setting.  Note also that
  50. ;;because of some hokey things like mqapply etc, if you want
  51. ;;fast referenceing use a[i], or b[i]:..., ie use variables,
  52. ;;since if you try something complicated it may not translate as
  53. ;;simply.
  54. ;;Idea of these is for the lispm to store the array in the value cell
  55. ;;to use equal-hash-tables, and to clean up the local variable
  56. ;;in translated code for an array.
  57. ;;txx(i,j):=block([hl],hl[i]:j,hl[i]); should leave hl unbound, after creating
  58. ;;a  hash table for hl, There should be a resource of these.
  59.  
  60.  
  61. ;;acceptable arguments to ar[i] or ar[i]:val
  62. #+cl
  63. (defun lispm-marray-type (ar)
  64.   (cond ((arrayp ar) 'array)
  65.     ( (hash-table-p ar) 'hash-table)
  66.     (($listp ar) '$list)
  67.     (($matrixp ar) '$matrix)
  68.     ((symbolp ar) 'symbol)
  69.     (t nil)))
  70.  
  71. #+cl
  72. (defun tr-maset (ar val  inds)
  73.   `(nil maset ,val ,ar  ,@ inds))
  74.  
  75.  
  76. #+cl
  77. (defun maset1 ( val ar  &rest inds &aux  )
  78.   (lisp:let
  79.    ((.type. (#. *primitive-data-type-function*  ar)))
  80.     (cond
  81.       ((one-of-types .type. (make-array 3))
  82.        (setf (apply #'aref ar inds)  val))
  83.       ((one-of-types .type. (make-hash-table :test 'equal))
  84.        (setf (gethash (if (cdr inds) (copy-rest inds) (car inds))
  85.               ar)
  86.          val))
  87.       ((one-of-types .type.  'a)
  88.        (error "must set the hash table outside")
  89.        )
  90.       (($listp ar)            (setf (nth (car inds) ar) val) val)
  91.       (($matrixp ar)  (setf (nth (second inds) (nth  (car inds) ar)) val) val)
  92.       (t (error "not a valid array reference to ~A" ar)))))
  93.  
  94.  
  95. ;;apply is too expensive for a simple array reference.  The time
  96. ;;is increased by a factor of 6.  Note we use the locf form to get at
  97. ;;the local variable of the function calling maset in order to be able
  98. ;;to store a hash-table there in the case that the variable was not an
  99. ;;array
  100.  
  101. ;;COULD USE THE FOLLOWING TO handle fast_arrays:true.
  102. ;(defun set-up-hash-table (&optional val key &aux tab)
  103. ;  (setq tab (make-hash-table :test 'equal)) ;alike?
  104. ;  (setf (gethash key tab) val) tab)
  105. ;
  106. ;(defun maset-help1 ( val ar  &rest inds &aux  )
  107. ;  "returns t if it set and nil if what went in could not be set but is a variable that
  108. ;    should be set to hash array"
  109. ;  (cond ((hash-table-p ar)
  110. ;     (setf (gethash (car inds) ar) val))
  111. ;    ((symbolp ar) nil)
  112. ;    (($listp ar)
  113. ;     (setf (nth (car inds) ar) val)  t)
  114. ;    (($matrixp ar) (setf (nth (second inds) (nth  (car inds) ar)) val) t)
  115. ;    (t (error "not valid place ~A to put an array" ar))))
  116. ;
  117. ;
  118. ;;;;doesn't prevent multiple evaluation of inds val and ar.. but doesn't use locf
  119. ;(defmacro maset (val ar &rest  inds )
  120. ;  `(cond
  121. ;     ((arrayp ar) (setf (aref ar ,@ inds) ,val))
  122. ;     ((maset-help1 ,val ,ar ,@ inds) ,val)
  123. ;      (t (setf ,ar (set-up-hash-table ,val (car ,ind))),val)))
  124. ;
  125. ;(defmacro maref ( ar &rest inds)
  126. ;  `(cond ((arrayp ,ar) (aref ,ar ,@ inds))
  127. ;     ((hash-table-p ,ar) (gethash ,ar (car ,inds)))
  128. ;     ((symbolp ,ar)`((,ar ,@ (copy-list ,inds))))))
  129.  
  130. ;;in maref in transl now
  131. #+cl
  132. (defun tr-maref (ar inds)
  133.     `(nil maref , ar ,@ (copy-list inds)))
  134.  
  135. #+cl
  136. (defun maref1 (ar  &rest inds &aux )
  137.   (let ((.type. (#. *primitive-data-type-function*  ar)))
  138.     (cond
  139.       ((one-of-types .type. (make-array 3))     (apply #'aref ar inds))
  140.       ((one-of-types .type. (make-hash-table :test 'equal))
  141.        (gethash (if (cdr inds) inds (car inds)) ar))
  142.       ((one-of-types .type.  'a)  `((,ar array) ,@ (copy-list inds)))
  143.       (($listp ar) (nth (car inds) ar))
  144.       (($matrixp ar) (nth (second inds) (nth (first inds) ar)))
  145.       (t (error "not a valid array reference to ~A" ar)))))
  146.  
  147.  
  148. (DEFTRFUN TR-ARRAYCALL (FORM &aux all-inds)
  149.        (COND ((GET (CAAR FORM) 'ARRAY-MODE)
  150.           (ADDL (CAAR FORM) ARRAYS)
  151.           `(,(ARRAY-MODE (CAAR FORM))
  152.         . (,(CAAR FORM) ,@(TR-ARGS (CDR FORM)))))
  153.          ;;((MEMQ (MGET (CAAR FORM) 'ARRAYFUN-MODE) '($FLOAT $FIXNUM))
  154.          ;;`(,(MGET (CAAR FORM) 'ARRAYFUN-MODE)
  155.          ;;MAFCALL ,(CAAR FORM) . ,(MAPCAR 'DTRANSLATE (CDR FORM))))
  156.          
  157.          #+cl
  158.          ($translate_fast_arrays (setq all-inds (mapcar 'dtranslate (cdr form)))
  159.                      ;;not apply changed 'tr-maref
  160.           (funcall 'tr-maref (cdr (translate (caar form)))   all-inds))
  161.          (T
  162.           (TRANSLATE `((MARRAYREF)
  163.                ,(IF $TR_ARRAY_AS_REF (CAAR FORM)
  164.                        `((MQUOTE) ,(CAAR FORM)))     
  165.                ,@(CDR FORM))))))
  166.  
  167.  
  168.  
  169. (DEFTRFUN TR-ARRAYSETQ (array-ref value)
  170.        ;; actually an array SETF, but it comes from A[X]:FOO
  171.        ;; which is ((MSETQ) ... ...)
  172.        (COND ((GETL (CAAR array-ref) '(ARRAY-MODE))
  173.           (LET ((T-REF (TRANSLATE ARRAY-REF))
  174.             (T-VALUE (TRANSLATE VALUE))
  175.             (MODE))
  176.            (WARN-MODE ARRAY-REF (CAR T-REF) (CAR T-VALUE))
  177.            (SETQ MODE (CAR T-REF)) ; ooh, could be bad.
  178.            `(,MODE
  179.              . (STORE ,(CDR T-REF) ,(CDR T-VALUE)))))
  180.          #+cl
  181.          ($translate_fast_arrays 
  182.           (funcall 'tr-maset (caar array-ref) (dtranslate value)
  183.                  (mapcar 'dtranslate (copy-list (cdr array-ref)))))
  184.          (T
  185.           ;; oops. Hey, I switch around order of evaluation
  186.           ;; here. no need to either man. gee.
  187.           (TRANSLATE `((MARRAYSET) ,Value
  188.                        ,(IF $TR_ARRAY_AS_REF (CAAR ARRAY-REF)
  189.                        `((MQUOTE) ,(CAAR ARRAY-REF)))
  190.                        ,@(CDR ARRAY-REF))))))
  191.  
  192.  
  193. (DEF%TR MARRAYREF (FORM)
  194.   (SETQ FORM (CDR FORM))
  195.   (LET ((MODE (COND ((ATOM (CAR FORM))
  196.              (MGET (CAR FORM) 'ARRAY-MODE)))))
  197.     (COND ((NULL MODE) (SETQ MODE '$ANY)))
  198.     (SETQ FORM (TR-ARGS FORM))
  199.     (LET ((OP (CAR FORM)))
  200.       `(,MODE . (,(IF (AND (= (LENGTH FORM) 2)
  201.                (EQ MODE '$FLOAT))
  202.               (PROGN (PUSH-AUTOLOAD-DEF 'MARRAYREF '(MARRAYREF1$))
  203.                  'MARRAYREF1$)
  204.               'MARRAYREF)
  205.          ,OP . ,(CDR FORM))))))
  206.  
  207. (DEF%TR MARRAYSET (FORM)
  208.   (SETQ FORM (CDR FORM))
  209.   (LET ((MODE (COND ((ATOM (CADR FORM))
  210.              (MGET (CADR FORM) 'ARRAY-MODE)))))
  211.     (COND ((NULL MODE) (SETQ MODE '$ANY)))
  212.     (SETQ FORM (TR-ARGS FORM))
  213.     (LET (((VAL AARRAY . INDS) FORM))
  214.       `(,MODE . (,(IF (AND (= (LENGTH INDS) 1)
  215.                (EQ MODE '$FLOAT))
  216.               (PROGN (PUSH-AUTOLOAD-DEF 'MARRAYSET '(MARRAYSET1$))
  217.                  'MARRAYSET1$)
  218.               'MARRAYSET)
  219.          ,VAL ,AARRAY . ,INDS)))))
  220.  
  221. (DEF%TR MLIST (FORM)
  222.     (COND ((NULL (CDR FORM)) ;;; []
  223.            '($ANY . '((MLIST))))
  224.           (T
  225.            `($ANY . (LIST '(MLIST) . ,(TR-ARGS (CDR FORM)))))))
  226.  
  227. (DEF%TR $FIRST (FORM)
  228.   (SETQ FORM (TRANSLATE (CADR FORM)))
  229.   (call-and-simp '$ANY
  230.          (COND ((EQ '$LIST (CAR FORM))
  231.             'CADR)
  232.                (T
  233.             '$FIRST))
  234.          (list (CDR FORM))))
  235.  
  236.  
  237.  
  238. ;; Local Modes:
  239. ;; Mode: LISP
  240. ;; Comment Col: 40
  241. ;; END:
  242.  
  243.