← Back to branch summary

~ubuntu-branches/debian/squeeze/maxima/squeeze

« back to all changes in this revision

Viewing changes to src/marray.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2006-10-18 14:52:42 UTC
  • mto: (1.1.5 upstream)
  • mto: This revision was merged to the branch mainline in revision 4.
  • Revision ID: james.westby@ubuntu.com-20061018145242-vzyrm5hmxr8kiosf
Import upstream version 5.10.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/marray.lisp
9
9
;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
10
10
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11
11
 
12
 
(in-package "MAXIMA")
 
12
(in-package :maxima)
13
13
(macsyma-module array)
14
14
 
15
15
;;; Macsyma User array utilities originally due to CFFK.
32
32
;;; simultaneously of type (1) and (1m).
33
33
 
34
34
(defun $listarray (ary)
35
 
       (Cons '(mlist)
36
 
             (cond ((mget ary 'hashar)
37
 
                    (mapcar #'(lambda (subs) ($arrayapply ary subs))
38
 
                            (cdddr (meval (list '($arrayinfo) ary)))))
39
 
                   ((mget ary 'array) (listarray (mget ary 'array)))
40
 
                   #+cl
41
 
                   ((arrayp ary) (coerce ary 'list))
42
 
                   #+cl
43
 
                   ( 
44
 
                    (hash-table-p ary)
45
 
                    (let (vals (tab ary))
46
 
                      (declare (special vals tab))
47
 
                       (maphash #'(lambda (x &rest l)l (push (gethash x tab) vals)) ary )
48
 
                       vals))
49
 
                   (t 
50
 
                    (merror "Argument to LISTARRAY must be an array:~%~M" ary)))))
 
35
  (cons '(mlist)
 
36
        (cond ((mget ary 'hashar)
 
37
               (mapcar #'(lambda (subs) ($arrayapply ary subs))
 
38
                       (cdddr (meval (list '($arrayinfo) ary)))))
 
39
              ((mget ary 'array) (listarray (mget ary 'array)))
 
40
              #+cl
 
41
              ((arrayp ary) (coerce ary 'list))
 
42
              #+cl
 
43
              ( 
 
44
               (hash-table-p ary)
 
45
               (let (vals (tab ary))
 
46
                 (declare (special vals tab))
 
47
                 (maphash #'(lambda (x &rest l)l (push (gethash x tab) vals)) ary )
 
48
                 vals))
 
49
              (t 
 
50
               (merror "Argument to `listarray' must be an array:~%~M" ary)))))
51
51
 
52
52
(defmfun $fillarray (ary1 ary2)
53
 
      (let ((ary
54
 
              (or
55
 
               (mget ary1 'array)
56
 
               #+cl
57
 
               (and (arrayp ary1) ary1)
58
 
               (merror "First argument to FILLARRAY must be a declared array:~%~M" ary1))))
59
 
            (fillarray
60
 
             ary
61
 
             (cond (($listp ary2) (cdr ary2))
62
 
                   ((get (mget ary2 'array) 'array))
63
 
                   #+cl
64
 
                   ((arrayp ary2) ary2)
65
 
                   (t
66
 
                    (merror
67
 
                     "Second argument to FILLARRAY must be an array or list:~%~M" ary2))))
68
 
            ary1))
69
 
;#+cl
70
 
;(defmacro $rearray (ar &rest dims)
71
 
;  `(cond ($use_fast_arrays (setq ,ar (rearray-aux ',ar ,(safe-value ar) ,@ dims)))
72
 
;        (t (rearray-aux ',ar (safe-value ,ar) ,@ dims))))
 
53
  (let ((ary
 
54
         (or
 
55
          (mget ary1 'array)
 
56
          #+cl
 
57
          (and (arrayp ary1) ary1)
 
58
          (merror "First argument to `fillarray' must be a declared array:~%~M" ary1))))
 
59
    (fillarray
 
60
     ary
 
61
     (cond (($listp ary2) (cdr ary2))
 
62
           ((get (mget ary2 'array) 'array))
 
63
           #+cl
 
64
           ((arrayp ary2) ary2)
 
65
           (t
 
66
            (merror
 
67
             "Second argument to `fillarray' must be an array or list:~%~M" ary2))))
 
68
    ary1))
 
69
;;#+cl
 
70
;;(defmacro $rearray (ar &rest dims)
 
71
;;  `(cond ($use_fast_arrays (setq ,ar (rearray-aux ',ar ,(safe-value ar) ,@ dims)))
 
72
;;       (t (rearray-aux ',ar (safe-value ,ar) ,@ dims))))
73
73
 
74
74
(defun getvalue (sym)
75
75
  (and (symbolp sym) (boundp sym) (symbol-value sym)))
76
 
(defmspec $rearray (l) (setq l (cdr l))
 
76
(defmspec $rearray (l)
 
77
  (setq l (cdr l))
77
78
  (let ((ar (car l)) (dims (cdr l)))
78
 
    (cond ($use_fast_arrays (set ar (rearray-aux ar (getvalue ar) dims )))
79
 
          (t (rearray-aux ar (getvalue ar) dims)))))
 
79
    (cond ($use_fast_arrays
 
80
           (set ar (rearray-aux ar (getvalue ar) dims )))
 
81
          (t
 
82
           (rearray-aux ar (getvalue ar) dims)))))
80
83
 
81
84
#+cl
82
85
(defun rearray-aux (ar val dims &aux marray-sym)
86
89
         (setf (symbol-array ar)
87
90
               (apply 'lispm-rearray (symbol-array ar ) dims)))
88
91
        ((setq marray-sym (mget ar 'array))
89
 
         (apply 'rearray-aux  marray-sym nil dims ) ar)
 
92
         ;; Why apply?  Why not directly call ourselves?
 
93
         #+nil
 
94
         (apply 'rearray-aux  marray-sym nil (list dims))
 
95
         (rearray-aux marray-sym nil dims)
 
96
         ar)
90
97
        (t (error "unknown array ~A " ar))))
91
98
 
92
99
#-cl
93
100
(defmspec $rearray (l) (setq l (cdr l))
94
101
          (cond ((> (length l) 6)
95
 
                 (merror "Too many arguments to REARRAY:~%~M" l))
 
102
                 (merror "Too many arguments to `rearray':~%~M" l))
96
103
                ((< (length l) 2)
97
 
                 (merror "Too few arguments to REARRAY:~%~M" l)))
 
104
                 (merror "Too few arguments to `rearray':~%~M" l)))
98
105
          (let ((name (car l))
99
106
                (ary (cond ($use_fast_arrays
100
 
                           (symbol-value (car l)))
101
 
                     (t
102
 
                       (cond ((mget (car l) 'array))
103
 
                             (t 
104
 
                              (merror "First argument to REARRAY must be a declared array:~%~M"
105
 
                                      (car l))))))))
 
107
                            (symbol-value (car l)))
 
108
                           (t
 
109
                            (cond ((mget (car l) 'array))
 
110
                                  (t 
 
111
                                   (merror "First argument to `rearray' must be a declared array:~%~M"
 
112
                                           (car l))))))))
106
113
            (setq l (cdr l)
107
114
                  l (mapcar #'(lambda (x)
108
115
                                (setq x (meval x))
109
116
                                (cond ((not (eq (ml-typep x) 'fixnum))
110
117
                                       (merror
111
 
                                         "Non-integer dimension to REARRAY:~%~M"
112
 
                                         x)))
 
118
                                        "Non-integer dimension to `rearray':~%~M"
 
119
                                        x)))
113
120
                                #-cl
114
121
                                (f1+ x)
115
122
                                #+cl x
118
125
            (show l)
119
126
            #-lispm
120
127
            (let ((new-array 
121
 
                    (apply '*rearray (cons ary 
122
 
                                           (cons (car (arraydims ary)) l)))))
123
 
              #+Franz(mputprop name new-array 'array)
 
128
                   (apply '*rearray (cons ary 
 
129
                                          (cons (car (arraydims ary)) l)))))
 
130
              #+franz(mputprop name new-array 'array)
124
131
              )
125
132
            #+lispm
126
133
            (progn
132
139
            name))
133
140
 
134
141
 
135
 
;(defmspec $rearray (l) (setq l (cdr l))
136
 
;         (cond ((> (length l) 6)
137
 
;                (merror "Too many arguments to REARRAY:~%~M" l))
138
 
;               ((< (length l) 2)
139
 
;                (merror "Too few arguments to REARRAY:~%~M" l)))
140
 
;         (let ((name (car l))
141
 
;               (ary (cond ($use_fast_arrays
142
 
;                          (symbol-value (car l)))
143
 
;                    (t
144
 
;                      (cond ((mget (car l) 'array))
145
 
;                            (t 
146
 
;                             (merror "First argument to REARRAY must be a declared array:~%~M"
147
 
;                                     (car l))))))))
148
 
;           (setq l (cdr l)
149
 
;                 l (mapcar #'(lambda (x)
150
 
;                               (setq x (meval x))
151
 
;                               (cond ((not (eq (ml-typep x) 'fixnum))
152
 
;                                      (merror
153
 
;                                        "Non-integer dimension to REARRAY:~%~M"
154
 
;                                        x)))
155
 
;                               #-lispm
156
 
;                               (f1+ x)
157
 
;                               #+Lispm x
158
 
;                               )
159
 
;                           l))
160
 
;           (show l)
161
 
;           #-lispm
162
 
;           (let ((new-array 
163
 
;                   (apply '*rearray (cons ary 
164
 
;                                          (cons (car (arraydims ary)) l)))))
165
 
;             #+Franz(mputprop name new-array 'array)
166
 
;             )
167
 
;           #+lispm
168
 
;           (progn
169
 
;             (cond ($use_fast_arrays
170
 
;                    (setq ary (apply 'lispm-rearray (cons ary l))))
171
 
;                   (t (setf (symbol-function ary) (apply 'lispm-rearray (cons (symbol-function ary) l)))))
172
 
;             (cond ($use_fast_arrays (setq name ary))
173
 
;                   (t (mputprop name ary 'array))))
174
 
;           name))
 
142
;;(defmspec $rearray (l) (setq l (cdr l))
 
143
;;        (cond ((> (length l) 6)
 
144
;;               (merror "Too many arguments to `rearray':~%~M" l))
 
145
;;              ((< (length l) 2)
 
146
;;               (merror "Too few arguments to `rearray':~%~M" l)))
 
147
;;        (let ((name (car l))
 
148
;;              (ary (cond ($use_fast_arrays
 
149
;;                         (symbol-value (car l)))
 
150
;;                   (t
 
151
;;                     (cond ((mget (car l) 'array))
 
152
;;                           (t 
 
153
;;                            (merror "First argument to `rearray' must be a declared array:~%~M"
 
154
;;                                    (car l))))))))
 
155
;;          (setq l (cdr l)
 
156
;;                l (mapcar #'(lambda (x)
 
157
;;                              (setq x (meval x))
 
158
;;                              (cond ((not (eq (ml-typep x) 'fixnum))
 
159
;;                                     (merror
 
160
;;                                       "Non-integer dimension to `rearray':~%~M"
 
161
;;                                       x)))
 
162
;;                              #-lispm
 
163
;;                              (f1+ x)
 
164
;;                              #+Lispm x
 
165
;;                              )
 
166
;;                          l))
 
167
;;          (show l)
 
168
;;          #-lispm
 
169
;;          (let ((new-array 
 
170
;;                  (apply '*rearray (cons ary 
 
171
;;                                         (cons (car (arraydims ary)) l)))))
 
172
;;            #+Franz(mputprop name new-array 'array)
 
173
;;            )
 
174
;;          #+lispm
 
175
;;          (progn
 
176
;;            (cond ($use_fast_arrays
 
177
;;                   (setq ary (apply 'lispm-rearray (cons ary l))))
 
178
;;                  (t (setf (symbol-function ary) (apply 'lispm-rearray (cons (symbol-function ary) l)))))
 
179
;;            (cond ($use_fast_arrays (setq name ary))
 
180
;;                  (t (mputprop name ary 'array))))
 
181
;;          name))
175
182
 
176
183
#+cl
177
 
;(defun lispm-rearray (ar &rest dims)
178
 
; ( make-array (mapcar '1+ (copy-list dims)) :element-type (array-element-type ar) :displaced-to ar ))
 
184
;;(defun lispm-rearray (ar &rest dims)
 
185
;; ( make-array (mapcar '1+ (copy-list dims)) :element-type (array-element-type ar) :displaced-to ar ))
179
186
 
180
187
 
181
188
(defun lispm-rearray (ar &rest dims)