mike
/
transcendental-lisp
1
1
Fork 0
Code Issues 10 Pull Requests Packages Projects Releases Wiki Activity

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:
Mike Cifelli 2017-03-13 14:43:31 -04:00
parent b2d6f21f88
commit a21114ac7c
7 changed files with 352 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

150
lisp/lang/dlambda-test.lisp
View File

@ -4,94 +4,94 @@
(setq assertions (unit-tester-assertions)) (setq assertions (unit-tester-assertions))
(setq tests (setq tests
(list (let ((arguments (gensym)))
(list
(defun empty-dlambda () (defun empty-dlambda ()
(call assertions :assert-equal (call assertions :assert-gensym-equal
'(lambda (&rest arguments) (case (first arguments))) `(lambda (&rest ,arguments) (case (first ,arguments)))
(dlambda))) (dlambda)))
(defun dlambda-default-method-only () (defun dlambda-default-method-only ()
(call assertions :assert-equal (call assertions :assert-gensym-equal
'(lambda (&rest arguments) `(lambda (&rest ,arguments)
(case (first arguments) (case (first ,arguments)
(t (apply (lambda () (print "nothing")) arguments)))) (t (apply (lambda () (print "nothing")) ,arguments))))
(dlambda (dlambda
(t () (print "nothing"))))) (t () (print "nothing")))))
(defun dlambda-named-method-only () (defun dlambda-named-method-only ()
(call assertions :assert-equal (call assertions :assert-gensym-equal
'(lambda (&rest arguments) `(lambda (&rest ,arguments)
(case (first arguments) (case (first ,arguments)
(:write (apply (lambda () (print "something")) (rest arguments))))) (:write (apply (lambda () (print "something")) (rest ,arguments)))))
(dlambda (dlambda
(:write () (print "something"))))) (:write () (print "something")))))
(defun dlambda-many-named-methods () (defun dlambda-many-named-methods ()
(call assertions :assert-equal (call assertions :assert-gensym-equal
'(lambda (&rest arguments) `(lambda (&rest ,arguments)
(case (first arguments) (case (first ,arguments)
(:write1 (apply (lambda () (print "something")) (rest arguments))) (:write1 (apply (lambda () (print "something")) (rest ,arguments)))
(:write2 (apply (lambda () (print "something")) (rest arguments))) (:write2 (apply (lambda () (print "something")) (rest ,arguments)))
(:write3 (apply (lambda () (print "something")) (rest arguments))))) (:write3 (apply (lambda () (print "something")) (rest ,arguments)))))
(dlambda (dlambda
(:write1 () (print "something")) (:write1 () (print "something"))
(:write2 () (print "something")) (:write2 () (print "something"))
(:write3 () (print "something"))))) (:write3 () (print "something")))))
(defun dlambda-named-and-default-method () (defun dlambda-named-and-default-method ()
(call assertions :assert-equal (call assertions :assert-gensym-equal
'(lambda (&rest arguments) `(lambda (&rest ,arguments)
(case (first arguments) (case (first ,arguments)
(:write (apply (lambda () (print "something")) (rest arguments))) (:write (apply (lambda () (print "something")) (rest ,arguments)))
(t (apply (lambda () (print "nothing")) arguments)))) (t (apply (lambda () (print "nothing")) ,arguments))))
(dlambda (dlambda
(:write () (print "something")) (:write () (print "something"))
(t () (print "nothing"))))) (t () (print "nothing")))))
(defun dlambda-methods-with-arguments () (defun dlambda-methods-with-arguments ()
(call assertions :assert-equal (call assertions :assert-gensym-equal
'(lambda (&rest arguments) `(lambda (&rest ,arguments)
(case (first arguments) (case (first ,arguments)
(:write (apply (lambda (message) (print message)) (rest arguments))) (:write (apply (lambda (message) (print message)) (rest ,arguments)))
(t (apply (lambda (&rest messages) (print messages)) arguments)))) (t (apply (lambda (&rest messages) (print messages)) ,arguments))))
(dlambda (dlambda
(:write (message) (print message)) (:write (message) (print message))
(t (&rest messages) (print messages))))) (t (&rest messages) (print messages)))))
(defun dlambda-methods-with-multiple-arguments () (defun dlambda-methods-with-multiple-arguments ()
(call assertions :assert-equal (call assertions :assert-gensym-equal
'(lambda (&rest arguments) `(lambda (&rest ,arguments)
(case (first arguments) (case (first ,arguments)
(:write (:write
(apply (apply
(lambda (message &rest other-stuff) (lambda (message &rest other-stuff)
(print message) (print message)
(print other-stuff)) (print other-stuff))
(rest arguments))) (rest ,arguments)))
(t (t
(apply (apply
(lambda (message1 message2 &rest other-stuff) (lambda (message1 message2 &rest other-stuff)
(print message1) (print message1)
(print message2) (print message2)
(print other-stuff)) (print other-stuff))
arguments)))) ,arguments))))
(dlambda (dlambda
(:write (message &rest other-stuff) (:write (message &rest other-stuff)
(print message) (print message)
(print other-stuff)) (print other-stuff))
(t (message1 message2 &rest other-stuff) (t (message1 message2 &rest other-stuff)
(print message1) (print message1)
(print message2) (print message2)
(print other-stuff))))))) (print other-stuff))))))))
(setq tester (unit-tester tests)) (call (unit-tester tests))
(call tester :run)

30
lisp/lang/dlambda.lisp
View File

@ -2,22 +2,16 @@
;; This is based on the dlambda macro presented in "Let Over Lambda" by Doug Hoyte. ;; This is based on the dlambda macro presented in "Let Over Lambda" by Doug Hoyte.
(let (defmacro dlambda (&rest methods)
((add-method-clause (let ((arguments (gensym)))
(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) `(lambda (&rest ,arguments)
(cons 'lambda (case (first ,arguments)
(cons '(&rest arguments) ,@(mapcar
(list (lambda (method)
(cons 'case `(,(first method)
(cons '(first arguments) (apply (lambda ,@(rest method))
(mapcar add-method-clause methods)))))))) ,(if (equal t (first method))
arguments
`(rest ,arguments)))))
methods)))))

4
lisp/random/structure.lisp
View File

@ -2,8 +2,8 @@
(load "../lang/functions.lisp") (load "../lang/functions.lisp")
(defmacro keys (&rest fields) (defmacro keys (&rest fields)
(list 'let (mapcar 'list fields) `(let ,(mapcar 'list fields)
'(dlambda (dlambda
(:get (field) (eval field)) (:get (field) (eval field))
(:set (field value) (set field value))))) (:set (field value) (set field value)))))

8
lisp/unit/unit-tester.lisp
View File

@ -26,6 +26,9 @@
(:assert-equal (expected actual) (:assert-equal (expected actual)
(call public-static :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) (:assert (comparison operand1 operand2)
(if (call comparison operand1 operand2) (if (call comparison operand1 operand2)
t t
@ -59,4 +62,7 @@
(setq public (setq public
(dlambda (dlambda
(:run () (:run ()
(apply 'and (call private :run-suite suite)))))))) (apply 'and (call private :run-suite suite)))
(t ()
(call public :run)))))))

96
src/function/builtin/predicate/GENSYM_EQUAL.java Normal file
View File

@ -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;
}
}
}

1
src/table/FunctionTable.java
View File

@ -34,6 +34,7 @@ public class FunctionTable {
allBuiltIns.add(FIRST.class); allBuiltIns.add(FIRST.class);
allBuiltIns.add(FUNCALL.class); allBuiltIns.add(FUNCALL.class);
allBuiltIns.add(GENSYM.class); allBuiltIns.add(GENSYM.class);
allBuiltIns.add(GENSYM_EQUAL.class);
allBuiltIns.add(NUMERIC_GREATER.class); allBuiltIns.add(NUMERIC_GREATER.class);
allBuiltIns.add(IF.class); allBuiltIns.add(IF.class);
allBuiltIns.add(LAMBDA.class); allBuiltIns.add(LAMBDA.class);

159
test/function/builtin/predicate/GENSYM_EQUALTester.java Normal file
View File

@ -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));
}
}