/[cmucl]/src/compiler/array-tran.lisp
ViewVC logotype

Diff of /src/compiler/array-tran.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.37.2.2 by rtoy, Mon Dec 19 01:09:58 2005 UTC revision 1.45 by rtoy, Tue Apr 20 17:57:46 2010 UTC
# Line 14  Line 14 
14  ;;; Extracted from srctran and extended by William Lott.  ;;; Extracted from srctran and extended by William Lott.
15  ;;;  ;;;
16  (in-package "C")  (in-package "C")
17    (intl:textdomain "cmucl")
18    
19    
20  ;;;; Derive-Type Optimizers  ;;;; Derive-Type Optimizers
# Line 196  Line 197 
197                (t                (t
198                 '*))                 '*))
199         ,(cond ((not simple)         ,(cond ((not simple)
200                 '*)                 ;; Can't derive the actual dimensions lest someone do
201                   ;; an ADJUST-ARRAY, but we can try to get the rank
202                   ;; correct.
203                   (cond ((constant-continuation-p dims)
204                          (let ((val (continuation-value dims)))
205                            (if (listp val)
206                                (make-list (length val) :initial-element '*)
207                                '(*))))
208                         ((csubtypep (continuation-type dims)
209                                     (specifier-type 'integer))
210                          '(*))
211                         (t
212                          '*)))
213                ((constant-continuation-p dims)                ((constant-continuation-p dims)
214                 (let ((val (continuation-value dims)))                 (let ((val (continuation-value dims)))
215                   (if (listp val) val (list val))))                   (if (listp val) val (list val))))
# Line 240  Line 253 
253                 :initial-element initial-element))                 :initial-element initial-element))
254    
255  (defconstant array-info  (defconstant array-info
256    '((base-char #\NULL 8 vm:simple-string-type)    '((base-char #\NULL #.vm:char-bits vm:simple-string-type)
257      (single-float 0.0f0 32 vm:simple-array-single-float-type)      (single-float 0.0f0 32 vm:simple-array-single-float-type)
258      (double-float 0.0d0 64 vm:simple-array-double-float-type)      (double-float 0.0d0 64 vm:simple-array-double-float-type)
259      #+long-float (long-float 0.0l0 #+x86 96 #+sparc 128      #+long-float (long-float 0.0l0 #+x86 96 #+sparc 128
260                    vm:simple-array-long-float-type)                    vm:simple-array-long-float-type)
261        #+double-double
262        (double-double-float 0w0 128
263                      vm::simple-array-double-double-float-type)
264      (bit 0 1 vm:simple-bit-vector-type)      (bit 0 1 vm:simple-bit-vector-type)
265      ((unsigned-byte 2) 0 2 vm:simple-array-unsigned-byte-2-type)      ((unsigned-byte 2) 0 2 vm:simple-array-unsigned-byte-2-type)
266      ((unsigned-byte 4) 0 4 vm:simple-array-unsigned-byte-4-type)      ((unsigned-byte 4) 0 4 vm:simple-array-unsigned-byte-4-type)
# Line 262  Line 278 
278      #+long-float      #+long-float
279      ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256      ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256
280       vm:simple-array-complex-long-float-type)       vm:simple-array-complex-long-float-type)
281        #+double-double
282        ((complex double-double-float) #C(0.0w0 0.0w0) 256
283         vm::simple-array-complex-double-double-float-type)
284      (t 0 32 vm:simple-vector-type)))      (t 0 32 vm:simple-vector-type)))
285    
286  ;;; MAKE-ARRAY  --  source-transform.  ;;; MAKE-ARRAY  --  source-transform.
# Line 274  Line 293 
293                            (integer &rest *))                            (integer &rest *))
294    (let* ((eltype (cond ((not element-type) t)    (let* ((eltype (cond ((not element-type) t)
295                         ((not (constant-continuation-p element-type))                         ((not (constant-continuation-p element-type))
296                          (give-up "Element-Type is not constant."))                          (give-up (intl:gettext "Element-Type is not constant.")))
297                         (t                         (t
298                          (continuation-value element-type))))                          (continuation-value element-type))))
299           (len (if (constant-continuation-p length)           (len (if (constant-continuation-p length)
# Line 285  Line 304 
304      (multiple-value-bind      (multiple-value-bind
305          (default-initial-element element-size typecode)          (default-initial-element element-size typecode)
306          (dolist (info array-info          (dolist (info array-info
307                        (give-up "Cannot open-code creation of ~S" spec))                        (give-up (intl:gettext "Cannot open-code creation of ~S") spec))
308            (when (csubtypep eltype-type (specifier-type (car info)))            (when (csubtypep eltype-type (specifier-type (car info)))
309              (return (values-list (cdr info)))))              (return (values-list (cdr info)))))
310        (let* ((nwords-form        (let* ((nwords-form
# Line 308  Line 327 
327                                     default-initial-element))))                                     default-initial-element))))
328                  (unless (csubtypep (ctype-of default-initial-element)                  (unless (csubtypep (ctype-of default-initial-element)
329                                     eltype-type)                                     eltype-type)
330                    (compiler-note "Default initial element ~s is not a ~s."                    (compiler-note _N"Default initial element ~s is not a ~s."
331                                   default-initial-element eltype))                                   default-initial-element eltype))
332                  constructor)                  constructor)
333                 (t                 (t
# Line 323  Line 342 
342  (deftransform make-array ((dims &key initial-element element-type)  (deftransform make-array ((dims &key initial-element element-type)
343                            (list &rest *))                            (list &rest *))
344    (unless (or (null element-type) (constant-continuation-p element-type))    (unless (or (null element-type) (constant-continuation-p element-type))
345      (give-up "Element-type not constant; cannot open code array creation"))      (give-up (intl:gettext "Element-type not constant; cannot open code array creation")))
346    (unless (constant-continuation-p dims)    (unless (constant-continuation-p dims)
347      (give-up "Dimension list not constant; cannot open code array creation"))      (give-up (intl:gettext "Dimension list not constant; cannot open code array creation")))
348    (let ((dims (continuation-value dims)))    (let ((dims (continuation-value dims)))
349      (unless (every #'integerp dims)      (unless (every #'integerp dims)
350        (give-up "Dimension list contains something other than an integer: ~S"        (give-up (intl:gettext "Dimension list contains something other than an integer: ~S")
351                 dims))                 dims))
352      (if (= (length dims) 1)      (if (= (length dims) 1)
353          `(make-array ',(car dims)          `(make-array ',(car dims)
# Line 378  Line 397 
397        (give-up))        (give-up))
398      (let ((dims (array-type-dimensions array-type)))      (let ((dims (array-type-dimensions array-type)))
399        (if (not (listp dims))        (if (not (listp dims))
400            (give-up "Array rank not known at compile time: ~S" dims)            (give-up (intl:gettext "Array rank not known at compile time: ~S") dims)
401            (length dims)))))            (length dims)))))
402    
403  ;;; ARRAY-DIMENSION  --  transform.  ;;; ARRAY-DIMENSION  --  transform.
# Line 391  Line 410 
410  (deftransform array-dimension ((array axis)  (deftransform array-dimension ((array axis)
411                                 (array index))                                 (array index))
412    (unless (constant-continuation-p axis)    (unless (constant-continuation-p axis)
413      (give-up "Axis not constant."))      (give-up (intl:gettext "Axis not constant.")))
414    (let ((array-type (continuation-type array))    (let ((array-type (continuation-type array))
415          (axis (continuation-value axis)))          (axis (continuation-value axis)))
416      (unless (array-type-p array-type)      (unless (array-type-p array-type)
# Line 399  Line 418 
418      (let ((dims (array-type-dimensions array-type)))      (let ((dims (array-type-dimensions array-type)))
419        (unless (listp dims)        (unless (listp dims)
420          (give-up          (give-up
421           "Array dimensions unknown, must call array-dimension at runtime."))           (intl:gettext "Array dimensions unknown, must call array-dimension at runtime.")))
422        (unless (> (length dims) axis)        (unless (> (length dims) axis)
423          (abort-transform "Array has dimensions ~S, ~D is too large."          (abort-transform (intl:gettext "Array has dimensions ~S, ~D is too large.")
424                           dims axis))                           dims axis))
425        (let ((dim (nth axis dims)))        (let ((dim (nth axis dims)))
426          (cond ((integerp dim)          (cond ((integerp dim)
# Line 413  Line 432 
432                   ((nil)                   ((nil)
433                    '(length array))                    '(length array))
434                   ((:maybe *)                   ((:maybe *)
435                    (give-up "Can't tell if array is simple."))))                    (give-up (intl:gettext "Can't tell if array is simple.")))))
436                (t                (t
437                 '(%array-dimension array axis)))))))                 '(%array-dimension array axis)))))))
438    
# Line 428  Line 447 
447        (give-up))        (give-up))
448      (let ((dims (array-type-dimensions type)))      (let ((dims (array-type-dimensions type)))
449        (unless (and (listp dims) (integerp (car dims)))        (unless (and (listp dims) (integerp (car dims)))
450          (give-up "Vector length unknown, must call length at runtime."))          (give-up (intl:gettext "Vector length unknown, must call length at runtime.")))
451        (car dims))))        (car dims))))
452    
453  ;;; LENGTH  --  transform.  ;;; LENGTH  --  transform.
# Line 467  Line 486 
486        (give-up))        (give-up))
487      (let ((dims (array-type-dimensions array-type)))      (let ((dims (array-type-dimensions array-type)))
488        (unless (listp dims)        (unless (listp dims)
489          (give-up "Can't tell the rank at compile time."))          (give-up (intl:gettext "Can't tell the rank at compile time.")))
490        (if (member '* dims)        (if (member '* dims)
491            (do ((form 1 `(truly-the index            (do ((form 1 `(truly-the index
492                                     (* (array-dimension array ,i) ,form)))                                     (* (array-dimension array ,i) ,form)))
# Line 492  Line 511 
511              ((nil)              ((nil)
512               nil)               nil)
513              (:maybe              (:maybe
514               (give-up "Array type ambiguous; must call ~               (give-up (intl:gettext "Array type ambiguous; must call ~
515                        array-has-fill-pointer-p at runtime.")))))))                        array-has-fill-pointer-p at runtime."))))))))
516    
517  ;;; %CHECK-BOUND  --  transform.  ;;; %CHECK-BOUND  --  transform.
518  ;;;  ;;;

Legend:
Removed from v.1.37.2.2  
changed lines
  Added in v.1.45

  ViewVC Help
Powered by ViewVC 1.1.5