/[gcl]/gcl/ansi-tests/ansi-aux.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/ansi-aux.lsp

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

revision 1.104 by pfdietz, Thu Sep 2 11:43:12 2004 UTC revision 1.105 by pfdietz, Sat Sep 25 15:08:57 2004 UTC
# Line 992  the condition to go uncaught if it canno Line 992  the condition to go uncaught if it canno
992                              :fill ,fill :adjust ,adjust                              :fill ,fill :adjust ,adjust
993                              :base ,base :displace ,displace)))                              :base ,base :displace ,displace)))
994                   ,@forms))))))))                   ,@forms))))))))
995    
996    (defun make-special-integer-vector (contents &key fill adjust displace (etype 'integer))
997      (let* ((len (length contents))
998             (min (reduce #'min contents))
999             (max (reduce #'max contents))
1000             (len2 (if fill (+ len 4) len)))
1001        (unless (and (typep min etype)
1002                     (typep max etype))
1003          (setq etype `(integer ,min ,max)))
1004        (if displace
1005            (let ((s0 (make-array (+ len2 5)
1006                                  :initial-contents
1007                                  (concatenate 'list
1008                                               (make-list 2 :initial-element
1009                                                          (if (typep 0 etype) 0 min))
1010                                               contents
1011                                               (make-list (if fill 7 3)
1012                                                          :initial-element
1013                                                          (if (typep 1 etype) 1 max)))
1014                                  :element-type etype)))
1015              (make-array len2 :element-type etype
1016                          :adjustable adjust
1017                          :fill-pointer (if fill len nil)
1018                          :displaced-to s0
1019                          :displaced-index-offset 2))
1020          (make-array len2 :element-type etype
1021                      :initial-contents
1022                      (if fill (concatenate 'list
1023                                            contents
1024                                            (make-list 4 :initial-element
1025                                                       (if (typep 2 etype) 2 (floor (+ min max) 2))))
1026                        contents)
1027                      :fill-pointer (if fill len nil)
1028                      :adjustable adjust))))
1029    
1030    (defmacro do-special-integer-vectors ((var vec-form &optional ret-form) &body forms)
1031      (let ((vector (gensym))
1032            (fill (gensym "FILL"))
1033            (adjust (gensym "ADJUST"))
1034            (etype (gensym "ETYPE"))
1035            (displace (gensym "DISPLACE")))
1036        `(let ((,vector ,vec-form))
1037           (dolist (,fill '(nil t) ,ret-form)
1038             (dolist (,adjust '(nil t))
1039               (dolist (,etype ',(append (loop for i from 1 to 32 collect `(unsigned-byte ,i))
1040                                         (loop for i from 2 to 32 collect `(signed-byte ,i))
1041                                         '(integer)))
1042                 (dolist (,displace '(nil t))
1043                   (let ((,var (make-special-integer-vector
1044                                ,vector
1045                                :fill ,fill :adjust ,adjust
1046                                :etype ,etype :displace ,displace)))
1047                     ,@forms))))))))

Legend:
Removed from v.1.104  
changed lines
  Added in v.1.105

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