Vim window logic, slimv
This commit is contained in:
Ian Keane
parent
babcc9e44b
commit
515847d07e
791 changed files with 51552 additions and 86 deletions
|
|
@ -0,0 +1,34 @@
|
|||
language: lisp
|
||||
sudo: required
|
||||
|
||||
env:
|
||||
matrix:
|
||||
- LISP=abcl
|
||||
- LISP=allegro
|
||||
- LISP=sbcl
|
||||
- LISP=sbcl32
|
||||
- LISP=ccl
|
||||
- LISP=ccl32
|
||||
- LISP=ecl
|
||||
- LISP=clisp
|
||||
- LISP=clisp32
|
||||
- LISP=cmucl
|
||||
|
||||
matrix:
|
||||
allow_failures:
|
||||
# Disabled until issue #6 is fixed.
|
||||
- env: LISP=clisp
|
||||
- env: LISP=clisp32
|
||||
# Disabled until cim supports cmucl.
|
||||
- env: LISP=cmucl
|
||||
|
||||
install:
|
||||
- curl -L https://github.com/tokenrove/cl-travis/raw/master/install.sh | sh
|
||||
- if [ "${LISP:(-2)}" = "32" ]; then
|
||||
sudo apt-get install -qq -y libc6-dev-i386;
|
||||
fi
|
||||
|
||||
script:
|
||||
- cl -e '(ql:quickload :anaphora/test)
|
||||
(unless (asdf:oos :test-op :anaphora/test)
|
||||
(uiop:quit 1))'
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
;;;; This file is part of the Anaphora package Common Lisp,
|
||||
;;;; and has been placed in Public Domain by the author,
|
||||
;;;; Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
# Anaphora
|
||||
|
||||
Anaphora is the anaphoric macro collection from Hell: it includes many
|
||||
new fiends in addition to old friends like `AIF` and `AWHEN`.
|
||||
Anaphora has been placed in Public Domain by the author, [Nikodemus
|
||||
Siivola](mailto:nikodemus@random-state.net).
|
||||
|
||||
# Installation
|
||||
|
||||
Use [quicklisp](http://www.quicklisp.org/), and simply:
|
||||
|
||||
```
|
||||
CL-USER(1): (ql:quickload "anaphora")
|
||||
```
|
||||
|
||||
# Documentation
|
||||
|
||||
Anaphoric macros provide implicit bindings for various
|
||||
operations. Extensive use of anaphoric macros is not good style,
|
||||
and probably makes you go blind as well — there's a reason why
|
||||
Anaphora claims to be from Hell.
|
||||
|
||||
Anaphora provides two families of anaphoric macros, which can be
|
||||
identified by their names and packages (both families are also
|
||||
exported from the package `ANAPHORA`). The implicitly-bound symbol
|
||||
`ANAPHORA:IT` is also exported from all three packages.
|
||||
|
||||
## Basic anaphora
|
||||
|
||||
#### Exported from package `ANAPHORA-BASIC`
|
||||
|
||||
These bind their first argument to `IT` via `LET`. In case of `COND`
|
||||
all clauses have their test-values bound to `IT`.
|
||||
|
||||
Variants: `AAND`, `ALET`, `APROG1`, `AIF`, `ACOND`, `AWHEN`, `ACASE`,
|
||||
`ACCASE`, `AECASE`, `ATYPECASE`, `ACTYPECASE`, and `AETYPECASE`.
|
||||
|
||||
## Symbol-macro anaphora
|
||||
|
||||
#### Exported from package `ANAPHORA-SYMBOL`
|
||||
|
||||
These bind their first argument (unevaluated) to `IT` via
|
||||
SYMBOL-`MACROLET.`
|
||||
|
||||
Variants: `SOR`, `SLET`, `SIF`, `SCOND`, `SUNLESS`,
|
||||
`SWHEN`, `SCASE`, `SCCASE`, `SECASE`, `STYPECASE`, `SCTYPECASE`,
|
||||
`SETYPECASE`.
|
||||
|
||||
Also: `ASIF`, which binds via `LET` for the
|
||||
then-clause, and `SYMBOL-MACROLET` for the else-clause.
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-lisp; -*-
|
||||
|
||||
;;;; Anaphora: The Anaphoric Macro Package from Hell
|
||||
;;;;
|
||||
;;;; This been placed in Public Domain by the author,
|
||||
;;;; Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
||||
(defsystem :anaphora
|
||||
:version "0.9.6"
|
||||
:description "The Anaphoric Macro Package from Hell"
|
||||
:author "Nikodemus Siivola <nikodemus@random-state.net>"
|
||||
:license "Public Domain"
|
||||
:components
|
||||
((:file "packages")
|
||||
(:file "early" :depends-on ("packages"))
|
||||
(:file "symbolic" :depends-on ("early"))
|
||||
(:file "anaphora" :depends-on ("symbolic"))))
|
||||
|
||||
(defsystem :anaphora/test
|
||||
:description "Tests for anaphora"
|
||||
:author "Nikodemus Siivola <nikodemus@random-state.net>"
|
||||
:license "Public Domain"
|
||||
:depends-on (:anaphora :rt)
|
||||
:components ((:file "tests")))
|
||||
|
||||
(defmethod perform ((o test-op) (c (eql (find-system :anaphora))))
|
||||
(test-system :anaphora/test))
|
||||
|
||||
(defmethod perform ((o test-op) (c (eql (find-system :anaphora/test))))
|
||||
(or (symbol-call :rt '#:do-tests)
|
||||
(error "test-op failed")))
|
||||
|
|
@ -0,0 +1,162 @@
|
|||
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*-
|
||||
|
||||
;;;; Anaphora: The Anaphoric Macro Package from Hell
|
||||
;;;;
|
||||
;;;; This been placed in Public Domain by the author,
|
||||
;;;; Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
||||
(in-package :anaphora)
|
||||
|
||||
;;; This was the original implementation of SYMBOLIC -- and still good
|
||||
;;; for getting the basic idea. Brian Masterbrooks solution to
|
||||
;;; infinite recusion during macroexpansion, that nested forms of this
|
||||
;;; are subject to, is in symbolic.lisp.
|
||||
;;;
|
||||
;;; (defmacro symbolic (op test &body body &environment env)
|
||||
;;; `(symbol-macrolet ((it ,test))
|
||||
;;; (,op it ,@body)))
|
||||
|
||||
(defmacro alet (form &body body)
|
||||
"Binds the FORM to IT (via LET) in the scope of the BODY."
|
||||
`(anaphoric ignore-first ,form (progn ,@body)))
|
||||
|
||||
(defmacro slet (form &body body)
|
||||
"Binds the FORM to IT (via SYMBOL-MACROLET) in the scope of the BODY. IT can
|
||||
be set with SETF."
|
||||
`(symbolic ignore-first ,form (progn ,@body)))
|
||||
|
||||
(defmacro aand (first &rest rest)
|
||||
"Like AND, except binds the first argument to IT (via LET) for the
|
||||
scope of the rest of the arguments."
|
||||
`(anaphoric and ,first ,@rest))
|
||||
|
||||
(defmacro sor (first &rest rest)
|
||||
"Like OR, except binds the first argument to IT (via SYMBOL-MACROLET) for
|
||||
the scope of the rest of the arguments. IT can be set with SETF."
|
||||
`(symbolic or ,first ,@rest))
|
||||
|
||||
(defmacro aif (test then &optional else)
|
||||
"Like IF, except binds the result of the test to IT (via LET) for
|
||||
the scope of the then and else expressions."
|
||||
`(anaphoric if ,test ,then ,else))
|
||||
|
||||
(defmacro sif (test then &optional else)
|
||||
"Like IF, except binds the test form to IT (via SYMBOL-MACROLET) for
|
||||
the scope of the then and else expressions. IT can be set with SETF"
|
||||
`(symbolic if ,test ,then ,else))
|
||||
|
||||
(defmacro asif (test then &optional else)
|
||||
"Like IF, except binds the result of the test to IT (via LET) for
|
||||
the the scope of the then-expression, and the test form to IT (via
|
||||
SYMBOL-MACROLET) for the scope of the else-expression. Within scope of
|
||||
the else-expression, IT can be set with SETF."
|
||||
`(let ((it ,test))
|
||||
(if it
|
||||
,then
|
||||
(symbolic ignore-first ,test ,else))))
|
||||
|
||||
(defmacro aprog1 (first &body rest)
|
||||
"Binds IT to the first form so that it can be used in the rest of the
|
||||
forms. The whole thing returns IT."
|
||||
`(anaphoric prog1 ,first ,@rest))
|
||||
|
||||
(defmacro awhen (test &body body)
|
||||
"Like WHEN, except binds the result of the test to IT (via LET) for the scope
|
||||
of the body."
|
||||
`(anaphoric when ,test ,@body))
|
||||
|
||||
(defmacro swhen (test &body body)
|
||||
"Like WHEN, except binds the test form to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the body. IT can be set with SETF."
|
||||
`(symbolic when ,test ,@body))
|
||||
|
||||
(defmacro sunless (test &body body)
|
||||
"Like UNLESS, except binds the test form to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the body. IT can be set with SETF."
|
||||
`(symbolic unless ,test ,@body))
|
||||
|
||||
(defmacro acase (keyform &body cases)
|
||||
"Like CASE, except binds the result of the keyform to IT (via LET) for the
|
||||
scope of the cases."
|
||||
`(anaphoric case ,keyform ,@cases))
|
||||
|
||||
(defmacro scase (keyform &body cases)
|
||||
"Like CASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the body. IT can be set with SETF."
|
||||
`(symbolic case ,keyform ,@cases))
|
||||
|
||||
(defmacro aecase (keyform &body cases)
|
||||
"Like ECASE, except binds the result of the keyform to IT (via LET) for the
|
||||
scope of the cases."
|
||||
`(anaphoric ecase ,keyform ,@cases))
|
||||
|
||||
(defmacro secase (keyform &body cases)
|
||||
"Like ECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the cases. IT can be set with SETF."
|
||||
`(symbolic ecase ,keyform ,@cases))
|
||||
|
||||
(defmacro accase (keyform &body cases)
|
||||
"Like CCASE, except binds the result of the keyform to IT (via LET) for the
|
||||
scope of the cases. Unlike CCASE, the keyform/place doesn't receive new values
|
||||
possibly stored with STORE-VALUE restart; the new value is received by IT."
|
||||
`(anaphoric ccase ,keyform ,@cases))
|
||||
|
||||
(defmacro sccase (keyform &body cases)
|
||||
"Like CCASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the cases. IT can be set with SETF."
|
||||
`(symbolic ccase ,keyform ,@cases))
|
||||
|
||||
(defmacro atypecase (keyform &body cases)
|
||||
"Like TYPECASE, except binds the result of the keyform to IT (via LET) for
|
||||
the scope of the cases."
|
||||
`(anaphoric typecase ,keyform ,@cases))
|
||||
|
||||
(defmacro stypecase (keyform &body cases)
|
||||
"Like TYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the cases. IT can be set with SETF."
|
||||
`(symbolic typecase ,keyform ,@cases))
|
||||
|
||||
(defmacro aetypecase (keyform &body cases)
|
||||
"Like ETYPECASE, except binds the result of the keyform to IT (via LET) for
|
||||
the scope of the cases."
|
||||
`(anaphoric etypecase ,keyform ,@cases))
|
||||
|
||||
(defmacro setypecase (keyform &body cases)
|
||||
"Like ETYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for
|
||||
the scope of the cases. IT can be set with SETF."
|
||||
`(symbolic etypecase ,keyform ,@cases))
|
||||
|
||||
(defmacro actypecase (keyform &body cases)
|
||||
"Like CTYPECASE, except binds the result of the keyform to IT (via LET) for
|
||||
the scope of the cases. Unlike CTYPECASE, new values possible stored by the
|
||||
STORE-VALUE restart are not received by the keyform/place, but by IT."
|
||||
`(anaphoric ctypecase ,keyform ,@cases))
|
||||
|
||||
(defmacro sctypecase (keyform &body cases)
|
||||
"Like CTYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for
|
||||
the scope of the cases. IT can be set with SETF."
|
||||
`(symbolic ctypecase ,keyform ,@cases))
|
||||
|
||||
(defmacro acond (&body clauses)
|
||||
"Like COND, except result of each test-form is bound to IT (via LET) for the
|
||||
scope of the corresponding clause."
|
||||
(labels ((rec (clauses)
|
||||
(if clauses
|
||||
(destructuring-bind ((test &body body) . rest) clauses
|
||||
(if body
|
||||
`(anaphoric if ,test (progn ,@body) ,(rec rest))
|
||||
`(anaphoric if ,test it ,(rec rest))))
|
||||
nil)))
|
||||
(rec clauses)))
|
||||
|
||||
(defmacro scond (&body clauses)
|
||||
"Like COND, except each test-form is bound to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the corresponsing clause. IT can be set with SETF."
|
||||
(labels ((rec (clauses)
|
||||
(if clauses
|
||||
(destructuring-bind ((test &body body) . rest) clauses
|
||||
(if body
|
||||
`(symbolic if ,test (progn ,@body) ,(rec rest))
|
||||
`(symbolic if ,test it ,(rec rest))))
|
||||
nil)))
|
||||
(rec clauses)))
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*-
|
||||
|
||||
;;;; Anaphora: The Anaphoric Macro Package from Hell
|
||||
;;;;
|
||||
;;;; This been placed in Public Domain by the author,
|
||||
;;;; Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
||||
(in-package :anaphora)
|
||||
|
||||
(defmacro with-unique-names ((&rest bindings) &body body)
|
||||
`(let ,(mapcar #'(lambda (binding)
|
||||
(destructuring-bind (var prefix)
|
||||
(if (consp binding) binding (list binding binding))
|
||||
`(,var (gensym ,(string prefix)))))
|
||||
bindings)
|
||||
,@body))
|
||||
|
||||
(defmacro ignore-first (first expr)
|
||||
(declare (ignore first))
|
||||
expr)
|
||||
|
|
@ -0,0 +1,90 @@
|
|||
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: CL-USER -*-
|
||||
|
||||
;;;; Anaphora: The Anaphoric Macro Package from Hell
|
||||
;;;;
|
||||
;;;; This been placed in Public Domain by the author,
|
||||
;;;; Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
||||
(defpackage :anaphora
|
||||
(:use :cl)
|
||||
(:export
|
||||
#:it
|
||||
#:alet
|
||||
#:slet
|
||||
#:aif
|
||||
#:aand
|
||||
#:sor
|
||||
#:awhen
|
||||
#:aprog1
|
||||
#:acase
|
||||
#:aecase
|
||||
#:accase
|
||||
#:atypecase
|
||||
#:aetypecase
|
||||
#:actypecase
|
||||
#:acond
|
||||
#:sif
|
||||
#:asif
|
||||
#:swhen
|
||||
#:sunless
|
||||
#:scase
|
||||
#:secase
|
||||
#:sccase
|
||||
#:stypecase
|
||||
#:setypecase
|
||||
#:sctypecase
|
||||
#:scond)
|
||||
(:documentation
|
||||
"ANAPHORA provides a full complement of anaphoric macros. Subsets of the
|
||||
functionality provided by this package are exported from ANAPHORA-BASIC and
|
||||
ANAPHORA-SYMBOL."))
|
||||
|
||||
(defpackage :anaphora-basic
|
||||
(:use :cl :anaphora)
|
||||
(:export
|
||||
#:it
|
||||
#:alet
|
||||
#:aif
|
||||
#:aand
|
||||
#:awhen
|
||||
#:aprog1
|
||||
#:acase
|
||||
#:aecase
|
||||
#:accase
|
||||
#:atypecase
|
||||
#:aetypecase
|
||||
#:actypecase
|
||||
#:acond)
|
||||
(:documentation
|
||||
"ANAPHORA-BASIC provides all normal anaphoric constructs, which bind
|
||||
primary values to IT."))
|
||||
|
||||
(defpackage :anaphora-symbol
|
||||
(:use :cl :anaphora)
|
||||
(:export
|
||||
#:it
|
||||
#:slet
|
||||
#:sor
|
||||
#:sif
|
||||
#:asif
|
||||
#:swhen
|
||||
#:sunless
|
||||
#:scase
|
||||
#:secase
|
||||
#:sccase
|
||||
#:stypecase
|
||||
#:setypecase
|
||||
#:sctypecase
|
||||
#:scond)
|
||||
(:documentation
|
||||
"ANAPHORA-SYMBOL provides ``symbolic anaphoric macros'', which bind forms
|
||||
to IT via SYMBOL-MACROLET.
|
||||
|
||||
Examples:
|
||||
|
||||
(sor (gethash key table) (setf it default))
|
||||
|
||||
(asif (gethash key table)
|
||||
(foo it) ; IT is a value bound by LET here
|
||||
(setf it default)) ; IT is the GETHASH form bound by SYMBOL-MACROLET here
|
||||
"))
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*-
|
||||
|
||||
;;;; Copyright (c) 2003 Brian Mastenbrook
|
||||
|
||||
;;;; 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 AUTHORS OR COPYRIGHT HOLDERS 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.
|
||||
|
||||
(in-package :anaphora)
|
||||
|
||||
(defmacro internal-symbol-macrolet (&rest whatever)
|
||||
`(symbol-macrolet ,@whatever))
|
||||
|
||||
(define-setf-expander internal-symbol-macrolet (binding-forms place &environment env)
|
||||
(multiple-value-bind (dummies vals newvals setter getter)
|
||||
(get-setf-expansion place env)
|
||||
(values dummies
|
||||
(substitute `(symbol-macrolet ,binding-forms it) 'it vals)
|
||||
newvals
|
||||
`(symbol-macrolet ,binding-forms ,setter)
|
||||
`(symbol-macrolet ,binding-forms ,getter))))
|
||||
|
||||
(with-unique-names (s-indicator current-s-indicator)
|
||||
(defmacro symbolic (operation test &rest other-args)
|
||||
(with-unique-names (this-s)
|
||||
(let ((current-s (get s-indicator current-s-indicator)))
|
||||
(setf (get s-indicator current-s-indicator) this-s)
|
||||
`(symbol-macrolet
|
||||
((,this-s (internal-symbol-macrolet ((it ,current-s)) ,test))
|
||||
(it ,this-s))
|
||||
(,operation it ,@other-args)))))
|
||||
|
||||
(defmacro anaphoric (op test &body body)
|
||||
(with-unique-names (this-s)
|
||||
(setf (get s-indicator current-s-indicator) this-s)
|
||||
`(let* ((it ,test)
|
||||
(,this-s it))
|
||||
(declare (ignorable ,this-s))
|
||||
(,op it ,@body)))))
|
||||
|
|
@ -0,0 +1,427 @@
|
|||
;;;; 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)
|
||||
Loading…
Add table
Add a link
Reference in a new issue