/[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.9 by camm, Wed Sep 7 02:45:32 2005 UTC revision 1.10 by camm, Sun Sep 18 02:08:49 2005 UTC
# Line 41  Line 41 
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)
# Line 90  Line 59 
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
# Line 243  Line 212 
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    

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

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