Add a GENSYM-EQUAL function for unit testing macros
Some macro definitions were refactored along with their associated unit tests.
This commit is contained in:
parent
b2d6f21f88
commit
a21114ac7c
|
|
@ -4,94 +4,94 @@
|
|||
(setq assertions (unit-tester-assertions))
|
||||
|
||||
(setq tests
|
||||
(list
|
||||
(let ((arguments (gensym)))
|
||||
(list
|
||||
|
||||
(defun empty-dlambda ()
|
||||
(call assertions :assert-equal
|
||||
'(lambda (&rest arguments) (case (first arguments)))
|
||||
(defun empty-dlambda ()
|
||||
(call assertions :assert-gensym-equal
|
||||
`(lambda (&rest ,arguments) (case (first ,arguments)))
|
||||
|
||||
(dlambda)))
|
||||
(dlambda)))
|
||||
|
||||
(defun dlambda-default-method-only ()
|
||||
(call assertions :assert-equal
|
||||
'(lambda (&rest arguments)
|
||||
(case (first arguments)
|
||||
(t (apply (lambda () (print "nothing")) arguments))))
|
||||
(defun dlambda-default-method-only ()
|
||||
(call assertions :assert-gensym-equal
|
||||
`(lambda (&rest ,arguments)
|
||||
(case (first ,arguments)
|
||||
(t (apply (lambda () (print "nothing")) ,arguments))))
|
||||
|
||||
(dlambda
|
||||
(t () (print "nothing")))))
|
||||
(dlambda
|
||||
(t () (print "nothing")))))
|
||||
|
||||
(defun dlambda-named-method-only ()
|
||||
(call assertions :assert-equal
|
||||
'(lambda (&rest arguments)
|
||||
(case (first arguments)
|
||||
(:write (apply (lambda () (print "something")) (rest arguments)))))
|
||||
(defun dlambda-named-method-only ()
|
||||
(call assertions :assert-gensym-equal
|
||||
`(lambda (&rest ,arguments)
|
||||
(case (first ,arguments)
|
||||
(:write (apply (lambda () (print "something")) (rest ,arguments)))))
|
||||
|
||||
(dlambda
|
||||
(:write () (print "something")))))
|
||||
(dlambda
|
||||
(:write () (print "something")))))
|
||||
|
||||
(defun dlambda-many-named-methods ()
|
||||
(call assertions :assert-equal
|
||||
'(lambda (&rest arguments)
|
||||
(case (first arguments)
|
||||
(:write1 (apply (lambda () (print "something")) (rest arguments)))
|
||||
(:write2 (apply (lambda () (print "something")) (rest arguments)))
|
||||
(:write3 (apply (lambda () (print "something")) (rest arguments)))))
|
||||
(defun dlambda-many-named-methods ()
|
||||
(call assertions :assert-gensym-equal
|
||||
`(lambda (&rest ,arguments)
|
||||
(case (first ,arguments)
|
||||
(:write1 (apply (lambda () (print "something")) (rest ,arguments)))
|
||||
(:write2 (apply (lambda () (print "something")) (rest ,arguments)))
|
||||
(:write3 (apply (lambda () (print "something")) (rest ,arguments)))))
|
||||
|
||||
(dlambda
|
||||
(:write1 () (print "something"))
|
||||
(:write2 () (print "something"))
|
||||
(:write3 () (print "something")))))
|
||||
(dlambda
|
||||
(:write1 () (print "something"))
|
||||
(:write2 () (print "something"))
|
||||
(:write3 () (print "something")))))
|
||||
|
||||
(defun dlambda-named-and-default-method ()
|
||||
(call assertions :assert-equal
|
||||
'(lambda (&rest arguments)
|
||||
(case (first arguments)
|
||||
(:write (apply (lambda () (print "something")) (rest arguments)))
|
||||
(t (apply (lambda () (print "nothing")) arguments))))
|
||||
(defun dlambda-named-and-default-method ()
|
||||
(call assertions :assert-gensym-equal
|
||||
`(lambda (&rest ,arguments)
|
||||
(case (first ,arguments)
|
||||
(:write (apply (lambda () (print "something")) (rest ,arguments)))
|
||||
(t (apply (lambda () (print "nothing")) ,arguments))))
|
||||
|
||||
(dlambda
|
||||
(:write () (print "something"))
|
||||
(t () (print "nothing")))))
|
||||
(dlambda
|
||||
(:write () (print "something"))
|
||||
(t () (print "nothing")))))
|
||||
|
||||
(defun dlambda-methods-with-arguments ()
|
||||
(call assertions :assert-equal
|
||||
'(lambda (&rest arguments)
|
||||
(case (first arguments)
|
||||
(:write (apply (lambda (message) (print message)) (rest arguments)))
|
||||
(t (apply (lambda (&rest messages) (print messages)) arguments))))
|
||||
(defun dlambda-methods-with-arguments ()
|
||||
(call assertions :assert-gensym-equal
|
||||
`(lambda (&rest ,arguments)
|
||||
(case (first ,arguments)
|
||||
(:write (apply (lambda (message) (print message)) (rest ,arguments)))
|
||||
(t (apply (lambda (&rest messages) (print messages)) ,arguments))))
|
||||
|
||||
(dlambda
|
||||
(:write (message) (print message))
|
||||
(t (&rest messages) (print messages)))))
|
||||
(dlambda
|
||||
(:write (message) (print message))
|
||||
(t (&rest messages) (print messages)))))
|
||||
|
||||
(defun dlambda-methods-with-multiple-arguments ()
|
||||
(call assertions :assert-equal
|
||||
'(lambda (&rest arguments)
|
||||
(case (first arguments)
|
||||
(:write
|
||||
(apply
|
||||
(lambda (message &rest other-stuff)
|
||||
(print message)
|
||||
(print other-stuff))
|
||||
(rest arguments)))
|
||||
(t
|
||||
(apply
|
||||
(lambda (message1 message2 &rest other-stuff)
|
||||
(print message1)
|
||||
(print message2)
|
||||
(print other-stuff))
|
||||
arguments))))
|
||||
(defun dlambda-methods-with-multiple-arguments ()
|
||||
(call assertions :assert-gensym-equal
|
||||
`(lambda (&rest ,arguments)
|
||||
(case (first ,arguments)
|
||||
(:write
|
||||
(apply
|
||||
(lambda (message &rest other-stuff)
|
||||
(print message)
|
||||
(print other-stuff))
|
||||
(rest ,arguments)))
|
||||
(t
|
||||
(apply
|
||||
(lambda (message1 message2 &rest other-stuff)
|
||||
(print message1)
|
||||
(print message2)
|
||||
(print other-stuff))
|
||||
,arguments))))
|
||||
|
||||
(dlambda
|
||||
(:write (message &rest other-stuff)
|
||||
(print message)
|
||||
(print other-stuff))
|
||||
(t (message1 message2 &rest other-stuff)
|
||||
(print message1)
|
||||
(print message2)
|
||||
(print other-stuff)))))))
|
||||
(dlambda
|
||||
(:write (message &rest other-stuff)
|
||||
(print message)
|
||||
(print other-stuff))
|
||||
(t (message1 message2 &rest other-stuff)
|
||||
(print message1)
|
||||
(print message2)
|
||||
(print other-stuff))))))))
|
||||
|
||||
|
||||
(setq tester (unit-tester tests))
|
||||
(call tester :run)
|
||||
(call (unit-tester tests))
|
||||
|
|
|
|||
|
|
@ -2,22 +2,16 @@
|
|||
|
||||
;; This is based on the dlambda macro presented in "Let Over Lambda" by Doug Hoyte.
|
||||
|
||||
(let
|
||||
((add-method-clause
|
||||
(lambda (method)
|
||||
(cons (first method)
|
||||
(list
|
||||
(cons 'apply
|
||||
(cons (cons 'lambda (rest method))
|
||||
(list
|
||||
(if (equal t (car method))
|
||||
'arguments
|
||||
'(rest arguments))))))))))
|
||||
(defmacro dlambda (&rest methods)
|
||||
(let ((arguments (gensym)))
|
||||
|
||||
(defmacro dlambda (&rest methods)
|
||||
(cons 'lambda
|
||||
(cons '(&rest arguments)
|
||||
(list
|
||||
(cons 'case
|
||||
(cons '(first arguments)
|
||||
(mapcar add-method-clause methods))))))))
|
||||
`(lambda (&rest ,arguments)
|
||||
(case (first ,arguments)
|
||||
,@(mapcar
|
||||
(lambda (method)
|
||||
`(,(first method)
|
||||
(apply (lambda ,@(rest method))
|
||||
,(if (equal t (first method))
|
||||
arguments
|
||||
`(rest ,arguments)))))
|
||||
methods)))))
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
(load "../lang/functions.lisp")
|
||||
|
||||
(defmacro keys (&rest fields)
|
||||
(list 'let (mapcar 'list fields)
|
||||
'(dlambda
|
||||
`(let ,(mapcar 'list fields)
|
||||
(dlambda
|
||||
(:get (field) (eval field))
|
||||
(:set (field value) (set field value)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -26,6 +26,9 @@
|
|||
(:assert-equal (expected actual)
|
||||
(call public-static :assert 'equal expected actual))
|
||||
|
||||
(:assert-gensym-equal (expected actual)
|
||||
(call public-static :assert 'gensym-equal expected actual))
|
||||
|
||||
(:assert (comparison operand1 operand2)
|
||||
(if (call comparison operand1 operand2)
|
||||
t
|
||||
|
|
@ -59,4 +62,7 @@
|
|||
(setq public
|
||||
(dlambda
|
||||
(:run ()
|
||||
(apply 'and (call private :run-suite suite))))))))
|
||||
(apply 'and (call private :run-suite suite)))
|
||||
|
||||
(t ()
|
||||
(call public :run)))))))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,96 @@
|
|||
package function.builtin.predicate;
|
||||
|
||||
import static function.builtin.GENSYM.GENSYM_PREFIX;
|
||||
import static sexpression.Nil.NIL;
|
||||
import static sexpression.Symbol.T;
|
||||
|
||||
import java.util.*;
|
||||
import java.util.Map.Entry;
|
||||
import java.util.regex.*;
|
||||
|
||||
import function.*;
|
||||
import sexpression.*;
|
||||
|
||||
@FunctionNames({ "GENSYM-EQUAL", "GENSYM-EQUAL?" })
|
||||
public class GENSYM_EQUAL extends LispFunction {
|
||||
|
||||
private ArgumentValidator argumentValidator;
|
||||
|
||||
public GENSYM_EQUAL(String name) {
|
||||
this.argumentValidator = new ArgumentValidator(name);
|
||||
this.argumentValidator.setExactNumberOfArguments(2);
|
||||
}
|
||||
|
||||
@Override
|
||||
public SExpression call(Cons argumentList) {
|
||||
argumentValidator.validate(argumentList);
|
||||
|
||||
Cons rest = (Cons) argumentList.getRest();
|
||||
SExpression firstArgument = argumentList.getFirst();
|
||||
SExpression secondArgument = rest.getFirst();
|
||||
|
||||
return gensymEqual(firstArgument, secondArgument);
|
||||
}
|
||||
|
||||
private SExpression gensymEqual(SExpression firstArgument, SExpression secondArgument) {
|
||||
String firstEqualized = equalizeGensyms(firstArgument);
|
||||
String secondEqualized = equalizeGensyms(secondArgument);
|
||||
|
||||
return firstEqualized.equals(secondEqualized) ? T : NIL;
|
||||
}
|
||||
|
||||
private String equalizeGensyms(SExpression expression) {
|
||||
GensymEqualizer equalizer = new GensymEqualizer(expression.toString());
|
||||
|
||||
return equalizer.equalize();
|
||||
}
|
||||
|
||||
private static class GensymEqualizer {
|
||||
|
||||
private static final String GENSYM_REGEX = Pattern.quote(GENSYM_PREFIX) + "[0-9]+";
|
||||
|
||||
Map<String, String> gensymAliases;
|
||||
Matcher matcher;
|
||||
String expression;
|
||||
int counter;
|
||||
|
||||
public GensymEqualizer(String expression) {
|
||||
this.gensymAliases = new HashMap<>();
|
||||
this.matcher = Pattern.compile(GENSYM_REGEX).matcher(expression);
|
||||
this.expression = expression;
|
||||
this.counter = 0;
|
||||
}
|
||||
|
||||
public String equalize() {
|
||||
createGensymAliases();
|
||||
|
||||
return equalizeGensyms();
|
||||
}
|
||||
|
||||
private void createGensymAliases() {
|
||||
while (matcher.find())
|
||||
createAliasForGensym();
|
||||
}
|
||||
|
||||
private void createAliasForGensym() {
|
||||
String gensym = matcher.group();
|
||||
|
||||
if (isNewGensym(gensym))
|
||||
gensymAliases.put(gensym, GENSYM_PREFIX + (counter++));
|
||||
}
|
||||
|
||||
private boolean isNewGensym(String gensym) {
|
||||
return !gensymAliases.containsKey(gensym);
|
||||
}
|
||||
|
||||
private String equalizeGensyms() {
|
||||
String equalizedExpression = expression;
|
||||
|
||||
for (Entry<String, String> entry : gensymAliases.entrySet())
|
||||
equalizedExpression = equalizedExpression.replace(entry.getKey(), entry.getValue());
|
||||
|
||||
return equalizedExpression;
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
|
@ -34,6 +34,7 @@ public class FunctionTable {
|
|||
allBuiltIns.add(FIRST.class);
|
||||
allBuiltIns.add(FUNCALL.class);
|
||||
allBuiltIns.add(GENSYM.class);
|
||||
allBuiltIns.add(GENSYM_EQUAL.class);
|
||||
allBuiltIns.add(NUMERIC_GREATER.class);
|
||||
allBuiltIns.add(IF.class);
|
||||
allBuiltIns.add(LAMBDA.class);
|
||||
|
|
|
|||
|
|
@ -0,0 +1,159 @@
|
|||
package function.builtin.predicate;
|
||||
|
||||
import static testutil.TestUtilities.evaluateString;
|
||||
import static testutil.TypeAssertions.*;
|
||||
|
||||
import org.junit.Test;
|
||||
|
||||
import function.ArgumentValidator.*;
|
||||
|
||||
public class GENSYM_EQUALTester {
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithTwoEqualAtoms() {
|
||||
String input = "(gensym-equal 'a 'a)";
|
||||
|
||||
assertT(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithTwoEqualAtomsAndAlias() {
|
||||
String input = "(gensym-equal? 'a 'a)";
|
||||
|
||||
assertT(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithTwoUnequalAtoms() {
|
||||
String input = "(gensym-equal 'a 'b)";
|
||||
|
||||
assertNil(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithTwoEqualNumbers() {
|
||||
String input = "(gensym-equal -4 -4)";
|
||||
|
||||
assertT(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithTwoUnequalNumbers() {
|
||||
String input = "(gensym-equal +5 +7)";
|
||||
|
||||
assertNil(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithTwoEqualStrings() {
|
||||
String input = "(gensym-equal \"potato\" \"potato\")";
|
||||
|
||||
assertT(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithTwoUnequalStrings() {
|
||||
String input = "(gensym-equal \"tomato\" \"potato\")";
|
||||
|
||||
assertNil(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithTwoDifferentCasedStrings() {
|
||||
String input = "(gensym-equal \"Potato\" \"potato\")";
|
||||
|
||||
assertNil(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithAtomAndList() {
|
||||
String input = "(gensym-equal \"string\" '(m i k e))";
|
||||
|
||||
assertNil(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithListAndAtom() {
|
||||
String input = "(gensym-equal '(m i k e) \"string\")";
|
||||
|
||||
assertNil(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithTwoEqualLists() {
|
||||
String input = "(gensym-equal '(1 2 3) '(1 2 3))";
|
||||
|
||||
assertT(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithTwoUnequalLists() {
|
||||
String input = "(gensym-equal '(1 2 3) '(1 3 3))";
|
||||
|
||||
assertNil(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithTwoEqualNestedLists() {
|
||||
String input = "(gensym-equal '(1 ((2) 3)) '(1 ((2) 3)))";
|
||||
|
||||
assertT(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test(expected = TooManyArgumentsException.class)
|
||||
public void gensymEqualWithTooManyArguments() {
|
||||
evaluateString("(gensym-equal 1 2 3)");
|
||||
}
|
||||
|
||||
@Test(expected = TooFewArgumentsException.class)
|
||||
public void gensymEqualWithTooFewArguments() {
|
||||
evaluateString("(gensym-equal 1)");
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithGensyms() {
|
||||
String input = "(gensym-equal (gensym) (gensym))";
|
||||
|
||||
assertT(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithNestedGensyms() {
|
||||
String input = "(gensym-equal `(1 ,(gensym) (2 ,(gensym))) `(1 ,(gensym) (2 ,(gensym))))";
|
||||
|
||||
assertT(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithUnmatchedGensymPositions() {
|
||||
String input = "(gensym-equal (let ((one (gensym))) `(,one ,one))"
|
||||
+ " (let ((one (gensym)) (two (gensym))) `(,one ,two)))";
|
||||
|
||||
assertNil(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithMatchedGensymPositions() {
|
||||
String input = "(gensym-equal (let ((one (gensym))) `(,one ,one))"
|
||||
+ " (let ((one (gensym)) (two (gensym))) `(,one ,one)))";
|
||||
|
||||
assertT(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithComplexMatchedGensymPositions() {
|
||||
String input = "(gensym-equal (let ((x (gensym)) (y (gensym)) (z (gensym))) `(,x (,y ,z)))"
|
||||
+ " (let ((a (gensym)) (b (gensym)) (c (gensym))) `(,c (,a ,b))))";
|
||||
|
||||
assertT(evaluateString(input));
|
||||
}
|
||||
|
||||
@Test
|
||||
public void gensymEqualWithComplexUnmatchedGensymPositions() {
|
||||
String input = "(gensym-equal (let ((x (gensym)) (y (gensym)) (z (gensym))) `(,x , y (,z ,z)))"
|
||||
+ " (let ((a (gensym)) (b (gensym)) (c (gensym))) `(,a ,c (,b ,c))))";
|
||||
|
||||
assertNil(evaluateString(input));
|
||||
}
|
||||
|
||||
}
|
||||
Loading…
Reference in New Issue