anaphora-0.9.4/0000755000175000017500000000000011576130636012653 5ustar julianjuliananaphora-0.9.4/symbolic.lisp0000644000175000017500000000443011575657235015376 0ustar julianjulian;;;; 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-0.9.4/anaphora.asd0000644000175000017500000000141511576130706015134 0ustar julianjulian;;;; Anaphora: The Anaphoric Macro Package from Hell ;;;; ;;;; This been placed in Public Domain by the author, ;;;; Nikodemus Siivola (defsystem :anaphora :version "0.9.4" :components ((:file "packages") (:file "early" :depends-on ("packages")) (:file "symbolic" :depends-on ("early")) (:file "anaphora" :depends-on ("symbolic")))) (defsystem :anaphora-test :depends-on (:anaphora :rt) :components ((:file "tests"))) (defmethod perform ((o test-op) (c (eql (find-system :anaphora)))) (operate 'load-op :anaphora-test) (operate 'test-op :anaphora-test :force t)) (defmethod perform ((o test-op) (c (eql (find-system :anaphora-test)))) (or (funcall (intern "DO-TESTS" :rt)) (error "test-op failed"))) anaphora-0.9.4/tests.lisp0000644000175000017500000001647511575657235014733 0ustar julianjulian;;;; 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 scond.3 (scond ((symbol-value '*default-pathname-defaults*) (let ((tmp it)) (unwind-protect (progn (setf it (truename "/tmp/")) (namestring *default-pathname-defaults*)) (setf it tmp))))) "/tmp/") (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) anaphora-0.9.4/anaphora.lisp0000644000175000017500000001410711576130707015337 0ustar julianjulian;;;; 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-0.9.4/early.lisp0000644000175000017500000000101510026277543014653 0ustar julianjulian;;;; 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-0.9.4/LICENSE0000644000175000017500000000025310026277543013656 0ustar julianjulian;;;; This file is part of the Anaphora package Common Lisp, ;;;; and has been placed in Public Domain by the author, ;;;; Nikodemus Siivola anaphora-0.9.4/packages.lisp0000644000175000017500000000314311405570365015321 0ustar julianjulian;;;; 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 "))