/[gcl]/gcl/lsp/gcl_arraylib.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_arraylib.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by camm, Fri Jan 7 17:58:34 2005 UTC revision 1.7 by camm, Sat Jul 23 08:50:21 2005 UTC
# Line 1  Line 1 
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
# Line 42  Line 43 
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))
# Line 277  Line 288 
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)
# Line 339  Line 350 
350      (when fill-pointer      (when fill-pointer
351        (setf (fill-pointer array) fill-pointer))        (setf (fill-pointer array) fill-pointer))
352        
     array))  
353        array))

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26