427 lines
7.1 KiB
Common Lisp
427 lines
7.1 KiB
Common Lisp
;;;; Anaphora: The Anaphoric Macro Package from Hell
|
|
;;;;
|
|
;;;; This been placed in Public Domain by the author,
|
|
;;;; Nikodemus Siivola <nikodemus@random-state.net>
|
|
|
|
(defpackage :anaphora-test
|
|
(:use :cl :anaphora :rt))
|
|
|
|
(in-package :anaphora-test)
|
|
|
|
(deftest alet.1
|
|
(alet (1+ 1)
|
|
(1+ it))
|
|
3)
|
|
|
|
(deftest alet.2
|
|
(alet (1+ 1)
|
|
it
|
|
(1+ it))
|
|
3)
|
|
|
|
(deftest slet.1
|
|
(let ((x (list 1 2 3)))
|
|
(slet (car x)
|
|
(incf it) (values it x)))
|
|
2 (2 2 3))
|
|
|
|
(deftest aand.1
|
|
(aand (+ 1 1)
|
|
(+ 1 it))
|
|
3)
|
|
|
|
(deftest aand.2
|
|
(aand 1 t (values it 2))
|
|
1 2)
|
|
|
|
(deftest aand.3
|
|
(let ((x 1))
|
|
(aand (incf x) t t (values t it)))
|
|
t 2)
|
|
|
|
(deftest aand.4
|
|
(aand 1 (values t it))
|
|
t 1)
|
|
|
|
#+(or)
|
|
;;; bug or a feature? forms like this expand to
|
|
;;;
|
|
;;; (let ((it (values ...))) (and it ...))
|
|
;;;
|
|
(deftest aand.5
|
|
(aand (values nil t) it)
|
|
nil t)
|
|
|
|
(deftest sor.1
|
|
(let ((x (list nil)))
|
|
(sor (car x)
|
|
(setf it t))
|
|
x)
|
|
(t))
|
|
|
|
(deftest aif.1
|
|
(aif (+ 1 1)
|
|
(+ 1 it)
|
|
:never)
|
|
3)
|
|
|
|
(deftest aif.2
|
|
(let ((x 0))
|
|
(aif (incf x)
|
|
it
|
|
:never))
|
|
1)
|
|
|
|
(deftest aif.3
|
|
(let ((x 0))
|
|
(aif (eval `(and ,(incf x) nil))
|
|
:never
|
|
(list it x)))
|
|
(nil 1))
|
|
|
|
(deftest sif.1
|
|
(let ((x (list nil)))
|
|
(sif (car x)
|
|
(setf it :oops)
|
|
(setf it :yes!))
|
|
(car x))
|
|
:yes!)
|
|
|
|
(deftest sif.2
|
|
(let ((x (list t)))
|
|
(sif (car x)
|
|
(setf it :yes!)
|
|
(setf it :oops))
|
|
(car x))
|
|
:yes!)
|
|
|
|
(deftest sif.3
|
|
(sif (list 1 2 3)
|
|
(sif (car it)
|
|
(setf it 'a)
|
|
:foo))
|
|
a)
|
|
|
|
(deftest sif.4
|
|
(progn
|
|
(defclass sif.4 ()
|
|
((a :initform (list :sif))))
|
|
(with-slots (a)
|
|
(make-instance 'sif.4)
|
|
(sif a
|
|
(sif (car it)
|
|
it))))
|
|
:sif)
|
|
|
|
(deftest asif.1
|
|
(let ((x (list 0)))
|
|
(asif (incf (car x))
|
|
it
|
|
(list :oops it)))
|
|
1)
|
|
|
|
(deftest asif.2
|
|
(let ((x (list nil)))
|
|
(asif (car x)
|
|
(setf x :oops)
|
|
(setf it :yes!))
|
|
x)
|
|
(:yes!))
|
|
|
|
(deftest awhen.1
|
|
(let ((x 0))
|
|
(awhen (incf x)
|
|
(+ 1 it)))
|
|
2)
|
|
|
|
(deftest awhen.2
|
|
(let ((x 0))
|
|
(or (awhen (not (incf x))
|
|
t)
|
|
x))
|
|
1)
|
|
|
|
(deftest swhen.1
|
|
(let ((x 0))
|
|
(swhen x
|
|
(setf it :ok))
|
|
x)
|
|
:ok)
|
|
|
|
(deftest swhen.2
|
|
(let ((x nil))
|
|
(swhen x
|
|
(setf it :oops))
|
|
x)
|
|
nil)
|
|
|
|
(deftest sunless.1
|
|
(let ((x nil))
|
|
(sunless x
|
|
(setf it :ok))
|
|
x)
|
|
:ok)
|
|
|
|
(deftest sunless.2
|
|
(let ((x t))
|
|
(sunless x
|
|
(setf it :oops))
|
|
x)
|
|
t)
|
|
|
|
(deftest acase.1
|
|
(let ((x 0))
|
|
(acase (incf x)
|
|
(0 :no)
|
|
(1 (list :yes it))
|
|
(2 :nono)))
|
|
(:yes 1))
|
|
|
|
(deftest scase.1
|
|
(let ((x (list 3)))
|
|
(scase (car x)
|
|
(0 (setf it :no))
|
|
(3 (setf it :yes!))
|
|
(t (setf it :nono)))
|
|
x)
|
|
(:yes!))
|
|
|
|
(deftest aecase.1
|
|
(let ((x (list :x)))
|
|
(aecase (car x)
|
|
(:y :no)
|
|
(:x (list it :yes))))
|
|
(:x :yes))
|
|
|
|
(deftest aecase.2
|
|
(nth-value 0 (ignore-errors
|
|
(let ((x (list :x)))
|
|
(secase (car x)
|
|
(:y :no)))
|
|
:oops))
|
|
nil)
|
|
|
|
(deftest secase.1
|
|
(let ((x (list :x)))
|
|
(secase (car x)
|
|
(:y (setf it :no))
|
|
(:x (setf it :yes)))
|
|
x)
|
|
(:yes))
|
|
|
|
(deftest secase.2
|
|
(nth-value 0 (ignore-errors
|
|
(let ((x (list :x)))
|
|
(secase (car x)
|
|
(:y (setf it :no)))
|
|
:oops)))
|
|
nil)
|
|
|
|
(deftest accase.1
|
|
(let ((x (list :x)))
|
|
(accase (car x)
|
|
(:y :no)
|
|
(:x (list it :yes))))
|
|
(:x :yes))
|
|
|
|
(deftest accase.2
|
|
(let ((x (list :x)))
|
|
(handler-bind ((type-error (lambda (e) (store-value :z e))))
|
|
(accase (car x)
|
|
(:y (setf x :no))
|
|
(:z (setf x :yes))))
|
|
x)
|
|
:yes)
|
|
|
|
(deftest accase.3
|
|
(let ((x (list :x)))
|
|
(accase (car x)
|
|
(:x (setf it :foo)))
|
|
x)
|
|
(:x))
|
|
|
|
(deftest sccase.1
|
|
(let ((x (list :x)))
|
|
(sccase (car x)
|
|
(:y (setf it :no))
|
|
(:x (setf it :yes)))
|
|
x)
|
|
(:yes))
|
|
|
|
(deftest sccase.2
|
|
(let ((x (list :x)))
|
|
(handler-bind ((type-error (lambda (e) (store-value :z e))))
|
|
(sccase (car x)
|
|
(:y (setf it :no))
|
|
(:z (setf it :yes))))
|
|
x)
|
|
(:yes))
|
|
|
|
(deftest atypecase.1
|
|
(atypecase 1.0
|
|
(integer (+ 2 it))
|
|
(float (1- it)))
|
|
0.0)
|
|
|
|
(deftest atypecase.2
|
|
(atypecase "Foo"
|
|
(fixnum :no)
|
|
(hash-table :nono))
|
|
nil)
|
|
|
|
(deftest stypecase.1
|
|
(let ((x (list 'foo)))
|
|
(stypecase (car x)
|
|
(vector (setf it :no))
|
|
(symbol (setf it :yes)))
|
|
x)
|
|
(:yes))
|
|
|
|
(deftest stypecase.2
|
|
(let ((x (list :bar)))
|
|
(stypecase (car x)
|
|
(fixnum (setf it :no)))
|
|
x)
|
|
(:bar))
|
|
|
|
(deftest aetypecase.1
|
|
(aetypecase 1.0
|
|
(fixnum (* 2 it))
|
|
(float (+ 2.0 it))
|
|
(symbol :oops))
|
|
3.0)
|
|
|
|
(deftest aetypecase.2
|
|
(nth-value 0 (ignore-errors
|
|
(aetypecase 1.0
|
|
(symbol :oops))))
|
|
nil)
|
|
|
|
(deftest setypecase.1
|
|
(let ((x (list "Foo")))
|
|
(setypecase (car x)
|
|
(symbol (setf it :no))
|
|
(string (setf it "OK"))
|
|
(integer (setf it :noon)))
|
|
x)
|
|
("OK"))
|
|
|
|
(deftest setypecase.2
|
|
(nth-value 0 (ignore-errors
|
|
(setypecase 'foo
|
|
(string :nono))))
|
|
nil)
|
|
|
|
(deftest actypecase.1
|
|
(actypecase :foo
|
|
(string (list :string it))
|
|
(keyword (list :keyword it))
|
|
(symbol (list :symbol it)))
|
|
(:keyword :foo))
|
|
|
|
(deftest actypecase.2
|
|
(handler-bind ((type-error (lambda (e) (store-value "OK" e))))
|
|
(actypecase 0
|
|
(string it)))
|
|
"OK")
|
|
|
|
(deftest sctypecase.1
|
|
(let ((x (list 0)))
|
|
(sctypecase (car x)
|
|
(symbol (setf it 'symbol))
|
|
(bit (setf it 'bit)))
|
|
x)
|
|
(bit))
|
|
|
|
(deftest sctypecase.2
|
|
(handler-bind ((type-error (lambda (e) (store-value "OK" e))))
|
|
(let ((x (list 0)))
|
|
(sctypecase (car x)
|
|
(string (setf it :ok)))
|
|
x))
|
|
(:ok))
|
|
|
|
(deftest acond.1
|
|
(acond (:foo))
|
|
:foo)
|
|
|
|
(deftest acond.2
|
|
(acond ((null 1) (list :no it))
|
|
((+ 1 2) (list :yes it))
|
|
(t :nono))
|
|
(:yes 3))
|
|
|
|
(deftest acond.3
|
|
(acond ((= 1 2) :no)
|
|
(nil :nono)
|
|
(t :yes))
|
|
:yes)
|
|
|
|
;; Test COND with multiple forms in the implicit progn.
|
|
(deftest acond.4
|
|
(let ((foo))
|
|
(acond ((+ 2 2) (setf foo 38) (incf foo it) foo)
|
|
(t nil)))
|
|
42)
|
|
|
|
(deftest scond.1
|
|
(let ((x (list nil))
|
|
(y (list t)))
|
|
(scond ((car x) (setf it :nono))
|
|
((car y) (setf it :yes)))
|
|
(values x y))
|
|
(nil)
|
|
(:yes))
|
|
|
|
(deftest scond.2
|
|
(scond ((= 1 2) :no!))
|
|
nil)
|
|
|
|
(deftest aprog.1
|
|
(aprog1 :yes
|
|
(unless (eql it :yes) (error "Broken."))
|
|
:no)
|
|
:yes)
|
|
|
|
(deftest aif.sif.1
|
|
(sif 1 (aif it it))
|
|
1)
|
|
|
|
(deftest aif.sif.2
|
|
(aif 1 (sif it it))
|
|
1)
|
|
|
|
(deftest aif.sif.3
|
|
(aif (list 1 2 3)
|
|
(sif (car it)
|
|
(setf it 'a)
|
|
:foo))
|
|
a)
|
|
|
|
(deftest alet.slet.1
|
|
(slet 42 (alet 43 (slet it it)))
|
|
43)
|
|
|
|
|
|
(defun elt-like (index seq)
|
|
(elt seq index))
|
|
|
|
(define-setf-expander elt-like (index seq)
|
|
(let ((index-var (gensym "index"))
|
|
(seq-var (gensym "seq"))
|
|
(store (gensym "store")))
|
|
(values (list index-var seq-var)
|
|
(list index seq)
|
|
(list store)
|
|
`(if (listp ,seq-var)
|
|
(setf (nth ,index-var ,seq-var) ,store)
|
|
(setf (aref ,seq-var ,index-var) ,store))
|
|
`(if (listp ,seq-var)
|
|
(nth ,index-var ,seq-var)
|
|
(aref ,seq-var ,index-var)))))
|
|
|
|
(deftest symbolic.setf-expansion.1
|
|
(let ((cell (list nil)))
|
|
(sor (elt-like 0 cell) (setf it 1))
|
|
(equal cell '(1)))
|
|
t)
|