/[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.71 by pfdietz, Sat Jun 28 21:02:55 2003 UTC revision 1.72 by pfdietz, Tue Jul 1 02:08:54 2003 UTC
# Line 91  Results: ~A~%" expected-number form n re Line 91  Results: ~A~%" expected-number form n re
91    (loop for i from 0 below n collect i))    (loop for i from 0 below n collect i))
92    
93  (defun make-int-array (n &optional (fn #'make-array))  (defun make-int-array (n &optional (fn #'make-array))
94    (let ((a (funcall fn n)))    (when (symbolp fn)
95        (assert (fboundp fn))
96        (setf fn (symbol-function (the symbol fn))))
97      (let ((a (funcall (the function fn) n)))
98        (declare (type (array * *) a))
99      (loop for i from 0 below n do (setf (aref a i) i))      (loop for i from 0 below n do (setf (aref a i) i))
100      a))      a))
101    
# Line 106  Results: ~A~%" expected-number form n re Line 110  Results: ~A~%" expected-number form n re
110             (equal (aref a1) (aref a2))             (equal (aref a1) (aref a2))
111           (let ((ad (array-dimensions a1)))           (let ((ad (array-dimensions a1)))
112             (and (equal ad (array-dimensions a2))             (and (equal ad (array-dimensions a2))
113                  (if (= (array-rank a1) 1)                  (locally
114                      (let ((as (first ad)))                   (declare (type (array * *) a1 a2))
115                        (loop                   (if (= (array-rank a1) 1)
116                         for i from 0 below as                       (let ((as (first ad)))
117                         always (equal (aref a1 i) (aref a2 i))))                         (loop
118                    (let ((as (array-total-size a1)))                          for i from 0 below as
119                      (and (= as (array-total-size a2))                          always (equal (aref a1 i) (aref a2 i))))
120                           (loop                     (let ((as (array-total-size a1)))
121                            for i from 0 below as                       (and (= as (array-total-size a2))
122                            always (equal (row-major-aref a1 i)                            (loop
123                                          (row-major-aref a2 i)))))))))))                             for i from 0 below as
124                               always (equal (row-major-aref a1 i)
125                                             (row-major-aref a2 i))))))))))))
126    
127  ;;; *universe* is defined elsewhere -- it is a list of various  ;;; *universe* is defined elsewhere -- it is a list of various
128  ;;; lisp objects used when stimulating things in various tests.  ;;; lisp objects used when stimulating things in various tests.
# Line 207  Results: ~A~%" expected-number form n re Line 213  Results: ~A~%" expected-number form n re
213    "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))    "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))
214     by applying both to all elements of *UNIVERSE*.  Print message     by applying both to all elements of *UNIVERSE*.  Print message
215     when a mismatch is found, and return number of mistakes."     when a mismatch is found, and return number of mistakes."
216    
217      (when (symbolp p)
218        (assert (fboundp p))
219        (setf p (symbol-function p)))
220      (assert (typep p 'function))
221      
222    (loop    (loop
223        for x in *universe* count        for x in *universe* count
224          (block failed          (block failed
225            (let ((p1 (handler-case            (let ((p1 (handler-case
226                          (funcall P x)                          (funcall (the function p) x)
227                        (error () (format t "(FUNCALL ~S ~S) failed~%"                        (error () (format t "(FUNCALL ~S ~S) failed~%"
228                                          P x)                                          P x)
229                          (return-from failed t))))                          (return-from failed t))))
# Line 376  the condition to go uncaught if it canno Line 388  the condition to go uncaught if it canno
388    
389  (defun compose (&rest fns)  (defun compose (&rest fns)
390    (let ((rfns (reverse fns)))    (let ((rfns (reverse fns)))
391      #'(lambda (x) (loop for f of-type function      #'(lambda (x) (loop for f
392                          in rfns do (setf x (funcall f x))) x)))                          in rfns do (setf x (funcall (the function f) x))) x)))
393    
394  (defun evendigitp (c)  (defun evendigitp (c)
395    (notnot (find c "02468")))    (notnot (find c "02468")))
# Line 417  the condition to go uncaught if it canno Line 429  the condition to go uncaught if it canno
429      (cons 'list args)))        (cons 'list args)))  
430    
431  (defparameter +standard-chars+  (defparameter +standard-chars+
432      (coerce
433    "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./    "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./
434   ")   " 'simple-base-string))
435    
436  (defparameter  (defparameter
437    +base-chars+ #.(concatenate 'simple-base-string    +base-chars+ #.(concatenate 'simple-base-string
# Line 436  the condition to go uncaught if it canno Line 449  the condition to go uncaught if it canno
449  (defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52))  (defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52))
450  (defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62))  (defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62))
451  (defparameter +digit-chars+ "0123456789")  (defparameter +digit-chars+ "0123456789")
452  (defparameter +extended-digit-chars+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")  (defparameter +extended-digit-chars+ (coerce
453                                          "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
454                                          'simple-base-string))
455    
456  (declaim (type simple-base-string +alpha-chars+ +lower-case-chars+  (declaim (type simple-base-string +alpha-chars+ +lower-case-chars+
457                 +upper-case-chars+ +alphanumeric-chars+))                 +upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+
458                   +standard-chars+))
459    
460  (defparameter +code-chars+  (defparameter +code-chars+
461    (coerce (loop for i from 0 below 256    (coerce (loop for i from 0 below 256
462                  for c = (code-char i)                  for c = (code-char i)
463                  when c collect c)                  when c collect c)
464            'string))            'simple-string))
465    
466    (declaim (type simple-string +code-chars+))
467    
468  (defparameter +rev-code-chars+ (reverse +code-chars+))  (defparameter +rev-code-chars+ (reverse +code-chars+))
469    
# Line 453  the condition to go uncaught if it canno Line 471  the condition to go uncaught if it canno
471    
472  (defun has-non-abort-restart (c)  (defun has-non-abort-restart (c)
473    (throw 'handled    (throw 'handled
474           (if (position 'abort (compute-restarts c)           (if (position 'abort (the list (compute-restarts c))
475                         :key #'restart-name :test-not #'eq)                         :key #'restart-name :test-not #'eq)
476               'success               'success
477             'fail)))             'fail)))
# Line 1256  the condition to go uncaught if it canno Line 1274  the condition to go uncaught if it canno
1274    (classify-error* (elt x n)))    (classify-error* (elt x n)))
1275    
1276  (defmacro defstruct* (&body args)  (defmacro defstruct* (&body args)
1277    `(eval-when (load eval compile)    `(eval-when #+gcl (load eval compile)
1278                  #-gcl (:load-toplevel :compile-toplevel :execute)
1279       (handler-case (eval '(defstruct ,@args))       (handler-case (eval '(defstruct ,@args))
1280                     (serious-condition () nil))))                     (serious-condition () nil))))
1281    
   
1282  (defun sort-package-list (x)  (defun sort-package-list (x)
1283    (sort (copy-list x)    (sort (copy-list x)
1284          #'string<          #'string<

Legend:
Removed from v.1.71  
changed lines
  Added in v.1.72

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