/[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.43 by rtoy, Thu Jun 11 16:03:59 2009 UTC revision 1.43.12.3 by rtoy, Thu Feb 25 03:59:43 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 292  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 _"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 303  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 _"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 326  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 341  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 _"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 _"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 _"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 396  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 _"Array rank not known at compile time: ~S" dims)
401            (length dims)))))            (length dims)))))
402    
403  ;;; ARRAY-DIMENSION  --  transform.  ;;; ARRAY-DIMENSION  --  transform.
# Line 409  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 _"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 417  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."))           _"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 _"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 431  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 _"Can't tell if array is simple."))))
436                (t                (t
437                 '(%array-dimension array axis)))))))                 '(%array-dimension array axis)))))))
438    
# Line 446  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 _"Vector length unknown, must call length at runtime."))
451        (car dims))))        (car dims))))
452    
453  ;;; LENGTH  --  transform.  ;;; LENGTH  --  transform.
# Line 485  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 _"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 510  Line 511 
511              ((nil)              ((nil)
512               nil)               nil)
513              (:maybe              (:maybe
514               (give-up "Array type ambiguous; must call ~               (give-up _"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.

Legend:
Removed from v.1.43  
changed lines
  Added in v.1.43.12.3

  ViewVC Help
Powered by ViewVC 1.1.5