├── .travis.yml ├── LICENSE ├── README.md ├── anaphora.asd ├── anaphora.lisp ├── early.lisp ├── packages.lisp ├── symbolic.lisp └── tests.lisp /.travis.yml: -------------------------------------------------------------------------------- 1 | language: lisp 2 | sudo: required 3 | 4 | env: 5 | matrix: 6 | - LISP=abcl 7 | - LISP=allegro 8 | - LISP=sbcl 9 | - LISP=sbcl32 10 | - LISP=ccl 11 | - LISP=ccl32 12 | - LISP=ecl 13 | - LISP=clisp 14 | - LISP=clisp32 15 | - LISP=cmucl 16 | 17 | matrix: 18 | allow_failures: 19 | # Disabled until issue #6 is fixed. 20 | - env: LISP=clisp 21 | - env: LISP=clisp32 22 | # Disabled until cim supports cmucl. 23 | - env: LISP=cmucl 24 | 25 | install: 26 | - curl -L https://github.com/tokenrove/cl-travis/raw/master/install.sh | sh 27 | - if [ "${LISP:(-2)}" = "32" ]; then 28 | sudo apt-get install -qq -y libc6-dev-i386; 29 | fi 30 | 31 | script: 32 | - cl -e '(ql:quickload :anaphora/test) 33 | (unless (asdf:oos :test-op :anaphora/test) 34 | (uiop:quit 1))' 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | ;;;; This file is part of the Anaphora package Common Lisp, 2 | ;;;; and has been placed in Public Domain by the author, 3 | ;;;; Nikodemus Siivola 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Anaphora 2 | 3 | Anaphora is the anaphoric macro collection from Hell: it includes many 4 | new fiends in addition to old friends like `AIF` and `AWHEN`. 5 | Anaphora has been placed in Public Domain by the author, [Nikodemus 6 | Siivola](mailto:nikodemus@random-state.net). 7 | 8 | # Installation 9 | 10 | Use [quicklisp](http://www.quicklisp.org/), and simply: 11 | 12 | ``` 13 | CL-USER(1): (ql:quickload "anaphora") 14 | ``` 15 | 16 | # Documentation 17 | 18 | Anaphoric macros provide implicit bindings for various 19 | operations. Extensive use of anaphoric macros is not good style, 20 | and probably makes you go blind as well — there's a reason why 21 | Anaphora claims to be from Hell. 22 | 23 | Anaphora provides two families of anaphoric macros, which can be 24 | identified by their names and packages (both families are also 25 | exported from the package `ANAPHORA`). The implicitly-bound symbol 26 | `ANAPHORA:IT` is also exported from all three packages. 27 | 28 | ## Basic anaphora 29 | 30 | #### Exported from package `ANAPHORA-BASIC` 31 | 32 | These bind their first argument to `IT` via `LET`. In case of `COND` 33 | all clauses have their test-values bound to `IT`. 34 | 35 | Variants: `AAND`, `ALET`, `APROG1`, `AIF`, `ACOND`, `AWHEN`, `ACASE`, 36 | `ACCASE`, `AECASE`, `ATYPECASE`, `ACTYPECASE`, and `AETYPECASE`. 37 | 38 | ## Symbol-macro anaphora 39 | 40 | #### Exported from package `ANAPHORA-SYMBOL` 41 | 42 | These bind their first argument (unevaluated) to `IT` via 43 | SYMBOL-`MACROLET.` 44 | 45 | Variants: `SOR`, `SLET`, `SIF`, `SCOND`, `SUNLESS`, 46 | `SWHEN`, `SCASE`, `SCCASE`, `SECASE`, `STYPECASE`, `SCTYPECASE`, 47 | `SETYPECASE`. 48 | 49 | Also: `ASIF`, which binds via `LET` for the 50 | then-clause, and `SYMBOL-MACROLET` for the else-clause. 51 | -------------------------------------------------------------------------------- /anaphora.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-lisp; -*- 2 | 3 | ;;;; Anaphora: The Anaphoric Macro Package from Hell 4 | ;;;; 5 | ;;;; This been placed in Public Domain by the author, 6 | ;;;; Nikodemus Siivola 7 | 8 | (defsystem :anaphora 9 | :version "0.9.8" 10 | :description "The Anaphoric Macro Package from Hell" 11 | :author "Nikodemus Siivola " 12 | :maintainer "Sean Whitton " 13 | :license "Public Domain" 14 | :components 15 | ((:file "packages") 16 | (:file "early" :depends-on ("packages")) 17 | (:file "symbolic" :depends-on ("early")) 18 | (:file "anaphora" :depends-on ("symbolic")))) 19 | 20 | (defsystem :anaphora/test 21 | :description "Tests for anaphora" 22 | :author "Nikodemus Siivola " 23 | :maintainer "Sean Whitton " 24 | :license "Public Domain" 25 | :depends-on (:anaphora :rt) 26 | :components ((:file "tests"))) 27 | 28 | (defmethod perform ((o test-op) (c (eql (find-system :anaphora)))) 29 | (test-system :anaphora/test)) 30 | 31 | (defmethod perform ((o test-op) (c (eql (find-system :anaphora/test)))) 32 | (or (symbol-call :rt '#:do-tests) 33 | (error "test-op failed"))) 34 | -------------------------------------------------------------------------------- /anaphora.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*- 2 | 3 | ;;;; Anaphora: The Anaphoric Macro Package from Hell 4 | ;;;; 5 | ;;;; This been placed in Public Domain by the author, 6 | ;;;; Nikodemus Siivola 7 | 8 | (in-package :anaphora) 9 | 10 | ;;; This was the original implementation of SYMBOLIC -- and still good 11 | ;;; for getting the basic idea. Brian Masterbrooks solution to 12 | ;;; infinite recusion during macroexpansion, that nested forms of this 13 | ;;; are subject to, is in symbolic.lisp. 14 | ;;; 15 | ;;; (defmacro symbolic (op test &body body &environment env) 16 | ;;; `(symbol-macrolet ((it ,test)) 17 | ;;; (,op it ,@body))) 18 | 19 | (defmacro alet (form &body body) 20 | "Binds the FORM to IT (via LET) in the scope of the BODY." 21 | `(anaphoric ignore-first ,form (progn ,@body))) 22 | 23 | (defmacro slet (form &body body) 24 | "Binds the FORM to IT (via SYMBOL-MACROLET) in the scope of the BODY. IT can 25 | be set with SETF." 26 | `(symbolic ignore-first ,form (progn ,@body))) 27 | 28 | (defmacro aand (first &rest rest) 29 | "Like AND, except binds the first argument to IT (via LET) for the 30 | scope of the rest of the arguments." 31 | `(anaphoric and ,first ,@rest)) 32 | 33 | (defmacro sor (first &rest rest) 34 | "Like OR, except binds the first argument to IT (via SYMBOL-MACROLET) for 35 | the scope of the rest of the arguments. IT can be set with SETF." 36 | `(symbolic or ,first ,@rest)) 37 | 38 | (defmacro aif (test then &optional else) 39 | "Like IF, except binds the result of the test to IT (via LET) for 40 | the scope of the then and else expressions." 41 | `(anaphoric if ,test ,then ,else)) 42 | 43 | (defmacro sif (test then &optional else) 44 | "Like IF, except binds the test form to IT (via SYMBOL-MACROLET) for 45 | the scope of the then and else expressions. IT can be set with SETF" 46 | `(symbolic if ,test ,then ,else)) 47 | 48 | (defmacro asif (test then &optional else) 49 | "Like IF, except binds the result of the test to IT (via LET) for 50 | the the scope of the then-expression, and the test form to IT (via 51 | SYMBOL-MACROLET) for the scope of the else-expression. Within scope of 52 | the else-expression, IT can be set with SETF." 53 | `(let ((it ,test)) 54 | (if it 55 | ,then 56 | (symbolic ignore-first ,test ,else)))) 57 | 58 | (defmacro aprog1 (first &body rest) 59 | "Binds IT to the first form so that it can be used in the rest of the 60 | forms. The whole thing returns IT." 61 | `(anaphoric prog1 ,first ,@rest)) 62 | 63 | (defmacro awhen (test &body body) 64 | "Like WHEN, except binds the result of the test to IT (via LET) for the scope 65 | of the body." 66 | `(anaphoric when ,test ,@body)) 67 | 68 | (defmacro swhen (test &body body) 69 | "Like WHEN, except binds the test form to IT (via SYMBOL-MACROLET) for the 70 | scope of the body. IT can be set with SETF." 71 | `(symbolic when ,test ,@body)) 72 | 73 | (defmacro sunless (test &body body) 74 | "Like UNLESS, except binds the test form to IT (via SYMBOL-MACROLET) for the 75 | scope of the body. IT can be set with SETF." 76 | `(symbolic unless ,test ,@body)) 77 | 78 | (defmacro acase (keyform &body cases) 79 | "Like CASE, except binds the result of the keyform to IT (via LET) for the 80 | scope of the cases." 81 | `(anaphoric case ,keyform ,@cases)) 82 | 83 | (defmacro scase (keyform &body cases) 84 | "Like CASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the 85 | scope of the body. IT can be set with SETF." 86 | `(symbolic case ,keyform ,@cases)) 87 | 88 | (defmacro aecase (keyform &body cases) 89 | "Like ECASE, except binds the result of the keyform to IT (via LET) for the 90 | scope of the cases." 91 | `(anaphoric ecase ,keyform ,@cases)) 92 | 93 | (defmacro secase (keyform &body cases) 94 | "Like ECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the 95 | scope of the cases. IT can be set with SETF." 96 | `(symbolic ecase ,keyform ,@cases)) 97 | 98 | (defmacro accase (keyform &body cases) 99 | "Like CCASE, except binds the result of the keyform to IT (via LET) for the 100 | scope of the cases. Unlike CCASE, the keyform/place doesn't receive new values 101 | possibly stored with STORE-VALUE restart; the new value is received by IT." 102 | `(anaphoric ccase ,keyform ,@cases)) 103 | 104 | (defmacro sccase (keyform &body cases) 105 | "Like CCASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the 106 | scope of the cases. IT can be set with SETF." 107 | `(symbolic ccase ,keyform ,@cases)) 108 | 109 | (defmacro atypecase (keyform &body cases) 110 | "Like TYPECASE, except binds the result of the keyform to IT (via LET) for 111 | the scope of the cases." 112 | `(anaphoric typecase ,keyform ,@cases)) 113 | 114 | (defmacro stypecase (keyform &body cases) 115 | "Like TYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the 116 | scope of the cases. IT can be set with SETF." 117 | `(symbolic typecase ,keyform ,@cases)) 118 | 119 | (defmacro aetypecase (keyform &body cases) 120 | "Like ETYPECASE, except binds the result of the keyform to IT (via LET) for 121 | the scope of the cases." 122 | `(anaphoric etypecase ,keyform ,@cases)) 123 | 124 | (defmacro setypecase (keyform &body cases) 125 | "Like ETYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for 126 | the scope of the cases. IT can be set with SETF." 127 | `(symbolic etypecase ,keyform ,@cases)) 128 | 129 | (defmacro actypecase (keyform &body cases) 130 | "Like CTYPECASE, except binds the result of the keyform to IT (via LET) for 131 | the scope of the cases. Unlike CTYPECASE, new values possible stored by the 132 | STORE-VALUE restart are not received by the keyform/place, but by IT." 133 | `(anaphoric ctypecase ,keyform ,@cases)) 134 | 135 | (defmacro sctypecase (keyform &body cases) 136 | "Like CTYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for 137 | the scope of the cases. IT can be set with SETF." 138 | `(symbolic ctypecase ,keyform ,@cases)) 139 | 140 | (defmacro acond (&body clauses) 141 | "Like COND, except result of each test-form is bound to IT (via LET) for the 142 | scope of the corresponding clause." 143 | (labels ((rec (clauses) 144 | (if clauses 145 | (destructuring-bind ((test &body body) . rest) clauses 146 | (if body 147 | `(anaphoric if ,test (progn ,@body) ,(rec rest)) 148 | `(anaphoric if ,test it ,(rec rest)))) 149 | nil))) 150 | (rec clauses))) 151 | 152 | (defmacro scond (&body clauses) 153 | "Like COND, except each test-form is bound to IT (via SYMBOL-MACROLET) for the 154 | scope of the corresponsing clause. IT can be set with SETF." 155 | (labels ((rec (clauses) 156 | (if clauses 157 | (destructuring-bind ((test &body body) . rest) clauses 158 | (if body 159 | `(symbolic if ,test (progn ,@body) ,(rec rest)) 160 | `(symbolic if ,test it ,(rec rest)))) 161 | nil))) 162 | (rec clauses))) 163 | 164 | (defmacro alambda (lambda-list &body body) 165 | "Like LAMBDA, except that SELF is bound to the resulting function (via LABELS) 166 | within BODY." 167 | `(labels ((self ,lambda-list ,@body)) 168 | #'self)) 169 | -------------------------------------------------------------------------------- /early.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*- 2 | 3 | ;;;; Anaphora: The Anaphoric Macro Package from Hell 4 | ;;;; 5 | ;;;; This been placed in Public Domain by the author, 6 | ;;;; Nikodemus Siivola 7 | 8 | (in-package :anaphora) 9 | 10 | (defmacro with-unique-names ((&rest bindings) &body body) 11 | `(let ,(mapcar #'(lambda (binding) 12 | (destructuring-bind (var prefix) 13 | (if (consp binding) binding (list binding binding)) 14 | `(,var (gensym ,(string prefix))))) 15 | bindings) 16 | ,@body)) 17 | 18 | (defmacro ignore-first (first expr) 19 | (declare (ignore first)) 20 | expr) 21 | -------------------------------------------------------------------------------- /packages.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: CL-USER -*- 2 | 3 | ;;;; Anaphora: The Anaphoric Macro Package from Hell 4 | ;;;; 5 | ;;;; This been placed in Public Domain by the author, 6 | ;;;; Nikodemus Siivola 7 | 8 | (defpackage :anaphora 9 | (:use :cl) 10 | (:export 11 | #:it 12 | #:self 13 | #:alet 14 | #:slet 15 | #:aif 16 | #:aand 17 | #:sor 18 | #:awhen 19 | #:aprog1 20 | #:acase 21 | #:aecase 22 | #:accase 23 | #:atypecase 24 | #:aetypecase 25 | #:actypecase 26 | #:acond 27 | #:alambda 28 | #:sif 29 | #:asif 30 | #:swhen 31 | #:sunless 32 | #:scase 33 | #:secase 34 | #:sccase 35 | #:stypecase 36 | #:setypecase 37 | #:sctypecase 38 | #:scond) 39 | (:documentation 40 | "ANAPHORA provides a full complement of anaphoric macros. Subsets of the 41 | functionality provided by this package are exported from ANAPHORA-BASIC and 42 | ANAPHORA-SYMBOL.")) 43 | 44 | (defpackage :anaphora-basic 45 | (:use :cl :anaphora) 46 | (:export 47 | #:it 48 | #:self 49 | #:alet 50 | #:aif 51 | #:aand 52 | #:awhen 53 | #:aprog1 54 | #:acase 55 | #:aecase 56 | #:accase 57 | #:atypecase 58 | #:aetypecase 59 | #:actypecase 60 | #:acond 61 | #:alambda) 62 | (:documentation 63 | "ANAPHORA-BASIC provides all normal anaphoric constructs, which bind 64 | primary values to IT/SELF.")) 65 | 66 | (defpackage :anaphora-symbol 67 | (:use :cl :anaphora) 68 | (:export 69 | #:it 70 | #:slet 71 | #:sor 72 | #:sif 73 | #:asif 74 | #:swhen 75 | #:sunless 76 | #:scase 77 | #:secase 78 | #:sccase 79 | #:stypecase 80 | #:setypecase 81 | #:sctypecase 82 | #:scond) 83 | (:documentation 84 | "ANAPHORA-SYMBOL provides ``symbolic anaphoric macros'', which bind forms 85 | to IT via SYMBOL-MACROLET. 86 | 87 | Examples: 88 | 89 | (sor (gethash key table) (setf it default)) 90 | 91 | (asif (gethash key table) 92 | (foo it) ; IT is a value bound by LET here 93 | (setf it default)) ; IT is the GETHASH form bound by SYMBOL-MACROLET here 94 | ")) 95 | -------------------------------------------------------------------------------- /symbolic.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*- 2 | 3 | ;;;; Copyright (c) 2003 Brian Mastenbrook 4 | 5 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 6 | ;;;; a copy of this software and associated documentation files (the 7 | ;;;; "Software"), to deal in the Software without restriction, including 8 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 9 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 10 | ;;;; permit persons to whom the Software is furnished to do so, subject to 11 | ;;;; the following conditions: 12 | 13 | ;;;; The above copyright notice and this permission notice shall be 14 | ;;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | ;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 20 | ;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 21 | ;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 22 | ;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | (in-package :anaphora) 25 | 26 | (defmacro internal-symbol-macrolet (&rest whatever) 27 | `(symbol-macrolet ,@whatever)) 28 | 29 | (define-setf-expander internal-symbol-macrolet (binding-forms place &environment env) 30 | (multiple-value-bind (dummies vals newvals setter getter) 31 | (get-setf-expansion place env) 32 | (values dummies 33 | (substitute `(symbol-macrolet ,binding-forms it) 'it vals) 34 | newvals 35 | `(symbol-macrolet ,binding-forms ,setter) 36 | `(symbol-macrolet ,binding-forms ,getter)))) 37 | 38 | (with-unique-names (s-indicator current-s-indicator) 39 | (defmacro symbolic (operation test &rest other-args) 40 | (with-unique-names (this-s) 41 | (let ((current-s (get s-indicator current-s-indicator))) 42 | (setf (get s-indicator current-s-indicator) this-s) 43 | `(symbol-macrolet 44 | ((,this-s (internal-symbol-macrolet ((it ,current-s)) ,test)) 45 | (it ,this-s)) 46 | (,operation it ,@other-args))))) 47 | 48 | (defmacro anaphoric (op test &body body) 49 | (with-unique-names (this-s) 50 | (setf (get s-indicator current-s-indicator) this-s) 51 | `(let* ((it ,test) 52 | (,this-s it)) 53 | (declare (ignorable ,this-s)) 54 | (,op it ,@body))))) 55 | -------------------------------------------------------------------------------- /tests.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Anaphora: The Anaphoric Macro Package from Hell 2 | ;;;; 3 | ;;;; This been placed in Public Domain by the author, 4 | ;;;; Nikodemus Siivola 5 | 6 | (defpackage :anaphora-test 7 | (:use :cl :anaphora :rt)) 8 | 9 | (in-package :anaphora-test) 10 | 11 | (deftest alet.1 12 | (alet (1+ 1) 13 | (1+ it)) 14 | 3) 15 | 16 | (deftest alet.2 17 | (alet (1+ 1) 18 | it 19 | (1+ it)) 20 | 3) 21 | 22 | (deftest slet.1 23 | (let ((x (list 1 2 3))) 24 | (slet (car x) 25 | (incf it) (values it x))) 26 | 2 (2 2 3)) 27 | 28 | (deftest aand.1 29 | (aand (+ 1 1) 30 | (+ 1 it)) 31 | 3) 32 | 33 | (deftest aand.2 34 | (aand 1 t (values it 2)) 35 | 1 2) 36 | 37 | (deftest aand.3 38 | (let ((x 1)) 39 | (aand (incf x) t t (values t it))) 40 | t 2) 41 | 42 | (deftest aand.4 43 | (aand 1 (values t it)) 44 | t 1) 45 | 46 | #+(or) 47 | ;;; bug or a feature? forms like this expand to 48 | ;;; 49 | ;;; (let ((it (values ...))) (and it ...)) 50 | ;;; 51 | (deftest aand.5 52 | (aand (values nil t) it) 53 | nil t) 54 | 55 | (deftest sor.1 56 | (let ((x (list nil))) 57 | (sor (car x) 58 | (setf it t)) 59 | x) 60 | (t)) 61 | 62 | (deftest aif.1 63 | (aif (+ 1 1) 64 | (+ 1 it) 65 | :never) 66 | 3) 67 | 68 | (deftest aif.2 69 | (let ((x 0)) 70 | (aif (incf x) 71 | it 72 | :never)) 73 | 1) 74 | 75 | (deftest aif.3 76 | (let ((x 0)) 77 | (aif (eval `(and ,(incf x) nil)) 78 | :never 79 | (list it x))) 80 | (nil 1)) 81 | 82 | (deftest sif.1 83 | (let ((x (list nil))) 84 | (sif (car x) 85 | (setf it :oops) 86 | (setf it :yes!)) 87 | (car x)) 88 | :yes!) 89 | 90 | (deftest sif.2 91 | (let ((x (list t))) 92 | (sif (car x) 93 | (setf it :yes!) 94 | (setf it :oops)) 95 | (car x)) 96 | :yes!) 97 | 98 | (deftest sif.3 99 | (sif (list 1 2 3) 100 | (sif (car it) 101 | (setf it 'a) 102 | :foo)) 103 | a) 104 | 105 | (deftest sif.4 106 | (progn 107 | (defclass sif.4 () 108 | ((a :initform (list :sif)))) 109 | (with-slots (a) 110 | (make-instance 'sif.4) 111 | (sif a 112 | (sif (car it) 113 | it)))) 114 | :sif) 115 | 116 | (deftest asif.1 117 | (let ((x (list 0))) 118 | (asif (incf (car x)) 119 | it 120 | (list :oops it))) 121 | 1) 122 | 123 | (deftest asif.2 124 | (let ((x (list nil))) 125 | (asif (car x) 126 | (setf x :oops) 127 | (setf it :yes!)) 128 | x) 129 | (:yes!)) 130 | 131 | (deftest awhen.1 132 | (let ((x 0)) 133 | (awhen (incf x) 134 | (+ 1 it))) 135 | 2) 136 | 137 | (deftest awhen.2 138 | (let ((x 0)) 139 | (or (awhen (not (incf x)) 140 | t) 141 | x)) 142 | 1) 143 | 144 | (deftest swhen.1 145 | (let ((x 0)) 146 | (swhen x 147 | (setf it :ok)) 148 | x) 149 | :ok) 150 | 151 | (deftest swhen.2 152 | (let ((x nil)) 153 | (swhen x 154 | (setf it :oops)) 155 | x) 156 | nil) 157 | 158 | (deftest sunless.1 159 | (let ((x nil)) 160 | (sunless x 161 | (setf it :ok)) 162 | x) 163 | :ok) 164 | 165 | (deftest sunless.2 166 | (let ((x t)) 167 | (sunless x 168 | (setf it :oops)) 169 | x) 170 | t) 171 | 172 | (deftest acase.1 173 | (let ((x 0)) 174 | (acase (incf x) 175 | (0 :no) 176 | (1 (list :yes it)) 177 | (2 :nono))) 178 | (:yes 1)) 179 | 180 | (deftest scase.1 181 | (let ((x (list 3))) 182 | (scase (car x) 183 | (0 (setf it :no)) 184 | (3 (setf it :yes!)) 185 | (t (setf it :nono))) 186 | x) 187 | (:yes!)) 188 | 189 | (deftest aecase.1 190 | (let ((x (list :x))) 191 | (aecase (car x) 192 | (:y :no) 193 | (:x (list it :yes)))) 194 | (:x :yes)) 195 | 196 | (deftest aecase.2 197 | (nth-value 0 (ignore-errors 198 | (let ((x (list :x))) 199 | (secase (car x) 200 | (:y :no))) 201 | :oops)) 202 | nil) 203 | 204 | (deftest secase.1 205 | (let ((x (list :x))) 206 | (secase (car x) 207 | (:y (setf it :no)) 208 | (:x (setf it :yes))) 209 | x) 210 | (:yes)) 211 | 212 | (deftest secase.2 213 | (nth-value 0 (ignore-errors 214 | (let ((x (list :x))) 215 | (secase (car x) 216 | (:y (setf it :no))) 217 | :oops))) 218 | nil) 219 | 220 | (deftest accase.1 221 | (let ((x (list :x))) 222 | (accase (car x) 223 | (:y :no) 224 | (:x (list it :yes)))) 225 | (:x :yes)) 226 | 227 | (deftest accase.2 228 | (let ((x (list :x))) 229 | (handler-bind ((type-error (lambda (e) (store-value :z e)))) 230 | (accase (car x) 231 | (:y (setf x :no)) 232 | (:z (setf x :yes)))) 233 | x) 234 | :yes) 235 | 236 | (deftest accase.3 237 | (let ((x (list :x))) 238 | (accase (car x) 239 | (:x (setf it :foo))) 240 | x) 241 | (:x)) 242 | 243 | (deftest sccase.1 244 | (let ((x (list :x))) 245 | (sccase (car x) 246 | (:y (setf it :no)) 247 | (:x (setf it :yes))) 248 | x) 249 | (:yes)) 250 | 251 | (deftest sccase.2 252 | (let ((x (list :x))) 253 | (handler-bind ((type-error (lambda (e) (store-value :z e)))) 254 | (sccase (car x) 255 | (:y (setf it :no)) 256 | (:z (setf it :yes)))) 257 | x) 258 | (:yes)) 259 | 260 | (deftest atypecase.1 261 | (atypecase 1.0 262 | (integer (+ 2 it)) 263 | (float (1- it))) 264 | 0.0) 265 | 266 | (deftest atypecase.2 267 | (atypecase "Foo" 268 | (fixnum :no) 269 | (hash-table :nono)) 270 | nil) 271 | 272 | (deftest stypecase.1 273 | (let ((x (list 'foo))) 274 | (stypecase (car x) 275 | (vector (setf it :no)) 276 | (symbol (setf it :yes))) 277 | x) 278 | (:yes)) 279 | 280 | (deftest stypecase.2 281 | (let ((x (list :bar))) 282 | (stypecase (car x) 283 | (fixnum (setf it :no))) 284 | x) 285 | (:bar)) 286 | 287 | (deftest aetypecase.1 288 | (aetypecase 1.0 289 | (fixnum (* 2 it)) 290 | (float (+ 2.0 it)) 291 | (symbol :oops)) 292 | 3.0) 293 | 294 | (deftest aetypecase.2 295 | (nth-value 0 (ignore-errors 296 | (aetypecase 1.0 297 | (symbol :oops)))) 298 | nil) 299 | 300 | (deftest setypecase.1 301 | (let ((x (list "Foo"))) 302 | (setypecase (car x) 303 | (symbol (setf it :no)) 304 | (string (setf it "OK")) 305 | (integer (setf it :noon))) 306 | x) 307 | ("OK")) 308 | 309 | (deftest setypecase.2 310 | (nth-value 0 (ignore-errors 311 | (setypecase 'foo 312 | (string :nono)))) 313 | nil) 314 | 315 | (deftest actypecase.1 316 | (actypecase :foo 317 | (string (list :string it)) 318 | (keyword (list :keyword it)) 319 | (symbol (list :symbol it))) 320 | (:keyword :foo)) 321 | 322 | (deftest actypecase.2 323 | (handler-bind ((type-error (lambda (e) (store-value "OK" e)))) 324 | (actypecase 0 325 | (string it))) 326 | "OK") 327 | 328 | (deftest sctypecase.1 329 | (let ((x (list 0))) 330 | (sctypecase (car x) 331 | (symbol (setf it 'symbol)) 332 | (bit (setf it 'bit))) 333 | x) 334 | (bit)) 335 | 336 | (deftest sctypecase.2 337 | (handler-bind ((type-error (lambda (e) (store-value "OK" e)))) 338 | (let ((x (list 0))) 339 | (sctypecase (car x) 340 | (string (setf it :ok))) 341 | x)) 342 | (:ok)) 343 | 344 | (deftest acond.1 345 | (acond (:foo)) 346 | :foo) 347 | 348 | (deftest acond.2 349 | (acond ((null 1) (list :no it)) 350 | ((+ 1 2) (list :yes it)) 351 | (t :nono)) 352 | (:yes 3)) 353 | 354 | (deftest acond.3 355 | (acond ((= 1 2) :no) 356 | (nil :nono) 357 | (t :yes)) 358 | :yes) 359 | 360 | ;; Test COND with multiple forms in the implicit progn. 361 | (deftest acond.4 362 | (let ((foo)) 363 | (acond ((+ 2 2) (setf foo 38) (incf foo it) foo) 364 | (t nil))) 365 | 42) 366 | 367 | (deftest scond.1 368 | (let ((x (list nil)) 369 | (y (list t))) 370 | (scond ((car x) (setf it :nono)) 371 | ((car y) (setf it :yes))) 372 | (values x y)) 373 | (nil) 374 | (:yes)) 375 | 376 | (deftest scond.2 377 | (scond ((= 1 2) :no!)) 378 | nil) 379 | 380 | (deftest scond.3 381 | (equal (scond ((list 'a 'b))) 382 | '(a b)) 383 | t) 384 | 385 | (deftest aprog.1 386 | (aprog1 :yes 387 | (unless (eql it :yes) (error "Broken.")) 388 | :no) 389 | :yes) 390 | 391 | (deftest aif.sif.1 392 | (sif 1 (aif it it)) 393 | 1) 394 | 395 | (deftest aif.sif.2 396 | (aif 1 (sif it it)) 397 | 1) 398 | 399 | (deftest aif.sif.3 400 | (aif (list 1 2 3) 401 | (sif (car it) 402 | (setf it 'a) 403 | :foo)) 404 | a) 405 | 406 | (deftest alet.slet.1 407 | (slet 42 (alet 43 (slet it it))) 408 | 43) 409 | 410 | (deftest alambda.1 411 | (funcall (alambda (x) 412 | (if (zerop x) 413 | x 414 | (self (1- x)))) 415 | 4) 416 | 0) 417 | 418 | 419 | (defun elt-like (index seq) 420 | (elt seq index)) 421 | 422 | (define-setf-expander elt-like (index seq) 423 | (let ((index-var (gensym "index")) 424 | (seq-var (gensym "seq")) 425 | (store (gensym "store"))) 426 | (values (list index-var seq-var) 427 | (list index seq) 428 | (list store) 429 | `(if (listp ,seq-var) 430 | (setf (nth ,index-var ,seq-var) ,store) 431 | (setf (aref ,seq-var ,index-var) ,store)) 432 | `(if (listp ,seq-var) 433 | (nth ,index-var ,seq-var) 434 | (aref ,seq-var ,index-var))))) 435 | 436 | (deftest symbolic.setf-expansion.1 437 | (let ((cell (list nil))) 438 | (sor (elt-like 0 cell) (setf it 1)) 439 | (equal cell '(1))) 440 | t) 441 | --------------------------------------------------------------------------------