(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "14-Jun-88 14:57:44" il:{qv}lisp>array-tester.\;1 10444 il:|changes| il:|to:| (verified-tests array-read-bit array-read-byte array-read-word array-read-signed-word array-read-fixp array-read-floatp array-read-thin-char array-read-fat-char array-read-pointer array-read-xpointer array-write-bit array-write-byte array-write-word array-write-signed-word array-write-fixp array-write-floatp array-write-thin-char array-write-fat-char array-write-pointer array-write-xpointer) (il:vars il:array-testercoms) (file-environments "ARRAY-TESTER")) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:array-testercoms) (il:rpaqq il:array-testercoms ((il:files il:tester) (il:coms (il:* il:|;;| "array-read and array-write ") (verified-tests array-read-bit array-read-byte array-read-word array-read-signed-word array-read-fixp array-read-floatp array-read-thin-char array-read-fat-char array-read-pointer array-read-xpointer) (verified-tests array-write-bit array-write-byte array-write-word array-write-signed-word array-write-fixp array-write-floatp array-write-thin-char array-write-fat-char array-write-pointer array-write-xpointer)) (file-environments "ARRAY-TESTER"))) (il:filesload il:tester) (il:* il:|;;| "array-read and array-write ") (define-verified-test array-read-bit "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" (flet ((array-read-bit (base index) ((il:opcodes il:misc3 9) base 0 index))) (let ((base (il:%make-array-storage 8 0))) (il:\\putbasebyte base 0 160) (with-collection (dotimes (i 4) (collect (array-read-bit base i))))))) (define-verified-test array-read-byte "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" (flet ((array-read-byte (base index) ((il:opcodes il:misc3 9) base 3 index))) (let ((base (il:%make-array-storage 4 3))) (do ((i 0 (1+ i)) (x (quote (0 23 255 4)) (cdr x))) ((eq i 4)) (il:\\putbasebyte base i (car x))) (with-collection (dotimes (i 4) (collect (array-read-byte base i))))))) (define-verified-test array-read-word "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" (flet ((array-read-word (base index) ((il:opcodes il:misc3 9) base 4 index))) (let ((base (il:%make-array-storage 4 4))) (do ((i 0 (1+ i)) (x (quote (0 23 255 65535)) (cdr x))) ((eq i 4)) (il:\\putbase base i (car x))) (with-collection (dotimes (i 4) (collect (array-read-word base i))))))) (define-verified-test array-read-signed-word "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" (flet ((array-read-signed-word (base index) ((il:opcodes il:misc3 9) base 20 index))) (let ((base (il:%make-array-storage 4 20))) (do ((i 0 (1+ i)) (x (quote (0 -23 255 -32768)) (cdr x))) ((eq i 4)) (il:\\putbase base i (il:\\loloc (car x)))) (with-collection (dotimes (i 4) (collect (array-read-signed-word base i))))))) (define-verified-test array-read-fixp "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" (flet ((array-read-fixp (base index) ((il:opcodes il:misc3 9) base 22 index))) (let ((base (il:%make-array-storage 4 22))) (do ((i 0 (1+ i)) (x (quote (0 -23 65536 -2147483648)) (cdr x))) ((eq i 4)) (il:\\putbasefixp base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-fixp base i))))))) (define-verified-test array-read-floatp "Opcode ARRAYREAD (MISC3 9), type single-float" (flet ((array-read-floatp (base index) ((il:opcodes il:misc3 9) base 54 index))) (let ((base (il:%make-array-storage 4 54))) (do ((i 0 (1+ i)) (x (quote (0.0 -23.0 3.4456E+24 -4.562435E-12)) (cdr x))) ((eq i 4)) (il:\\putbasefloatp base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-floatp base i))))))) (define-verified-test array-read-thin-char "Opcode ARRAYREAD (MISC3 9), type string-char" (flet ((array-read-thin-char (base index) ((il:opcodes il:misc3 9) base 67 index))) (let ((base (il:%make-array-storage 4 67))) (do ((i 0 (1+ i)) (x (quote (#\a #\b #\c #\A)) (cdr x))) ((eq i 4)) (il:\\putbasebyte base i (char-code (car x)))) (with-collection (dotimes (i 4) (collect (array-read-thin-char base i))))))) (define-verified-test array-read-fat-char "Opcode ARRAYREAD (MISC3 9), type fat-string-char" (flet ((array-read-fat-char (base index) ((il:opcodes il:misc3 9) base 68 index))) (let ((base (il:%make-array-storage 4 68))) (do ((i 0 (1+ i)) (x (quote (#\a #\b #\c #\A)) (cdr x))) ((eq i 4)) (il:\\putbase base i (char-code (car x)))) (with-collection (dotimes (i 4) (collect (array-read-fat-char base i))))))) (define-verified-test array-read-pointer "Opcode ARRAYREAD (MISC3 9), type t" (flet ((array-read-pointer (base index) ((il:opcodes il:misc3 9) base 38 index))) (let ((base (il:%make-array-storage 4 38))) (do ((i 0 (1+ i)) (x (quote (2 #\c 2.3 (a . b))) (cdr x))) ((eq i 4)) (il:\\rplptr base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-pointer base i))))))) (define-verified-test array-read-xpointer "Opcode ARRAYREAD (MISC3 9), type il:xpointer" (flet ((array-read-xpointer (base index) ((il:opcodes il:misc3 9) base 86 index))) (let ((base (il:%make-array-storage 4 86))) (do ((i 0 (1+ i)) (x (quote (2 #\c 2.3 (a . b))) (cdr x))) ((eq i 4)) (il:\\putbaseptr base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-xpointer base i))))))) (define-verified-test array-write-bit "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" (flet ((array-write-bit (new-value base index) ((il:opcodes il:misc4 7) new-value base 0 index))) (let ((base (il:%make-array-storage 8 0))) (il:\\putbasebyte base 0 160) (with-collection (do ((i 0 (1+ i)) (x (quote (1 0 1 0)) (cdr x))) ((eq i 4)) (collect (array-write-bit (car x) base i))) (collect (let ((byte (il:\\getbasebyte base 0))) (list (ldb (byte 1 7) byte) (ldb (byte 1 6) byte) (ldb (byte 1 5) byte) (ldb (byte 1 4) byte)))))))) (define-verified-test array-write-byte "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" (flet ((array-write-byte (new-value base index) ((il:opcodes il:misc4 7) new-value base 3 index))) (let ((base (il:%make-array-storage 4 3))) (with-collection (do ((i 0 (1+ i)) (x (quote (0 23 255 4)) (cdr x))) ((eq i 4)) (collect (array-write-byte (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbasebyte base i))))))))) (define-verified-test array-write-word "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" (flet ((array-write-word (new-value base index) ((il:opcodes il:misc4 7) new-value base 4 index))) (let ((base (il:%make-array-storage 4 4))) (with-collection (do ((i 0 (1+ i)) (x (quote (0 23 255 65535)) (cdr x))) ((eq i 4)) (collect (array-write-word (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbase base i))))))))) (define-verified-test array-write-signed-word "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" (flet ((array-write-signed-word (new-value base index) ((il:opcodes il:misc4 7) new-value base 20 index))) (let ((base (il:%make-array-storage 4 20))) (with-collection (do ((i 0 (1+ i)) (x (quote (0 -23 255 -32768)) (cdr x))) ((eq i 4)) (collect (array-write-signed-word (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (let ((word (il:\\getbase base i))) (if (> word 32767) (il:\\vag2 15 word) word)))))))))) (define-verified-test array-write-fixp "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" (flet ((array-write-fixp (new-value base index) ((il:opcodes il:misc4 7) new-value base 22 index))) (let ((base (il:%make-array-storage 4 22))) (with-collection (do ((i 0 (1+ i)) (x (quote (0 -23 65536 -2147483648)) (cdr x))) ((eq i 4)) (collect (array-write-fixp (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbasefixp base (ash i 1)))))))))) (define-verified-test array-write-floatp "Opcode ARRAYWRITE (MISC4 7), type single-float" (flet ((array-write-floatp (new-value base index) ((il:opcodes il:misc4 7) new-value base 54 index))) (let ((base (il:%make-array-storage 4 54))) (with-collection (do ((i 0 (1+ i)) (x (quote (0.0 -23.0 3.4456E+24 -4.562435E-12)) (cdr x))) ((eq i 4)) (collect (array-write-floatp (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbasefloatp base (ash i 1)))))))))) (define-verified-test array-write-thin-char "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" (flet ((array-write-thin-char (new-value base index) ((il:opcodes il:misc4 7) new-value base 67 index))) (let ((base (il:%make-array-storage 4 67))) (with-collection (do ((i 0 (1+ i)) (x (quote (#\a #\b #\c #\A)) (cdr x))) ((eq i 4)) (collect (array-write-thin-char (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (code-char (il:\\getbasebyte base i)))))))))) (define-verified-test array-write-fat-char "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" (flet ((array-write-fat-char (new-value base index) ((il:opcodes il:misc4 7) new-value base 68 index))) (let ((base (il:%make-array-storage 4 68))) (with-collection (do ((i 0 (1+ i)) (x (quote (#\a #\b #\c #\A)) (cdr x))) ((eq i 4)) (collect (array-write-fat-char (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (code-char (il:\\getbase base i)))))))))) (define-verified-test array-write-pointer "Opcode ARRAYWRITE (MISC4 7), type t" (flet ((array-write-pointer (new-value base index) ((il:opcodes il:misc4 7) new-value base 38 index))) (let ((base (il:%make-array-storage 4 38))) (with-collection (do ((i 0 (1+ i)) (x (list 2 #\c (quote a) (cons (quote a) (quote b))) (cdr x))) ((eq i 4)) (collect (array-write-pointer (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (cons (il:\\getbaseptr base (ash i 1)) (il:\\refcnt (il:\\getbaseptr base (ash i 1)))))))))))) (define-verified-test array-write-xpointer "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" (flet ((array-write-xpointer (new-value base index) ((il:opcodes il:misc4 7) new-value base 86 index))) (let ((base (il:%make-array-storage 4 86))) (with-collection (do ((i 0 (1+ i)) (x (list 2 #\c (quote a) (cons (quote a) (quote b))) (cdr x))) ((eq i 4)) (collect (array-write-xpointer (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (cons (il:\\getbaseptr base (ash i 1)) (il:\\refcnt (il:\\getbaseptr base (ash i 1)))))))))))) (define-file-environment "ARRAY-TESTER" :package "XCL-USER" :readtable "XCL" :compiler :compile-file) (il:putprops il:array-tester il:copyright ("Xerox Corporation" 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop