pax_global_header00006660000000000000000000000064130503331730014510gustar00rootroot0000000000000052 comment=aeace4c68cf55098a67112750b28f8f2dc6d0e30 anaphora-20170227-git/000077500000000000000000000000001305033317300143305ustar00rootroot00000000000000anaphora-20170227-git/.travis.yml000066400000000000000000000013041305033317300164370ustar00rootroot00000000000000language: 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))' anaphora-20170227-git/LICENSE000066400000000000000000000002531305033317300153350ustar00rootroot00000000000000;;;; This file is part of the Anaphora package Common Lisp, ;;;; and has been placed in Public Domain by the author, ;;;; Nikodemus Siivola anaphora-20170227-git/README.md000066400000000000000000000030411305033317300156050ustar00rootroot00000000000000# 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. anaphora-20170227-git/anaphora.asd000066400000000000000000000017511305033317300166160ustar00rootroot00000000000000;;;; Anaphora: The Anaphoric Macro Package from Hell ;;;; ;;;; This been placed in Public Domain by the author, ;;;; Nikodemus Siivola (defsystem :anaphora :version "0.9.6" :description "The Anaphoric Macro Package from Hell" :author "Nikodemus Siivola " :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 " :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"))) anaphora-20170227-git/anaphora.lisp000066400000000000000000000141071305033317300170150ustar00rootroot00000000000000;;;; Anaphora: The Anaphoric Macro Package from Hell ;;;; ;;;; This been placed in Public Domain by the author, ;;;; Nikodemus Siivola (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))) anaphora-20170227-git/early.lisp000066400000000000000000000010151305033317300163320ustar00rootroot00000000000000;;;; Anaphora: The Anaphoric Macro Package from Hell ;;;; ;;;; This been placed in Public Domain by the author, ;;;; Nikodemus Siivola (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) anaphora-20170227-git/packages.lisp000066400000000000000000000031431305033317300170000ustar00rootroot00000000000000;;;; Anaphora: The Anaphoric Macro Package from Hell ;;;; ;;;; This been placed in Public Domain by the author, ;;;; Nikodemus Siivola (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 ")) anaphora-20170227-git/symbolic.lisp000066400000000000000000000044301305033317300170430ustar00rootroot00000000000000;;;; 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))))) anaphora-20170227-git/tests.lisp000066400000000000000000000161071305033317300163700ustar00rootroot00000000000000;;;; Anaphora: The Anaphoric Macro Package from Hell ;;;; ;;;; This been placed in Public Domain by the author, ;;;; Nikodemus Siivola (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)