← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to lsp/gcl_arraylib.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
lsp/gcl_arraylib.lsp
 
1
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
 
2
 
 
3
;; This file is part of GNU Common Lisp, herein referred to as GCL
 
4
;;
 
5
;; GCL is free software; you can redistribute it and/or modify it under
 
6
;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
 
7
;; the Free Software Foundation; either version 2, or (at your option)
 
8
;; any later version.
 
9
;; 
 
10
;; GCL is distributed in the hope that it will be useful, but WITHOUT
 
11
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
12
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
 
13
;; License for more details.
 
14
;; 
 
15
;; You should have received a copy of the GNU Library General Public License 
 
16
;; along with GCL; see the file COPYING.  If not, write to the Free Software
 
17
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
18
 
 
19
 
 
20
;;;;    arraylib.lsp
 
21
;;;;
 
22
;;;;                            array routines
 
23
 
 
24
 
 
25
(in-package 'lisp)
 
26
 
 
27
 
 
28
(export '(make-array array-displacement vector
 
29
          array-element-type array-rank array-dimension
 
30
          array-dimensions
 
31
          array-in-bounds-p array-row-major-index
 
32
          adjustable-array-p
 
33
          bit sbit 
 
34
          bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor
 
35
          bit-andc1 bit-andc2 bit-orc1 bit-orc2 bit-not
 
36
          array-has-fill-pointer-p fill-pointer
 
37
          vector-push vector-push-extend vector-pop
 
38
          adjust-array upgraded-array-element-type))
 
39
 
 
40
(in-package 'system)
 
41
 
 
42
 
 
43
(proclaim '(optimize (safety 2) (space 3)))
 
44
 
 
45
(defun best-array-element-type (type)
 
46
  (cond ((or (eql t type) (null type))
 
47
         t)
 
48
        ((memq type '(bit unsigned-char signed-char
 
49
                                    unsigned-short
 
50
                                    signed-short fixnum))
 
51
               type)
 
52
        ((subtypep type 'fixnum)
 
53
         (dolist (v '(bit unsigned-char signed-char
 
54
                                    unsigned-short
 
55
                                    signed-short)
 
56
                    'fixnum)
 
57
                 (cond ((subtypep type v)
 
58
                        (return v)))))
 
59
        ((eql type 'character) 'string-char)
 
60
        (t (or (dolist (v '(string-char bit short-float
 
61
                                    long-float))
 
62
                   (cond ((subtypep type v)
 
63
                          (return v))))
 
64
               t))))
 
65
         
 
66
(defun upgraded-array-element-type (type &optional environment)
 
67
  (declare (ignore environment))
 
68
  (best-array-element-type type))
 
69
 
 
70
;(defun array-displacement (array)
 
71
;  (let ((x (si:array-displacement1 array)))
 
72
;  (values (car x) (cdr x)))
 
73
;  )
 
74
 
 
75
(defun make-array (dimensions
 
76
                   &key (element-type t)
 
77
                        (initial-element nil)
 
78
                        (initial-contents nil initial-contents-supplied-p)
 
79
                        adjustable fill-pointer
 
80
                        displaced-to (displaced-index-offset 0)
 
81
                        static)
 
82
  (when (integerp dimensions) (setq dimensions (list dimensions)))
 
83
  (setq element-type (best-array-element-type element-type))
 
84
  (cond ((= (length dimensions) 1)
 
85
         (let ((x (si:make-vector element-type (car dimensions)
 
86
                                  adjustable fill-pointer
 
87
                                  displaced-to displaced-index-offset
 
88
                                  static initial-element)))
 
89
           (when initial-contents-supplied-p
 
90
                 (do ((n (car dimensions))
 
91
                      (i 0 (1+ i)))
 
92
                     ((>= i n))
 
93
                   (declare (fixnum n i))
 
94
                   (si:aset x i (elt initial-contents i))))
 
95
           x))
 
96
        (t
 
97
         (let ((x
 
98
                (make-array1
 
99
                       (the fixnum(get-aelttype element-type))
 
100
                        static initial-element 
 
101
                       displaced-to (the fixnum displaced-index-offset)
 
102
                       dimensions)))
 
103
           (if fill-pointer (error "fill pointer for 1 dimensional arrays only"))
 
104
           (unless (member 0 dimensions)
 
105
           (when initial-contents-supplied-p
 
106
                 (do ((cursor
 
107
                       (make-list (length dimensions)
 
108
                                  :initial-element 0)))
 
109
                     (nil)
 
110
                     (declare (:dynamic-extent cursor))
 
111
                   (aset-by-cursor x
 
112
                                   (sequence-cursor initial-contents
 
113
                                                    cursor)
 
114
                                   cursor)
 
115
                   (when (increment-cursor cursor dimensions)
 
116
                          (return nil)))))
 
117
            x))))
 
118
 
 
119
 
 
120
(defun increment-cursor (cursor dimensions)
 
121
  (if (null cursor)
 
122
      t
 
123
      (let ((carry (increment-cursor (cdr cursor) (cdr dimensions))))
 
124
        (if carry
 
125
            (cond ((>= (the fixnum (1+ (the fixnum (car cursor))))
 
126
                       (the fixnum (car dimensions)))
 
127
                   (rplaca cursor 0)
 
128
                   t)
 
129
                  (t
 
130
                   (rplaca cursor
 
131
                           (the fixnum (1+ (the fixnum (car cursor)))))
 
132
                   nil))
 
133
            nil))))
 
134
 
 
135
 
 
136
(defun sequence-cursor (sequence cursor)
 
137
  (if (null cursor)
 
138
      sequence
 
139
      (sequence-cursor (elt sequence (the fixnum (car cursor)))
 
140
                       (cdr cursor))))
 
141
 
 
142
 
 
143
(defun vector (&rest objects &aux (l (list (length objects))))
 
144
  (declare (:dynamic-extent objects l))
 
145
  (make-array l
 
146
              :element-type t
 
147
              :initial-contents objects))
 
148
 
 
149
 
 
150
(defun array-dimensions (array)
 
151
  (do ((i (array-rank array))
 
152
       (d nil))
 
153
      ((= i 0) d)
 
154
    (setq i (1- i))
 
155
    (setq d (cons (array-dimension array i) d))))
 
156
 
 
157
 
 
158
(defun array-in-bounds-p (array &rest indices &aux (r (array-rank array)))
 
159
  (declare (:dynamic-extent indices))
 
160
  (when (/= r (length indices))
 
161
        (error "The rank of the array is ~R,~%~
 
162
               ~7@Tbut ~R ~:*~[indices are~;index is~:;indices are~] ~
 
163
               supplied."
 
164
               r (length indices)))
 
165
  (do ((i 0 (1+ i))
 
166
       (s indices (cdr s)))
 
167
      ((>= i r) t)
 
168
    (when (or (< (car s) 0)
 
169
              (>= (car s) (array-dimension array i)))
 
170
          (return nil))))
 
171
 
 
172
 
 
173
(defun array-row-major-index (array &rest indices)
 
174
  (declare (:dynamic-extent indices))
 
175
  (do ((i 0 (1+ i))
 
176
       (j 0 (+ (* j (array-dimension array i)) (car s)))
 
177
       (s indices (cdr s)))
 
178
      ((null s) j)))
 
179
 
 
180
 
 
181
(defun bit (bit-array &rest indices)
 
182
  (declare (:dynamic-extent indices))
 
183
  (apply #'aref bit-array indices))
 
184
 
 
185
 
 
186
(defun sbit (bit-array &rest indices)
 
187
  (declare (:dynamic-extent indices))
 
188
  (apply #'aref bit-array indices))
 
189
 
 
190
 
 
191
(defun bit-and (bit-array1 bit-array2 &optional result-bit-array)
 
192
  (bit-array-op boole-and bit-array1 bit-array2 result-bit-array))
 
193
 
 
194
 
 
195
(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array)
 
196
  (bit-array-op boole-ior bit-array1 bit-array2 result-bit-array))
 
197
 
 
198
 
 
199
(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array)
 
200
  (bit-array-op boole-xor bit-array1 bit-array2 result-bit-array))
 
201
 
 
202
 
 
203
(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array)
 
204
  (bit-array-op boole-eqv bit-array1 bit-array2 result-bit-array))
 
205
 
 
206
    
 
207
(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array)
 
208
  (bit-array-op boole-nand bit-array1 bit-array2 result-bit-array))
 
209
 
 
210
    
 
211
(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array)
 
212
  (bit-array-op boole-nor bit-array1 bit-array2 result-bit-array))
 
213
 
 
214
    
 
215
(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array)
 
216
  (bit-array-op boole-andc1 bit-array1 bit-array2 result-bit-array))
 
217
 
 
218
    
 
219
(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array)
 
220
  (bit-array-op boole-andc2 bit-array1 bit-array2 result-bit-array))
 
221
 
 
222
    
 
223
(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array)
 
224
  (bit-array-op boole-orc1 bit-array1 bit-array2 result-bit-array))
 
225
 
 
226
    
 
227
(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array)
 
228
  (bit-array-op boole-orc2 bit-array1 bit-array2 result-bit-array))
 
229
 
 
230
    
 
231
(defun bit-not (bit-array &optional result-bit-array)
 
232
  (bit-array-op boole-c1 bit-array bit-array result-bit-array))
 
233
 
 
234
 
 
235
(defun vector-push (new-element vector)
 
236
  (let ((fp (fill-pointer vector)))
 
237
    (declare (fixnum fp))
 
238
    (cond ((< fp (the fixnum (array-dimension vector 0)))
 
239
           (si:aset vector fp new-element)
 
240
           (si:fill-pointer-set vector (the fixnum (1+ fp)))
 
241
           fp)
 
242
          (t nil))))
 
243
 
 
244
 
 
245
(defun vector-push-extend (new-element vector &optional extension)
 
246
  (let ((fp (fill-pointer vector)))
 
247
    (declare (fixnum fp))
 
248
    (cond ((< fp (the fixnum (array-dimension vector 0)))
 
249
           (si:aset vector fp new-element)
 
250
           (si:fill-pointer-set vector (the fixnum (1+ fp)))
 
251
           fp)
 
252
          (t
 
253
           (adjust-array vector
 
254
                         (list (+ (array-dimension vector 0)
 
255
                                  (or extension
 
256
                                      (if (> (array-dimension vector 0)  0)
 
257
                                          (array-dimension vector 0)
 
258
                                        5))))
 
259
                         :element-type (array-element-type vector)
 
260
                         :fill-pointer fp)
 
261
           (si:aset vector fp new-element)
 
262
           (si:fill-pointer-set vector (the fixnum (1+ fp)))
 
263
           fp))))
 
264
 
 
265
 
 
266
(defun vector-pop (vector)
 
267
  (let ((fp (fill-pointer vector)))
 
268
    (declare (fixnum fp))
 
269
    (when (= fp 0)
 
270
          (error "The fill pointer of the vector ~S zero." vector))
 
271
    (si:fill-pointer-set vector (the fixnum (1- fp)))
 
272
    (aref vector (the fixnum (1- fp)))))
 
273
 
 
274
 
 
275
(defun adjust-array (array new-dimensions
 
276
                     &rest r
 
277
                     &key element-type
 
278
                          initial-element
 
279
                          initial-contents
 
280
                          fill-pointer
 
281
                          displaced-to
 
282
                          displaced-index-offset
 
283
                          static
 
284
                     &aux fill-pointer-spec
 
285
                      )
 
286
  (declare (ignore 
 
287
                   initial-element
 
288
                   initial-contents
 
289
                   fill-pointer
 
290
                   displaced-to
 
291
                   displaced-index-offset
 
292
                   static))
 
293
  (declare (:dynamic-extent r new-dimensions))
 
294
  (when (integerp new-dimensions)
 
295
        (setq new-dimensions (list new-dimensions)))
 
296
  (if (setq fill-pointer-spec (member :fill-pointer r))
 
297
      (unless (array-has-fill-pointer-p array)
 
298
              (error ":fill-pointer specified for array with no fill pointer"))
 
299
    (when (array-has-fill-pointer-p array)
 
300
      (push (fill-pointer array) r) (push :fill-pointer r)))
 
301
 
 
302
  (setq element-type (array-element-type array))
 
303
  (unless (eq element-type t) (push element-type r)
 
304
          (push :element-type r))
 
305
  (unless (member :static r)
 
306
        (push (staticp array) r) (push :static r))
 
307
  (let ((x (apply #'make-array new-dimensions :adjustable t r)))        
 
308
    (cond ((or (null (cdr new-dimensions))
 
309
               (and (equal (cdr new-dimensions)
 
310
                           (cdr (array-dimensions array)))
 
311
                    (or (not (eq element-type 'bit))
 
312
                        (eql 0 (the fixnum
 
313
                                    (mod
 
314
                                      (the fixnum (car (last new-dimensions)))
 
315
                                      char-size))))))
 
316
           (copy-array-portion array   x
 
317
                               0 0
 
318
                               (min (array-total-size x)
 
319
                                    (array-total-size array))))
 
320
          (t
 
321
            (do ((cursor (make-list (length new-dimensions)
 
322
                                    :initial-element 0)))
 
323
                (nil)
 
324
                (declare (:dynamic-extent cursor))
 
325
                (when (apply #'array-in-bounds-p array cursor)
 
326
                      (aset-by-cursor x
 
327
                                      (apply #'aref array cursor)
 
328
                                      cursor))
 
329
                (when (increment-cursor cursor new-dimensions)
 
330
                      (return nil)))))
 
331
    
 
332
    (si:replace-array array x)
 
333
    (setf fill-pointer-spec (cadr fill-pointer-spec))
 
334
    (when fill-pointer-spec
 
335
        (cond ((eql t fill-pointer-spec)
 
336
               (setf (fill-pointer array) (array-total-size array)))
 
337
              ((typep fill-pointer-spec 'fixnum)
 
338
               (setf (fill-pointer array) fill-pointer-spec))
 
339
              (t (error "bad :fill-pointer arg: ~a" fill-pointer-spec))))
 
340
    array
 
341
    ))
 
342
 
 
343
 
 
344
 
 
345