41 |
(in-package 'system) |
(in-package 'system) |
42 |
|
|
43 |
|
|
44 |
(proclaim '(optimize (safety 2) (space 3))) |
;(proclaim '(optimize (safety 2) (space 3))) |
45 |
|
|
46 |
(defun best-array-element-type (type) |
(defun best-array-element-type (type) |
47 |
(cond ((not type) nil) |
(cond ((not type) nil) |
48 |
((eq type '*) '*) |
((eq type '*) '*) |
|
((member type '(string-char character standard-char base-char extended-char)) 'string-char) ;FIXME |
|
49 |
((car (member type +array-types+))) |
((car (member type +array-types+))) |
50 |
((car (member type +array-types+ :test 'subtypep))) |
((car (member type +array-types+ :test 'subtypep1))) |
51 |
((subtypep type 'float) 'long-float) |
((subtypep1 type 'float) 'long-float) |
52 |
(t))) |
(t))) |
53 |
|
|
|
;;FIXME -- this needs integration with other type functions. CM 20050106 |
|
|
;(defun best-array-element-type (type) |
|
|
; (cond ((null type) nil) |
|
|
; ((eql t type) t) |
|
|
; ((memq type '(bit unsigned-char signed-char |
|
|
; unsigned-short |
|
|
; signed-short fixnum)) |
|
|
; type) |
|
|
; ((subtypep type 'fixnum) |
|
|
; (dolist (v ;'(bit non-negative-char signed-char unsigned-char non-negative-short signed-short unsigned-short) |
|
|
; '(bit signed-char unsigned-char signed-short unsigned-short) |
|
|
; 'fixnum) |
|
|
; (cond ((subtypep type v) |
|
|
; (return v))))) |
|
|
; ((eql type 'character) 'string-char) |
|
|
; (t (or (dolist (v '(string-char bit short-float |
|
|
; long-float)) |
|
|
; (cond ((subtypep type v) |
|
|
; (return v)))) |
|
|
; t)))) |
|
|
|
|
|
;(defun upgraded-array-element-type (type &optional environment) |
|
|
; (declare (ignore environment)) |
|
|
; (best-array-element-type type)) |
|
|
|
|
|
;(defun array-displacement (array) |
|
|
; (let ((x (si:array-displacement1 array))) |
|
|
; (values (car x) (cdr x))) |
|
|
; ) |
|
|
|
|
54 |
(defun make-array (dimensions |
(defun make-array (dimensions |
55 |
&key (element-type t) |
&key (element-type t) |
56 |
(initial-element nil) |
(initial-element nil) |
59 |
displaced-to (displaced-index-offset 0) |
displaced-to (displaced-index-offset 0) |
60 |
static) |
static) |
61 |
(when (integerp dimensions) (setq dimensions (list dimensions))) |
(when (integerp dimensions) (setq dimensions (list dimensions))) |
62 |
(setq element-type (or (best-array-element-type element-type) 'string-char)) |
(setq element-type (or (best-array-element-type element-type) 'character)) |
63 |
(cond ((= (length dimensions) 1) |
(cond ((= (length dimensions) 1) |
64 |
(let ((x (si:make-vector element-type (car dimensions) |
(let ((x (si:make-vector element-type (car dimensions) |
65 |
adjustable fill-pointer |
adjustable fill-pointer |
212 |
|
|
213 |
|
|
214 |
(defun vector-push (new-element vector) |
(defun vector-push (new-element vector) |
215 |
|
(declare (optimize (safety 1))) |
216 |
|
(assert (array-has-fill-pointer-p vector)) |
217 |
(let ((fp (fill-pointer vector))) |
(let ((fp (fill-pointer vector))) |
218 |
(declare (fixnum fp)) |
(cond ((< fp (array-dimension vector 0)) |
|
(cond ((< fp (the fixnum (array-dimension vector 0))) |
|
219 |
(si:aset vector fp new-element) |
(si:aset vector fp new-element) |
220 |
(si:fill-pointer-set vector (the fixnum (1+ fp))) |
(si:fill-pointer-set vector (1+ fp)) |
221 |
fp) |
fp) |
222 |
(t nil)))) |
(t nil)))) |
223 |
|
|