Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5452
Modified Files: arrays.lisp Log Message: Fixed a bug where (make-array '(K)) was mistaken for multi-dimensional (which is not supported). The dimension argument was not allowed to be a cons even if it was really a one-element list.
Date: Wed Jul 21 04:47:49 2004 Author: lgorrie
Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.37 movitz/losp/muerte/arrays.lisp:1.38 --- movitz/losp/muerte/arrays.lisp:1.37 Tue Jul 20 05:38:59 2004 +++ movitz/losp/muerte/arrays.lisp Wed Jul 21 04:47:49 2004 @@ -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.37 2004/07/20 12:38:59 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.38 2004/07/21 11:47:49 lgorrie Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -685,23 +685,25 @@ (defun make-array (dimensions &key element-type initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset) (declare (ignore adjustable displaced-to displaced-index-offset)) - (etypecase dimensions - (cons - (error "Multi-dimensional arrays not supported.")) - (integer - (cond + (let ((size (cond ((integerp dimensions) + dimensions) + ((and (consp dimensions) (null (cdr dimensions))) + (car dimensions)) + (t + (error "Multi-dimensional arrays not supported."))))) + (cond ;; These should be replaced by subtypep sometime. ((eq element-type 'character) - (make-basic-vector%character dimensions fill-pointer initial-element initial-contents)) + (make-basic-vector%character size fill-pointer initial-element initial-contents)) ((member element-type '(bit (unsigned-byte 1)) :test #'equal) - (make-basic-vector%bit dimensions fill-pointer initial-element initial-contents)) + (make-basic-vector%bit size fill-pointer initial-element initial-contents)) ((member element-type '(u8 (unsigned-byte 8)) :test #'equal) - (make-basic-vector%u8 dimensions fill-pointer initial-element initial-contents)) + (make-basic-vector%u8 size fill-pointer initial-element initial-contents)) ((member element-type '(u32 (unsigned-byte 32)) :test #'equal) - (make-basic-vector%u32 dimensions fill-pointer initial-element initial-contents)) + (make-basic-vector%u32 size fill-pointer initial-element initial-contents)) ((eq element-type 'code) - (make-basic-vector%code dimensions fill-pointer initial-element initial-contents)) - (t (make-basic-vector%t dimensions fill-pointer initial-element initial-contents)))))) + (make-basic-vector%code size fill-pointer initial-element initial-contents)) + (t (make-basic-vector%t size fill-pointer initial-element initial-contents)))))
(defun vector (&rest objects) "=> vector"