diff options
Diffstat (limited to 'lisp/test')
| -rw-r--r-- | lisp/test/hello.lsp | 72 | ||||
| -rw-r--r-- | lisp/test/list.lsp | 1895 | ||||
| -rw-r--r-- | lisp/test/math.lsp | 982 | ||||
| -rw-r--r-- | lisp/test/psql-1.lsp | 80 | ||||
| -rw-r--r-- | lisp/test/psql-2.lsp | 74 | ||||
| -rw-r--r-- | lisp/test/psql-3.lsp | 118 | ||||
| -rw-r--r-- | lisp/test/regex.lsp | 440 | ||||
| -rw-r--r-- | lisp/test/stream.lsp | 807 | ||||
| -rw-r--r-- | lisp/test/widgets.lsp | 71 |
9 files changed, 4539 insertions, 0 deletions
diff --git a/lisp/test/hello.lsp b/lisp/test/hello.lsp new file mode 100644 index 0000000..5446919 --- /dev/null +++ b/lisp/test/hello.lsp @@ -0,0 +1,72 @@ +;; +;; Copyright (c) 2001 by The XFree86 Project, Inc. +;; +;; Permission is hereby granted, free of charge, to any person obtaining a +;; copy of this software and associated documentation files (the "Software"), +;; to deal in the Software without restriction, including without limitation +;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;; and/or sell copies of the Software, and to permit persons to whom the +;; Software is furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in +;; all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;; THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF +;; OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. +;; +;; Except as contained in this notice, the name of the XFree86 Project shall +;; not be used in advertising or otherwise to promote the sale, use or other +;; dealings in this Software without prior written authorization from the +;; XFree86 Project. +;; +;; Author: Paulo César Pereira de Andrade +;; +;; +;; $XFree86: xc/programs/xedit/lisp/test/hello.lsp,v 1.3 2002/11/08 08:01:01 paulo Exp $ +;; +(require "xaw") +(require "xt") + +(defun quit-callback (widget user call) (quit)) + +(defun fix-shell-size (shell) + (let ((size (xt-get-values shell '("width" "height")))) + (xt-set-values shell + (list (cons "minWidth" (cdar size)) + (cons "maxWidth" (cdar size)) + (cons "minHeight" (cdadr size)) + (cons "maxHeight" (cdadr size))) + ) + ) +) + +(setq toplevel + (xt-app-initialize 'appcontext "Hello" + '(("title" . "Hello World!")))) + +(setq form + (xt-create-managed-widget "form" form-widget-class toplevel + '(("background" . "gray85") + ("displayList" . "foreground rgb:7/9/7;lines 1,-1,-1,-1,-1,1;foreground gray90;lines -1,0,0,0,0,-1") + ))) + +(setq button + (xt-create-managed-widget "button" command-widget-class form + '(("label" . "Goodbye world!") + ("tip" . "This sample uses some customizations") + ("foreground" . "gray10") + ("background" . "gray80") + ("displayList" . "foreground rgb:7/9/7;lines 1,-1,-1,-1,-1,1;foreground gray90;lines -1,0,0,0,0,-1") + ))) +(xt-add-callback button "callback" 'quit-callback) + +(xt-realize-widget toplevel) + +(fix-shell-size toplevel) + +(xt-app-main-loop appcontext) diff --git a/lisp/test/list.lsp b/lisp/test/list.lsp new file mode 100644 index 0000000..23f4496 --- /dev/null +++ b/lisp/test/list.lsp @@ -0,0 +1,1895 @@ +;; +;; Copyright (c) 2002 by The XFree86 Project, Inc. +;; +;; Permission is hereby granted, free of charge, to any person obtaining a +;; copy of this software and associated documentation files (the "Software"), +;; to deal in the Software without restriction, including without limitation +;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;; and/or sell copies of the Software, and to permit persons to whom the +;; Software is furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in +;; all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;; THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF +;; OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. +;; +;; Except as contained in this notice, the name of the XFree86 Project shall +;; not be used in advertising or otherwise to promote the sale, use or other +;; dealings in this Software without prior written authorization from the +;; XFree86 Project. +;; +;; Author: Paulo César Pereira de Andrade +;; +;; +;; $XFree86: xc/programs/xedit/lisp/test/list.lsp,v 1.6 2002/12/06 03:25:29 paulo Exp $ +;; + +;; basic lisp function tests + +;; Most of the tests are just the examples from the +;; +;; Common Lisp HyperSpec (TM) +;; Copyright 1996-2001, Xanalys Inc. All rights reserved. +;; +;; Some tests are hand crafted, to test how the interpreter treats +;; uncommon arguments or special conditions + + +#| + MAJOR PROBLEMS: + + o NIL and T should be always treated as symbols, actually it is + legal to say (defun nil (...) ...) + o There aren't true uninterned symbols, there are only symbols that + did not yet establish the home package, but once one is created, an + interned symbol is always returned. +|# + +(defun compare-test (test expect function arguments + &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + ) + (if error + (format t "ERROR: (~S~{ ~S~}) => ~S~%" function arguments error-value) + (or (funcall test result expect) + (format t "(~S~{ ~S~}) => should be ~S not ~S~%" + function arguments expect result + ) + ) + ) +) + +(defun compare-eval (test expect form + &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (eval form)) + (setq error nil) + ) + ) + (if error + (format t "ERROR: ~S => ~S~%" form error-value) + (or (funcall test result expect) + (format t "~S => should be ~S not ~S~%" + form expect result + ) + ) + ) +) + +(defun error-test (function &rest arguments &aux result (error t)) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + (or error + (format t "ERROR: no error for (~S~{ ~S~}), result was ~S~%" + function arguments result) + ) +) + +(defun error-eval (form &aux result (error t)) + (ignore-errors + (setq result (eval form)) + (setq error nil) + ) + (or error + (format t "ERROR: no error for ~S, result was ~S~%" form result) + ) +) + +(defun eq-test (expect function &rest arguments) + (compare-test #'eq expect function arguments)) + +(defun eql-test (expect function &rest arguments) + (compare-test #'eql expect function arguments)) + +(defun equal-test (expect function &rest arguments) + (compare-test #'equal expect function arguments)) + +(defun equalp-test (expect function &rest arguments) + (compare-test #'equalp expect function arguments)) + + +(defun eq-eval (expect form) + (compare-eval #'eq expect form)) + +(defun eql-eval (expect form) + (compare-eval #'eql expect form)) + +(defun equal-eval (expect form) + (compare-eval #'equal expect form)) + +(defun equalp-eval (expect form) + (compare-eval #'equalp expect form)) + +;; clisp treats strings loaded from a file as constants +(defun xseq (sequence) + #+clisp (if *load-pathname* (copy-seq sequence) sequence) + #-clisp sequence +) + +;; apply - function +(equal-test '((+ 2 3) . 4) #'apply 'cons '((+ 2 3) 4)) +(eql-test -1 #'apply #'- '(1 2)) +(eql-test 7 #'apply #'max 3 5 '(2 7 3)) +(error-test #'apply #'+ 1) +(error-test #'apply #'+ 1 2) +(error-test #'apply #'+ 1 . 2) +(error-test #'apply #'+ 1 2 3) +(error-test #'apply #'+ 1 2 . 3) +(eql-test 6 #'apply #'+ 1 2 3 ()) + +;; eq - function +(eq-eval t '(let* ((a #\a) (b a)) (eq a b))) +(eq-test t #'eq 'a 'a) +(eq-test nil #'eq 'a 'b) +(eq-eval t '(eq #1=1 #1#)) +(eq-test nil #'eq "abc" "abc") +(setq a '('x #c(1 2) #\z)) +(eq-test nil #'eq a (copy-seq a)) + +;; eql - function +(eq-test t #'eql 1 1) +(eq-test t #'eql 1.3d0 1.3d0) +(eq-test nil #'eql 1 1d0) +(eq-test t #'eql #c(1 -5) #c(1 -5)) +(eq-test t #'eql 'a 'a) +(eq-test nil #'eql :a 'a) +(eq-test t #'eql #c(5d0 0) 5d0) +(eq-test nil #'eql #c(5d0 0d0) 5d0) +(eq-test nil #'eql "abc" "abc") +(equal-eval '(1 5/6 #p"test" #\#) '(setq a '(1 5/6 #p"test" #\#))) +(eq-test nil #'eql a (copy-seq a)) + +(setf + hash0 (make-hash-table) + hash1 (make-hash-table) + (gethash 1 hash0) 2 + (gethash 1 hash1) 2 + (gethash :foo hash0) :bar + (gethash :foo hash1) :bar +) +(defstruct test a b c) +(setq + struc0 (make-test :a 1 :b 2 :c #\c) + struc1 (make-test :a 1 :b 2 :c #\c) +) + +;; equal - function +(eq-test t #'equal "abc" "abc") +(eq-test t #'equal 1 1) +(eq-test t #'equal #c(1 2) #c(1 2)) +(eq-test nil #'equal #c(1 2) #c(1 2d0)) +(eq-test t #'equal #\A #\A) +(eq-test nil #'equal #\A #\a) +(eq-test nil #'equal "abc" "Abc") +(equal-eval '(1 2 3/5 #\a) '(setq a '(1 2 3/5 #\a))) +(eq-test t #'equal a (copy-seq a)) +(eq-test nil #'equal hash0 hash1) +(eq-test nil #'equal struc0 struc1) +(eq-test nil #'equal #(1 2 3 4) #(1 2 3 4)) + +;; equalp - function +(eq-test t #'equalp hash0 hash1) +(setf + (gethash 2 hash0) "FoObAr" + (gethash 2 hash1) "fOoBaR" +) +(eq-test t #'equalp hash0 hash1) +(setf + (gethash 3 hash0) 3 + (gethash 3d0 hash1) 3 +) +(eq-test nil #'equalp hash0 hash1) +(eq-test t #'equalp struc0 struc1) +(setf + (test-a struc0) #\a + (test-a struc1) #\A +) +(eq-test t #'equalp struc0 struc1) +(setf + (test-b struc0) 'test + (test-b struc1) :test +) +(eq-test nil #'equalp struc0 struc1) +(eq-test t #'equalp #c(1/2 1d0) #c(0.5d0 1)) +(eq-test t #'equalp 1 1d0) +(eq-test t #'equalp #(1 2 3 4) #(1 2 3 4)) +(eq-test t #'equalp #(1 #\a 3 4d0) #(1 #\A 3 4)) + +;; acons - function +(equal-test '((1 . "one")) #'acons 1 "one" nil) +(equal-test '((2 . "two") (1 . "one")) #'acons 2 "two" '((1 . "one"))) + +;; adjoin - function +(equal-test '(nil) #'adjoin nil nil) +(equal-test '(a) #'adjoin 'a nil) +(equal-test '(1 2 3) #'adjoin 1 '(1 2 3)) +(equal-test '(1 2 3) #'adjoin 2 '(1 2 3)) +(equal-test '((1) (1) (2) (3)) #'adjoin '(1) '((1) (2) (3))) +(equal-test '((1) (2) (3)) #'adjoin '(1) '((1) (2) (3)) :key #'car) +(error-test #'adjoin nil 1) + +;; alpha-char-p - function +(eq-test t #'alpha-char-p #\a) +(eq-test nil #'alpha-char-p #\5) +(error-test #'alpha-char-p 'a) + +;; alphanumericp - function +(eq-test t #'alphanumericp #\Z) +(eq-test t #'alphanumericp #\8) +(eq-test nil #'alphanumericp #\#) + +;; and - macro +(eql-eval 1 '(setq temp1 1 temp2 1 temp3 1)) +(eql-eval 2 '(and (incf temp1) (incf temp2) (incf temp3))) +(eq-eval t '(and (eql 2 temp1) (eql 2 temp2) (eql 2 temp3))) +(eql-eval 1 '(decf temp3)) +(eq-eval nil '(and (decf temp1) (decf temp2) (eq temp3 'nil) (decf temp3))) +(eq-eval t '(and (eql temp1 temp2) (eql temp2 temp3))) +(eq-eval t '(and)) +(equal-eval '(1 2 3) '(multiple-value-list (and (values 'a) (values 1 2 3)))) +(equal-eval nil '(and (values) t)) + +;; append - function +(equal-test '(a b c d e f g) #'append '(a b c) '(d e f) '() '(g)) +(equal-test '(a b c . d) #'append '(a b c) 'd) +(eq-test nil #'append) +(eql-test 'a #'append nil 'a) +(error-test #'append 1 2) + +;; assoc - function +(equal-test '(1 . "one") #'assoc 1 '((2 . "two") (1 . "one"))) +(equal-test '(2 . "two") #'assoc 2 '((1 . "one") (2 . "two"))) +(eq-test nil #'assoc 1 nil) +(equal-test '(2 . "two") #'assoc-if #'evenp '((1 . "one") (2 . "two"))) +(equal-test '(3 . "three") #'assoc-if-not #'(lambda(x) (< x 3)) + '((1 . "one") (2 . "two") (3 . "three"))) +(equal-test '("two" . 2) #'assoc #\o '(("one" . 1) ("two" . 2) ("three" . 3)) + :key #'(lambda (x) (char x 2))) +(equal-test '(a . b) #'assoc 'a '((x . a) (y . b) (a . b) (a . c))) + +;; atom - function +(eq-test t #'atom 1) +(eq-test t #'atom '()) +(eq-test nil #'atom '(1)) +(eq-test t #'atom 'a) + +;; block - special operator +(eq-eval nil '(block empty)) +(eql-eval 2 '(let ((x 1)) + (block stop (setq x 2) (return-from stop) (setq x 3)) x)) +(eql-eval 2 '(block twin (block twin (return-from twin 1)) 2)) + +;; both-case-p - function +(eq-test t #'both-case-p #\a) +(eq-test nil #'both-case-p #\1) + +;; boundp - function +(eql-eval 1 '(setq x 1)) +(eq-test t #'boundp 'x) +(makunbound 'x) +(eq-test nil #'boundp 'x) +(eq-eval nil '(let ((x 1)) (boundp 'x))) +(error-test #'boundp 1) + +;; butlast, nbutlast - function +(setq x '(1 2 3 4 5 6 7 8 9)) +(equal-test '(1 2 3 4 5 6 7 8) #'butlast x) +(equal-eval '(1 2 3 4 5 6 7 8 9) 'x) +(eq-eval nil '(nbutlast x 9)) +(equal-test '(1) #'nbutlast x 8) +(equal-eval '(1) 'x) +(eq-test nil #'butlast nil) +(eq-test nil #'nbutlast '()) +(error-test #'butlast 1 2) +(error-test #'butlast -1 '(1 2)) + +;; car, cdr, caar ... - function +(eql-test 1 #'car '(1 2)) +(eql-test 2 #'cdr '(1 . 2)) +(eql-test 1 #'caar '((1 2))) +(eql-test 2 #'cadr '(1 2)) +(eql-test 2 #'cdar '((1 . 2))) +(eql-test 3 #'cddr '(1 2 . 3)) +(eql-test 1 #'caaar '(((1 2)))) +(eql-test 2 #'caadr '(1 (2 3))) +(eql-test 2 #'cadar '((1 2) 2 3)) +(eql-test 3 #'caddr '(1 2 3 4)) +(eql-test 2 #'cdaar '(((1 . 2)) 3)) +(eql-test 3 #'cdadr '(1 (2 . 3) 4)) +(eql-test 3 #'cddar '((1 2 . 3) 3)) +(eql-test 4 #'cdddr '(1 2 3 . 4)) +(eql-test 1 #'caaaar '((((1 2))))) +(eql-test 2 #'caaadr '(1 ((2)))) +(eql-test 2 #'caadar '((1 (2)) 3)) +(eql-test 3 #'caaddr '(1 2 (3 4))) +(eql-test 2 #'cadaar '(((1 2)) 3)) +(eql-test 3 #'cadadr '(1 (2 3) 4)) +(eql-test 3 #'caddar '((1 2 3) 4)) +(eql-test 4 #'cadddr '(1 2 3 4 5)) +(eql-test 2 #'cdaaar '((((1 . 2))) 3)) +(eql-test 3 #'cdaadr '(1 ((2 . 3)) 4)) +(eql-test 3 #'cdadar '((1 (2 . 3)) 4)) +(eql-test 4 #'cdaddr '(1 2 (3 . 4) 5)) +(eql-test 3 #'cddaar '(((1 2 . 3)) 4)) +(eql-test 4 #'cddadr '(1 (2 3 . 4) 5)) +(eql-test 4 #'cdddar '((1 2 3 . 4) 5)) +(eql-test 5 #'cddddr '(1 2 3 4 . 5)) + +;; first ... tenth, rest - function +(eql-test 2 #'rest '(1 . 2)) +(eql-test 1 #'first '(1 2)) +(eql-test 2 #'second '(1 2 3)) +(eql-test 2 #'second '(1 2 3)) +(eql-test 3 #'third '(1 2 3 4)) +(eql-test 4 #'fourth '(1 2 3 4 5)) +(eql-test 5 #'fifth '(1 2 3 4 5 6)) +(eql-test 6 #'sixth '(1 2 3 4 5 6 7)) +(eql-test 7 #'seventh '(1 2 3 4 5 6 7 8)) +(eql-test 8 #'eighth '(1 2 3 4 5 6 7 8 9)) +(eql-test 9 #'ninth '(1 2 3 4 5 6 7 8 9 10)) +(eql-test 10 #'tenth '(1 2 3 4 5 6 7 8 9 10 11)) +(error-test #'car 1) +(error-test #'car #c(1 2)) +(error-test #'car #(1 2)) + +;; case - macro +(eql-eval t '(let ((a 1)) (case a ((4 5 6) nil) ((3 2 1) t) (otherwise :error)))) +(eql-eval t '(let ((a 1)) (case a ((3 2) nil) (1 t) (t :error)))) +(error-eval '(let ((a 1)) (case a (2 :error) (t nil) (otherwise t)))) +(error-eval '(let ((a 1)) (case a (2 :error) (otherwise t) (t nil)))) + +;; catch - special operator +(eql-eval 3 '(catch 'dummy-tag 1 2 (throw 'dummy-tag 3) 4)) +(eql-eval 4 '(catch 'dummy-tag 1 2 3 4)) +(eq-eval 'throw-back '(defun throw-back (tag) (throw tag t))) +(eq-eval t '(catch 'dummy-tag (throw-back 'dummy-tag) 2)) + +;; char - function +(eql-test #\a #'char "abc" 0) +(eql-test #\b #'char "abc" 1) +(error-test #'char "abc" 3) + +;; char-* - function +(eq-test nil #'alpha-char-p #\3) +(eq-test t #'alpha-char-p #\y) +(eql-test #\a #'char-downcase #\a) +(eql-test #\a #'char-downcase #\a) +(eql-test #\1 #'char-downcase #\1) +(error-test #'char-downcase 1) +(eql-test #\A #'char-upcase #\a) +(eql-test #\A #'char-upcase #\A) +(eql-test #\1 #'char-upcase #\1) +(error-test #'char-upcase 1) +(eq-test t #'lower-case-p #\a) +(eq-test nil #'lower-case-p #\A) +(eq-test t #'upper-case-p #\W) +(eq-test nil #'upper-case-p #\w) +(eq-test t #'both-case-p #\x) +(eq-test nil #'both-case-p #\%) +(eq-test t #'char= #\d #\d) +(eq-test t #'char-equal #\d #\d) +(eq-test nil #'char= #\A #\a) +(eq-test t #'char-equal #\A #\a) +(eq-test nil #'char= #\d #\x) +(eq-test nil #'char-equal #\d #\x) +(eq-test nil #'char= #\d #\D) +(eq-test t #'char-equal #\d #\D) +(eq-test nil #'char/= #\d #\d) +(eq-test nil #'char-not-equal #\d #\d) +(eq-test nil #'char/= #\d #\d) +(eq-test nil #'char-not-equal #\d #\d) +(eq-test t #'char/= #\d #\x) +(eq-test t #'char-not-equal #\d #\x) +(eq-test t #'char/= #\d #\D) +(eq-test nil #'char-not-equal #\d #\D) +(eq-test t #'char= #\d #\d #\d #\d) +(eq-test t #'char-equal #\d #\d #\d #\d) +(eq-test nil #'char= #\d #\D #\d #\d) +(eq-test t #'char-equal #\d #\D #\d #\d) +(eq-test nil #'char/= #\d #\d #\d #\d) +(eq-test nil #'char-not-equal #\d #\d #\d #\d) +(eq-test nil #'char/= #\d #\d #\D #\d) +(eq-test nil #'char-not-equal #\d #\d #\D #\d) +(eq-test nil #'char= #\d #\d #\x #\d) +(eq-test nil #'char-equal #\d #\d #\x #\d) +(eq-test nil #'char/= #\d #\d #\x #\d) +(eq-test nil #'char-not-equal #\d #\d #\x #\d) +(eq-test nil #'char= #\d #\y #\x #\c) +(eq-test nil #'char-equal #\d #\y #\x #\c) +(eq-test t #'char/= #\d #\y #\x #\c) +(eq-test t #'char-not-equal #\d #\y #\x #\c) +(eq-test nil #'char= #\d #\c #\d) +(eq-test nil #'char-equal #\d #\c #\d) +(eq-test nil #'char/= #\d #\c #\d) +(eq-test nil #'char-not-equal #\d #\c #\d) +(eq-test t #'char< #\d #\x) +(eq-test t #'char-lessp #\d #\x) +(eq-test t #'char-lessp #\d #\X) +(eq-test t #'char-lessp #\D #\x) +(eq-test t #'char-lessp #\D #\X) +(eq-test t #'char<= #\d #\x) +(eq-test t #'char-not-greaterp #\d #\x) +(eq-test t #'char-not-greaterp #\d #\X) +(eq-test t #'char-not-greaterp #\D #\x) +(eq-test t #'char-not-greaterp #\D #\X) +(eq-test nil #'char< #\d #\d) +(eq-test nil #'char-lessp #\d #\d) +(eq-test nil #'char-lessp #\d #\D) +(eq-test nil #'char-lessp #\D #\d) +(eq-test nil #'char-lessp #\D #\D) +(eq-test t #'char<= #\d #\d) +(eq-test t #'char-not-greaterp #\d #\d) +(eq-test t #'char-not-greaterp #\d #\D) +(eq-test t #'char-not-greaterp #\D #\d) +(eq-test t #'char-not-greaterp #\D #\D) +(eq-test t #'char< #\a #\e #\y #\z) +(eq-test t #'char-lessp #\a #\e #\y #\z) +(eq-test t #'char-lessp #\a #\e #\y #\Z) +(eq-test t #'char-lessp #\a #\E #\y #\z) +(eq-test t #'char-lessp #\A #\e #\y #\Z) +(eq-test t #'char<= #\a #\e #\y #\z) +(eq-test t #'char-not-greaterp #\a #\e #\y #\z) +(eq-test t #'char-not-greaterp #\a #\e #\y #\Z) +(eq-test t #'char-not-greaterp #\A #\e #\y #\z) +(eq-test nil #'char< #\a #\e #\e #\y) +(eq-test nil #'char-lessp #\a #\e #\e #\y) +(eq-test nil #'char-lessp #\a #\e #\E #\y) +(eq-test nil #'char-lessp #\A #\e #\E #\y) +(eq-test t #'char<= #\a #\e #\e #\y) +(eq-test t #'char-not-greaterp #\a #\e #\e #\y) +(eq-test t #'char-not-greaterp #\a #\E #\e #\y) +(eq-test t #'char> #\e #\d) +(eq-test t #'char-greaterp #\e #\d) +(eq-test t #'char-greaterp #\e #\D) +(eq-test t #'char-greaterp #\E #\d) +(eq-test t #'char-greaterp #\E #\D) +(eq-test t #'char>= #\e #\d) +(eq-test t #'char-not-lessp #\e #\d) +(eq-test t #'char-not-lessp #\e #\D) +(eq-test t #'char-not-lessp #\E #\d) +(eq-test t #'char-not-lessp #\E #\D) +(eq-test t #'char> #\d #\c #\b #\a) +(eq-test t #'char-greaterp #\d #\c #\b #\a) +(eq-test t #'char-greaterp #\d #\c #\b #\A) +(eq-test t #'char-greaterp #\d #\c #\B #\a) +(eq-test t #'char-greaterp #\d #\C #\b #\a) +(eq-test t #'char-greaterp #\D #\C #\b #\a) +(eq-test t #'char>= #\d #\c #\b #\a) +(eq-test t #'char-not-lessp #\d #\c #\b #\a) +(eq-test t #'char-not-lessp #\d #\c #\b #\A) +(eq-test t #'char-not-lessp #\D #\c #\b #\a) +(eq-test t #'char-not-lessp #\d #\C #\B #\a) +(eq-test nil #'char> #\d #\d #\c #\a) +(eq-test nil #'char-greaterp #\d #\d #\c #\a) +(eq-test nil #'char-greaterp #\d #\d #\c #\A) +(eq-test nil #'char-greaterp #\d #\D #\c #\a) +(eq-test nil #'char-greaterp #\d #\D #\C #\a) +(eq-test t #'char>= #\d #\d #\c #\a) +(eq-test t #'char-not-lessp #\d #\d #\c #\a) +(eq-test t #'char-not-lessp #\d #\D #\c #\a) +(eq-test t #'char-not-lessp #\D #\d #\c #\a) +(eq-test t #'char-not-lessp #\D #\D #\c #\A) +(eq-test nil #'char> #\e #\d #\b #\c #\a) +(eq-test nil #'char-greaterp #\e #\d #\b #\c #\a) +(eq-test nil #'char-greaterp #\E #\d #\b #\c #\a) +(eq-test nil #'char-greaterp #\e #\D #\b #\c #\a) +(eq-test nil #'char-greaterp #\E #\d #\B #\c #\A) +(eq-test nil #'char>= #\e #\d #\b #\c #\a) +(eq-test nil #'char-not-lessp #\e #\d #\b #\c #\a) +(eq-test nil #'char-not-lessp #\e #\d #\b #\c #\A) +(eq-test nil #'char-not-lessp #\E #\d #\B #\c #\a) + +;; char-code - function +;; XXX assumes ASCII +(eql-test 49 #'char-code #\1) +(eql-test 90 #'char-code #\Z) +(eql-test 127 #'char-code #\Delete) +(eql-test 27 #'char-code #\Escape) +(eql-test 13 #'char-code #\Return) +(eql-test 0 #'char-code #\Null) +(eql-test 10 #'char-code #\Newline) +(error-test #'char-code 65) + +;; character - function +(eql-test #\a #'character #\a) +(eql-test #\a #'character "a") +(eql-test #\A #'character 'a) + +;; XXX assumes ASCII, and should be allowed to fail? +(eql-test #\A #'character 65) + +(error-test #'character 1/2) +(error-test #'character "abc") +(error-test #'character :test) +(eq-test #\T #'character t) +(error-test #'character nil) + +;; characterp - function +(eq-test t #'characterp #\a) +(eq-test nil #'characterp 1) +(eq-test nil #'characterp 1/2) +(eq-test nil #'characterp 'a) +(eq-test nil #'characterp '`a) + + + + +;; TODO coerce + + + + +;; cond - macro +(eql-eval 2 '(let ((a 1)) (cond ((= a 2) 1) ((= a 1) 2) ((= a 0) 1) (t nil)))) +(eql-eval nil '(let ((a 1)) (cond ((= a 2) 1) (t nil) ((= a 1) 2) ((= a 0) 1)))) + +;; consp - function (predicate) +(eq-test t #'consp '(1 2)) +(eq-test t #'consp '(1 . 2)) +(eq-test nil #'consp nil) +(eq-test nil #'consp 1) + +;; constantp - function (predicate) +(eq-test t #'constantp 1) +(eq-test t #'constantp #\x) +(eq-test t #'constantp :test) +(eq-test nil #'constantp 'test) +(eq-test t #'constantp ''1) +(eq-test t #'constantp '(quote 1)) +(eq-test t #'constantp "string") +(eq-test t #'constantp #c(1 2)) +(eq-test t #'constantp #(1 2)) +(eq-test nil #'constantp #p"test") +(eq-test nil #'constantp '(1 2)) +(eq-test nil #'constantp (make-hash-table)) +(eq-test nil #'constantp *package*) +(eq-test nil #'constantp *standard-input*) + +;; copy-list, copy-alist and copy-tree - function +(equal-test '(1 2) #'copy-list '(1 2)) +(equal-test '(1 . 2) #'copy-list '(1 . 2)) +(eq-test nil #'copy-list nil) +(error-test #'copy-list 1) +(equal-eval '(1 (2 3)) '(setq x '(1 (2 3)))) +(equal-eval x '(setq y (copy-list x))) +(equal-test '("one" (2 3)) #'rplaca x "one") +(eql-test 1 #'car y) +(equal-test '("two" 3) #'rplaca (cadr x) "two") +(eq-test (caadr x) #'caadr y) +(equal-eval '(1 (2 3) 4) '(setq a '(1 (2 3) 4) b (copy-list a))) +(eq-eval t '(eq (cadr a) (cadr b))) +(eq-eval t '(eq (car a) (car b))) +(setq a '(1 (2 3) 4) b (copy-alist a)) +(eq-eval nil '(eq (cadr a) (cadr b))) +(eq-eval t '(eq (car a) (car b))) +(eq-test nil #'copy-alist nil) +(eq-test nil #'copy-list nil) +(error-test #'copy-list 1) +(setq a '(1 (2 (3)))) +(setq as-list (copy-list a)) +(setq as-alist (copy-alist a)) +(setq as-tree (copy-tree a)) +(eq-eval t '(eq (cadadr a) (cadadr as-list))) +(eq-eval t '(eq (cadadr a) (cadadr as-alist))) +(eq-eval nil '(eq (cadadr a) (cadadr as-tree))) + +;; decf - macro +(setq n 2) +(eql-eval 1 '(decf n)) +(eql-eval 1 'n) +(setq n -2147483648) +(eql-eval -2147483649 '(decf n)) +(eql-eval -2147483649 'n) +(setq n 0) +(eql-eval -0.5d0 '(decf n 0.5d0)) +(eql-eval -0.5d0 'n) +(setq n 1) +(eql-eval 1/2 '(decf n 1/2)) +(eql-eval 1/2 'n) + +;; delete and remove - function +(setq a '(1 3 4 5 9) b a) +(equal-test '(1 3 5 9) #'remove 4 a) +(eq-eval t '(eq a b)) +(setq a (delete 4 a)) +(equal-eval '(1 3 5 9) 'a) +(setq a '(1 2 4 1 3 4 5) b a) +(equal-test '(1 2 1 3 5) #'remove 4 a) +(eq-eval t '(eq a b)) +(equal-test '(1 2 1 3 4 5) #'remove 4 a :count 1) +(eq-eval t '(eq a b)) +(equal-test '(1 2 4 1 3 5) #'remove 4 a :count 1 :from-end t) +(eq-eval t '(eq a b)) +(equal-test '(4 3 4 5) #'remove 3 a :test #'>) +(eq-eval t '(eq a b)) +(setq a (delete 4 '(1 2 4 1 3 4 5))) +(equal-eval '(1 2 1 3 5) 'a) +(setq a (delete 4 '(1 2 4 1 3 4 5) :count 1)) +(equal-eval '(1 2 1 3 4 5) 'a) +(setq a (delete 4 '(1 2 4 1 3 4 5) :count 1 :from-end t)) +(equal-eval '(1 2 4 1 3 5) 'a) +(equal-test "abc" #'delete-if #'digit-char-p "a1b2c3") +(equal-test "123" #'delete-if-not #'digit-char-p "a1b2c3") +(eq-test nil #'delete 1 nil) +(eq-test nil #'remove 1 nil) +(setq a '(1 2 3 4 :test 5 6 7 8) b a) +(equal-test '(1 2 :test 7 8) #'remove-if #'numberp a :start 2 :end 7) +(eq-eval t '(eq a b)) +(setq a (delete-if #'numberp a :start 2 :end 7)) +(equal-eval '(1 2 :test 7 8) 'a) + +;; digit-char - function +(eql-test #\0 #'digit-char 0) +(eql-test #\A #'digit-char 10 11) +(eq-test nil #'digit-char 10 10) +(eql-test 35 #'digit-char-p #\z 36) +(error-test #'digit-char #\a) +(error-test #'digit-char-p 1/2) + + + +;; TODO directory (known to have problems with parameters like "../*/../*/") + + + +;; elt - function +(eql-test #\a #'elt "xabc" 1) +(eql-test 3 #'elt '(0 1 2 3) 3) +(error-test #'elt nil 0) + +;; endp - function +(eql-test t #'endp nil) +(error-test #'endp t) +(eql-test nil #'endp '(1 . 2)) +(error-test #'endp #(1 2)) + +;; every - function +(eql-test t #'every 'not-used ()) +(eql-test t #'every #'characterp "abc") +(eql-test nil #'every #'< '(1 2 3) '(4 5 6) #(7 8 -1)) +(eql-test t #'every #'< '(1 2 3) '(4 5 6) #(7 8)) + +;; fboundp and fmakunbound - function +(eq-test t #'fboundp 'car) +(eq-eval 'test '(defun test ())) +(eq-test t #'fboundp 'test) +(eq-test 'test #'fmakunbound 'test) +(eq-test nil #'fboundp 'test) +(eq-eval 'test '(defmacro test (x) x)) +(eq-test t #'fboundp 'test) +(eq-test 'test #'fmakunbound 'test) + +;; fill - function +(setq x (list 1 2 3 4)) +(equal-test '((4 4 4 4) (4 4 4 4) (4 4 4 4) (4 4 4 4)) #'fill x '(4 4 4 4)) +(eq-eval t '(eq (car x) (cadr x))) +(equalp-test '#(a z z d e) #'fill '#(a b c d e) 'z :start 1 :end 3) +(equal-test "012ee" #'fill (xseq "01234") #\e :start 3) +(error-test #'fill 1 #\a) + +;; find - function +(eql-test #\Space #'find #\d "here are some letters that can be looked at" :test #'char>) +(eql-test 3 #'find-if #'oddp '(1 2 3 4 5) :end 3 :from-end t) +(eq-test nil #'find-if-not #'complexp '#(3.5 2 #C(1.0 0.0) #C(0.0 1.0)) :start 2) +(eq-test nil #'find 1 "abc") +(error-test #'find 1 #c(1 2)) + +;; find-symbol - function +(equal-eval '(nil nil) + '(multiple-value-list (find-symbol "NEVER-BEFORE-USED"))) +(equal-eval '(nil nil) + '(multiple-value-list (find-symbol "NEVER-BEFORE-USED"))) +(setq test (multiple-value-list (intern "NEVER-BEFORE-USED"))) +(equal-eval test '(read-from-string "(never-before-used nil)")) +(equal-eval '(never-before-used :internal) + '(multiple-value-list (intern "NEVER-BEFORE-USED"))) +(equal-eval '(never-before-used :internal) + '(multiple-value-list (find-symbol "NEVER-BEFORE-USED"))) +(equal-eval '(nil nil) + '(multiple-value-list (find-symbol "never-before-used"))) +(equal-eval '(car :inherited) + '(multiple-value-list (find-symbol "CAR" 'common-lisp-user))) +(equal-eval '(car :external) + '(multiple-value-list (find-symbol "CAR" 'common-lisp))) +;; XXX these will generate wrong results, NIL is not really a symbol +;; currently in the interpreter +(equal-eval '(nil :inherited) + '(multiple-value-list (find-symbol "NIL" 'common-lisp-user))) +(equal-eval '(nil :external) + '(multiple-value-list (find-symbol "NIL" 'common-lisp))) +(setq test (multiple-value-list + (find-symbol "NIL" (prog1 (make-package "JUST-TESTING" :use '()) + (intern "NIL" "JUST-TESTING"))))) +(equal-eval (read-from-string "(just-testing::nil :internal)") 'test) +(eq-eval t '(export 'just-testing::nil 'just-testing)) +(equal-eval '(just-testing:nil :external) + '(multiple-value-list (find-symbol "NIL" 'just-testing))) + +#+xedit (equal-eval '(nil nil) + '(multiple-value-list (find-symbol "NIL" "KEYWORD"))) +#| +;; optional result of previous form: +(equal-eval '(:nil :external) + '(multiple-value-list (find-symbol "NIL" "KEYWORD"))) +|# + + + +;; funcall - function +(eql-test 6 #'funcall #'+ 1 2 3) +(eql-test 1 #'funcall #'car '(1 2 3)) +(equal-test '(1 2 3) #'funcall #'list 1 2 3) + + + +;; TODO properly implement ``function'' + + + +;; functionp - function (predicate) +(eq-test nil #'functionp 'append) +(eq-test t #'functionp #'append) +(eq-test nil #'functionp '(lambda (x) (* x x))) +(eq-test t #'functionp #'(lambda (x) (* x x))) +(eq-test t #'functionp (symbol-function 'append)) +(eq-test nil #'functionp 1) +(eq-test nil #'functionp nil) + +;; gensym - function +(setq sym1 (gensym)) +(eq-test nil #'symbol-package sym1) +(setq sym1 (gensym 100)) +(setq sym2 (gensym 100)) +(eq-test nil #'eq sym1 sym2) +(eq-test nil #'equalp (gensym) (gensym)) + +;; get - accessor +(defun make-person (first-name last-name) + (let ((person (gensym "PERSON"))) + (setf (get person 'first-name) first-name) + (setf (get person 'last-name) last-name) + person)) +(eq-eval '*john* '(defvar *john* (make-person "John" "Dow"))) +(eq-eval '*sally* '(defvar *sally* (make-person "Sally" "Jones"))) +(equal-eval "John" '(get *john* 'first-name)) +(equal-eval "Jones" '(get *sally* 'last-name)) +(defun marry (man woman married-name) + (setf (get man 'wife) woman) + (setf (get woman 'husband) man) + (setf (get man 'last-name) married-name) + (setf (get woman 'last-name) married-name) + married-name) +(equal-eval "Dow-Jones" '(marry *john* *sally* "Dow-Jones")) +(equal-eval "Dow-Jones" '(get *john* 'last-name)) +(equal-eval "Sally" '(get (get *john* 'wife) 'first-name)) +(equal-eval `(wife ,*sally* last-name "Dow-Jones" first-name "John") + '(symbol-plist *john*)) +(eq-eval 'age + '(defmacro age (person &optional (default ''thirty-something)) + `(get ,person 'age ,default))) +(eq-eval 'thirty-something '(age *john*)) +(eql-eval 20 '(age *john* 20)) +(eql-eval 25 '(setf (age *john*) 25)) +(eql-eval 25 '(age *john*)) +(eql-eval 25 '(age *john* 20)) + +;; graphic-char-p - function +(eq-test t #'graphic-char-p #\a) +(eq-test t #'graphic-char-p #\Space) +(eq-test nil #'graphic-char-p #\Newline) +(eq-test nil #'graphic-char-p #\Tab) +(eq-test nil #'graphic-char-p #\Rubout) + +;; if - special operator +(eq-eval nil '(if nil t)) +(eq-eval nil '(if t nil t)) +(eq-eval nil '(if nil t nil)) +(eq-eval nil '(if nil t (if nil (if nil t) nil))) + +;; incf - macro +(setq n 1) +(eql-eval 2 '(incf n)) +(eql-eval 2 'n) +(setq n 2147483647) +(eql-eval 2147483648 '(incf n)) +(eql-eval 2147483648 'n) +(setq n 0) +(eql-eval 0.5d0 '(incf n 0.5d0)) +(eql-eval 0.5d0 'n) +(setq n 1) +(eql-eval 3/2 '(incf n 1/2)) +(eql-eval 3/2 'n) + +;; intersection - function +(setq list1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d") + list2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D")) +(equal-test '(1 1 4 b c) #'intersection list1 list2) +(equal-test '(1 1 4 b c "B") #'intersection list1 list2 :test 'equal) +(equal-test '(1 1 4 b c "A" "B" "C" "d") + #'intersection list1 list2 :test #'equalp) +(setq list1 (nintersection list1 list2)) +(equal-eval '(1 1 4 b c) 'list1) +(setq list1 (copy-list '((1 . 2) (2 . 3) (3 . 4) (4 . 5)))) +(setq list2 (copy-list '((1 . 3) (2 . 4) (3 . 6) (4 . 8)))) +(equal-test '((2 . 3) (3 . 4)) #'nintersection list1 list2 :key #'cdr) + +;; keywordp - function (predicate) +(eq-test t #'keywordp :test) +(eq-test nil #'keywordp 'test) +(eq-test nil #'keywordp '#:test) +(eq-test nil #'keywordp 1) +(eq-test nil #'keywordp #'keywordp) +(eq-test nil #'keywordp nil) + +;; last - function +(equal-test '(3) #'last '(1 2 3)) +(equal-test '(2 . 3) #'last '(1 2 . 3)) +(eq-test nil #'last nil) +(eql-test () #'last '(1 2 3) 0) +(setq a '(1 . 2)) +(eql-test 2 #'last a 0) +(eq-test a #'last a 1) +(eq-test a #'last a 2) +(eq-test t #'last t) +(equal-test #c(1 2) #'last #c(1 2)) +(equalp-test #(1 2 3) #'last #(1 2 3)) + +;; length - function +(eql-test 3 #'length "abc") +(eql-test 0 #'length nil) +(eql-test 1 #'length '(1 . 2)) +(eql-test 2 #'length #(1 2)) +(error-test #'length #c(1 2)) +(error-test #'length t) + +;; let - special operator +(eql-eval 2 '(setq a 1 b 2)) +(eql-eval 2 '(let ((a 2)) a)) +(eql-eval 1 'a) +(eql-eval 1 '(let ((a 3) (b a)) b)) +(eql-eval 2 'b) + +;; let* - special operator +(setq a 1 b 2) +(eql-eval 2 '(let* ((a 2)) a)) +(eql-eval 1 'a) +(eql-eval 3 '(let* ((a 3) (b a)) b)) +(eql-eval 2 'b) + +;; list - function +(equal-test '(1) #'list 1) +(equal-test '(3 4 a b 4) #'list 3 4 'a (car '(b . c)) (+ 6 -2)) +(eq-test nil #'list) + +;; list-length - function +(eql-test 4 #'list-length '(a b c d)) +(eql-test 3 #'list-length '(a (b c) d)) +(eql-test 0 #'list-length '()) +(eql-test 0 #'list-length nil) +(defun circular-list (&rest elements) + (let ((cycle (copy-list elements))) + (nconc cycle cycle))) +(eq-test nil #'list-length (circular-list 'a 'b)) +(eq-test nil #'list-length (circular-list 'a)) +(eql-test 0 #'list-length (circular-list)) + +;; list* - function +(eql-test 1 #'list* 1) +(equal-test '(a b c . d) #'list* 'a 'b 'c 'd) +(error-test #'list*) +(setq a '(1 2)) +(eq-test a #'list* a) + +;; listp - function (predicate) +(eq-test t #'listp nil) +(eq-test t #'listp '(1 . 2)) +(eq-test nil #'listp t) +(eq-test nil #'listp #'listp) +(eq-test nil #'listp #(1 2)) +(eq-test nil #'listp #c(1 2)) + +;; lower-case-p - function +(eq-test t #'lower-case-p #\a) +(eq-test nil #'lower-case-p #\1) +(eq-test nil #'lower-case-p #\Newline) +(error-test #'lower-case-p 1) + + + +;; TODO make-array (will be rewritten) + + + +;; make-list - function +(equal-test '(nil nil nil) #'make-list 3) +(equal-test '((1 2) (1 2)) #'make-list 2 :initial-element '(1 2)) +(eq-test nil #'make-list 0) +(eq-test nil #'make-list 0 :initial-element 1) + +;; make-package - function +(setq pack1 (make-package "PACKAGE-1" :nicknames '("PACK-1" "PACK1"))) +(setq pack2 (make-package "PACKAGE-2" :nicknames '("PACK-2" "PACK2") :use '("PACK1"))) +(equal-test (list pack2) #'package-used-by-list pack1) +(equal-test (list pack1) #'package-use-list pack2) +(eq-test pack1 #'symbol-package 'pack1::test) +(eq-test pack2 #'symbol-package 'pack2::test) + +;; make-string - function +(equal-test "55555" #'make-string 5 :initial-element #\5) +(equal-test "" #'make-string 0) +(error-test #'make-string 10 :initial-element t) +(error-test #'make-string 10 :initial-element nil) +(error-test #'make-string 10 :initial-element 1) +(eql-test 10 #'length (make-string 10)) + +;; make-symbol - function +(setq a "TEST") +;; This will fail +(eq-test nil #'eq (make-symbol a) (make-symbol a)) +(equal-test a #'symbol-name (make-symbol a)) +(setq temp-string "temp") +(setq temp-symbol (make-symbol temp-string)) +(equal-test temp-string #'symbol-name temp-symbol) +(equal-eval '(nil nil) '(multiple-value-list (find-symbol temp-string))) + +;; makunbound - function +(eq-eval 1 '(setf (symbol-value 'a) 1)) +(eq-test t #'boundp 'a) +(eql-eval 1 'a) +(eq-test 'a #'makunbound 'a) +(eq-test nil #'boundp 'a) +(error-test #'makunbound 1) + +;; mapc - function +(setq dummy nil) +(equal-test '(1 2 3 4) + #'mapc #'(lambda (&rest x) (setq dummy (append dummy x))) + '(1 2 3 4) + '(a b c d e) + '(x y z)) +(equal-eval '(1 a x 2 b y 3 c z) 'dummy) + +;; mapcan - function +(equal-test '(d 4 e 5) + #'mapcan #'(lambda (x y) (if (null x) nil (list x y))) + '(nil nil nil d e) + '(1 2 3 4 5 6)) +(equal-test '(1 3 4 5) + #'mapcan #'(lambda (x) (and (numberp x) (list x))) + '(a 1 b c 3 4 d 5)) + +;; mapcar - function +(equal-test '(1 2 3) #'mapcar #'car '((1 a) (2 b) (3 c))) +(equal-test '(3 4 2 5 6) #'mapcar #'abs '(3 -4 2 -5 -6)) +(equal-test '((a . 1) (b . 2) (c . 3)) #'mapcar #'cons '(a b c) '(1 2 3)) +(equal-test '((1 3 5)) #'mapcar #'list* '(1 2) '(3 4) '((5))) +(equal-test '((1 3 5) (2 4 6)) #'mapcar #'list* '(1 2) '(3 4) '((5) (6))) + +;; mapcon - function +(equal-test '(1 a 2 b (3) c) #'mapcon #'car '((1 a) (2 b) ((3) c))) +(equal-test '((1 2 3 4) (2 3 4) (3 4) (4)) #'mapcon #'list '(1 2 3 4)) + +;; mapl - function +(setq dummy nil) +(equal-test '(1 2 3 4) #'mapl #'(lambda (x) (push x dummy)) '(1 2 3 4)) +(equal-eval '((4) (3 4) (2 3 4) (1 2 3 4)) 'dummy) + +;; maplist - function +(equal-test '((1 2 3 4 1 2 1 2 3) (2 3 4 2 2 3)) + #'maplist #'append '(1 2 3 4) '(1 2) '(1 2 3)) +(equal-test '((foo a b c d) (foo b c d) (foo c d) (foo d)) + #'maplist #'(lambda (x) (cons 'foo x)) '(a b c d)) +(equal-test '(0 0 1 0 1 1 1) + #'maplist #'(lambda (x) (if (member (car x) (cdr x)) 0 1)) '(a b a c d b c)) + +;; member - function +(setq a '(1 2 3)) +(eq-test (cdr a) #'member 2 a) +(setq a '((1 . 2) (3 . 4))) +(eq-test (cdr a) #'member 2 a :test-not #'= :key #'cdr) +(eq-test nil #'member 'e '(a b c d)) +(eq-test nil #'member 1 nil) +(error-test #'member 2 '(1 . 2)) +(setq a '(a b nil c d)) +(eq-test (cddr a) #'member-if #'listp a) +(setq a '(a #\Space 5/3 foo)) +(eq-test (cddr a) #'member-if #'numberp a) +(setq a '(3 6 9 11 . 12)) +(eq-test (cdddr a) #'member-if-not #'zerop a :key #'(lambda (x) (mod x 3))) + +;; multiple-value-bind - macro +(equal-eval '(11 9) '(multiple-value-bind (f r) (floor 130 11) (list f r))) + +;; multiple-value-call - special operator +(equal-eval '(1 / 2 3 / / 2 0.5) + '(multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5))) +(eql-eval 10 '(multiple-value-call #'+ (floor 5 3) (floor 19 4))) + +;; multiple-value-list - macro +(equal-eval '(-1 1) '(multiple-value-list (floor -3 4))) +(eql-eval nil '(multiple-value-list (values))) +(equal-eval '(nil) '(multiple-value-list (values nil))) + +;; multiple-value-prog1 - special operator +(setq temp '(1 2 3)) +(equal-eval temp + '(multiple-value-list + (multiple-value-prog1 + (values-list temp) + (setq temp nil) + (values-list temp)))) + +;; multiple-value-setq - macro +(eql-eval 1 '(multiple-value-setq (quotient remainder) (truncate 3.5d0 2))) +(eql-eval 1 quotient) +(eql-eval 1.5d0 'remainder) +(eql-eval 1 '(multiple-value-setq (a b c) (values 1 2))) +(eql-eval 1 'a) +(eql-eval 2 'b) +(eq-eval nil 'c) +(eql-eval 4 '(multiple-value-setq (a b) (values 4 5 6))) +(eql-eval 4 'a) +(eql-eval 5 'b) +(setq a 1) +(eql-eval nil '(multiple-value-setq (a) (values))) +(eql-eval nil 'a) + +;; nconc - function +(eq-test nil #'nconc) +(setq x '(a b c)) +(setq y '(d e f)) +(equal-test '(a b c d e f) #'nconc x y) +(equal-eval '(a b c d e f) 'x) +(eq-test y #'cdddr x) +(equal-test '(1 . 2) #'nconc (list 1) 2) +(error-test #'nconc 1 2 3) +(equal-eval '(k l m) + '(setq foo (list 'a 'b 'c 'd 'e) + bar (list 'f 'g 'h 'i 'j) + baz (list 'k 'l 'm))) +(equal-test '(a b c d e f g h i j k l m) #'nconc foo bar baz) +(equal-eval '(a b c d e f g h i j k l m) 'foo) +(equal-eval (nthcdr 5 foo) 'bar) +(equal-eval (nthcdr 10 foo) 'baz) +(setq foo (list 'a 'b 'c 'd 'e) + bar (list 'f 'g 'h 'i 'j) + baz (list 'k 'l 'm)) +(equal-eval '(a b c d e f g h i j k l m) '(setq foo (nconc nil foo bar nil baz))) +(equal-eval '(a b c d e f g h i j k l m) 'foo) +(equal-eval (nthcdr 5 foo) 'bar) +(equal-eval (nthcdr 10 foo) 'baz) + +;; notany - function +(eql-test t #'notany #'> '(1 2 3 4) '(5 6 7 8) '(9 10 11 12)) +(eql-test t #'notany 'not-used ()) +(eql-test nil #'notany #'characterp #(1 2 3 4 5 #\6 7 8)) + +;; notevery - function +(eql-test nil #'notevery #'< '(1 2 3 4) '(5 6 7 8) '(9 10 11 12)) +(eql-test nil #'notevery 'not-used ()) +(eql-test t #'notevery #'numberp #(1 2 3 4 5 #\6 7 8)) + +;; nth - accessor (function) +(eql-test 'foo #'nth 0 '(foo bar baz)) +(eql-test 'bar #'nth 1 '(foo bar baz)) +(eq-test nil #'nth 3 '(foo bar baz)) +(error-test #'nth 0 #c(1 2)) +(error-test #'nth 0 #(1 2)) +(error-test #'nth 0 "test") + +;; nth-value - macro +(equal-eval 'a '(nth-value 0 (values 'a 'b))) +(equal-eval 'b '(nth-value 1 (values 'a 'b))) +(eq-eval nil '(nth-value 2 (values 'a 'b))) +(equal-eval '(3332987528 3332987528 t) + '(multiple-value-list + (let* ((x 83927472397238947423879243432432432) + (y 32423489732) + (a (nth-value 1 (floor x y))) + (b (mod x y))) + (values a b (= a b))))) + +;; nthcdr - function +(eq-test nil #'nthcdr 0 '()) +(eq-test nil #'nthcdr 3 '()) +(equal-test '(a b c) #'nthcdr 0 '(a b c)) +(equal-test '(c) #'nthcdr 2 '(a b c)) +(eq-test () #'nthcdr 4 '(a b c)) +(eql-test 1 #'nthcdr 1 '(0 . 1)) +(error-test #'nthcdr -1 '(1 2)) +(error-test #'nthcdr #\Null '(1 2)) +(error-test #'nthcdr 1 t) +(error-test #'nthcdr 1 #(1 2 3)) + +;; or - macro +(eq-eval nil '(or)) +(setq temp0 nil temp1 10 temp2 20 temp3 30) +(eql-eval 10 '(or temp0 temp1 (setq temp2 37))) +(eql-eval 20 'temp2) +(eql-eval 11 '(or (incf temp1) (incf temp2) (incf temp3))) +(eql-eval 11 'temp1) +(eql-eval 20 temp2) +(eql-eval 30 'temp3) +(eql-eval 11 '(or (values) temp1)) +(eql-eval 11 '(or (values temp1 temp2) temp3)) +(equal-eval '(11 20) '(multiple-value-list (or temp0 (values temp1 temp2)))) +(equal-eval '(20 30) + '(multiple-value-list (or (values temp0 temp1) (values temp2 temp3)))) + +;; packagep - function (predicate) +(eq-test t #'packagep *package*) +(eq-test nil #'packagep 10) +(eq-test t #'packagep (make-package "TEST-PACKAGE")) +(eq-test nil #'packagep 'keyword) +(eq-test t #'packagep (find-package 'keyword)) + +;; pairlis - function +#+xedit ;; order of result may vary +(progn + (equal-test '((one . 1) (two . 2) (three . 3) (four . 19)) + #'pairlis '(one two) '(1 2) '((three . 3) (four . 19))) + (setq keys '(1 2 3) + data '("one" "two" "three") + alist '((4 . "four"))) + (equal-test '((1 . "one") (2 . "two") (3 . "three")) + #'pairlis keys data) + (equal-test '((1 . "one") (2 . "two") (3 . "three") (4 . "four")) + #'pairlis keys data alist) + (equal-eval '(1 2 3) 'keys) + (equal-eval '("one" "two" "three") 'data) + (equal-eval '((4 . "four")) 'alist) + (eq-test nil #'pairlis 1 2) + (error-test #'pairlis '(1 2 3) '(4 5)) +) + +;; pop - macro +(setq stack '(a b c) test stack) +(eq-eval 'a '(pop stack)) +(eq-eval (cdr test) 'stack) +(setq llst '((1 2 3 4)) test (car llst)) +(eq-eval 1 '(pop (car llst))) +(eq-eval (cdr test) '(car llst)) +(error-eval '(pop 1)) +(error-eval '(pop nil)) +;; dotted list +(setq stack (cons 1 2)) +(eq-eval 1 '(pop stack)) +(error-eval '(pop stack)) +;; circular list +(setq stack '#1=(1 . #1#) *print-circle* t) +(eql-eval 1 '(pop stack)) +(eql-eval 1 '(pop stack)) +(eql-eval 1 '(pop (cdr stack))) + +;; position - function +(eql-test 4 #'position #\a "baobab" :from-end t) +(eql-test 2 #'position-if #'oddp '((1) (2) (3) (4)) :start 1 :key #'car) +(eq-test nil #'position 595 '()) +(eq-test 4 #'position-if-not #'integerp '(1 2 3 4 5.0)) +(eql-test 1 #'position (char-int #\1) "0123" :key #'char-int) + +;; prog - macro +(eq-eval nil '(prog () :error)) +(eq-eval 'ok + '(prog ((a 0)) + l1 (if (< a 10) (go l3) (go l2)) + (return 'failed) + l2 (return 'ok) + (return 'failed) + l3 (incf a) (go l1) + (return 'failed) + )) +(setq a 1) +(eq-eval '/= '(prog ((a 2) (b a)) (return (if (= a b) '= '/=)))) + +;; prog* - macro +(setq a 1) +(eq-eval nil '(prog* () :error)) +(eq-eval 'ok + '(prog* ((a 0) (b 0)) + l1 (if (< a 10) (go l3) (go l2)) + (return 'failed) + l2 (if (< b 10) (go l4) (return 'ok)) + (return 'failed) + l3 (incf a) (go l1) + (return 'failed) + l4 (incf b) (setq a 0) (go l1) + (return 'failed) + )) +(eq-eval '= '(prog* ((a 2) (b a)) (return (if (= a b) '= '/=)))) + +;; prog1 - macro +(setq temp 1) +(eql-eval 1 '(prog1 temp (incf temp) (eql-eval 2 'temp) temp)) +(eql-eval 2 'temp) +(eql-eval 2 '(prog1 temp (setq temp nil) (eql-eval nil 'temp) temp)) +(eq-eval nil 'temp) +(eql-eval 1 '(prog1 (values 1 2 3) 4)) +(setq temp (list 'a 'b 'c)) +(eq-eval 'a '(prog1 (car temp) (setf (car temp) 'alpha))) +(equal-eval '(alpha b c) 'temp) +(equal-eval '(1) + '(multiple-value-list (prog1 (values 1 2) (values 4 5)))) + +;; prog2 - macro +(setq temp 1) +(eql-eval 3 '(prog2 (incf temp) (incf temp) (incf temp))) +(eql-eval 4 'temp) +(eql-eval 2 '(prog2 1 (values 2 3 4) 5)) +(equal-eval '(3) + '(multiple-value-list (prog2 (values 1 2) (values 3 4) (values 5 6)))) + +;; progn - special operator +(eq-eval nil '(progn)) +(eql-eval 3 '(progn 1 2 3)) +(equal-eval '(1 2 3) '(multiple-value-list (progn (values 1 2 3)))) +(setq a 1) +(eq-eval 'here '(if a (progn (setq a nil) 'here) (progn (setq a t) 'there))) +(eq-eval nil 'a) + +;; progv - special operator +(makunbound '*x*) ;; make sure it is not bound +(setq *x* 1) +(eql-eval 2 '(progv '(*x*) '(2) *x*)) +(eql-eval 1 '*x*) +(equal-eval '(3 4) + '(let ((*x* 3)) (progv '(*x*) '(4) (list *x* (symbol-value '*x*))))) +(makunbound '*x*) +(defvar *x* 1) +(equal-eval '(4 4) + '(let ((*x* 3)) (progv '(*x*) '(4) (list *x* (symbol-value '*x*))))) +(equal-eval '(4 4) + '(multiple-value-list + (let ((*x* 3)) + (progv '(*x*) '(4) (values-list (list *x* (symbol-value '*x*))))))) + +;; push - macro +(setq llst '(nil)) +(equal-eval '(1) '(push 1 (car llst))) +(equal-eval '((1)) 'llst) +(equal-eval '(1 1) '(push 1 (car llst))) +(equal-eval '((1 1)) 'llst) +(setq x '(a (b c) d)) +(equal-eval '(5 B C) '(push 5 (cadr x))) +(equal-eval '(a (5 b c) d) 'x) + +;; pushnew - macro +(setq x '(a (b c) d)) +(equal-eval '(5 b c) '(pushnew 5 (cadr x))) +(equal-eval '(a (5 b c) d) 'x) +(equal-eval '(5 b c) '(pushnew 'b (cadr x))) +(equal-eval '(a (5 b c) d) 'x) +(setq lst '((1) (1 2) (1 2 3))) +(equal-eval '((2) (1) (1 2) (1 2 3)) '(pushnew '(2) lst)) +(equal-eval '((1) (2) (1) (1 2) (1 2 3)) '(pushnew '(1) lst)) +(equal-eval '((1) (2) (1) (1 2) (1 2 3)) '(pushnew '(1) lst :test 'equal)) +(equal-eval '((1) (2) (1) (1 2) (1 2 3)) '(pushnew '(1) lst :key #'car)) + +;; remove-duplicates - function +(equal-test "aBcD" #'remove-duplicates "aBcDAbCd" :test #'char-equal :from-end t) +(equal-test '(a c b d e) #'remove-duplicates '(a b c b d d e)) +(equal-test '(a b c d e) #'remove-duplicates '(a b c b d d e) :from-end t) +(equal-test '((bar #\%) (baz #\A)) + #'remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) + :test #'char-equal :key #'cadr) +(equal-test '((foo #\a) (bar #\%)) + #'remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) + :test #'char-equal :key #'cadr :from-end t) +(setq tester (list 0 1 2 3 4 5 6)) +(equal-test '(0 4 5 6) #'delete-duplicates tester :key #'oddp :start 1 :end 6) + +;; replace - function +(equal-test "abcd456hij" + #'replace (copy-seq "abcdefghij") "0123456789" :start1 4 :end1 7 :start2 4) +(setq lst (xseq "012345678")) +(equal-test "010123456" #'replace lst lst :start1 2 :start2 0) +(equal-eval "010123456" 'lst) + +;; rest - accessor +(equal-eval '(2) '(rest '(1 2))) +(eql-eval 2 '(rest '(1 . 2))) +(eq-eval nil '(rest '(1))) +(setq *cons* '(1 . 2)) +(equal-eval "two" '(setf (rest *cons*) "two")) +(equal-eval '(1 . "two") '*cons*) + +;; return - macro +(eq-eval nil '(block nil (return) 1)) +(eql-eval 1 '(block nil (return 1) 2)) +(equal-eval '(1 2) '(multiple-value-list (block nil (return (values 1 2)) 3))) +(eql-eval 1 '(block nil (block alpha (return 1) 2))) +(eql-eval 2 '(block alpha (block nil (return 1)) 2)) +(eql-eval 1 '(block nil (block nil (return 1) 2))) + +;; return-from - special operator +(eq-eval nil '(block alpha (return-from alpha) 1)) +(eql-eval 1 '(block alpha (return-from alpha 1) 2)) +(equal-eval '(1 2) + '(multiple-value-list (block alpha (return-from alpha (values 1 2)) 3))) +(eql-eval 2 + '(let ((a 0)) (dotimes (i 10) (incf a) (when (oddp i) (return))) a)) +(eq-eval 'temp '(defun temp (x) (if x (return-from temp ''dummy)) 44)) +(eql-eval 44 '(temp nil)) +(eq-eval 'dummy (temp t)) +(eql-eval 2 (block nil (unwind-protect (return-from nil 1) (return-from nil 2)))) +(error-eval '(funcall (block nil #'(lambda () (return-from nil))))) + +;; reverse - function +(setq str (xseq "abc") test str) +(equal-test "cba" #'reverse str) +(eq-eval test 'str) +(equal-eval "cba" '(setq test (nreverse str))) +(equal-eval "cba" 'test) +(setq l (list 1 2 3) test l) +(equal-eval '(3 2 1) '(setq test (nreverse l))) +(equal-eval '(3 2 1) 'test) + +;; rplac? - function +(eql-eval '*some-list* + '(defparameter *some-list* (list* 'one 'two 'three 'four))) +(equal-eval '(one two three . four) '*some-list*) +(equal-test '(uno two three . four) #'rplaca *some-list* 'uno) +(equal-eval '(uno two three . four) '*some-list*) +(equal-test '(three iv) #'rplacd (last *some-list*) (list 'iv)) +(equal-eval '(uno two three iv) '*some-list*) + +;; search - function +(eql-test 7 #'search "dog" "it's a dog's life") +(eql-test 2 #'search '(0 1) '(2 4 6 1 3 5) :key #'oddp) +(eql-test 8 #'search "foo" "foooobarfooooobarfo" :from-end t) +(eql-test 5 + #'search "123" + (mapcar #'(lambda (x) (+ x (char-code #\0))) + '(1 2 34 3 2 1 2 3 4 3 2 1)) :from-end t + :key #'(lambda (x) (if (integerp x) (code-char x) x))) +(eql-test 0 #'search "abc" "abcd" :from-end t) +(eql-test 3 #'search "bar" "foobar") + +;; set - function +(eql-eval 1 '(setf (symbol-value 'n) 1)) +(eql-test 2 #'set 'n 2) +(eql-test 2 #'symbol-value 'n) +(eql-eval 4 + '(let ((n 3)) + (setq n (+ n 1)) + (setf (symbol-value 'n) (* n 10)) + (set 'n (+ (symbol-value 'n) n)) + n)) +(eql-eval 44 'n) +(defvar *n* 2) +(eql-eval 80 + '(let ((*n* 3)) + (setq *n* (+ *n* 1)) + (setf (symbol-value '*n*) (* *n* 10)) + (set '*n* (+ (symbol-value '*n*) *n*)) + *n*)) +(eql-eval 2 '*n*) +(eq-eval '*even-count* '(defvar *even-count* 0)) +(eq-eval '*odd-count* '(defvar *odd-count* 0)) +(eql-eval 'tally-list + '(defun tally-list (list) + (dolist (element list) + (set (if (evenp element) '*even-count* '*odd-count*) + (+ element (if (evenp element) *even-count* *odd-count*)))))) +(eq-eval nil '(tally-list '(1 9 4 3 2 7))) +(eql-eval 6 '*even-count*) +(eql-eval 20 '*odd-count*) + +;; set-difference - function +(setq lst1 (list "A" "b" "C" "d") lst2 (list "a" "B" "C" "d")) +(equal-test '("A" "b" "C" "d") #'set-difference lst1 lst2) +(equal-test '("A" "b") #'set-difference lst1 lst2 :test 'equal) +(eq-test nil #'set-difference lst1 lst2 :test #'equalp) +(equal-test '("A" "b") #'nset-difference lst1 lst2 :test #'string=) +(setq lst1 '(("a" . "b") ("c" . "d") ("e" . "f")) + lst2 '(("c" . "a") ("e" . "b") ("d" . "a"))) +(equal-test '(("c" . "d") ("e" . "f")) + #'nset-difference lst1 lst2 :test #'string= :key #'cdr) +(equal-eval '(("c" . "a") ("e" . "b") ("d" . "a")) 'lst2) +(equal-test '("banana" "lemon" "rhubarb") + #'set-difference + '("strawberry" "chocolate" "banana" "lemon" "pistachio" "rhubarb") + '(#\c #\w) :test #'(lambda (s c) (find c s))) + +;; set-exclusive-or - function +(setq lst1 (list 1 "a" "b") lst2 (list 1 "A" "b")) +(equal-test '("a" "b" "A" "b") #'set-exclusive-or lst1 lst2) +(equal-test '("a" "A") #'set-exclusive-or lst1 lst2 :test #'equal) +(eq-test nil #'set-exclusive-or lst1 lst2 :test 'equalp) +(equal-test '("a" "b" "A" "b") #'nset-exclusive-or lst1 lst2) +(setq lst1 '(("a" . "b") ("c" . "d") ("e" . "f")) + lst2 '(("c" . "a") ("e" . "b") ("d" . "a"))) +(equal-test '(("c" . "d") ("e" . "f") ("c" . "a") ("d" . "a")) + #'nset-exclusive-or lst1 lst2 :test #'string= :key #'cdr) + +;; setf - macro +(setq x (cons 'a 'b) y (list 1 2 3)) +(equal-eval '(1 x 3) '(setf (car x) 'x (cadr y) (car x) (cdr x) y)) +(equal-eval '(x 1 x 3) 'x) +(equal-eval '(1 x 3) 'y) +(setq x (cons 'a 'b) y (list 1 2 3)) +(eq-eval nil '(psetf (car x) 'x (cadr y) (car x) (cdr x) y)) +(equal-eval '(x 1 a 3) 'x) +(equal-eval '(1 a 3) 'y) +(error-eval '(setf x)) +(error-eval '(psetf x)) + +;; setq - special form +(eql-eval 3 '(setq a 1 b 2 c 3)) +(eql-eval 1 'a) +(eql-eval 2 'b) +(eql-eval 3 'c) +(eql-eval 7 '(setq a (1+ b) b (1+ a) c (+ a b))) +(eql-eval 3 'a) +(eql-eval 4 'b) +(eql-eval 7 'c) +(eq-eval nil '(psetq a 1 b 2 c 3)) +(eql-eval 1 'a) +(eql-eval 2 'b) +(eql-eval 3 'c) +(equal-eval '(2 1) + '(multiple-value-list (let ((a 1) (b 2)) (psetq a b b a) (values a b)))) +(error-eval '(setq x)) +(error-eval '(setq x 1 y)) + +;; some - function +(eq-test t #'some #'= '(1 2 3 4 5) '(5 4 3 2 1)) + +;; sort - function +(setq tester (copy-seq "lkjashd")) +(equal-test "adhjkls" #'sort tester #'char-lessp) +(setq tester (list '(1 2 3) '(4 5 6) '(7 8 9))) +(equal-test '((7 8 9) (4 5 6) (1 2 3)) #'sort tester #'> :key #'car) +(setq tester (list 1 2 3 4 5 6 7 8 9 0)) +(equal-test '(1 3 5 7 9 2 4 6 8 0) + #'stable-sort tester #'(lambda (x y) (and (oddp x) (evenp y)))) +(equalp-test + #((("Kathy" "Chapman") "Editorial") + (("Dick" "Gabriel") "Objects") + (("Gregor" "Kiczales") "Objects") + (("Sandra" "Loosemore") "Compiler") + (("Larry" "Masinter") "Cleanup") + (("David" "Moon") "Objects") + (("Kent" "Pitman") "Conditions") + (("Dick" "Waters") "Iteration") + (("JonL" "White") "Iteration")) + #'sort (setq committee-data + (vector (list (list "JonL" "White") "Iteration") + (list (list "Dick" "Waters") "Iteration") + (list (list "Dick" "Gabriel") "Objects") + (list (list "Kent" "Pitman") "Conditions") + (list (list "Gregor" "Kiczales") "Objects") + (list (list "David" "Moon") "Objects") + (list (list "Kathy" "Chapman") "Editorial") + (list (list "Larry" "Masinter") "Cleanup") + (list (list "Sandra" "Loosemore") "Compiler"))) + #'string-lessp :key #'cadar) +(equalp-eval + #((("Larry" "Masinter") "Cleanup") + (("Sandra" "Loosemore") "Compiler") + (("Kent" "Pitman") "Conditions") + (("Kathy" "Chapman") "Editorial") + (("Dick" "Waters") "Iteration") + (("JonL" "White") "Iteration") + (("Dick" "Gabriel") "Objects") + (("Gregor" "Kiczales") "Objects") + (("David" "Moon") "Objects")) + '(setq committee-data + (stable-sort committee-data #'string-lessp :key #'cadr))) +(error-test #'sort #c(1 2)) + +;; string - function +(setq a "already a string") +(eq-test a #'string a) +(equal-test "ELM" #'string 'elm) +(equal-test "c" #'string #\c) + +;; string-* - function +(eq-test t #'string= "foo" "foo") +(eq-test nil #'string= "foo" "Foo") +(eq-test nil #'string= "foo" "bar") +(eq-test t #'string= "together" "frog" :start1 1 :end1 3 :start2 2) +(eq-test t #'string-equal "foo" "Foo") +(eq-test t #'string= "abcd" "01234abcd9012" :start2 5 :end2 9) +(eql-test 3 #'string< "aaaa" "aaab") +(eql-test 4 #'string>= "aaaaa" "aaaa") +(eql-test 5 #'string-not-greaterp "Abcde" "abcdE") +(eql-test 6 #'string-lessp "012AAAA789" "01aaab6" :start1 3 :end1 7 + :start2 2 :end2 6) +(eq-test nil #'string-not-equal "AAAA" "aaaA") +(error-test #'string= #(1 2 3) '(1 2 3)) +(eql-test 0 #'string< "abcd" "efg") +(eql-test 1 #'string< "abcd" "afg") +(eql-test 0 #'string/= "foo" "baar") +(eql-test nil #'string/= "foobar" "foobar") + +;; string-{upcase,downcase,capitalize} - function +(equal-test "ABCDE" #'string-upcase "abcde") +(equal-test "aBCDe" #'string-upcase "abcde" :start 1 :end 4) +(equal-test "aBCDe" #'nstring-upcase (xseq "abcde") :start 1 :end 4) +(equal-test "DR. LIVINGSTON, I PRESUME?" + #'string-upcase "Dr. Livingston, I presume?") +(equal-test "Dr. LIVINGSTON, I Presume?" + #'string-upcase "Dr. Livingston, I presume?" :start 4 :end 19) +(equal-test "Dr. LIVINGSTON, I Presume?" + #'nstring-upcase (xseq "Dr. Livingston, I presume?") :start 4 :end 19) +(equal-test "Dr. LiVINGston, I presume?" + #'string-upcase "Dr. Livingston, I presume?" :start 6 :end 10) +(equal-test "Dr. LiVINGston, I presume?" + #'nstring-upcase (xseq "Dr. Livingston, I presume?") :start 6 :end 10) +(equal-test "dr. livingston, i presume?" + #'string-downcase "Dr. Livingston, I presume?") +(equal-test "Dr. livingston, i Presume?" + #'string-downcase "Dr. Livingston, I Presume?" :start 1 :end 17) +(equal-test "Dr. livingston, i Presume?" + #'nstring-downcase (xseq "Dr. Livingston, I Presume?") :start 1 :end 17) +(equal-test "Elm 13c Arthur;Fig Don'T" + #'string-capitalize "elm 13c arthur;fig don't") +(equal-test "elm 13C Arthur;Fig Don't" + #'string-capitalize "elm 13c arthur;fig don't" :start 6 :end 21) +(equal-test "elm 13C Arthur;Fig Don't" + #'nstring-capitalize (xseq "elm 13c arthur;fig don't") :start 6 :end 21) +(equal-test " Hello " #'string-capitalize " hello ") +(equal-test " Hello " #'nstring-capitalize (xseq " hello ")) +(equal-test "Occluded Casements Forestall Inadvertent Defenestration" + #'string-capitalize "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION") +(equal-test "Don'T!" #'string-capitalize "DON'T!") +(equal-test "Pipe 13a, Foo16c" #'string-capitalize "pipe 13a, foo16c") +(setq str (copy-seq "0123ABCD890a")) +(equal-test "0123AbcD890a" #'nstring-downcase str :start 5 :end 7) +(equal-eval "0123AbcD890a" 'str) +(error-test #'nstring-capitalize 1) +(error-test #'string-capitalize "foobar" :start 4 :end 2) +(equal-test "foobar" #'string-capitalize "foobar" :start 0 :end 0) + +;; string-{,left-,right-}trim - function +(equal-test "kaaak" #'string-trim "abc" "abcaakaaakabcaaa") +#+xedit (equal-test "kaaak" #'nstring-trim "abc" "abcaakaaakabcaaa") +(equal-test "garbanzo beans" + #'string-trim '(#\Space #\Tab #\Newline) " garbanzo beans + ") +#+xedit (equal-test "garbanzo beans" + #'nstring-trim '(#\Space #\Tab #\Newline) " garbanzo beans + ") +(equal-test "three (silly) words" + #'string-trim " (*)" " ( *three (silly) words* ) ") +#+xedit (equal-test "three (silly) words" + #'nstring-trim " (*)" " ( *three (silly) words* ) ") +(equal-test "labcabcabc" #'string-left-trim "abc" "labcabcabc") +#+xedit (equal-test "labcabcabc" #'nstring-left-trim "abc" "labcabcabc") +(equal-test "three (silly) words* ) " + #'string-left-trim " (*)" " ( *three (silly) words* ) ") +#+xedit (equal-test "three (silly) words* ) " + #'nstring-left-trim " (*)" " ( *three (silly) words* ) ") +(equal-test " ( *three (silly) words" + #'string-right-trim " (*)" " ( *three (silly) words* ) ") +#+xedit (equal-test " ( *three (silly) words" + #'nstring-right-trim " (*)" " ( *three (silly) words* ) ") +(error-test #'string-trim 123 "123") +(error-test #'string-left-trim 123 "123") + +;; stringp - function (predicate) +(eq-test t #'stringp "abc") +(eq-test nil #'stringp #\a) +(eq-test nil #'stringp 1) +(eq-test nil #'stringp #(#\a #\b #\c)) + +;; subseq - accessor +(setq str (xseq "012345")) +(equal-test "2345" #'subseq str 2) +(equal-test "34" #'subseq str 3 5) +(equal-eval "abc" '(setf (subseq str 4) "abc")) +(equal-eval "0123ab" 'str) +(equal-eval "A" '(setf (subseq str 0 2) "A")) +(equal-eval "A123ab" 'str) + +;; subsetp - function +(setq cosmos '(1 "a" (1 2))) +(eq-test t #'subsetp '(1) cosmos) +(eq-test nil #'subsetp '((1 2)) cosmos) +(eq-test t #'subsetp '((1 2)) cosmos :test 'equal) +(eq-test t #'subsetp '(1 "A") cosmos :test #'equalp) +(eq-test nil #'subsetp '((1) (2)) '((1) (2))) +(eq-test t #'subsetp '((1) (2)) '((1) (2)) :key #'car) + +;; svref - function +;; XXX vectors will be reimplemented, just a test for the current implementation +(setq v (vector 1 2 'sirens)) +(eql-eval 1 '(svref v 0)) +(eql-eval 'sirens '(svref v 2)) +(eql-eval 'newcomer '(setf (svref v 1) 'newcomer)) +(equalp-eval #(1 newcomer sirens) 'v) + +;; symbol-name - function +(equal-test "TEMP" #'symbol-name 'temp) +(equal-test "START" #'symbol-name :start) +(error-test #'symbol-name 1) + +;; symbol-package - function +(eq-test (find-package "LISP") #'symbol-package 'car) +(eql-test *package* #'symbol-package 'bus) +(eq-test (find-package "KEYWORD") #'symbol-package :optional) +;; Gensyms are uninterned, so have no home package. +(eq-test nil #'symbol-package (gensym)) +(setq pk1 (make-package 'pk1)) +(intern "SAMPLE1" "PK1") +(eq-eval t '(export (find-symbol "SAMPLE1" "PK1") "PK1")) +(setq pk2 (make-package 'pk2 :use '(pk1))) +(equal-eval '(pk1:sample1 :inherited) + '(multiple-value-list (find-symbol "SAMPLE1" "PK2"))) +(eq-test pk1 #'symbol-package 'pk1::sample1) +(eq-test pk1 #'symbol-package 'pk2::sample1) +(eq-test pk1 #'symbol-package 'pk1::sample2) +(eq-test pk2 #'symbol-package 'pk2::sample2) +;; The next several forms create a scenario in which a symbol +;; is not really uninterned, but is "apparently uninterned", +;; and so SYMBOL-PACKAGE still returns NIL. +(setq s3 'pk1::sample3) +(eq-eval t '(import s3 'pk2)) +(eq-eval t '(unintern s3 'pk1)) ;; XXX unintern not yet implemented +(eq-test nil #'symbol-package s3) ;; fail due to unintern not implemented +(eq-test t #'eq s3 'pk2::sample3) + +;; symbol-plist - accessor +(setq sym (gensym)) +(eq-eval () '(symbol-plist sym)) +(eq-eval 'val1 '(setf (get sym 'prop1) 'val1)) +(equal-eval '(prop1 val1) '(symbol-plist sym)) +(eq-eval 'val2 '(setf (get sym 'prop2) 'val2)) +(equal-eval '(prop2 val2 prop1 val1) '(symbol-plist sym)) +(setq sym-plist (list 'prop3 'val3)) +(eq-eval sym-plist '(setf (symbol-plist sym) sym-plist)) +(eq-eval sym-plist '(symbol-plist sym)) + +;; symbol-value - accessor +(eql-eval 1 '(setf (symbol-value 'a) 1)) +(eql-eval 1 '(symbol-value 'a)) +;; SYMBOL-VALUE cannot see lexical variables. +(eql-eval 1 '(let ((a 2)) (symbol-value 'a))) +(eql-eval 1 '(let ((a 2)) (setq a 3) (symbol-value 'a))) + +#+xedit ;; incorrect... +(progn + ;; SYMBOL-VALUE can see dynamic variables. + ;; declare not yet implemented + (proclaim '(special a)) + (eql-eval 2 '(let ((a 2)) (symbol-value 'a))) + (eql-eval 1 'a) + (eql-eval 3 '(let ((a 2)) (setq a 3) (symbol-value 'a))) + (eql-eval 1 'a) + ;; declare not yet implement + (makunbound 'a) + (eql-eval 2 '(let ((a 2)) (setf (symbol-value 'a) 3) a)) + (eql-eval 3 'a) + (eql-eval 3 '(symbol-value 'a)) + ;; declare not yet implement + (makunbound 'a) + (equal-eval '(5 4) + '(multiple-value-list + (let ((a 4)) + + ;; declare not yet implemented + (defparameter a 3) + + (let ((b (symbol-value 'a))) + (setf (symbol-value 'a) 5) + (values a b))))) + (eql-eval 3 'a) +) +(eq-eval :any-keyword '(symbol-value :any-keyword)) +;; XXX these will fail +(eq-eval nil '(symbol-value 'nil)) +(eq-eval nil '(symbol-value '())) + +;; symbolp - function (predicate) +(eq-test t #'symbolp 'elephant) +(eq-test nil #'symbolp 12) +;; XXX these will fail +(eq-test t #'symbolp nil) +(eq-test t #'symbolp '()) +(eq-test t #'symbolp :test) +(eq-test nil #'symbolp "hello") + +;; remprop - function +(setq test (make-symbol "PSEUDO-PI")) +(eq-eval () '(symbol-plist test)) +(eq-eval t '(setf (get test 'constant) t)) +(eql-eval 3.14 '(setf (get test 'approximation) 3.14)) +(eql-eval 'noticeable '(setf (get test 'error-range) 'noticeable)) +(equal-eval '(error-range noticeable approximation 3.14 constant t) + '(symbol-plist test)) +(eq-eval nil '(setf (get test 'approximation) nil)) +(equal-eval '(error-range noticeable approximation nil constant t) + '(symbol-plist test)) +(eq-eval nil (get test 'approximation)) +(eq-test t #'remprop test 'approximation) +(eq-eval nil '(get test 'approximation)) +(equal-eval '(error-range noticeable constant t) '(symbol-plist test)) +(eq-test nil #'remprop test 'approximation) +(equal-eval '(error-range noticeable constant t) '(symbol-plist test)) +(eq-test t #'remprop test 'error-range) +(eql-eval 3 '(setf (get test 'approximation) 3)) +(equal-eval '(approximation 3 constant t) '(symbol-plist test)) + +;; throw - special operator +(equal-eval '(3 9) + '(multiple-value-list + (catch 'result + (setq i 0 j 0) + (loop (incf j 3) (incf i) + (if (= i 3) (throw 'result (values i j))))))) +(eql-eval 2 '(catch nil (unwind-protect (throw nil 1) (throw nil 2)))) + +;; XXX undefined consequences +(eql-eval 2 + '(catch 'a + (catch 'b + (unwind-protect (throw 'a 1) + (throw 'b 2))))) +(eq-eval :outer-catch + '(catch 'foo + (setq string (format nil "The inner catch returns ~s." + (catch 'foo + (unwind-protect (throw 'foo :first-throw) + (throw 'foo :second-throw))))) + :outer-catch)) +(equal-eval "The inner catch returns :SECOND-THROW." 'string) + +;; tree-equal - function +(setq tree1 '(1 (1 2)) + tree2 '(1 (1 2))) +(eq-test t #'tree-equal tree1 tree2) +(eq-test nil #'eql tree1 tree2) +(setq tree1 '('a ('b 'c)) + tree2 '('a ('b 'c))) +(eq-test t #'tree-equal tree1 tree2 :test 'eq) +(eq-test t #'tree-equal 1 1) +(eq-test nil #'tree-equal (list 1 2) (cons 1 2)) +(eq-test nil #'tree-equal 1 2) + +;; union - function +(equal-test '(b c f a d) #'union '(a b c) '(f a d)) +(equal-test '((y 6) (z 2) (x 4)) + #'union '((x 5) (y 6)) '((z 2) (x 4)) :key #'car) +(setq lst1 (list 1 2 '(1 2) "a" "b") + lst2 (list 2 3 '(2 3) "B" "C")) +(equal-test '(1 (1 2) "a" "b" 2 3 (2 3) "B" "C") #'nunion lst1 lst2) + +;; unless - macro +(eq-eval 'hello '(when t 'hello)) +(eq-eval nil '(unless t 'hello)) +(eq-eval nil (when nil 'hello)) +(eq-eval 'hello '(unless nil 'hello)) +(eq-eval nil (when t)) +(eql-eval nil '(unless nil)) +(setq test nil) +(equal-eval '(3 2 1) '(when t (push 1 test) (push 2 test) (push 3 test))) +(equal-eval '(3 2 1) 'test) +(setq test nil) +(eq-eval nil '(unless t (push 1 test) (push 2 test) (push 3 test))) +(eq-eval nil 'test) +(eq-eval nil '(when nil (push 1 test) (push 2 test) (push 3 test))) +(eq-eval nil 'test) +(equal-eval '(3 2 1) '(unless nil (push 1 test) (push 2 test) (push 3 test))) +(equal-eval '(3 2 1) 'test) +(equal-eval '((4) nil (5) nil 6 (6) 7 (7)) + '(let ((x 3)) + (list (when (oddp x) (incf x) (list x)) + (when (oddp x) (incf x) (list x)) + (unless (oddp x) (incf x) (list x)) + (unless (oddp x) (incf x) (list x)) + (if (oddp x) (incf x) (list x)) + (if (oddp x) (incf x) (list x)) + (if (not (oddp x)) (incf x) (list x)) + (if (not (oddp x)) (incf x) (list x))))) + +;; unwind-protect - special operator +(defun dummy-function (x) + (setq state 'running) + (unless (numberp x) (throw 'abort 'not-a-number)) + (setq state (1+ x))) +(eql-eval 2 '(catch 'abort (dummy-function 1))) +(eql-eval 2 'state) +(eq-eval 'not-a-number '(catch 'abort (dummy-function 'trash))) +(eq-eval 'running 'state) +(eq-eval 'not-a-number + '(catch 'abort (unwind-protect (dummy-function 'trash) + (setq state 'aborted)))) +(eq-eval 'aborted 'state) +(eql-eval 2 '(block nil (unwind-protect (return 1) (return 2)))) +;; XXX undefined consequences +(eql-eval 2 + '(block a + (block b + (unwind-protect (return-from a 1) + (return-from b 2))))) +(eql-eval 2 '(catch nil (unwind-protect (throw nil 1) (throw nil 2)))) +;; XXX undefined consequences +(eql-eval 2 + '(catch 'a (catch 'b (unwind-protect (throw 'a 1) (throw 'b 2))))) +(eq-eval ':outer-catch + '(catch 'foo + (setq string + (format nil "The inner catch returns ~s." + (catch 'foo + (unwind-protect (throw 'foo :first-throw) + (throw 'foo :second-throw))))) + :outer-catch)) +(equal-eval "The inner catch returns :SECOND-THROW." 'string) +(eql-eval 10 + '(catch 'a + (catch 'b + (unwind-protect (1+ (catch 'a (throw 'b 1))) + (throw 'a 10))))) +;; XXX undefined consequences +(eql-eval 4 + '(catch 'foo + (catch 'bar + (unwind-protect (throw 'foo 3) + (throw 'bar 4) + (print 'xxx))))) +(eql-eval 4 + '(catch 'bar + (catch 'foo + (unwind-protect (throw 'foo 3) + (throw 'bar 4) + (print 'xxx))))) +(eql-eval 5 + '(block nil + (let ((x 5)) + (unwind-protect (return) + (return x))))) + +;; upper-case-p - function +(eq-test t #'upper-case-p #\A) +(eq-test nil #'upper-case-p #\a) +(eq-test nil #'upper-case-p #\5) +(error-test #'upper-case-p 1) + +;; values - accessor +(eq-eval () '(multiple-value-list (values))) +(equal-eval '(1) '(multiple-value-list (values 1))) +(equal-eval '(1 2) '(multiple-value-list (values 1 2))) +(equal-eval '(1 2 3) '(multiple-value-list (values 1 2 3))) +(equal-eval '(1 4 5) '(multiple-value-list (values (values 1 2 3) 4 5))) + +;; values-list - function +(eq-eval nil '(multiple-value-list (values-list nil))) +(equal-eval '(1) '(multiple-value-list (values-list '(1)))) +(equal-eval '(1 2) '(multiple-value-list (values-list '(1 2)))) +(equal-eval '(1 2 3) '(multiple-value-list (values-list '(1 2 3)))) diff --git a/lisp/test/math.lsp b/lisp/test/math.lsp new file mode 100644 index 0000000..162f73f --- /dev/null +++ b/lisp/test/math.lsp @@ -0,0 +1,982 @@ +;; +;; Copyright (c) 2002 by The XFree86 Project, Inc. +;; +;; Permission is hereby granted, free of charge, to any person obtaining a +;; copy of this software and associated documentation files (the "Software"), +;; to deal in the Software without restriction, including without limitation +;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;; and/or sell copies of the Software, and to permit persons to whom the +;; Software is furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in +;; all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;; THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF +;; OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. +;; +;; Except as contained in this notice, the name of the XFree86 Project shall +;; not be used in advertising or otherwise to promote the sale, use or other +;; dealings in this Software without prior written authorization from the +;; XFree86 Project. +;; +;; Author: Paulo César Pereira de Andrade +;; +;; +;; $XFree86: xc/programs/xedit/lisp/test/math.lsp,v 1.5 2003/01/30 02:46:26 paulo Exp $ +;; + +;; basic math tests +;; This is far from a good regression test, but in the current stage of +;; the interpreter, this is good enough to make sure it is not "so" +;; broken. But note that this does not test all cases where there is +;; change in the type of a numeric object. + +(setq *default-float-format* 'double-float) + +;; floating point results may differ from implementation to implementation (?!) + +(defun test (expect function &rest arguments &aux result (error t)) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + (if error + (format t "ERROR: (~A~{ ~A~})~%" function arguments) + ;; Use eql to make sure result and expect have the same type + (or (eql result expect) +#-xedit ;; hack... + (or + (and + (floatp result) + (floatp expect) + (< (abs (- (abs result) (abs expect))) + 0.00000000000001d0) + ) + (format t "(~A~{ ~A~}) => should be ~A not ~A~%" + function arguments expect result + ) + ) +#+xedit (format t "(~A~{ ~A~}) => should be ~A not ~A~%" + function arguments expect result + ) + ) + ) +) + +(defun div-test (quotient remainder function &rest arguments + &aux quo rem (error t)) + (ignore-errors + (multiple-value-setq (quo rem) (apply function arguments)) + (setq error nil) + ) + (if error + (format t "ERROR: (~A~{ ~A~})~%" function arguments) + (or (and (eql quotient quo) (eql remainder rem)) +#-xedit ;; hack + (or + (or + (eql quotient quo) + (and + (floatp quotient) + (floatp quo) + (< (abs (- (abs quotient) (abs quo))) + 0.00000000000001d0) + ) + ) + (or + (eql remainder rem) + (and + (floatp remainder) + (floatp rem) + (< (abs (- (abs remainder) (abs rem))) + 0.00000000000001d0) + ) + ) + (format t "(~A~{ ~A~}) => should be ~A; ~A not ~A; ~A~%" + function arguments quotient remainder quo rem + ) + ) +#+xedit (format t "(~A~{ ~A~}) => should be ~A; ~A not ~A; ~A~%" + function arguments quotient remainder quo rem + ) + ) + ) +) + +(defun bool-test (expect function &rest arguments &aux result (error t)) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + (if error + (format t "ERROR: (~A~{ ~A~})~%" function arguments) + (or (eq result expect) + (format t "(~A~{ ~A~}) => should be ~A not ~A~%" + function arguments expect result + ) + ) + ) +) + +(defun error-test (function &rest arguments &aux result (error t)) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil)) + (unless error + (format t "ERROR: no error for (~A~{ ~A}), result was ~A~%" + function arguments result))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixnum fixnum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 0 #'+) +(test 5 #'+ 5) +(test -2 #'+ -2) +(test 3 #'+ 2 1) +(test 134217728 #'+ 134217727 1) +(test -134217729 #'+ -134217728 -1) +(test 2147483648 #'+ 2147483647 1) +(test -2147483649 #'+ -2147483648 -1) +(test -5 #'- 5) +(test 6 #'- -6) +(test 1 #'- 2 1) +(test 134217728 #'- 134217727 -1) +(test -2147483649 #'- -2147483648 1) +(test 4294967295 #'- 2147483647 -2147483648) +(test 1 #'*) +(test 4 #'* 4) +(test -5 #'* -5) +(test 6 #'* 2 3) +(test 2147483648 #'* 65536 32768) +(test 2147418112 #'* 65536 32767) +(test 134217728 #'* 65536 2048) +(test -134217728 #'* 65536 -2048) +(test 1/3 #'/ 3) +(test -1/4 #'/ -4) +(test 1/3 #'/ 10 30) +(test -1/2 #'/ -5 10) +(test -4 #'/ 20 -5) +(test 431432412345/32 #'/ 431432412345 32) +(test -2147483647/2147483648 #'/ 2147483647 -2147483648) +(test -1 #'/ 2147483648 -2147483648) +(test 2147483648 #'/ -2147483648 -1) +(test -1/2147483648 #'/ 1 -2147483648) +(test 1 #'min 2 3 4 1 5) +(test 7 #'max 0 -2 7 6 3) +(test -2147483648 #'min -2147483648 2147483647) +(test 2147483647 #'max -2147483648 2147483647) +(bool-test t #'< 1 2) +(bool-test nil #'< 2 2) +(bool-test nil #'< 4 3) +(bool-test t #'< -2147483648 -1) +(bool-test t #'< -2147483648 2147483648) +(bool-test t #'<= 3 3) +(bool-test nil #'<= 3 2) +(bool-test t #'<= 3 7) +(bool-test t #'<= -2147483648 2147483648) +(bool-test t #'= 1 1) +(bool-test nil #'= 1 -1) +(bool-test t #'= -2147483648 -2147483648) +(bool-test t #'>= 4 3) +(bool-test t #'>= 5 5) +(bool-test nil #'>= 4 9) +(bool-test t #'>= 2147483647 -2147483648) +(bool-test t #'> 7 5) +(bool-test nil #'> 20 20) +(bool-test nil #'> 19 31) +(bool-test nil #'> 2147483647 2147483648) +(bool-test nil #'> -2147483648 2147483647) +(bool-test nil #'/= 2147483647 2147483647) +(bool-test t #'/= 2147483647 -2147483648) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixnum bignum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 4123412341238575768576858308380 #'+ + 431412 4123412341238575768576857876968) +(test -653653534554686349560628211 #'- + 4231423 653653534554686349564859634) +(test 17952112630025927929 #'* 4342423 4134123421423) +(test 412341/766687896595678 #'/ 412341 766687896595678) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixnum flonum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 566594.4123d0 #'+ 43141 523453.4123d0) +(test -2.106249523586876d9 #'+ -2147483647 41234123.413124d0) +(test -6530250.653d0 #'- 4314 6534564.653d0) +(test -358687.653d0 #'- -324123 34564.653d0) +(test 3.26338916904d67 #'* 431234 756756d56) +(test 5.731169192902366d-50 #'/ 3 5234534d43) +(bool-test t #'< 423421 646454d0) +(bool-test t #'= 43242113 43242113d0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixnum fixratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 38654705646/17 #'+ 2147483647 2147483647/17) +(test -2146748499/17 #'+ 43244 -2147483647/17) +(test 17633127/4232 #'- 4321 653345/4232) +(test 28227714415090/4323 #'* 4312442 6545645/4323) +(test 639030/1441 #'* 42 15215/1441) +(test 924444112/547 #'/ 3432342 1641/808) +(bool-test t #'> 41342 42423/32) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixnum bigratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 134681902103055335/31231131234 #'+ 4312423 53453535353/31231131234) +(test 134681795195984629/31231131234 #'- 4312423 53453535353/31231131234) +(test 230514255287590319/31231131234 #'* 4312423 53453535353/31231131234) +(test 134681848649519982/53453535353 #'/ 4312423 53453535353/31231131234) +(bool-test t #'> 4312423 53453535353/31231131234) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bignum fixnum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 4123412341234124068 #'+ 4123412341234123412 656) +(test 2147483647 #'+ 2147483648 -1) +(test 2147483648 #'- 2147483647 -1) +(test 3245393337480 #'* 4242344232 765) +(test 1414114744/255 #'/ 4242344232 765) +(bool-test nil #'< 2147483648 1) +(bool-test t #'> 2147483648 -2147483648) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bignum flonum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 5.452523543454353d15 #'+ 5452523543454353 423d-6) +(test -3.41423d205 #'- 54235423452345424443423 341423d200) +(test 2.7061221650759596d89 #'* 413423412341231232 6.545643242d71) +(test 9.744908405310087d-29 #'/ 41341234214 4242342d32) +(bool-test t #'< 4314123412312341234123 4234242d46) +(bool-test nil #'> 42342342142142421412341242 423423.432423d51) +(bool-test t #'= 100000000000000000000 1d20) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bignum fixratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 3027180466416641662/7 #'+ 432454352345234523 1/7) +(test 4294967295/2 #'- 2147483648 1/2) +(test 14113747078041141/152263 #'* 42341241234123423 1/456789) +(test 475355357536664/19 #'* 43214123412424 11/19) +(test 143960192608 #'/ 4234123312 1/34) +(test 15032385536/5 #'/ 2147483648 5/7) +(bool-test nil #'< 4123412341234123 423424/23) +(bool-test nil #'= 2147483648 1/3) +(bool-test t #'> 2147483648 1/3) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bignum bigratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test -493153721444554600746963362777609/11404707804137 + #'+ -43241241241241234234 18178448448449/11404707804137) +(test 22573725350444837506376255369215081106984960/431241324242143434377 + #'- 52345923457394857234895 455/431241324242143434377) +(test 355905909219316970540364021939287762325439304380984344811607132990/14374707710807 + #'* 45523452345234790345923405723902389345782390 23454234524234523623623/43124123132421) +(test -853356237922877963618542794532291751029677352/21566206170617061706171 + #'/ 4131234123412342 -43132412341234123412342/413124123412312234123412312312) +(bool-test nil #'< 9482384762389461234892 463124869123897/43124123456678) +(bool-test t #'/= 4689123469123846123843 4123894623894612/211) +(bool-test t #'> 90437849234701234891203 4234123423/37) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; flonum fixnum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 4.3291328479d86 #'+ 43291328479d76 431243) +(test 4.123123123432d58 #'- 4123123123432d46 2147483647) +(test 4.1974800714094d109 #'* 970874791d96 43234) +(test -1.0004838618250252d55 #'/ -432423.432d56 4322143) +(bool-test nil #'< 4324932.342d5 4321421) +(bool-test t #'> 2147483648d0 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; flonum bignum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 4.3124325345d62 #'+ 4312432.5345d56 431241234901234791023479023) +(test 4.123123443242d39 #'- 41231234.43242d32 -10947390284720389) +(test 9.81681448753991d48 #'* 42342.89d27 231840917980324712) +(test 6.837110051466236d49 #'/ -64832d57 -948236894126) +(bool-test nil #'< 7589079203d56 43214124124312) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; flonum flonum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 4.12685643412d7 #'+ 34442.3412d0 41234122d0) +(test -4.23432d84 #'- -45523453d56 423432d79) +(test 2.0000000000000004d0 #'* 1.4142135623730951d0 1.4142135623730951d0) +(test -1.414213562373095d0 #'/ -2d0 1.4142135623730951d0) +(test 0.7071067811865476d0 #'/ 1.4142135623730951d0 2d0) +(bool-test nil #'< 43124123d56 4231412d43) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; flonum fixratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 3.41412d61 #'+ 341412d56 3/652) +(test 4.312443d72 #'- 43124.43d68 42421/5678) +(test -4.32112300201218d73 #'* 4321123d67 -2147483648/2147483647) +(test 3.388443859138533d58 #'/ 432412d54 13744/1077) +(bool-test t #'> 423194237d43 4231412/23) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; flonum bigratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 4.378904431d62 #'+ 4378904.431d56 49230471923047129/32412341234126) +(test 0d0 #'- 1.7320508075688772d0 3900231685776981/2251799813685248) +(test 5.000000000000001d0 #'* 2.23606797749979d0 629397181890197/281474976710656) +(test 7.000000000000001d0 #'/ 2.6457513110645907d0 1125899906842624/2978851154656373) +(bool-test nil #'< 790412390412d45 1005712007432/10518078881) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixratio fixnum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 23502480199/57 #'+ 1/57 412324214) +(test -1608505/39 #'- 11/39 41244) +(test 241844976595/3121 #'* 45245/3121 5345231) +(test 4231/30211050 #'/ 4231/67890 445) +(bool-test nil #'< 43123/12 -3432) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixratio bignum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 290071443963580821646/4115 #'+ -14119/4115 70491237901234711) +(test 92654360215843653827434431256/1237 #'- 423412/1237 -74902473901247901234789012) +(test 139081825032265225396/111 #'* 13/777 74890213478912044444) +(test -22/19000187487170108051697772680759 #'/ -176/31 4903274190237447239147812304712) +(bool-test t #'< 7094123/312 423412429047) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixratio flonum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 3756.777956289953d0 #'+ 41290/11 3.141592653589793d0) +(test 3750.494770982774d0 #'- 41290/11 3.141592653589793d0) +(test 11792.396424247505d0 #'* 41290/11 3.141592653589793d0) +(test 1194.8195636844289d0 #'/ 41290/11 3.141592653589793d0) +(bool-test nil #'< 41290/11 3.141592653589793d0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixratio fixratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test -2/2147483647 #'+ 2147483646/2147483647 -2147483648/2147483647) +(test 4611686015206162432/2305843005992468481 #'+ 2147483648/2147483646 2147483648/2147483647) +(test 114/91 #'+ 5/7 7/13) +(test 2 #'- 2147483646/2147483647 -2147483648/2147483647) +(test -6442450939/4611686009837453315 #'- 2147483646/2147483647 2147483647/2147483645) +(test 214/231 #'- 5/7 -7/33) +(test 183092240452/408559 #'* '432421/3217 423412/127) +(test 1057751/7345 #'* 34121/65 31/113) +(test -93866791/102381559 #'/ 143747/107 -956837/653) +(test 117/517 #'/ 13/33 47/27) +(bool-test nil #'< 5/3 7/9) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fixratio bigratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 1211321073398067249731082729214954013/1099249926163926018396018404101914 + #'+ 23141/21 572903572390457239/52345234579234572304572304957234) +(test -1210401943424090457832980748892408320175/1099249926163926018396018404101914 + #'+ -23123441/21 572903572390457239/52345234579234572304572304957234) +(test -130565585970579643613431728982140/1297324236427391 + #'- 6/83 1573079349043128237436315709694/15630412487077) +(test 119377824848653/98027 #'* 4123/61 28954117111/1607) +(test -533081148/1126543487854337661125 #'/ 4132412/125 -9012347902834701289/129) +(bool-test nil #'< 4132412/125 -9012347902834701289/129) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bigratio fixnum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 48668779872364438/8438103123 #'+ 49032749012471920/8438103123 -43134) +(test 49396718152579402/8438103123 #'- 49032749012471920/8438103123 -43134) +(test -704992865301321265760/2812701041 #'* 49032749012471920/8438103123 -43134) +(test -24516374506235960/181984570053741 #'/ 49032749012471920/8438103123 -43134) +(bool-test t #'> 49032749012471920/8438103123 -43134) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bigratio bignum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 22765322736543569109219273030163417097453878379283263605274270/46382946123894712341 + #'+ 4692318468912374612389461278/46382946123894712341 490812348912346238794612389461238961238912) +(test -22765322736543569109219273030163417097453878379283263605274270/46382946123894712341 + #'- -4692318468912374612389461278/46382946123894712341 490812348912346238794612389461238961238912) +(test -2303047849571666696101160700266058250647016644840659232609643130849536/46382946123894712341 + #'* 4692318468912374612389461278/46382946123894712341 -490812348912346238794612389461238961238912) +(test 2346159234456187306194730639/11382661368271784554609636515081706202567704733454325607906496 + #'/ -4692318468912374612389461278/46382946123894712341 -490812348912346238794612389461238961238912) +(bool-test t #'< 4692318468912374612389461278/46382946123894712341 490812348912346238794612389461238961238912) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bigratio flonum +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 63.2771680782255d0 #'+ 31.63858403911275d0 4452734852783697/140737488355328) +(test 0d0 #'+ -31.63858403911275d0 4452734852783697/140737488355328) +(test -1001.0000000000001d0 #'* -31.63858403911275d0 4452734852783697/140737488355328) +(test 1d0 #'/ -31.63858403911275d0 -4452734852783697/140737488355328) +(bool-test nil #'< -31.63858403911275d0 -4452734852783697/140737488355328) +(bool-test nil #'> -31.63858403911275d0 -4452734852783697/140737488355328) +(bool-test nil #'/= -31.63858403911275d0 -4452734852783697/140737488355328) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bigratio fixratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 0 #'+ 2147483648/2147483647 -2147483648/2147483647) +(test 3230093924913437/413416372043776 #'+ 45705840067699/8796093022208 123/47) +(test 4294967296/2147483647 #'- 2147483648/2147483647 -2147483648/2147483647) +(test 1066255041450269/413416372043776 #'- 45705840067699/8796093022208 123/47) +(test -5621818328326977/413416372043776 #'* -45705840067699/8796093022208 123/47) +(test -2148174483181853/1081919441731584 #'/ 45705840067699/8796093022208 -123/47) +(bool-test t #'> 45705840067699/8796093022208 123/47) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bigratio bigratio +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 2679495973598190955776211861634126560767052764822779809414184089582/140710542183009389719255843429922029722593 + #'+ 649812364891236481923461238946128/34124123 -7489023423142/4123491823746192384761238946123891) +(test 2679495973598190955776211861634126560767052765333892522296541398514/140710542183009389719255843429922029722593 + #'- 649812364891236481923461238946128/34124123 -7489023423142/4123491823746192384761238946123891) +(test -4866460021317766216371472892133283923086494176/140710542183009389719255843429922029722593 + #'* 649812364891236481923461238946128/34124123 -7489023423142/4123491823746192384761238946123891) +(test -1339747986799095477888105930817063280383526382539168082927681372024/127778178220589327233 + #'/ 649812364891236481923461238946128/34124123 -7489023423142/4123491823746192384761238946123891) +(bool-test t #'> 649812364891236481923461238946128/34124123 -7489023423142/4123491823746192384761238946123891) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; complex real +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test #c(2147483648 -1) #'+ #c(1 -1) 2147483647) +(test #c(2.147483648d9 -1) #'+ #c(2147483647 -1) 1d0) +(test #c(129642370237029633787/3 0.25d0) #'- #c(-11/3 0.25d0) -43214123412343211266) +(test #c(23470/21 4.333333333333334d0) #'* #c(2347/7 1.3d0) 10/3) +(test #c(134217728/11 67108864/11) #'* #c(65536 32768) 2048/11) +(test #c(1.3133333333333332d0 82304) #'/ #c(1.97d0 123456) 3/2) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; real complex +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test #c(80/7 7/13) #'+ 3/7 #c(11 7/13)) +(test #c(1.2345d47 -1) #'+ 12345d43 #c(-2147483648 -1)) +(test #c(-2147483649 2147483647) #'+ -2147483648 #c(-1 2147483647)) +(test #c(41/15 1.23456d68) #'- #c(7/5 1234.56d65) -4/3) +(test #c(-41/19 2147483648) #'* #c(41/19 -2147483648) -1) +(test #c(-88046829568/40802189293 2.147483649d41) #'* #c(41/19 -2147483648d32) -2147483648/2147483647) +(test #c(-5.0691244239631335d0 1.3911008563333336d16) + #'/ #c(-11/7 4312412654633334) 0.31d0) +(bool-test t #'= #c(1 0.0) 1) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; complex complex +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test #c(-16.0d0 -4.0d0) #'+ #c(-16.0d0 -4.0d0)) +(test #c(0d0 1d0) #'- #c(0d0 -1d0)) +(test #c(1d0 3d0) #'- #c(-1d0 -3d0)) +(test #c(-16.0d0 -4.0d0) #'* #c(-16.0d0 -4.0d0)) +(test #c(-0.058823529411764705d0 0.014705882352941176d0) #'/ #c(-16d0 -4d0)) +(test #c(1.94d0 301868863889/7) #'+ #c(3/5 5/7) #c(1.34d0 43124123412)) +(test #c(8641975242/7 -3.4596d0) #'- #c(1234567890 0.0004d0) #c(-12/7 3.46d0)) +(test #c(2944.315858312371d0 5.59002d13) #'* #c(-11/7 -1234d9) #c(-45.3d0 5/2147483647)) +(test #c(1.9635384272224412d-8 -0.33333333317811176d0) + #'/ #c(2147483647/3 -0.5d0) #c(128 2147483648.0d0)) +(test #c(8.154945137073864d11 2.621232365490813d12) + #'/ #c(-1.3d0 4312412654633) #c(3/2 7/15)) +(test #c(0.003674737027278924d0 -257.6948748113586d0) + #'/ #c(1.5d0 -432412) #c(1678 -567/31313)) +(bool-test t #'= #c(1 2d0) #c(1 2)) +(bool-test nil #'/= #c(1 2) #c(1d0 2d0)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; abs +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 2147483648 #'abs -2147483648) +(test 2147483647 #'abs -2147483647) +(test 2147483647 #'abs 2147483647) +(test 1 #'abs 1) +(test 5/7 #'abs -5/7) +(test 2147483648/2147483647 #'abs -2147483648/2147483647) +(test 3.12d0 #'abs -3.12d0) +(test 4312412341234124124123412 #'abs 4312412341234124124123412) +(test 4312412341234124124123412 #'abs -4312412341234124124123412) +(test 1.0 #'abs #c(1 0.0)) +(test 11.40175425099138d0 #'abs #c(-11 3d0)) +(test 4.47213595499958d0 #'abs #c(-4 -2)) +(test 1.0 #'abs #c(0.0 -1.0)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; sqrt +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 3.4641016151377544d0 #'sqrt 12) +(test #c(0 12) #'sqrt -144) +(test 6.429728792199102d18 #'sqrt 41341412341234123412490123470912347210) +(test 41341412341234123412490123470912347210 + #'sqrt 1709112374367945085349927261774254951456404621200206927501652414831594784100) +(test 46340.95001184158d0 #'sqrt 2147483648) +(test 0.7071067811865476d0 #'sqrt 0.5d0) +(test 0 #'sqrt 0) +(test 0d0 #'sqrt 0d0) +(test 111.1106106544285d0 #'sqrt 12345.5678d0) +(test #c(0 11.119982014373944d0) #'sqrt -123.654d0) +(test 3/8 #'sqrt 9/64) +(test #c(0 1.1832159566199232d0) #'sqrt -7/5) +(test 514.7536007118473d0 #'sqrt 821974900428408092/3102128401119) +(test 413412341293461238946192384612893/314212341412341246128361289 + #'sqrt 170909763933741276657131032282211169869649489782500833989461829449/98729395495825697643724477479624921705328808513741521) +;; check for overflow +(error-test #'sqrt 402387260077093773543702433923003985719374864210714632543799910429938512398629020592044208486969404800479988610197196058631666872994808558901323829669944590997424504087073759918823627727188732519779505950995276120874975462497043601418278094646496291056393887437886487337119181045825783647849977012476632889835955735432513185323958463075557409114262417474349347553428646576611667797396668820291207379143853719588249808126867838374559731746136085379534524221586593201928090878297308431392844403281231558611036976801357304216168747609675871348312025478589320767169132448426236131412508780208000261683151027341827977704784635868170164365024153691398281264810213092761244896359928705114964975419909342221566832572080821333186116811553615836546984046708975602900950537616475847728421889679646244945160765353408198901385442487984959953319101723355556602139450399736280750137837615307127761926849034352625200015888535147331611702103968175921510907788019393178114194545257223865541461062892187960223838971476088506276862967146674697562911234082439208160153780889893964518263243671616762179168909779911903754031274622289988005195444414282012187361745992642956581746628302955570299024324153181617210465832036786906117260158783520751516284225540265170483304226143974286933061690897968482590125458327168226458066526769958652682272807075781391858178889652208164348344825993266043367660176999612831860788386150279465955131156552036093988180612138558600301435694527224206344631797460594682573103790084024432438465657245014402821885252470935190620929023136493273497565513958720559654228749774011413346962715422845862377387538230483865688976461927383814900140767310446640259899490222221765904339901886018566526485061799702356193897017860040811889729918311021171229845901641921068884387121855646124960798722908519296819372388642614839657382291123125024186649353143970137428531926649875337218940694281434118520158014123344828015051399694290153483077644569099073152433278288269864602789864321139083506217095002597389863554277196742822248757586765752344220207573630569498825087968928162753848863396909959826280956121450994871701244516461260379029309120889086942028510640182154399457156805941872748998094254742173582401063677404595741785160829230135358081840096996372524230560855903700624271243416909004153690105933983835777939410970027753472000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; mod +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 5 #'mod 5 9) +(test 4 #'mod -5 9) +(test -4 #'mod 5 -9) +(test -5 #'mod -5 -9) +(test 2147483646 #'mod -2147483648 2147483647) +(test -1 #'mod -2147483648 -2147483647) +(test 1 #'mod 2147483648 2147483647) +(test 0 #'mod -170909763933741276657131032282211169869649489782500833989461829449 413412341293461238946192384612893) +(test -1709112374367945085349927261774254951415063208858972804089162291360682436890 + #'mod 41341412341234123412490123470912347210 -1709112374367945085349927261774254951456404621200206927501652414831594784100) +(test 9.666666666666666d0 #'mod -1/3 10d0) +(test -9.666666666666666d0 #'mod 1/3 -10d0) +(test -0.3333333333333333d0 #'mod -1/3 -10d0) +(test 0.3333333333333333d0 #'mod 1/3 10d0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; rem +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 2 #'rem 11 3) +(test 2 #'rem 11 -3) +(test -2 #'rem -11 3) +(test -2 #'rem -11 -3) +(test -1 #'rem -2147483648 2147483647) +(test 0.1499999999999999d0 #'rem 1.35d0 1/5) +(test -0.1499999999999999d0 #'rem -1.35d0 1/5) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; gcd +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 11 #'gcd 33 11) +(test 7 #'gcd 91 -49) +(test 4 #'gcd -4) +(test 0 #'gcd) +(test 11 #'gcd 3333 -33 1002001) +(test 1 #'gcd -2147483648 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; lcm +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 1 #'lcm) +(test 10 #'lcm 10) +(test 5 #'lcm -5) +(test 4611686016279904256 #'lcm -2147483648 2147483647) +(test 0 #'lcm 0 5) +(test 60 #'lcm 1 2 3 4 5 6) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; and +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test -1 #'logand) +(test 0 #'logand 1 2) +(test -2147483648 #'logand -2147483648 -1) +(test 2147483647 #'logand 2147483647 -1) +(test 2147479552 #'logand 8796093018112 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; eqv +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test -1 #'logeqv) +(test -4 #'logeqv 1 2) +(test -2147483648 #'logeqv -2147483648 -1) +(test 2147483647 #'logeqv 2147483647 -1) +(test -8793945542656 #'logeqv 8796093018112 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; or +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 0 #'logior) +(test 3 #'logior 1 2) +(test -1 #'logior -2147483648 -1) +(test -1 #'logior 2147483647 -1) +(test 8796093022207 #'logior 8796093018112 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; xor +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test 0 #'logxor) +(test 3 #'logxor 1 2) +(test 2147483647 #'logxor -2147483648 -1) +(test -2147483648 #'logxor 2147483647 -1) +(test 8793945542655 #'logxor 8796093018112 2147483647) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; not +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test -1 #'lognot 0) +(test 0 #'lognot -1) +(test -2 #'lognot 1) +(test 1 #'lognot -2) +(test -3 #'lognot 2) +(test 2 #'lognot -3) +(test -2147483648 #'lognot 2147483647) +(test 2147483647 #'lognot -2147483648) +(test -8793945542656 #'lognot 8793945542655) +(test -8796093018113 #'lognot 8796093018112) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; floor +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(div-test 1 1/2 #'floor 3/2) +(div-test 1d0 1 #'ffloor 3 2) +(div-test -2 2147483646 #'floor -2147483648 2147483647) +(div-test 2147483648 0 #'floor -2147483648 -1) +(div-test 17179869184 0 #'floor 18446744073709551616 1073741824) +(div-test -17179869201 -1073741807 #'floor 18446744073709551616 -1073741823) +(div-test 2147483648 0d0 #'floor -2147483648 -1d0) +(div-test -2 2147483646/2147483647 #'floor -2147483648/2147483647) +(div-test 32768 32768/2147483647 #'floor 2147483648/2147483647 65535/2147483647) +(div-test -32769 -32767/2147483647 #'floor 2147483648/2147483647 -65535/2147483647) +(div-test -32769 32767/2147483647 #'floor -2147483648/2147483647 65535/2147483647) +(div-test 32768 -32768/2147483647 #'floor -2147483648/2147483647 -65535/2147483647) +(div-test 2 0.5d0 #'floor 3d0 1.25d0) +(div-test 2 1d0 #'floor 4d0 1.5d0) +(div-test -3 -0.5d0 #'floor 4d0 -1.5d0) +(div-test -3 0.5d0 #'floor -4d0 1.5d0) +(div-test 2 -1d0 #'floor -4d0 -1.5d0) +(div-test 1 2/91 #'floor 5/7 9/13) +(div-test -2 -61/91 #'floor 5/7 -9/13) +(div-test -2 61/91 #'floor -5/7 9/13) +(div-test 1 -2/91 #'floor -5/7 -9/13) +(div-test 1 0 #'floor 2147483648/2147483647 2147483648/2147483647) +(div-test -1 0 #'floor 2147483648/2147483647 -2147483648/2147483647) +(div-test -1 0 #'floor -2147483648/2147483647 2147483648/2147483647) +(div-test 1 0 #'floor -2147483648/2147483647 -2147483648/2147483647) +(div-test 9437 1416337955817765/144137437447079 + #'floor 16324116304212832041/144137437447079 12) +(div-test -9438 -313311293547183/144137437447079 + #'floor 16324116304212832041/144137437447079 -12) +(div-test -9438 313311293547183/144137437447079 + #'floor -16324116304212832041/144137437447079 12) +(div-test 9437 -1416337955817765/144137437447079 + #'floor -16324116304212832041/144137437447079 -12) +(div-test 8081 1138147903718848755797/4324123123412370 + #'floor 2147483648 1148972348912638496123/4324123123412370) +(div-test -8082 -1804074198964956721/720687187235395 + #'floor 2147483648 -1148972348912638496123/4324123123412370) +(div-test -8082 1804074198964956721/720687187235395 + #'floor -2147483648 1148972348912638496123/4324123123412370) +(div-test 8081 -1138147903718848755797/4324123123412370 + #'floor -2147483648 -1148972348912638496123/4324123123412370) +(div-test 0 1148972348912638496123/4324123123412370111 + #'floor 1148972348912638496123/4324123123412370111 2147483648) +(div-test -1 -9285982550494401861657948805/4324123123412370111 + #'floor 1148972348912638496123/4324123123412370111 -2147483648) +(div-test -1 9285982550494401861657948805/4324123123412370111 + #'floor -1148972348912638496123/4324123123412370111 2147483648) +(div-test 0 -1148972348912638496123/4324123123412370111 + #'floor -1148972348912638496123/4324123123412370111 -2147483648) +(div-test 0.0d0 1.0000000004656613d0 #'ffloor 2147483648/2147483647 2147483648d0) +(div-test -1.0d0 -2.147483647d9 #'ffloor 2147483648/2147483647 -2147483648d0) +(div-test -1.0d0 2.147483647d9 #'ffloor -2147483648/2147483647 2147483648d0) +(div-test 0.0d0 -1.0000000004656613d0 #'ffloor -2147483648/2147483647 -2147483648d0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ceiling +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(div-test 2 -1/2 #'ceiling 3/2) +(div-test 2d0 -1 #'fceiling 3 2) +(div-test -1 -1 #'ceiling -2147483648 2147483647) +(div-test 2147483648 0 #'ceiling -2147483648 -1) +(div-test 17179869184 0 #'ceiling 18446744073709551616 1073741824) +(div-test -17179869200 16 #'ceiling 18446744073709551616 -1073741823) +(div-test 2147483648 0d0 #'ceiling -2147483648 -1d0) +(div-test -1 -1/2147483647 #'ceiling -2147483648/2147483647) +(div-test 32769 -32767/2147483647 #'ceiling 2147483648/2147483647 65535/2147483647) +(div-test -32768 32768/2147483647 #'ceiling 2147483648/2147483647 -65535/2147483647) +(div-test -32768 -32768/2147483647 #'ceiling -2147483648/2147483647 65535/2147483647) +(div-test 32769 32767/2147483647 #'ceiling -2147483648/2147483647 -65535/2147483647) +(div-test 3 -0.75d0 #'ceiling 3d0 1.25d0) +(div-test 3 -0.5d0 #'ceiling 4d0 1.5d0) +(div-test -2 1d0 #'ceiling 4d0 -1.5d0) +(div-test -2 -1d0 #'ceiling -4d0 1.5d0) +(div-test 3 0.5d0 #'ceiling -4d0 -1.5d0) +(div-test 2 -61/91 #'ceiling 5/7 9/13) +(div-test -1 2/91 #'ceiling 5/7 -9/13) +(div-test -1 -2/91 #'ceiling -5/7 9/13) +(div-test 2 61/91 #'ceiling -5/7 -9/13) +(div-test 1 0 #'ceiling 2147483648/2147483647 2147483648/2147483647) +(div-test -1 0 #'ceiling 2147483648/2147483647 -2147483648/2147483647) +(div-test -1 0 #'ceiling -2147483648/2147483647 2147483648/2147483647) +(div-test 1 0 #'ceiling -2147483648/2147483647 -2147483648/2147483647) +(div-test 9438 -313311293547183/144137437447079 + #'ceiling 16324116304212832041/144137437447079 12) +(div-test -9437 1416337955817765/144137437447079 + #'ceiling 16324116304212832041/144137437447079 -12) +(div-test -9437 -1416337955817765/144137437447079 + #'ceiling -16324116304212832041/144137437447079 12) +(div-test 9438 313311293547183/144137437447079 + #'ceiling -16324116304212832041/144137437447079 -12) +(div-test 8082 -1804074198964956721/720687187235395 + #'ceiling 2147483648 1148972348912638496123/4324123123412370) +(div-test -8081 1138147903718848755797/4324123123412370 + #'ceiling 2147483648 -1148972348912638496123/4324123123412370) +(div-test -8081 -1138147903718848755797/4324123123412370 + #'ceiling -2147483648 1148972348912638496123/4324123123412370) +(div-test 8082 1804074198964956721/720687187235395 + #'ceiling -2147483648 -1148972348912638496123/4324123123412370) +(div-test 1 -9285982550494401861657948805/4324123123412370111 + #'ceiling 1148972348912638496123/4324123123412370111 2147483648) +(div-test 0 1148972348912638496123/4324123123412370111 + #'ceiling 1148972348912638496123/4324123123412370111 -2147483648) +(div-test 0 -1148972348912638496123/4324123123412370111 + #'ceiling -1148972348912638496123/4324123123412370111 2147483648) +(div-test 1 9285982550494401861657948805/4324123123412370111 + #'ceiling -1148972348912638496123/4324123123412370111 -2147483648) +(div-test 1.0d0 -2.147483647d9 #'fceiling 2147483648/2147483647 2147483648d0) +(div-test 0d0 1.0000000004656613d0 #'fceiling 2147483648/2147483647 -2147483648d0) +(div-test 0d0 -1.0000000004656613d0 #'fceiling -2147483648/2147483647 2147483648d0) +(div-test 1d0 2.147483647d9 #'fceiling -2147483648/2147483647 -2147483648d0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; truncate +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(div-test 1 1/2 #'truncate 3/2) +(div-test 1d0 1 #'ftruncate 3 2) +(div-test -1 -1 #'truncate -2147483648 2147483647) +(div-test 2147483648 0 #'truncate -2147483648 -1) +(div-test 17179869184 0 #'truncate 18446744073709551616 1073741824) +(div-test -17179869200 16 #'truncate 18446744073709551616 -1073741823) +(div-test 2147483648 0d0 #'truncate -2147483648 -1d0) +(div-test -1 -1/2147483647 #'truncate -2147483648/2147483647) +(div-test 32768 32768/2147483647 #'truncate 2147483648/2147483647 65535/2147483647) +(div-test -32768 32768/2147483647 #'truncate 2147483648/2147483647 -65535/2147483647) +(div-test -32768 -32768/2147483647 #'truncate -2147483648/2147483647 65535/2147483647) +(div-test 32768 -32768/2147483647 #'truncate -2147483648/2147483647 -65535/2147483647) +(div-test 2 0.5d0 #'truncate 3d0 1.25d0) +(div-test 2 1d0 #'truncate 4d0 1.5d0) +(div-test -2 1d0 #'truncate 4d0 -1.5d0) +(div-test -2 -1d0 #'truncate -4d0 1.5d0) +(div-test 2 -1d0 #'truncate -4d0 -1.5d0) +(div-test 1 2/91 #'truncate 5/7 9/13) +(div-test -1 2/91 #'truncate 5/7 -9/13) +(div-test -1 -2/91 #'truncate -5/7 9/13) +(div-test 1 -2/91 #'truncate -5/7 -9/13) +(div-test 1 0 #'truncate 2147483648/2147483647 2147483648/2147483647) +(div-test -1 0 #'truncate 2147483648/2147483647 -2147483648/2147483647) +(div-test -1 0 #'truncate -2147483648/2147483647 2147483648/2147483647) +(div-test 1 0 #'truncate -2147483648/2147483647 -2147483648/2147483647) +(div-test 9437 1416337955817765/144137437447079 + #'truncate 16324116304212832041/144137437447079 12) +(div-test -9437 1416337955817765/144137437447079 + #'truncate 16324116304212832041/144137437447079 -12) +(div-test -9437 -1416337955817765/144137437447079 + #'truncate -16324116304212832041/144137437447079 12) +(div-test 9437 -1416337955817765/144137437447079 + #'truncate -16324116304212832041/144137437447079 -12) +(div-test 8081 1138147903718848755797/4324123123412370 + #'truncate 2147483648 1148972348912638496123/4324123123412370) +(div-test -8081 1138147903718848755797/4324123123412370 + #'truncate 2147483648 -1148972348912638496123/4324123123412370) +(div-test -8081 -1138147903718848755797/4324123123412370 + #'truncate -2147483648 1148972348912638496123/4324123123412370) +(div-test 8081 -1138147903718848755797/4324123123412370 + #'truncate -2147483648 -1148972348912638496123/4324123123412370) +(div-test 0 1148972348912638496123/4324123123412370111 + #'truncate 1148972348912638496123/4324123123412370111 2147483648) +(div-test 0 1148972348912638496123/4324123123412370111 + #'truncate 1148972348912638496123/4324123123412370111 -2147483648) +(div-test 0 -1148972348912638496123/4324123123412370111 + #'truncate -1148972348912638496123/4324123123412370111 2147483648) +(div-test 0 -1148972348912638496123/4324123123412370111 + #'truncate -1148972348912638496123/4324123123412370111 -2147483648) +(div-test 0d0 1.0000000004656613d0 #'ftruncate 2147483648/2147483647 2147483648d0) +(div-test 0d0 1.0000000004656613d0 #'ftruncate 2147483648/2147483647 -2147483648d0) +(div-test 0d0 -1.0000000004656613d0 #'ftruncate -2147483648/2147483647 2147483648d0) +(div-test 0d0 -1.0000000004656613d0 #'ftruncate -2147483648/2147483647 -2147483648d0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; round +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(div-test 2 -1/2 #'round 3/2) +(div-test 2d0 -1 #'fround 3 2) +(div-test -1 -1 #'round -2147483648 2147483647) +(div-test 2147483648 0 #'round -2147483648 -1) +(div-test 17179869184 0 #'round 18446744073709551616 1073741824) +(div-test -17179869200 16 #'round 18446744073709551616 -1073741823) +(div-test 2147483648 0d0 #'round -2147483648 -1d0) +(div-test -1 -1/2147483647 #'round -2147483648/2147483647) +(div-test 32769 -32767/2147483647 #'round 2147483648/2147483647 65535/2147483647) +(div-test -32769 -32767/2147483647 #'round 2147483648/2147483647 -65535/2147483647) +(div-test -32769 32767/2147483647 #'round -2147483648/2147483647 65535/2147483647) +(div-test 32769 32767/2147483647 #'round -2147483648/2147483647 -65535/2147483647) +(div-test 2 0.5d0 #'round 3d0 1.25d0) +(div-test 3 -0.5d0 #'round 4d0 1.5d0) +(div-test -3 -0.5d0 #'round 4d0 -1.5d0) +(div-test -3 0.5d0 #'round -4d0 1.5d0) +(div-test 3 0.5d0 #'round -4d0 -1.5d0) +(div-test 1 2/91 #'round 5/7 9/13) +(div-test -1 2/91 #'round 5/7 -9/13) +(div-test -1 -2/91 #'round -5/7 9/13) +(div-test 1 -2/91 #'round -5/7 -9/13) +(div-test 1 0 #'round 2147483648/2147483647 2147483648/2147483647) +(div-test -1 0 #'round 2147483648/2147483647 -2147483648/2147483647) +(div-test -1 0 #'round -2147483648/2147483647 2147483648/2147483647) +(div-test 1 0 #'round -2147483648/2147483647 -2147483648/2147483647) +(div-test 9438 -313311293547183/144137437447079 + #'round 16324116304212832041/144137437447079 12) +(div-test -9438 -313311293547183/144137437447079 + #'round 16324116304212832041/144137437447079 -12) +(div-test -9438 313311293547183/144137437447079 + #'round -16324116304212832041/144137437447079 12) +(div-test 9438 313311293547183/144137437447079 + #'round -16324116304212832041/144137437447079 -12) +(div-test 8082 -1804074198964956721/720687187235395 + #'round 2147483648 1148972348912638496123/4324123123412370) +(div-test -8082 -1804074198964956721/720687187235395 + #'round 2147483648 -1148972348912638496123/4324123123412370) +(div-test -8082 1804074198964956721/720687187235395 + #'round -2147483648 1148972348912638496123/4324123123412370) +(div-test 8082 1804074198964956721/720687187235395 + #'round -2147483648 -1148972348912638496123/4324123123412370) +(div-test 0 1148972348912638496123/4324123123412370111 + #'round 1148972348912638496123/4324123123412370111 2147483648) +(div-test 0 1148972348912638496123/4324123123412370111 + #'round 1148972348912638496123/4324123123412370111 -2147483648) +(div-test 0 -1148972348912638496123/4324123123412370111 + #'round -1148972348912638496123/4324123123412370111 2147483648) +(div-test 0 -1148972348912638496123/4324123123412370111 + #'round -1148972348912638496123/4324123123412370111 -2147483648) +(div-test 0d0 1.0000000004656613d0 #'fround 2147483648/2147483647 2147483648d0) +(div-test 0d0 1.0000000004656613d0 #'fround 2147483648/2147483647 -2147483648d0) +(div-test 0d0 -1.0000000004656613d0 #'fround -2147483648/2147483647 2147483648d0) +(div-test 0d0 -1.0000000004656613d0 #'fround -2147483648/2147483647 -2147483648d0) +(div-test 2 0.5d0 #'round 2.5d0) +(div-test -2 -0.5d0 #'round -2.5d0) +(div-test 5 0d0 #'round 2.5d0 0.5d0) +(div-test -5 0d0 #'round 2.5d0 -0.5d0) +(div-test -5 0d0 #'round 2.5d0 -0.5d0) +(div-test -5 0d0 #'round -2.5d0 0.5d0) +(div-test 5 0d0 #'round -2.5d0 -0.5d0) +(div-test 1 -2/7 #'round 5/7) +(div-test -1 2/7 #'round -5/7) +(div-test 2 -1/2 #'round 3/2) +(div-test -2 1/2 #'round -3/2) +(div-test 2 1 #'round 30/2 7) +(div-test -2 1 #'round 30/2 -7) +(div-test -2 -1 #'round -30/2 7) +(div-test 2 -1 #'round -30/2 -7) +(div-test 1073741824 -1/2 #'round 2147483647/2) +(div-test -1073741824 1/2 #'round -2147483647/2) +(div-test 1 -2147483645/2 #'round 2147483647/2 2147483646) +(div-test -1 -2147483645/2 #'round 2147483647/2 -2147483646) +(div-test -1 2147483645/2 #'round -2147483647/2 2147483646) +(div-test 1 -2147483645/2 #'round 2147483647/2 2147483646) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; misc +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(test #c(5 -5) #'conjugate #c(5 5)) +(test #c(5 5) #'conjugate #c(5 -5)) +(test #c(-5 -5) #'conjugate #c(-5 5)) +(test #c(-5 5) #'conjugate #c(-5 -5)) + +(test 1 #'denominator 10) +(test 3 #'denominator 10/3) +(test 3 #'denominator 1804074198964956721/3) +(test 4324123123412370111 #'denominator -1148972348912638496123/4324123123412370111) + +(bool-test nil #'evenp -1) +(bool-test t #'evenp -2147483648) +(bool-test t #'evenp -4294967296) +(bool-test nil #'evenp -4294967295) + +(test 0.5d0 #'float 1/2) +(test 10.0d0 #'float 10) +(test 4.978341823462786d22 #'float 49783418234627861238926) +(test 1.845867531346429d12 #'float 643827946123846123984/348794231) + +(bool-test t #'floatp 0.3d0) +(bool-test nil #'floatp 1/3) + +(test 0 #'imagpart 1) +(test -5 #'imagpart #c(1 -5)) + +(bool-test t #'integerp 12) +(bool-test nil #'integerp 1/2) +(bool-test nil #'integerp :test) +(bool-test nil #'integerp 0d0) +(bool-test t #'integerp 49783418234627861238926) + +(test 3 #'isqrt 12) +(test 46340 #'isqrt 2147483648) +(test 46340 #'isqrt 2147483647) +(test 25373764918 #'isqrt 643827946123846123984) + +(bool-test nil #'logtest 1 2) +(bool-test t #'logtest 1 3) +(bool-test t #'logtest 7 -1) + +(bool-test nil #'minusp 0) +(bool-test nil #'minusp 2147483648) +(bool-test t #'minusp -2147483648) +(bool-test t #'minusp -1/4) +(bool-test nil #'minusp 0.2d0) +(bool-test nil #'minusp 0d0) +(bool-test nil #'minusp 984723891462817946123897416) +(bool-test t #'minusp -1148972348912638496123/4324123123412370111) + +(bool-test t #'numberp #c(1 2)) +(bool-test t #'numberp -200) +(bool-test nil #'numberp :test) + +(test 10 #'numerator 10) +(test 10 #'numerator 10/3) +(test 1804074198964956721 #'numerator 1804074198964956721/3) +(test -1148972348912638496123 #'numerator -1148972348912638496123/4324123123412370111) + +(bool-test t #'oddp -1) +(bool-test nil #'oddp -2147483648) +(bool-test nil #'oddp -4294967296) +(bool-test t #'oddp -4294967295) + +(bool-test nil #'plusp 0) +(bool-test t #'plusp 2147483648) +(bool-test nil #'plusp -2147483648) +(bool-test nil #'plusp -1/4) +(bool-test t #'plusp 0.2d0) +(bool-test nil #'plusp 0d0) +(bool-test t #'plusp 984723891462817946123897416) +(bool-test nil #'plusp -1148972348912638496123/4324123123412370111) + +(test 1/4 #'rational 0.25d0) +(test 5/2 #'rational 2.5d0) +(test 1/8 #'rational 0.125d0) +(test -5/8 #'rational -0.625d0) +(test 524293/8 #'rational 65536.625d0) +(test 17179869181/8 #'rational 2147483647.625d0) + +(bool-test t #'rationalp -3) +(bool-test t #'rationalp 1/2) +(bool-test t #'rationalp 1/2412341242424122412) +(bool-test nil #'rationalp :test) +(bool-test nil #'rationalp 0d0) +(bool-test t #'rationalp 49783418234627861238926) + +(test -1 #'realpart #c(-1 0.5d0)) + +(test 1 #'signum 123/5) +(test 0d0 #'signum 0d0) +(test -1d0 #'signum -7.3d0) + +(bool-test nil #'zerop 1) +(bool-test nil #'zerop 1/4312412341234123412) +(bool-test nil #'zerop 0.000003d0) +(bool-test t #'zerop 0) +(bool-test t #'zerop 0d0) +(bool-test t #'zerop #c(0 0d0)) + +(bool-test t #'= 10 #c(10 0d0)) + diff --git a/lisp/test/psql-1.lsp b/lisp/test/psql-1.lsp new file mode 100644 index 0000000..2410fd8 --- /dev/null +++ b/lisp/test/psql-1.lsp @@ -0,0 +1,80 @@ +;; Postgresql C library interface, example program 1, using the xedit +;; lisp interface + +;; Test the C version of libpq, the PostgreSQL frontend library. +(require "psql") + +(defun exit-nicely (conn) + (pq-finish conn) + (quit 1) +) + +;; begin, by setting the parameters for a backend connection if the +;; parameters are null, then the system will try to use reasonable +;; defaults by looking up environment variables or, failing that, +;; using hardwired constants +(setq pghost nil) ; host name of the backend server +(setq pgport nil) ; port of the backend server +(setq pgoptions nil) ; special options to start up the backend server +(setq pgtty nil) ; debugging tty for the backend server +(setq pgdbname "template1") + +;; make a connection to the database +(setq conn (pq-setdb pghost pgport pgoptions pgtty pgdbname)) + +;; check to see that the backend connection was successfully made +(when (= (pq-status conn) pg-connection-bad) + (format t "Connection to database '~A' failed.~%" pgdbname) + (format t "~A" (pq-error-message conn)) + (exit-nicely conn)) + +;; start a transaction block +(setq res (pq-exec conn "BEGIN")) +(when (or (null res) (not (= (pq-result-status res) pgres-command-ok))) + (format t "BEGIN command failed~%") + (pq-clear res) + (exit-nicely conn)) + +;; Should PQclear PGresult whenever it is no longer needed to avoid memory leaks +(pq-clear res) + +;; fetch rows from the pg_database, the system catalog of databases +(setq res (pq-exec conn "DECLARE mycursor CURSOR FOR select * from pg_database")) +(when (or (null res) (not (= (pq-result-status res) pgres-command-ok))) + (format t "DECLARE CURSOR command failed~%") + (pq-clear res) + (exit-nicely conn)) +(pq-clear res) +(setq res (pq-exec conn "FETCH ALL in mycursor")) +(when (or (null res) (not (= (pq-result-status res) pgres-tuples-ok))) + (format t "FETCH ALL command didn't return tuples properly~%") + (pq-clear res) + (exit-nicely conn)) + +;; first, print out the attribute names +(setq nfields (pq-nfields res)) +(dotimes (i nfields) + (format t "~15@<~A~>" (pq-fname res i)) +) +(format t "~%") + +;; next, print out the rows +(setq ntuples (pq-ntuples res)) +(dotimes (i ntuples) + (dotimes (j nfields) + (format t "~15@<~A~>" (pq-getvalue res i j)) + ) + (format t "~%") +) +(pq-clear res) + +;; close the cursor +(setq res (pq-exec conn "CLOSE mycursor")) +(pq-clear res) + +;; commit the transaction +(setq res (pq-exec conn "COMMIT")) +(pq-clear res) + +;; close the connection to the database and cleanup +(pq-finish conn) diff --git a/lisp/test/psql-2.lsp b/lisp/test/psql-2.lsp new file mode 100644 index 0000000..011512c --- /dev/null +++ b/lisp/test/psql-2.lsp @@ -0,0 +1,74 @@ +;; Postgresql C library interface, example program 2, using the xedit +;; lisp interface + +;; Test of the asynchronous notification interface +;; +;; Start this program, then from psql in another window do +;; NOTIFY TBL2; +;; +;; Or, if you want to get fancy, try this: +;; Populate a database with the following: +;; +;; CREATE TABLE TBL1 (i int4); +;; +;; CREATE TABLE TBL2 (i int4); +;; +;; CREATE RULE r1 AS ON INSERT TO TBL1 DO +;; (INSERT INTO TBL2 values (new.i); NOTIFY TBL2); +;; +;; and do +;; +;; INSERT INTO TBL1 values (10); +(require "psql") + +(defun exit-nicely (conn) + (pq-finish conn) + (quit 1) +) + +;; begin, by setting the parameters for a backend connection if the +;; parameters are null, then the system will try to use reasonable +;; defaults by looking up environment variables or, failing that, +;; using hardwired constants +(setq pghost nil) ; host name of the backend server +(setq pgport nil) ; port of the backend server +(setq pgoptions nil) ; special options to start up the backend server +(setq pgtty nil) ; debugging tty for the backend server +(setq pgdbname "test") ; change this to the name of your test database + ;; XXX Note: getenv not yet implemented in the + ; lisp interpreter + +;; make a connection to the database +(setq conn (pq-setdb pghost pgport pgoptions pgtty pgdbname)) + +;; check to see that the backend connection was successfully made +(when (= (pq-status conn) pg-connection-bad) + (format t "Connection to database '~A' failed.~%" pgdbname) + (format t "~A" (pq-error-message conn)) + (exit-nicely conn)) + +(setq res (pq-exec conn "LISTEN TBL2")) +(when (= (pq-status conn) pg-connection-bad) + (format t "LISTEN command failed~%") + (format t "~A" (pq-error-message conn)) + (exit-nicely conn)) + +;; Should PQclear PGresult whenever it is no longer needed to avoid memory leaks +(pq-clear res) + +(loop + ;; wait a little bit between checks; waiting with select() + ;; would be more efficient. + ;; XXX Note: sleep not yet implemented in the lisp interpreter + + ;; collect any asynchronous backend messages + (pq-consume-input conn) + + ;; check for asynchronous notify messages + (when (setq notifies (pq-notifies conn)) + (format t "ASYNC NOTIFY of '~A' from backend pid '~D' received~%" + (pg-notify-relname notifies) (pg-notify-be-pid notifies)) + ) +) + +(pq-finish conn) diff --git a/lisp/test/psql-3.lsp b/lisp/test/psql-3.lsp new file mode 100644 index 0000000..bb172c9 --- /dev/null +++ b/lisp/test/psql-3.lsp @@ -0,0 +1,118 @@ +;; Postgresql C library interface, example program 3, using the xedit +;; lisp interface + +;; Test the binary cursor interface +;; +;; populate a database by doing the following: +;; +;; CREATE TABLE test1 (i int4, d real, p polygon); +;; +;; INSERT INTO test1 values (1, 3.567, polygon '(3.0, 4.0, 1.0, 2.0)'); +;; +;; INSERT INTO test1 values (2, 89.05, polygon '(4.0, 3.0, 2.0, 1.0)'); +;; +;; the expected output is: +;; +;; tuple 0: got i = (4 bytes) 1, d = (4 bytes) 3.567000, p = (4 +;; bytes) 2 points boundbox = (hi=3.000000/4.000000, lo = +;; 1.000000,2.000000) tuple 1: got i = (4 bytes) 2, d = (4 bytes) +;; 89.050003, p = (4 bytes) 2 points boundbox = +;; (hi=4.000000/3.000000, lo = 2.000000,1.000000) + +;; Output of the lisp code: +;; +;; type[0] = 23, size[0] = 4 +;; type[1] = 700, size[1] = 4 +;; type[2] = 604, size[2] = -1 +;; tuple 0: got +;; i = (4 bytes) 1 +;; d = (4 bytes) 3.567 +;; p = (4 bytes) 2 points boundbox = (hi=3.0/4.0, lo = 1.0/2.0) +;; tuple 1: got +;; i = (4 bytes) 2 +;; d = (4 bytes) 89.05 +;; p = (4 bytes) 2 points boundbox = (hi=4.0/3.0, lo = 2.0/1.0) + + +(require "psql") + +(defun exit-nicely (conn) + (pq-finish conn) + (quit 1) +) + +;; begin, by setting the parameters for a backend connection if the +;; parameters are null, then the system will try to use reasonable +;; defaults by looking up environment variables or, failing that, +;; using hardwired constants +(setq pghost nil) ; host name of the backend server +(setq pgport nil) ; port of the backend server +(setq pgoptions nil) ; special options to start up the backend server +(setq pgtty nil) ; debugging tty for the backend server +(setq pgdbname "test") ; change this to the name of your test database + ;; XXX Note: getenv not yet implemented in the + ; lisp interpreter + +;; make a connection to the database +(setq conn (pq-setdb pghost pgport pgoptions pgtty pgdbname)) + +;; check to see that the backend connection was successfully made +(when (= (pq-status conn) pg-connection-bad) + (format t "Connection to database '~A' failed.~%" pgdbname) + (format t "~A" (pq-error-message conn)) + (exit-nicely conn)) + +(setq res (pq-exec conn "BEGIN")) +(when (= (pq-status conn) pg-connection-bad) + (format t "BEGIN command failed~%") + (pq-clear res) + (exit-nicely conn)) + +;; Should PQclear PGresult whenever it is no longer needed to avoid memory leaks +(pq-clear res) + +(setq res (pq-exec conn "DECLARE mycursor BINARY CURSOR FOR select * from test1")) +(when (= (pq-status conn) pg-connection-bad) + (format t "DECLARE CURSOR command failed~%") + (pq-clear res) + (exit-nicely conn)) +(pq-clear res) + +(setq res (pq-exec conn "FETCH ALL in mycursor")) +(when (or (null res) (not (= (pq-result-status res) pgres-tuples-ok))) + (format t "FETCH ALL command didn't return tuples properly~%") + (pq-clear res) + (exit-nicely conn)) + +(setq i-fnum (pq-fnumber res "i")) +(setq d-fnum (pq-fnumber res "d")) +(setq p-fnum (pq-fnumber res "p")) + +(dotimes (i 3) + (format t "type[~D] = ~D, size[~D] = ~D~%" + i (pq-ftype res i) i (pq-fsize res i)) +) + +(dotimes (i (pq-ntuples res)) + (setq i-val (pq-getvalue res i i-fnum 'int32)) + (setq d-val (pq-getvalue res i d-fnum 'float)) + (setq p-val (pq-getvalue res i p-fnum 'pg-polygon)) + (format t "tuple ~D: got~%" i) + (format t " i = (~D bytes) ~D~%" (pq-getlength res i i-fnum) i-val) + (format t " d = (~D bytes) ~D~%" (pq-getlength res i d-fnum) d-val) + (format t " p = (~D bytes) ~D points~,8@Tboundbox = (hi=~F/~F, lo = ~F/~F)~%" + (pq-getlength res i d-fnum) (pg-polygon-num-points p-val) + (pg-point-x (pg-box-high (pg-polygon-boundbox p-val))) + (pg-point-y (pg-box-high (pg-polygon-boundbox p-val))) + (pg-point-x (pg-box-low (pg-polygon-boundbox p-val))) + (pg-point-y (pg-box-low (pg-polygon-boundbox p-val)))) +) +(pq-clear res) + +(setq res (pq-exec conn "CLOSE mycursor")) +(pq-clear res) + +(setq res (pq-exec conn "COMMIT")) +(pq-clear res) + +(pq-finish conn) diff --git a/lisp/test/regex.lsp b/lisp/test/regex.lsp new file mode 100644 index 0000000..64ba572 --- /dev/null +++ b/lisp/test/regex.lsp @@ -0,0 +1,440 @@ +;; +;; Copyright (c) 2002 by The XFree86 Project, Inc. +;; +;; Permission is hereby granted, free of charge, to any person obtaining a +;; copy of this software and associated documentation files (the "Software"), +;; to deal in the Software without restriction, including without limitation +;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;; and/or sell copies of the Software, and to permit persons to whom the +;; Software is furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in +;; all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;; THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF +;; OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. +;; +;; Except as contained in this notice, the name of the XFree86 Project shall +;; not be used in advertising or otherwise to promote the sale, use or other +;; dealings in this Software without prior written authorization from the +;; XFree86 Project. +;; +;; Author: Paulo César Pereira de Andrade +;; +;; +;; $XFree86: xc/programs/xedit/lisp/test/regex.lsp,v 1.2 2002/12/11 04:44:28 paulo Exp $ +;; + +;; Basic regex tests. This file is only for xedit lisp and for it's regex +;; library. Note that the regex library used by xedit lisp is not mean't +;; to be fully compatible with most regexes, but to be as fast as possible. +;; This means that some patterns that looks basic may never be matched, +;; but it is expected that almost any pattern can be rewritten to be +;; matched, or in the worst case, it may be required to search in the +;; regions matched by a previous regex. + +(defun re-test (expect &rest arguments &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (apply #'re-exec arguments)) + (setq error nil))) + (if error + (format t "ERROR: (re-exec~{ ~S~}) => ~S~%" arguments error-value) + (or (equal result expect) + (format t "(re-exec~{ ~S~}) => should be ~S not ~S~%" + arguments expect result)))) + +;; errors only generated for regex compilation (or incorrect arguments) +(defun re-error (&rest arguments &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (apply #'re-comp arguments)) + (setq error nil))) + (or error + (format t "ERROR: no error for (re-comp~{ ~S~})" arguments))) + +(re-error "") +(re-error "a**") +(re-error "[a") +(re-error "a{") +(re-error "a(") +(re-error "a||b") +(re-error "|b|c") +(re-error "a|b|") + +(setq re (re-comp "abc")) +(re-test '((0 . 3)) re "abc") +(re-test '((0 . 3)) re "abc" :notbol t) +(re-test '((0 . 3)) re "abc" :noteol t) +(re-test '((0 . 3)) re "abc" :notbol t :noteol t) +(re-test '((14 . 17)) re "aaaaaaaaaaaaaaabc") +(re-test '((14 . 17)) re "aaaaaaaaaaaaaaabc" :start 12 :end 17) +(re-test '((30 . 33)) re "xxxxxxxxxxxxxxaaaaaaaaaaaaaaaaabcxx") +(re-test '((30 . 33)) re "xxxxxxxxxxxxxxaaaaaaaaaaaaaaaaabcxx" :start 28 :end 34) + +(setq re (re-comp "^abc")) +(re-test '((0 . 3)) re "abc") +(re-test :nomatch re "xabc") +(re-test '((1 . 4)) re "xabc" :start 1) +(re-test :nomatch re "xabc" :start 1 :notbol t) + +(setq re (re-comp "abc$")) +(re-test '((0 . 3)) re "abc") +(re-test :nomatch re "xabcx") +(re-test '((1 . 4)) re "xabcx" :end 4) +(re-test :nomatch re "xabc" :end 4 :noteol t) + +(setq re (re-comp "^abc$")) +(re-test '((0 . 3)) re "abc") +(re-test :nomatch re "xabcx") +(re-test '((1 . 4)) re "xabcx" :start 1 :end 4) +(re-test :nomatch re "xabcx" :start 1 :end 4 :notbol t) +(re-test :nomatch re "xabcx" :start 1 :end 4 :noteol t) +(re-test :nomatch re "xabcx" :start 1 :end 4 :notbol t :noteol t) +(re-test nil re "abc" :count 0) + +(setq re (re-comp "abc|bcd|cde")) +(re-test '((0 . 3)) re "abc") +(re-test '((1 . 4)) re "aabc") +(re-test '((3 . 6)) re "xxxbcdef") +(re-test '((8 . 11)) re "abdzzzcdabcde") +(re-test '((13 . 16)) re "xxxxabdecdabdcde") + +(setq re (re-comp "^abc|bcd$|cde")) +(re-test '((0 . 3)) re "abcde") +(re-test '((3 . 6)) re "xabcde") +(re-test '((1 . 4)) re "xabcde" :start 1) +(re-test '((3 . 6)) re "xabcde" :start 1 :notbol t) +(re-test '((2 . 5)) re "xabcd") +(re-test :nomatch re "xabcd" :noteol t) +(re-test nil re "xabcd" :count 0) +(re-test :nomatch re "abcdx" :notbol t) + +(setq re (re-comp "a?bc|ab?c|abc?")) +(re-test '((0 . 3)) re "abc") +(re-test :nomatch re "xxxb") +(re-test '((3 . 5)) re "xxxbc") +(re-test '((5 . 7)) re "sssssab") +(re-test '((0 . 3)) re "abcd") +(re-test '((1 . 4)) re "aabcdef") +(re-test '((1 . 3)) re "aabbccdef") ;; ab matches abc? + +(setq re (re-comp "a?bc")) +(re-test '((2 . 4)) re "acbcd") +(re-test '((2 . 5)) re "acabcd") + +(setq re (re-comp "ab?c")) +(re-test '((1 . 3)) re "xacc") +(re-test '((2 . 5)) re "xxabcc") + +(setq re (re-comp "abc?")) +(re-test '((1 . 3)) re "xababc") +(re-test '((2 . 5)) re "xxabccabc") + +(setq re (re-comp "a*bc|ab*c|abc*")) +(re-test '((0 . 9)) re "aaaaaaabc") +(re-test '((1 . 10)) re "xaaaaaaabc") +(re-test '((3 . 12)) re "xyzaaaaaaabc") +(re-test '((0 . 4)) re "abbc") +(re-test '((2 . 9)) re "xxabbbbbc") +(re-test '((0 . 12)) re "abcccccccccc") +(re-test '((0 . 12)) re "abccccccccccd") +(re-test '((16 . 29)) re "xxxxxxxaaaaaaaaaabbbbbbbbbbbccccccccccc") +(re-test '((11 . 13)) re "xxxbbbbbbbbbc") +(re-test '((8 . 10)) re "aaaaazbxacd") + +(setq re (re-comp "a*bc")) +(re-test '((2 . 4)) re "acbcd") +(re-test '((2 . 5)) re "acabcd") +(re-test '((2 . 8)) re "acaaaabcd") + +(setq re (re-comp "ab*c")) +(re-test '((1 . 3)) re "xacc") +(re-test '((2 . 5)) re "xxabcc") +(re-test '((3 . 8)) re "xxaabbbcc") + +(setq re (re-comp "abc*")) +(re-test '((1 . 3)) re "xababc") +(re-test '((2 . 5)) re "xxabcbabccc") +(re-test '((3 . 7)) re "axxabccabc") + +(setq re (re-comp "a+bc|ab+c|abc+")) +(re-test :nomatch re "xxxbc") +(re-test '((1 . 6)) re "xaaabc") +(re-test '((8 . 12)) re "zzzzaaaaabbc") +(re-test '((7 . 15)) re "zzzzaaaabbbbbbcccc") + +(setq re (re-comp "a.c")) +(re-test '((0 . 3)) re "abc") +(re-test '((1 . 4)) re "aaac") +(re-test :nomatch re "xac") +(re-test '((3 . 6)) re "xaxaac") +(re-test '((2 . 5)) re "xxabc") +(re-test '((3 . 6)) re "acxaxc") + +(setq re (re-comp "a*c")) +(re-test '((0 . 1)) re "c") +(re-test '((5 . 6)) re "xxxxxc") +(re-test '((8 . 9)) re "xxxxxxxxc") +(re-test '((7 . 8)) re "xxxxxxxcc") +(re-test '((0 . 2)) re "ac") +(re-test '((0 . 5)) re "aaaac") +(re-test '((1 . 3)) re "xac") +(re-test '((3 . 6)) re "xxxaac") +(re-test '((2 . 4)) re "xxac") +(re-test '((4 . 6)) re "xxxxac") + +(setq re (re-comp "a+c")) +(re-test '((2 . 5)) re "xxaac") +(re-test '((3 . 8)) re "xxxaaaac") +(re-test '((6 . 8)) re "xaaaabac") +(re-test :nomatch re "xxxc") +(re-test '((4 . 9)) re "xxxxaaaaccc") + +(setq re (re-comp "a{4}b")) +(re-test '((19 . 24)) re "xabxxaabxxxaaabxxxxaaaab") +(re-test '((4 . 9)) re "aaabaaaab") + +(setq re (re-comp "a{4,}b")) +(re-test '((3 . 8)) re "xxxaaaab") +(re-test '((8 . 25)) re "zaaabzzzaaaaaaaaaaaaaaaab") + +(setq re (re-comp "a{,4}b")) +(re-test '((0 . 1)) re "b") +(re-test '((8 . 9)) re "xxxxxxxxb") +(re-test '((6 . 11)) re "xaaaaaaaaab") +(re-test '((3 . 5)) re "xxxab") +(re-test '((6 . 10)) re "aaaaaxaaab") + +(setq re (re-comp "a{2,4}b")) +(re-test :nomatch re "xab") +(re-test '((1 . 4)) re "xaab") +(re-test '((1 . 5)) re "xaaab") +(re-test '((2 . 7)) re "xxaaaab") +(re-test '((4 . 9)) re "xxxaaaaab") + +(setq re (re-comp "foo(bar|baz)fee")) +(re-test '((9 . 18)) re "feebarbazfoobarfee") +(re-test '((9 . 18) (12 . 15)) re "feebarbazfoobarfee" :count 2) +(re-test '((13 . 22)) re "foofooobazfeefoobazfee") +(re-test '((13 . 22) (16 . 19)) re "foofooobazfeefoobazfee" :count 3) + +(setq re (re-comp "foo(bar|baz)fee" :nosub t)) +(re-test '((9 . 18)) re "feebarbazfoobarfee") +(re-test '((9 . 18)) re "feebarbazfoobarfee" :count 2) +(re-test '((13 . 22)) re "foofooobazfeefoobazfee") +(re-test '((13 . 22)) re "foofooobazfeefoobazfee" :count 3) + +(setq re (re-comp "f(oo|ee)ba[rz]")) +(re-test :nomatch re "barfoebaz") +(re-test '((3 . 9) (4 . 6)) re "bazfoobar" :count 2) +(re-test '((3 . 9) (4 . 6)) re "barfeebaz" :count 2) + +(setq re (re-comp "f(oo|ee)ba[rz]" :nosub t)) +(re-test :nomatch re "barfoebaz") +(re-test '((3 . 9)) re "bazfoobar" :count 2) +(re-test '((3 . 9)) re "barfeebaz" :count 2) + +(setq re (re-comp "\\<(int|char)\\>")) +(re-test '((15 . 18)) re "aint character int foo") +(re-test '((15 . 18) (15 . 18)) re "aint character int foo" :count 2) + +(setq re (re-comp "\\<(int|char)\\>" :nosub t)) +(re-test '((15 . 18)) re "aint character int foo" :count 2) + +(setq re (re-comp "foo.*bar")) +(re-test '((11 . 17)) re "barfoblaboofoobarfoobarfoobar") + +(setq re (re-comp "foo.+bar")) +(re-test :nomatch re "foobar") +(re-test '((6 . 13)) re "fobbarfooxbarfooybar") + +(setq re (re-comp "foo.?bar")) +(re-test '((1 . 7)) re "xfoobar") +(re-test :nomatch re "xxfooxxbar") +(re-test '((3 . 10)) re "yyyfootbar") + +(setq re (re-comp "a.*b.*c")) +(re-test '((0 . 3)) re "abc") +(re-test '((9 . 18)) re "xxxxxxxxxabbbbbbbccaaaaabbbc") + +(setq re (re-comp "a.+b.*c")) +(re-test :nomatch re "xxxabc") +(re-test '((2 . 7)) re "xxaxbbc") + +(setq re (re-comp "a.+b.?c")) +(re-test '((1 . 5)) re "xaabc") +(re-test '((2 . 7)) re "xxaabbc") + +(setq re (re-comp "(foo.*|bar)fee")) +(re-test '((3 . 9) (3 . 6)) re "barfoofee" :count 2) +(re-test '((0 . 9) (0 . 6)) re "foobarfee" :count 2) +(re-test '((4 . 10) (4 . 7)) re "xxfobarfee" :count 2) +(re-test '((3 . 17) (3 . 14)) re "barfooooooobarfee" :count 2) +(re-test '((4 . 10) (4 . 7)) re "xxfobarfeefoobar" :count 2) + +(setq re (re-comp "(foo.+|bar)fee")) +(re-test :nomatch re "barfoofee" :count 2) +(re-test '((3 . 10) (3 . 7)) re "barfooxfee" :count 2) + +(setq re (re-comp "(foo.?|bar)fee")) +(re-test :nomatch re "foobar" :count 2) +(re-test '((2 . 8) (2 . 5)) re "bafoofee" :count 2) +(re-test '((2 . 9) (2 . 6)) re "bafooofeebarfee" :count 4) +(re-test '((2 . 8) (2 . 5)) re "bafoofeebarfee" :count 2) +(re-test nil re "bafoofeebarfee" :count 0) +(re-test '((2 . 8)) re "bafoofeebarfee" :count 1) + +(setq re (re-comp "(a|b|c)\\1")) +(re-test '((0 . 2) (0 . 1)) re "aa" :count 2) + +(setq re (re-comp "(a|b|c)(a|b|c)\\1\\2")) +(re-test '((0 . 4) (0 . 1) (1 . 2)) re "acac" :count 5) +(re-test '((4 . 8) (4 . 5) (5 . 6)) re "xxxxacac" :count 4) +(re-test '((24 . 28) (24 . 25) (25 . 26)) re "xxacabacbcacbbacbcaaccabcaca" :count 3) +(re-test '((4 . 8) (4 . 5) (5 . 6)) re "xyabcccc" :count 3) +(re-test '((4 . 8) (4 . 5)) re "xyabcccc" :count 2) +(re-test '((4 . 8)) re "xyabcccc" :count 1) +(re-test nil re "xyabcccc" :count 0) + +(setq re (re-comp "(a*b)\\1")) +(re-test '((3 . 15) (3 . 9)) re "xxxaaaaabaaaaab" :count 2) +(re-test '((7 . 9) (7 . 8)) re "abaabaxbb" :count 2) + +(setq re (re-comp "(ab+c)\\1")) +(re-test '((3 . 13) (3 . 8)) re "xaaabbbcabbbc" :count 3) + +(setq re (re-comp "(ab?c)\\1")) +(re-test :nomatch re "abcac" :count 2) +(re-test '((4 . 8) (4 . 6)) re "acabacac" :count 2) +(re-test '((5 . 11) (5 . 8)) re "abcacabcabc" :count 2) +(re-test '((3 . 7) (3 . 5)) re "abcacac" :count 2) + +(setq re (re-comp "a(.*)b\\1")) +(re-test '((3 . 5) (4 . 4)) re "xxxab" :count 2) +(re-test '((4 . 12) (5 . 8)) re "xxxxazzzbzzz" :count 2) + +(setq re (re-comp "abc" :icase t)) +(re-test '((0 . 3)) re "AbC") + +(setq re (re-comp "[0-9][a-z]+" :icase t)) +(re-test '((3 . 10)) re "xxx0aaZxYT9") + +(setq re (re-comp "a.b" :icase t)) +(re-test '((10 . 13)) re "aaaaaaaaaaaxB") + +(setq re (re-comp "a.*z" :icase t)) +(re-test '((3 . 9)) re "xxxAaaaaZ") +(re-test '((2 . 6)) re "xxaaaZaaa") + +(setq re (re-comp "\\<(lambda|defun|defmacro)\\>" :icase t)) +(re-test '((5 . 11)) re " (lambda") +(re-test '((5 . 11) (5 . 11)) re " (lambda" :count 2) +(re-test :nomatch re "lamda defunn deffmacro") + +(setq re (re-comp "\\<(nil|t)\\>" :icase t)) +(re-test '((3 . 6)) re "it Nil") +(re-test '((3 . 6) (3 . 6)) re "it Nil" :count 6) +(re-test :nomatch re "nilo") + +(setq re (re-comp "\\<(begin|end)\\>" :icase t)) +(re-test '((21 . 24) (21 . 24)) re "beginning the ending EnD" :count 7) + +(setq re (re-comp "a.*" :newline t)) +(re-test '((0 . 1)) re "a +aaa") +(re-test '((3 . 4)) re "xyza +aa") + +(setq re (re-comp "a.+" :newline t)) +(re-test '((2 . 5)) re "a +aaa") +(re-test '((5 . 7)) re "xyza +aa") + +(setq re (re-comp "a.?" :newline t)) +(re-test '((0 . 1)) re "a +aaa") +(re-test '((3 . 4)) re "xyza +aa") + +(setq re (re-comp "a.*b.*c" :newline t)) +(re-test '((11 . 14)) re "xxaa +zyacb +abc") +(re-test '((6 . 9)) re "xxxab +abc +c") + +(setq re (re-comp "a.+b.*c" :newline t)) +(re-test '((6 . 10)) re "ab +bc +abbc") + +(setq re (re-comp "a.?b.*c" :newline t)) +(re-test '((4 . 8)) re "ab +cabbc +cc") + +(setq re (re-comp "^foo$" :newline t)) +(re-test '((11 . 14)) re "bar +foobar +foo") +(re-test '((0 . 3)) re "foo +bar +foo +bar") +(re-test '((8 . 11)) re "foo +bar +foo +bar" :notbol t) +(re-test '((8 . 11)) re "foo +bar +foo" :notbol t) +(re-test :nomatch re "foo +bar +foo" :notbol t :noteol t) + +(setq re (re-comp "^\\s*#\\s*(define|include)\\s+.+" :newline t)) +(re-test '((8 . 18)) re "#define +#include x") +(re-test '((8 . 18) (9 . 16)) re "#define +#include x" :count 2) + +(setq re (re-comp "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")) +(re-test '((3 . 259)) re "zzzxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxzzz") + +(setq re (re-comp "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~")) +(re-test '((13 . 333)) re "String here: ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890~/") + +(setq re (re-comp "(.*)\\D(\\d+)")) +(re-test '((0 . 6) (0 . 3) (4 . 6)) re "abcW12" :count 3) +(re-test '((0 . 6) (0 . 3)) re "abcW12" :count 2) +(re-test '((0 . 6)) re "abcW12" :count 1) +(re-test nil re "abcW12" :count 0) +(re-test '((0 . 6) (0 . 3) (4 . 6)) re "abcW12abcW12" :count 3) +(re-test '((0 . 6) (0 . 3) (4 . 6)) re "abcW12abcW12a" :count 3) + +(setq re (re-comp ".*\\d")) +(re-test '((0 . 2)) re "a1a1a1aaaaaaa") ; minimal match only + +(setq re (re-comp "(.*)\\d")) +(re-test '((0 . 2) (0 . 1)) re "a1a1a1aaaaaaa" :count 2); minimal match only + +(setq re (re-comp ".*(\\d)")) +(re-test '((0 . 2) (1 . 2)) re "a1a1a1aaaaaaa" :count 2); minimal match only + +;; XXX this very simple pattern was entering an infinite loop +;; actually, this pattern is not supported, just test if is not +;; crashing (not supported because it is not cheap to match variations +;; of the pattern) +(setq re (re-comp "(.*a)?")) +(re-test '((0 . 1)) re "aaaa") ; expected, minimal match +(re-test '((0 . 1) (0 . 1)) re "aaaa" :count 2) diff --git a/lisp/test/stream.lsp b/lisp/test/stream.lsp new file mode 100644 index 0000000..8af4ff6 --- /dev/null +++ b/lisp/test/stream.lsp @@ -0,0 +1,807 @@ +;; +;; Copyright (c) 2002 by The XFree86 Project, Inc. +;; +;; Permission is hereby granted, free of charge, to any person obtaining a +;; copy of this software and associated documentation files (the "Software"), +;; to deal in the Software without restriction, including without limitation +;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;; and/or sell copies of the Software, and to permit persons to whom the +;; Software is furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in +;; all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;; THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF +;; OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. +;; +;; Except as contained in this notice, the name of the XFree86 Project shall +;; not be used in advertising or otherwise to promote the sale, use or other +;; dealings in this Software without prior written authorization from the +;; XFree86 Project. +;; +;; Author: Paulo César Pereira de Andrade +;; +;; +;; $XFree86: xc/programs/xedit/lisp/test/stream.lsp,v 1.4 2002/12/10 03:59:04 paulo Exp $ +;; + +;; most format tests from the cltl second edition samples + +;; basic io/format/pathname/stream tests + +(defun do-format-test (error-test expect arguments + &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (apply #'format nil arguments)) + (setq error nil) + ) + ) + (if error-test + (or error + (format t "ERROR: no error for (format nil~{ ~S~}), result was ~S~%" + arguments result)) + (if error + (format t "ERROR: (format nil~{ ~S~}) => ~S~%" arguments error-value) + (or (string= result expect) + (format t "(format nil~{ ~S~}) => should be ~S not ~S~%" + arguments expect result))) + ) +) + +(defun format-test (expect &rest arguments) + (do-format-test nil expect arguments)) + +(defun format-error (&rest arguments) + (do-format-test t nil arguments)) + + + +(defun compare-test (test expect function arguments + &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + ) + (if error + (format t "ERROR: (~S~{ ~S~}) => ~S~%" function arguments error-value) + (or (funcall test result expect) + (format t "(~S~{ ~S~}) => should be ~S not ~S~%" + function arguments expect result + ) + ) + ) +) + +(defun compare-eval (test expect form + &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (eval form)) + (setq error nil) + ) + ) + (if error + (format t "ERROR: ~S => ~S~%" form error-value) + (or (funcall test result expect) + (format t "~S => should be ~S not ~S~%" + form expect result + ) + ) + ) +) + +(defun error-test (function &rest arguments &aux result (error t)) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + (or error + (format t "ERROR: no error for (~S~{ ~S~}), result was ~S~%" + function arguments result) + ) +) + +(defun error-eval (form &aux result (error t)) + (ignore-errors + (setq result (eval form)) + (setq error nil) + ) + (or error + (format t "ERROR: no error for ~S, result was ~S~%" form result) + ) +) + +(defun eq-test (expect function &rest arguments) + (compare-test #'eq expect function arguments)) + +(defun eql-test (expect function &rest arguments) + (compare-test #'eql expect function arguments)) + +(defun equal-test (expect function &rest arguments) + (compare-test #'equal expect function arguments)) + +(defun equalp-test (expect function &rest arguments) + (compare-test #'equalp expect function arguments)) + +(defun eq-eval (expect form) + (compare-eval #'eq expect form)) + +(defun eql-eval (expect form) + (compare-eval #'eql expect form)) + +(defun equal-eval (expect form) + (compare-eval #'equal expect form)) + +(defun equalp-eval (expect form) + (compare-eval #'equalp expect form)) + +(defun bool-test (expect function &rest arguments + &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (apply function arguments)) + (setq error nil) + ) + ) + (if error + (format t "ERROR: (~S~{ ~S~}) => ~S~%" function arguments error-value) + (or (eq (null result) (null expect)) + (format t "(~S~{ ~S~}) => should be ~A not ~A~%" + function arguments expect result + ) + ) + ) +) + +(defun bool-eval (expect form &aux result (error t) unused error-value) + (multiple-value-setq + (unused error-value) + (ignore-errors + (setq result (eval form)) + (setq error nil) + ) + ) + (if error + (format t "ERROR: ~S => ~S~%" form error-value) + (or (eq (null result) (null expect)) + (format t "~S => should be ~A not ~A~%" + form expect result + ) + ) + ) +) + + +;; format - function + +;; ~c +(format-test "A" "~C" #\A) +(format-test " " "~C" #\Space) +(format-test "A" "~:C" #\A) +(format-test "Space" "~:C" #\Space) +(format-test "#\\A" "~@C" #\A) +(format-test "#\\Space" "~@C" #\Space) +(format-test " " "~A" #\Space) +(let ((*print-escape* t)) (format-test " " "~A" #\Space)) +(format-test "#\\Space" "~S" #\Space) +(let ((*print-escape* nil)) (format-test "#\\Space" "~S" #\Space)) + +;; ~% +(format-test " +" "~%") +(format-test " + + +" "~3%") + +;; ~& +(format-test "" "~&") +(format-test " +" "~2&") + +;; ~| +(format-test " " "~|") + +;; ~~ +(format-test "~~~" "~3~") + +;; radix +(format-test "1101" "~,,' ,4:B" 13) +(format-test "1 0001" "~,,' ,4:B" 17) +(format-test "1101 0000 0101" "~14,,' ,4:B" 3333) +(format-test "1 22" "~3,,,' ,2:R" 17) +(format-test "6|55|35" "~,,'|,2:D" #xFFFF) +(format-test "1,000,000" "~,,,3:D" 1000000) +(format-test "one hundred and twenty-three thousand, four hundred and fifty-six" + "~R" 123456) +(format-test "six hundred and fifty-four thousand, three hundred twenty-first" + "~:R" 654321) +(format-test "MCCXXXIV" "~@R" 1234) +(format-test "MCCXXXXVIIII" "~@:R" 1249) +(format-test "3039" "~X" 12345) +(format-test "30071" "~O" 12345) +(format-test "9IX" "~36R" 12345) +(format-test "11000000111001" "~B" 12345) +(format-test "The answer is 5." "The answer is ~D." 5) +(format-test "The answer is 5." "The answer is ~3D." 5) +(format-test "The answer is 005." "The answer is ~3,'0D." 5) +(format-test "1111 1010 1100 1110" "~,,' ,4:B" #xFACE) +(format-test "1 1100 1110" "~,,' ,4:B" #x1CE) +(format-test "1111 1010 1100 1110" "~19,,' ,4:B" #xFACE) +(format-test " 1 1100 1110" "~19,,' ,4:B" #x1CE) + +;; 6.37 and 6.38 are correct +#+xedit (format-test "6.38" "~4,2F" 6.375d0) +(format-test "10.0" "~,1F" 9.995d0) +;; 6.37E+2 and 6.38E+2 are correct +#+xedit (format-test " 6.38E+2" "~8,2E" 637.5) +(do* + ( + (n '(3.14159 -3.14159 100.0 1234.0 0.006) (cdr n)) + (r '(" 3.14| 31.42| 3.14|3.1416|3.14|3.14159" + " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" + "100.00|******|100.00| 100.0|100.00|100.0" + "1234.00|******|??????|1234.0|1234.00|1234.0" + " 0.01| 0.06| 0.01| 0.006|0.01|0.006") (cdr r)) + (x (car n) (car n)) + ) + ((endp n)) + (format-test (car r) + "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" x x x x x x) +) +(do* + ( + (n '(3.14159 -3.14159 1100.0 1.1e13 #+xedit 1.1e120) (cdr n)) + (r '(" 3.14E+0| 31.42$-01|+.003E+03| 3.14E+0" + " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0" + " 1.10E+3| 11.00$+02|+.001E+06| 1.10E+3" + "*********| 11.00$+12|+.001E+16| 1.10E+13" + #+xedit + "*********|??????????|%%%%%%%%%|1.10E+120") (cdr r)) + (x (car n) (car n)) + ) + ((endp n)) + (format-test (car r) + "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~9,3,2,-2,'%@E|~9,2E" x x x x) +) +(do + ( + (k -5 (1+ k)) + (r '("Scale factor -5: | 0.000003E+06|" + "Scale factor -4: | 0.000031E+05|" + "Scale factor -3: | 0.000314E+04|" + "Scale factor -2: | 0.003142E+03|" + "Scale factor -1: | 0.031416E+02|" + "Scale factor 0: | 0.314159E+01|" + "Scale factor 1: | 3.141590E+00|" + "Scale factor 2: | 31.41590E-01|" + "Scale factor 3: | 314.1590E-02|" + "Scale factor 4: | 3141.590E-03|" + "Scale factor 5: | 31415.90E-04|" + "Scale factor 6: | 314159.0E-05|" + "Scale factor 7: | 3141590.E-06|") (cdr r)) + ) + ((endp r)) + (format-test (car r) "Scale factor ~2D: | ~12,6,2,VE|" k k 3.14159) +) +(do* + ( + (n '(0.0314159 0.314159 3.14159 31.4159 314.159 3141.59 3.14E12 + #+xedit 3.14d120) (cdr n)) + (r '(" 3.14E-2|314.2$-04|0.314E-01| 3.14E-2" + " 0.31 |0.314 |0.314 | 0.31 " + " 3.1 | 3.14 | 3.14 | 3.1 " + " 31. | 31.4 | 31.4 | 31. " + " 3.14E+2| 314. | 314. | 3.14E+2" + " 3.14E+3|314.2$+01|0.314E+04| 3.14E+3" + "*********|314.0$+10|0.314E+13| 3.14E+12" + #+xedit "*********|?????????|%%%%%%%%%|3.14E+120") (cdr r)) + (x (car n) (car n)) + ) + ((endp n)) + (format-test (car r) "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G" + x x x x) +) +(format-test " 1." "~4,0f" 0.5) +(format-test " 0." "~4,0f" 0.4) + +;; ~p +(setq n 3) +(format-test "3 items found.""~D item~:P found." n) +(format-test "three dogs are here." "~R dog~:[s are~; is~] here." n (= n 1)) +(format-test "three dogs are here." "~R dog~:*~[s are~; is~:;s are~] here." n) +(format-test "Here are three puppies.""Here ~[are~;is~:;are~] ~:*~R pupp~:@P." n) +(format-test "7 tries/1 win" "~D tr~:@P/~D win~:P" 7 1) +(format-test "1 try/0 wins" "~D tr~:@P/~D win~:P" 1 0) +(format-test "1 try/3 wins" "~D tr~:@P/~D win~:P" 1 3) + +;; ~t +(format-test " foo" "~8Tfoo") +#+xedit (format-test " foo" "~8,3Tfoo") +(format-test " foo" "~8,3@Tfoo") +(format-test " foo" "~1,3@Tfoo") + +;; ~* +(format-test "2" "~*~D" 1 2 3 4) +(format-test "4" "~3*~D" 1 2 3 4) +(format-test "2" "~3*~2:*~D" 1 2 3 4) +(format-test "4 3 2 1 2 3 4" "~3@*~D ~2@*~D ~1@*~D ~0@*~D ~D ~D ~D" 1 2 3 4) + +;; ~? +(format-test "<Foo 5> 7" "~? ~D" "<~A ~D>" '("Foo" 5) 7) +(format-test "<Foo 5> 7" "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) +(format-test "<Foo 5> 7" "~@? ~D" "<~A ~D>" "Foo" 5 7) +(format-test "<Foo 5> 14" "~@? ~D" "<~A ~D>" "Foo" 5 14 7) + + +(format-error "~:[abc~:@(def~;ghi~:@(jkl~]mno~)" 1) +(format-error "~?ghi~)" "abc~@(def") + + +;; ~(...~) +(format-test "XIV xiv" "~@R ~(~@R~)" 14 14) +(format-test "Zero errors detected." "~@(~R~) error~:P detected." 0) +(format-test "One error detected." "~@(~R~) error~:P detected." 1) +(format-test "Twenty-three errors detected." "~@(~R~) error~:P detected." 23) + +;; ~[...~] +(format-test "Persian Cat" "~[Siamese~;Manx~;Persian~] Cat" 2) +(format-test " Cat" "~[Siamese~;Manx~;Persian~] Cat" 3) +(format-test "Siamese Cat" "~[Siamese~;Manx~;Persian~] Cat" 0) +(setq *print-level* nil *print-length* 5) +(format-test " print length = 5" + "~@[ print level = ~D~]~@[ print length = ~D~]" *print-level* *print-length*) +(setq foo "Items:~#[ none~; ~S~; ~S and ~S~:;~@{ ~#[~;and ~]~S~^,~}~].") +(format-test "Items: none." foo) +(format-test "Items: FOO." foo 'foo) +(format-test "Items: FOO and BAR." foo 'foo 'bar) +(format-test "Items: FOO, BAR, and BAZ." foo 'foo 'bar 'baz) +(format-test "Items: FOO, BAR, BAZ, and QUUX." foo 'foo 'bar 'baz 'quux) + +;; ~{...~} +(format-test "The winners are: FRED HARRY JILL." + "The winners are:~{ ~S~}." '(fred harry jill)) +(format-test "Pairs: <A,1> <B,2> <C,3>." "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3)) +(format-test "Pairs: <A,1> <B,2> <C,3>." + "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3))) +(format-test "Pairs: <A,1> <B,2> <C,3>." + "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3)) + +;; ~<...~> +(format-test "foo bar" "~10<foo~;bar~>") +(format-test " foo bar" "~10:<foo~;bar~>") +(format-test " foo bar " "~10:@<foo~;bar~>") +(format-test " foobar" "~10<foobar~>") +(format-test " foobar" "~10:<foobar~>") +(format-test "foobar " "~10@<foobar~>") +(format-test " foobar " "~10:@<foobar~>") + +;; ~^ +(setq donestr "Done.~^ ~D warning~:P.~^ ~D error~:P.") +(format-test "Done." donestr) +(format-test "Done. 3 warnings." donestr 3) +(format-test "Done. 1 warning. 5 errors." donestr 1 5) +(format-test "/HOT .../HAMBURGER/ICE .../FRENCH ..." + "~:{/~S~^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries))) +(format-test "/HOT .../HAMBURGER .../ICE .../FRENCH" + "~:{/~S~:^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries))) +(format-test "/HOT .../HAMBURGER" + "~:{/~S~:#^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries))) +(setq tellstr "~@(~@[~R~]~^ ~A.~)") +(format-test "Twenty-three" tellstr 23) +(format-test " Losers." tellstr nil "losers") +(format-test "Twenty-three losers." tellstr 23 "losers") +(format-test " FOO" "~15<~S~;~^~S~;~^~S~>" 'foo) +(format-test "FOO BAR" "~15<~S~;~^~S~;~^~S~>" 'foo 'bar) +(format-test "FOO BAR BAZ" "~15<~S~;~^~S~;~^~S~>" 'foo 'bar 'baz) + + +;; make-pathname - function +(equal-test #P"/public/games/chess.db" + #'make-pathname :directory '(:absolute "public" "games") + :name "chess" :type "db") +(equal-test #P"/etc/passwd" #'list* #P"/etc/passwd") +(setq path (make-pathname :directory '(:absolute "public" "games") + :name "chess" :type "db")) +(eq-test path #'pathname path) +(eq-test nil #'pathname-host path) +(eq-test nil #'pathname-device path) +(equal-test '(:absolute "public" "games") #'pathname-directory path) +(equal-test "chess" #'pathname-name path) +(equal-test "db" #'pathname-type path) +(eq-test nil #'pathname-version path) +(equal-test #P"/tmp/foo.txt" #'make-pathname :defaults "/tmp/foo.txt") + +#+xedit (equal-test #P"/tmp/foo.txt" #'pathname "///tmp///foo.txt") +;; XXX changed to remove extra separators +;; (equal-test #P"///tmp///foo.txt" #'pathname "///tmp///foo.txt") + + +;; merge-pathnames - function +(equal-test #P"/tmp/foo.txt" #'merge-pathnames "/tmp/foo" "/tmp/foo.txt") +(equal-test #P"/tmp/foo.txt" #'merge-pathnames "foo" "/tmp/foo.txt") +(equal-test #P"/tmp/foo/bar.txt" #'merge-pathnames "foo/bar" "/tmp/foo.txt") + +;; namestring - function +(setq path (merge-pathnames "foo/bar" "/tmp/foo.txt")) +(equal-test "/tmp/foo/bar.txt" #'namestring path) +(equal-test "" #'host-namestring path) +(equal-test "/tmp/foo/" #'directory-namestring path) +(equal-test "bar.txt" #'file-namestring path) +(equal-test "/tmp/foo/bar.txt" #'enough-namestring path) +(equal-test "foo/bar.txt" #'enough-namestring path "/tmp/") +(equal-test "bar.txt" #'enough-namestring path "/tmp/foo/") +(equal-test "foo/bar.txt" #'enough-namestring path "/tmp/foo") + +;; parse-namestring - function +(equal-eval '(#P"foo" 3) '(multiple-value-list (parse-namestring "foo"))) +(equal-eval '(#P"foo" 0) '(multiple-value-list (parse-namestring #P"foo"))) + + + +;; read - function +(setq is (make-string-input-stream " foo ")) +(eq-test t #'streamp is) +(eq-test t #'input-stream-p is) +(eq-test nil #'output-stream-p is) +(eq-test 'foo #'read is) +(eq-test t #'close is) +(setq is (make-string-input-stream "xfooy" 1 4)) +(eq-test 'foo #'read is) +(eq-test t #'close is) +(setq is (make-string-input-stream "")) +(eq-test nil #'read is nil) +(eq-test 'end-of-string #'read is nil 'end-of-string) +(close is) +(error-test #'read is) +(error-test #'read is nil) +(error-test #'read is nil 'end-of-string) +(eq-test t #'streamp is) +(eq-test nil #'input-stream-p is) +(eq-test nil #'streamp "test") +(error-test #'input-stream-p "test") + +;; read-char - function +(setq is (make-string-input-stream "0123")) +(setq test nil) +(equal-eval '(#\0 #\1 #\2 #\3) + '(do ((c (read-char is) (read-char is nil 'the-end))) + ((not (characterp c)) test) + (setq test (append test (list c))))) +(close is) +(setq is (make-string-input-stream "abc")) +(eql-test #\a #'read-char is) +(eql-test #\b #'read-char is) +(eql-test #\c #'read-char is) +(error-test #'read-char is) +(eq-test nil #'read-char is nil) +(eq-test :end-of-string #'read-char is nil :end-of-string) +(eq-test t #'close is) + +;; read-char-no-hang - function +(setq is (make-string-input-stream "0123")) +(setq test nil) +(equal-eval '(#\0 #\1 #\2 #\3) + '(do ((c (read-char-no-hang is) (read-char-no-hang is nil 'the-end))) + ((not (characterp c)) test) + (setq test (append test (list c))))) +(close is) +(setq is (make-string-input-stream "abc")) +(eql-test #\a #'read-char-no-hang is) +(eql-test #\b #'read-char-no-hang is) +(eql-test #\c #'read-char-no-hang is) +(error-test #'read-char-no-hang is) +(eq-test nil #'read-char-no-hang is nil) +(eq-test :end-of-string #'read-char-no-hang is nil :end-of-string) +(eq-test t #'close is) +#+(and xedit unix) +(progn + ;; wait one second for input pooling every 0.1 seconds + (defun wait-for-cat () + (let ((time 0.0)) + (loop + (and (listen is) (return)) + (sleep 0.1) + (when (>= (incf time 0.1) 1.0) + (format t "Cat is sleeping~%") + (return))))) + (setq is (make-pipe "/bin/cat" :direction :io)) + (equal-test "dog" #'write-line "dog" is) + (wait-for-cat) + (eql-test #\d #'read-char-no-hang is) + (eql-test #\o #'read-char-no-hang is) + (eql-test #\g #'read-char-no-hang is) + (eql-test #\Newline #'read-char-no-hang is) + (eq-test nil #'read-char-no-hang is) + (eq-test nil #'read-char-no-hang is) + (equal-test "mouse" #'write-line "mouse" is) + (wait-for-cat) + (eql-test #\m #'read-char-no-hang is) + (eql-test #\o #'read-char-no-hang is) + (eql-test #\u #'read-char-no-hang is) + (eql-test #\s #'read-char-no-hang is) + (eql-test #\e #'read-char-no-hang is) + (eql-test #\Newline #'read-char-no-hang is) + (eq-test nil #'read-char-no-hang is) + (eq-test t #'close is) + (error-test #'read-char-no-hang is) + (error-test #'read-char-no-hang is nil) + (error-test #'read-char-no-hang is nil t) +) + +;; read-from-string - function +(equal-eval '(3 5) + '(multiple-value-list (read-from-string " 1 3 5" t nil :start 2))) +(equal-eval '((a b c) 7) + '(multiple-value-list (read-from-string "(a b c)"))) +(error-test #'read-from-string "") +(eq-test nil #'read-from-string "" nil) +(eq-test 'end-of-file #'read-from-string "" nil 'end-of-file) + +;; read-line - function +(setq is (make-string-input-stream "line 1 +line 2")) +(equal-eval '("line 1" nil) '(multiple-value-list (read-line is))) +(equal-eval '("line 2" t) '(multiple-value-list (read-line is))) +(error-test #'read-line is) +(equal-eval '(nil t) '(multiple-value-list (read-line is nil))) +(equal-eval '(end-of-string t) + '(multiple-value-list (read-line is nil 'end-of-string))) + + +;; write - function +;; XXX several write options still missing +(setq os (make-string-output-stream)) +(equal-test '(1 2 3 4) #'write '(1 2 3 4) :stream os) +(equal-test "(1 2 3 4)" #'get-output-stream-string os) +(eq-test t #'streamp os) +(eq-test t #'output-stream-p os) +(eq-test nil #'input-stream-p os) +(equal-test '(:foo :bar) #'write '(:foo :bar) :case :downcase :stream os) +(equal-test "(:foo :bar)" #'get-output-stream-string os) +(equal-test '(:foo :bar) #'write '(:foo :bar) :case :capitalize :stream os) +(equal-test "(:Foo :Bar)" #'get-output-stream-string os) +(equal-test '(:foo :bar) #'write '(:foo :bar) :case :upcase :stream os) +(equal-test "(:FOO :BAR)" #'get-output-stream-string os) +(equal-test '(foo bar baz) #'write '(foo bar baz) :length 2 :stream os) +(equal-test "(FOO BAR ...)" #'get-output-stream-string os) +(equal-test '(foo (bar) baz) #'write '(foo (bar) baz) :level 1 :stream os) +(equal-test "(FOO # BAZ)" #'get-output-stream-string os) +(setq circle '#1=(1 #1#)) +(eq-test circle #'write circle :circle t :stream os) +(equal-test "#1=(1 #1#)" #'get-output-stream-string os) +(eql-test #\Space #'write #\Space :stream os) +(equal-test "#\\Space" #'get-output-stream-string os) +(eql-test #\Space #'write #\Space :escape nil :stream os) +(equal-test " " #'get-output-stream-string os) +(eq-test t #'close os) +(eq-test nil #'output-stream-p os) +(error-test #'output-stream-p "test") +(error-test #'write 'foo :stream "bar") + +;; fresh-line - function +(setq os (make-string-output-stream)) +(equal-test "some text" #'write-string "some text" os) +(eq-test t #'fresh-line os) +(eq-test nil #'fresh-line os) +(equal-test "more text" #'write-string "more text" os) +(equal-test "some text +more text" #'get-output-stream-string os) +(equal-test nil #'fresh-line os) +(equal-test nil #'fresh-line os) +(equal-test "" #'get-output-stream-string os) +(close os) +(error-test #'fresh-line 1) + +;; prin1 - function +;; (prin1 object stream) == +;; (write object :stream stream :escape t) +(setq p-os (make-string-output-stream) w-os (make-string-output-stream)) +(dolist (object (list #\a 1 "string" 2.5d0 '(a . b) '(a b c) #P"foo" + *package* *standard-input* #c(1 2) #(1 2 3) + (make-hash-table))) + (eq-test object #'prin1 object p-os) + (eq-test object #'write object :stream w-os :escape t) + (equal-test (get-output-stream-string p-os) + #'get-output-stream-string w-os)) +(close p-os) +(close w-os) +(error-test #'prin1 1 1) + +;; princ - function +;; (princ object stream) == +;; (write object :stream stream :escape nil :readably nil) +;; XXX readably not yet implemented +(setq p-os (make-string-output-stream) w-os (make-string-output-stream)) +(dolist (object (list #\a 1 "string" 2.5d0 '(a . b) '(a b c) #P"foo" + *package* *standard-input* #c(1 2) #(1 2 3) + (make-hash-table))) + (eq-test object #'princ object p-os) + (eq-test object #'write object :stream w-os :escape nil) + (equal-test (get-output-stream-string p-os) + #'get-output-stream-string w-os)) +(close p-os) +(close w-os) +(error-test #'princ 1 1) + +;; print - function +;; (print object stream) == +;; (progn +;; (terpri stream) +;; (write object :stream stream :escape t) +;; (write-char #\Space stream)) +(setq p-os (make-string-output-stream) w-os (make-string-output-stream)) +(dolist (object (list #\a 1 "string" 2.5d0 '(a . b) '(a b c) #P"foo" + *package* *standard-input* #c(1 2) #(1 2 3) + (make-hash-table))) + (eq-test object #'print object p-os) + (progn + (eq-test nil #'terpri w-os) + (eq-test object #'write object :stream w-os :escape t) + (eql-test #\Space #'write-char #\Space w-os)) + (equal-test (get-output-stream-string p-os) + #'get-output-stream-string w-os)) +(close p-os) +(close w-os) +(error-test #'print 1 1) + +;; terpri - function +(setq os (make-string-output-stream)) +(equal-test "some text" #'write-string "some text" os) +(eq-test nil #'terpri os) +(eq-test nil #'terpri os) +(equal-test "more text" #'write-string "more text" os) +(equal-test "some text + +more text" #'get-output-stream-string os) +(equal-test nil #'terpri os) +(equal-test nil #'terpri os) +(equal-test " + +" #'get-output-stream-string os) +(close os) +(error-test #'terpri 1) + +;; write-char - function +(equal-eval "a b" + '(with-output-to-string (s) + (write-char #\a s) + (write-char #\Space s) + (write-char #\b s))) +(error-test #'write-char 1) + +;; write-line - function +(setq os (make-string-output-stream)) +(equal-test "text" #'write-line "text" os) +(equal-test "text +" #'get-output-stream-string os) +(eql-test #\< #'write-char #\< os) +(equal-test "text" #'write-line "text" os :start 1 :end 3) +(eql-test #\> #'write-char #\> os) +(equal-test "<ex +>" #'get-output-stream-string os) +(error-test #'write-line 1) +(close os) + +;; write-string - function +(setq os (make-string-output-stream)) +(equal-test "text" #'write-string "text" os) +(equal-test "text" #'get-output-stream-string os) +(eql-test #\< #'write-char #\< os) +(equal-test "text" #'write-string "text" os :start 1 :end 3) +(eql-test #\> #'write-char #\> os) +(equal-test "<ex>" #'get-output-stream-string os) +(error-test #'write-string #\a) +(close os) + + +;; open - function +(setq name #P"delete-me.text") +(bool-eval t '(setq file (open name :direction :output))) +(equal-test "some text" #'write-line "some text" file) +(close file) +(equal-test "delete-me.text" #'file-namestring (truename name)) +(setq file (open name :direction :output :if-exists :rename)) +(equal-test "other text" #'write-line "other text" file) +(close file) +(equal-test "delete-me.text" #'file-namestring (truename name)) +;; Clisp returns the pathname if the file exists +#+xedit (eq-test t #'delete-file name) +#+clisp (bool-test t #'delete-file name) +(setq backup + #+xedit "delete-me.text~" + #+clisp "delete-me.text%" + #+cmu "delete-me.text.BAK") +(bool-test t #'delete-file backup) +(eq-test nil #'delete-file name) +(eq-test nil #'directory name) +(eq-test nil #'directory backup) +;; test append +(with-open-file (s name :direction :output :if-exists :error) + (write-line "line 1" s)) +(with-open-file (s name :direction :output :if-exists :append) + (write-line "line 2" s)) +(with-open-file (s name :direction :input) + (equal-test "line 1" #'read-line s) + (equal-test "line 2" #'read-line s) + (eq-test 'eof #'read-line s nil 'eof) +) +(bool-test t #'delete-file name) +;; test overwrite +(with-open-file (s name :direction :output :if-exists :error) + (write-line "overwrite-me" s)) +(with-open-file (s name :direction :output :if-exists :overwrite) + (write-line "some-text" s)) +(with-open-file (s name :direction :input) + (equal-test "some-text" #'read-line s) + (eq-test 'eof #'read-line s nil 'eof)) +;; test check for file existence +(eq-test nil #'open name :direction :output :if-exists nil) +(error-test #'open name :direction :output :if-exists :error) +(bool-test t #'delete-file name) +;; test check for no file existence +(eq-test nil #'open name :direction :output :if-does-not-exist nil) +(error-test #'open name :direction :output :if-does-not-exist :error) +#+xedit ;; test io -- not sure if this is the expected behaviour +(progn + (with-open-file (s name :direction :io) + (write-line "foo" s) + (write-line "bar" s)) + (with-open-file (s name :direction :io :if-exists :append) + (equal-test "foo" #'read-line s) + (equal-test "bar" #'read-line s) + (eq-test 'eof #'read-line s nil 'eof) + (write-line "baz" s)) + (with-open-file (s name :direction :io :if-exists :append) + (equal-test "foo" #'read-line s) + (equal-test "bar" #'read-line s) + (equal-test "baz" #'read-line s) + (eq-test 'eof #'read-line s nil 'eof)) + (bool-test t #'delete-file name) +) + +;; delete-file - function +(eq-eval nil + '(with-open-file (s "delete-me.text" :direction :output :if-exists :error))) +(eq-test t #'pathnamep (setq p (probe-file "delete-me.text"))) +(bool-test t #'delete-file p) +(eq-test nil #'probe-file "delete-me.text") +(bool-eval t + '(with-open-file (s "delete-me.text" :direction :output :if-exists :error) + (delete-file s))) +(bool-test nil #'probe-file "delete-me.text") + +;; rename-file - function +(setq name "foo.bar") +(bool-eval t '(setq file (open name :direction :output :if-exists :error))) +(eq-test t #'close file) +(setq result (multiple-value-list (rename-file name "bar.foo"))) +(eql-test 3 #'length result) +(eq-test t #'pathnamep (first result)) +(eq-test t #'pathnamep (second result)) +(eq-test t #'pathnamep (third result)) +(equal-test (third result) #'truename "bar.foo") +(eq-test nil #'directory name) +(eq-test nil #'directory (second result)) +(equal-test (list (third result)) #'directory (third result)) +(error-test #'truename name) +(error-test #'truename (second result)) +(eq-test nil #'probe-file name) +(bool-test t #'probe-file (first result)) +(eq-test nil #'probe-file (second result)) +(bool-test t #'probe-file (third result)) +(bool-test t #'delete-file "bar.foo") +(eq-test nil #'delete-file (third result)) +(eq-test nil #'delete-file (second result)) diff --git a/lisp/test/widgets.lsp b/lisp/test/widgets.lsp new file mode 100644 index 0000000..be68788 --- /dev/null +++ b/lisp/test/widgets.lsp @@ -0,0 +1,71 @@ +;; +;; Copyright (c) 2001 by The XFree86 Project, Inc. +;; +;; Permission is hereby granted, free of charge, to any person obtaining a +;; copy of this software and associated documentation files (the "Software"), +;; to deal in the Software without restriction, including without limitation +;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;; and/or sell copies of the Software, and to permit persons to whom the +;; Software is furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in +;; all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;; THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF +;; OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. +;; +;; Except as contained in this notice, the name of the XFree86 Project shall +;; not be used in advertising or otherwise to promote the sale, use or other +;; dealings in this Software without prior written authorization from the +;; XFree86 Project. +;; +;; Author: Paulo César Pereira de Andrade +;; +;; +;; $XFree86: xc/programs/xedit/lisp/test/widgets.lsp,v 1.3 2002/11/08 08:01:01 paulo Exp $ +;; +(require "xaw") +(require "xt") + +(defun quit-callback (widget user call) (quit)) + +(setq toplevel + (xt-app-initialize 'appcontext "Widgets" + '(("title" . "Widgets (without customization)")))) + +(setq vpane + (xt-create-managed-widget "vpane" paned-widget-class toplevel)) +(setq form + (xt-create-managed-widget "form" form-widget-class vpane)) +(xt-create-managed-widget "command" command-widget-class form + '(("label" . "Command Widget"))) +(xt-create-managed-widget "label" label-widget-class form + '(("label" . "Label Widget") ("fromVert" . "command"))) +(xt-create-managed-widget "button" menu-button-widget-class form + '(("label" . "MenuButton Widget") ("fromVert" . "label"))) + +(setq popup + (xt-create-managed-widget "menu" simple-menu-widget-class toplevel)) +(xt-create-managed-widget "smebsb" sme-bsb-object-class popup + '(("label" . "SmeBSB Object"))) +(xt-create-managed-widget "smeline" sme-line-object-class popup) +(xt-create-managed-widget "smebsb2" sme-bsb-object-class popup + '(("label" . "SmeBSB Object two"))) + +(xt-create-managed-widget "toggle" toggle-widget-class form + '(("label" . "Toggle Widget") ("fromVert" . "button"))) +(xt-create-managed-widget "repeater" repeater-widget-class form + '(("label" . "Repeater Widget") ("fromVert" . "toggle"))) + +(setq quit + (xt-create-managed-widget "quit" command-widget-class vpane + '(("label" . "Quit")))) +(xt-add-callback quit "callback" 'quit-callback) + +(xt-realize-widget toplevel) +(xt-app-main-loop appcontext) |