Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv22228
Modified Files: arrays.lisp Log Message: Change upgraded-array-element-type for type NIL.
--- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2008/04/18 09:55:13 1.67 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2008/04/21 19:30:40 1.68 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.67 2008/04/18 09:55:13 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.68 2008/04/21 19:30:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -21,6 +21,10 @@
(in-package muerte)
+(defconstant array-total-size-limit most-positive-fixnum) +(defconstant array-dimension-limit most-positive-fixnum) +(defconstant array-rank-limit 1024) + (defmacro/cross-compilation vector-double-dispatch ((s1 s2) &rest clauses) (flet ((make-double-dispatch-value (et1 et2) (+ (* #x100 (bt:enum-value 'movitz::movitz-vector-element-type et1)) @@ -85,42 +89,42 @@ "=> upgraded-type-specifier" ;; We're in dire need of subtypep.. (cond - ((symbolp type-specifier) - (case type-specifier - ((character base-char standard-char) - 'character) - ((code) - 'code) - (t (let ((deriver (gethash type-specifier *derived-typespecs*))) - (if (not deriver) - t - (upgraded-array-element-type (funcall deriver))))))) - ((null type-specifier) - t) - ((consp type-specifier) - (case (car type-specifier) - ((integer) - (let* ((q (cdr type-specifier)) - (min (if q (pop q) '*)) - (max (if q (pop q) '*))) - (let ((min (if (consp min) (1+ (car min)) min)) - (max (if (consp max) (1- (car max)) max))) - (cond - ((or (eq min '*) (eq max '*)) - t) - ((<= 0 min max 1) - 'bit) - ((<= 0 min max #xff) - '(unsigned-byte 8)) - ((<= 0 min max #xffff) - '(unsigned-byte 16)) - ((<= 0 min max #xffffffff) - '(unsigned-byte 32)))))) - (t (let ((deriver (gethash (car type-specifier) *derived-typespecs*))) - (if (not deriver) - t - (upgraded-array-element-type (apply deriver (cdr type-specifier)) environment)))))) - (t t))) + ((symbolp type-specifier) + (case type-specifier + ((nil character base-char standard-char) + 'character) + ((code) + 'code) + (t (let ((deriver (gethash type-specifier *derived-typespecs*))) + (if (not deriver) + t + (upgraded-array-element-type (funcall deriver))))))) + ((null type-specifier) + t) + ((consp type-specifier) + (case (car type-specifier) + ((integer) + (let* ((q (cdr type-specifier)) + (min (if q (pop q) '*)) + (max (if q (pop q) '*))) + (let ((min (if (consp min) (1+ (car min)) min)) + (max (if (consp max) (1- (car max)) max))) + (cond + ((or (eq min '*) (eq max '*)) + t) + ((<= 0 min max 1) + 'bit) + ((<= 0 min max #xff) + '(unsigned-byte 8)) + ((<= 0 min max #xffff) + '(unsigned-byte 16)) + ((<= 0 min max #xffffffff) + '(unsigned-byte 32)))))) + (t (let ((deriver (gethash (car type-specifier) *derived-typespecs*))) + (if (not deriver) + t + (upgraded-array-element-type (apply deriver (cdr type-specifier)) environment)))))) + (t t)))
(defun array-dimension (array axis-number) @@ -407,14 +411,16 @@ (:compile-form (:result-mode :edx) index) (:testb 7 :cl) (:jnz '(:sub-program (not-a-vector) - (:compile-form (:result-mode :ignore) - (error "Not a vector: ~S." vector)))) + (:movl :ebx :eax) + (:load-constant vector :edx) + (:int 59))) (:movl (:ebx ,movitz:+other-type-offset+) :ecx) (:andl #xffff :ecx) (:testb ,movitz:+movitz-fixnum-zmask+ :dl) (:jnz '(:sub-program (not-an-index) - (:compile-form (:result-mode :ignore) - (error "Not a vector index: ~S." index)))) + (:movl :edx :eax) + (:load-constant index :edx) + (:int 59))) (:cmpl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) :edx) (:jnc '(:sub-program (illegal-index) @@ -434,8 +440,8 @@ (:jne 'not-character-vector) (:cmpb ,(movitz:tag :character) :al) (:jne '(:sub-program (not-a-character) - (:compile-form (:result-mode :ignore) - (error "Not a character: ~S" value)))) + (:load-constant character :edx) + (:int 59))) (:movl :edx :ecx) (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:movb :ah (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) @@ -1163,7 +1169,7 @@ (make-basic-vector%code size fill-pointer initial-element initial-contents)) (t (make-basic-vector%t size fill-pointer initial-element initial-contents)))))
-(defun make-array (dimensions &key element-type initial-element initial-contents adjustable +(defun make-array (dimensions &key (element-type t) initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset) (let ((size (cond ((integerp dimensions) dimensions)