Add a GENSYM-EQUAL function for unit testing macros

Some macro definitions were refactored along with their associated
unit tests.

lisp/lang/dlambda-test.lisp

@@ -4,39 +4,40 @@
 (setq assertions (unit-tester-assertions))
 
 (setq tests
+  (let ((arguments (gensym)))
     (list
 
       (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)))
 
       (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
             (t () (print "nothing")))))
 
       (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
             (:write () (print "something")))))
 
       (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
             (:write1 () (print "something"))
@@ -44,44 +45,44 @@
             (:write3 () (print "something")))))
 
       (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
             (:write () (print "something"))
             (t () (print "nothing")))))
 
       (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
             (:write (message) (print message))
             (t (&rest messages) (print messages)))))
 
       (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
                 (apply
                   (lambda (message &rest other-stuff)
                     (print message)
                     (print other-stuff))
-                (rest arguments)))
+                  (rest ,arguments)))
               (t
                 (apply
                   (lambda (message1 message2 &rest other-stuff)
                     (print message1)
                     (print message2)
                     (print other-stuff))
-                arguments))))
+                  ,arguments))))
 
           (dlambda
             (:write (message &rest other-stuff)
@@ -90,8 +91,7 @@
             (t (message1 message2 &rest other-stuff)
               (print message1)
               (print message2)
-            (print other-stuff)))))))
+              (print other-stuff))))))))
 
 
-(setq tester (unit-tester tests))
+(call (unit-tester tests))
-(call tester :run)

lisp/lang/dlambda.lisp

@@ -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)
-    (cons 'lambda
+  (let ((arguments (gensym)))
-      (cons '(&rest arguments)
+
-        (list
+    `(lambda (&rest ,arguments)
-          (cons 'case
+      (case (first ,arguments)
-            (cons '(first arguments)
+        ,@(mapcar
-              (mapcar add-method-clause methods))))))))
+            (lambda (method)
+              `(,(first method)
+                (apply (lambda ,@(rest method))
+                       ,(if (equal t (first method))
+                         arguments
+                         `(rest ,arguments)))))
+            methods)))))

lisp/random/structure.lisp

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

lisp/unit/unit-tester.lisp

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

src/function/builtin/predicate/GENSYM_EQUAL.java

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

src/table/FunctionTable.java

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

test/function/builtin/predicate/GENSYM_EQUALTester.java

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