1 |
|
;; -*-Lisp-*- |
2 |
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
3 |
|
|
4 |
;; This file is part of GNU Common Lisp, herein referred to as GCL |
;; This file is part of GNU Common Lisp, herein referred to as GCL |
43 |
|
|
44 |
(proclaim '(optimize (safety 2) (space 3))) |
(proclaim '(optimize (safety 2) (space 3))) |
45 |
|
|
|
;;FIXME -- this needs integration with other type functions. CM 20050106 |
|
46 |
(defun best-array-element-type (type) |
(defun best-array-element-type (type) |
47 |
(cond ((null type) nil) |
(cond ((not type) nil) |
48 |
((eql t type) t) |
((eq type '*) '*) |
49 |
((memq type '(bit unsigned-char signed-char |
((member type '(string-char character standard-char base-char extended-char)) 'string-char) ;FIXME |
50 |
unsigned-short |
((car (member type +array-types+))) |
51 |
signed-short fixnum)) |
((car (member type +array-types+ :test 'subtypep))) |
52 |
type) |
((subtypep type 'float) 'long-float) |
53 |
((subtypep type 'fixnum) |
(t))) |
54 |
(dolist (v '(bit non-negative-char signed-char unsigned-char non-negative-short signed-short unsigned-short) |
|
55 |
'fixnum) |
;;FIXME -- this needs integration with other type functions. CM 20050106 |
56 |
(cond ((subtypep type v) |
;(defun best-array-element-type (type) |
57 |
(return v))))) |
; (cond ((null type) nil) |
58 |
((eql type 'character) 'string-char) |
; ((eql t type) t) |
59 |
(t (or (dolist (v '(string-char bit short-float |
; ((memq type '(bit unsigned-char signed-char |
60 |
long-float)) |
; unsigned-short |
61 |
(cond ((subtypep type v) |
; signed-short fixnum)) |
62 |
(return v)))) |
; type) |
63 |
t)))) |
; ((subtypep type 'fixnum) |
64 |
|
; (dolist (v ;'(bit non-negative-char signed-char unsigned-char non-negative-short signed-short unsigned-short) |
65 |
|
; '(bit signed-char unsigned-char signed-short unsigned-short) |
66 |
|
; 'fixnum) |
67 |
|
; (cond ((subtypep type v) |
68 |
|
; (return v))))) |
69 |
|
; ((eql type 'character) 'string-char) |
70 |
|
; (t (or (dolist (v '(string-char bit short-float |
71 |
|
; long-float)) |
72 |
|
; (cond ((subtypep type v) |
73 |
|
; (return v)))) |
74 |
|
; t)))) |
75 |
|
|
76 |
(defun upgraded-array-element-type (type &optional environment) |
(defun upgraded-array-element-type (type &optional environment) |
77 |
(declare (ignore environment)) |
(declare (ignore environment)) |
288 |
initial-element |
initial-element |
289 |
(initial-contents nil initial-contents-supplied-p) |
(initial-contents nil initial-contents-supplied-p) |
290 |
(fill-pointer nil fill-pointer-supplied-p) |
(fill-pointer nil fill-pointer-supplied-p) |
291 |
(displaced-to nil displaced-to-supplied-p) |
(displaced-to nil) |
292 |
(displaced-index-offset 0) |
(displaced-index-offset 0) |
293 |
(static nil static-supplied-p)) |
(static nil static-supplied-p)) |
294 |
|
|
295 |
(declare (ignore initial-element static) |
(declare (ignore initial-element static displaced-index-offset) ;FIXME |
296 |
(:dynamic-extent r new-dimensions)) |
(:dynamic-extent r new-dimensions)) |
297 |
|
|
298 |
(when (integerp new-dimensions) |
(when (integerp new-dimensions) |
350 |
(when fill-pointer |
(when fill-pointer |
351 |
(setf (fill-pointer array) fill-pointer)) |
(setf (fill-pointer array) fill-pointer)) |
352 |
|
|
|
array)) |
|
353 |
|
array)) |