Add DEFMACRO special function

Resolves #16

lisp/finance/interest-compounder.lisp

@@ -3,13 +3,11 @@
 (let ((static))
 
   (setq static
-    (eval
     (dlambda
-
       (:percent-of-number (n percentage)
         (if (> percentage 0)
           (/ (+ (* n percentage) 50) 100)
-            (/ (- (* n percentage) 50) 100))))))
+          (/ (- (* n percentage) 50) 100)))))
 
   (defun interest-compounder (initial-principal initial-interest-rate)
     (let ((private) (public)
@@ -18,9 +16,7 @@
           (years-passed 0))
 
       (setq private
-        (eval
         (dlambda
-
           (:add-years (years)
             (if (> years 0)
               (setq years-passed (+ years-passed years))))
@@ -31,12 +27,10 @@
                 (setq principal
                   (+ principal
                     (call static :percent-of-number principal interest-rate)))
-                  (call private :compound-interest (- years 1))))))))
+                (call private :compound-interest (- years 1)))))))
 
       (setq public
-        (eval
         (dlambda
-
           (:get-years-passed ()
             years-passed)
 
@@ -54,4 +48,4 @@
 
           (:move-forward-years (years)
             (call private :compound-interest years)
-              (call private :add-years years))))))))
+            (call private :add-years years)))))))

lisp/lang/dlambda.lisp

@@ -1,6 +1,6 @@
 (load "functions.lisp")
 
-;; A special function 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
   ((add-method-clause
@@ -14,7 +14,7 @@
                   'arguments
                   '(rest arguments))))))))))
 
-  (define-special dlambda (&rest methods)
+  (defmacro dlambda (&rest methods)
     (cons 'lambda
       (cons '(&rest arguments)
         (list

lisp/object/composition.lisp

@@ -3,9 +3,7 @@
 (defun counter (initial-count)
   (let ((count initial-count))
 
-    (eval
     (dlambda
-
       (:inc ()
         (setq count (+ count 1)))
 
@@ -16,7 +14,7 @@
         count)
 
       (:set (value)
-          (setq count value))))))
+        (setq count value)))))
 
 
 (defun fruit-counter (initial-count)
@@ -24,9 +22,7 @@
         (banana-counter (counter initial-count))
         (coconut-counter (counter initial-count)))
 
-    (eval
     (dlambda
-
       (:inc-apples ()
         (call apple-counter :inc))
 
@@ -67,7 +63,7 @@
         (list
           (list 'apples   (call apple-counter :get))
           (list 'bananas  (call banana-counter :get))
-            (list 'coconuts (call coconut-counter :get))))))))
+          (list 'coconuts (call coconut-counter :get)))))))
 
 
 ; Create an instance

lisp/object/this.lisp

@@ -7,9 +7,7 @@
     (setq name "Counter")
 
     (setq this
-      (eval
       (dlambda
-
         (:inc ()
           (setq count (+ count 1)))
 
@@ -33,7 +31,7 @@
           (setq count value))
 
         (t ()
-            (cons name count)))))))
+          (cons name count))))))
 
 
 (let ((instance (counter 0)))

lisp/random/structure.lisp

@@ -1,13 +1,11 @@
 (load "../lang/dlambda.lisp")
 (load "../lang/functions.lisp")
 
-(define-special keys (&rest fields)
-  (eval
+(defmacro keys (&rest fields)
   (list 'let (mapcar 'list fields)
-      '(eval
-        (dlambda
+    '(dlambda
       (:get (field) (eval field))
-          (:set (field value) (set field value)))))))
+      (:set (field value) (set field value)))))
 
 (defun process-data (data)
   (let ((one (call data :get 'one))

lisp/unit/unit-tester.lisp

@@ -6,9 +6,7 @@
     public-static)
 
   (setq private-static
-    (eval
     (dlambda
-
       (:assertion-failed (comparison operand1 operand2)
         (call private-static :print-failure comparison operand1 operand2)
         nil)
@@ -18,12 +16,10 @@
         (print (list comparison 'comparison 'failed))
         (print operand1)
         (print operand2)
-          (print '--------------------------------------------------)))))
+        (print '--------------------------------------------------))))
 
   (setq public-static
-    (eval
     (dlambda
-
       (:assert= (expected actual)
         (call public-static :assert '= expected actual))
 
@@ -33,16 +29,14 @@
       (:assert (comparison operand1 operand2)
         (if (call comparison operand1 operand2)
           t
-            (call private-static :assertion-failed comparison operand1 operand2))))))
+          (call private-static :assertion-failed comparison operand1 operand2)))))
 
   (defun unit-tester (suite)
     (let ((private) (public)
           (suite suite))
 
       (setq private
-        (eval
         (dlambda
-
           (:run-suite (suite)
             (if suite
               (cons
@@ -60,11 +54,9 @@
 
           (:indicate-failure (test)
             (print (cons 'f test))
-              nil))))
+            nil)))
 
       (setq public
-        (eval
         (dlambda
-
           (:run ()
-              (apply 'and (call private :run-suite suite)))))))))
+            (apply 'and (call private :run-suite suite))))))))

src/function/LispFunction.java

@@ -6,8 +6,12 @@ public abstract class LispFunction {
 
     public abstract SExpression call(Cons argList);
 
-    public boolean evaluateArguments() {
+    public boolean isArgumentListEvaluated() {
         return true;
     }
     
+    public boolean isMacro() {
+        return false;
+    }
+
 }

src/function/LispMacro.java

@@ -0,0 +1,10 @@
+package function;
+
+public abstract class LispMacro extends LispSpecialFunction {
+
+    @Override
+    public boolean isMacro() {
+        return true;
+    }
+
+}

src/function/LispSpecialFunction.java

@@ -3,7 +3,7 @@ package function;
 public abstract class LispSpecialFunction extends LispFunction {
 
     @Override
-    public boolean evaluateArguments() {
+    public boolean isArgumentListEvaluated() {
         return false;
     }
 

src/function/UserDefinedMacro.java

@@ -0,0 +1,16 @@
+package function;
+
+import sexpression.Cons;
+
+public class UserDefinedMacro extends UserDefinedSpecialFunction {
+
+    public UserDefinedMacro(String name, Cons lambdaList, Cons body) {
+        super(name, lambdaList, body);
+    }
+
+    @Override
+    public boolean isMacro() {
+        return true;
+    }
+
+}

src/function/UserDefinedSpecialFunction.java

@@ -9,7 +9,7 @@ public class UserDefinedSpecialFunction extends UserDefinedFunction {
     }
 
     @Override
-    public boolean evaluateArguments() {
+    public boolean isArgumentListEvaluated() {
         return false;
     }
 

src/function/builtin/EVAL.java

@@ -1,5 +1,7 @@
 package function.builtin;
 
+import static function.builtin.cons.LIST.makeList;
+import static function.builtin.special.LAMBDA.*;
 import static sexpression.Nil.NIL;
 import static sexpression.Symbol.T;
 import static table.FunctionTable.lookupFunction;
@@ -8,14 +10,18 @@ import java.text.MessageFormat;
 
 import error.LispException;
 import function.*;
-import function.builtin.cons.LIST;
-import function.builtin.special.LAMBDA;
 import sexpression.*;
 import table.ExecutionContext;
 
 @FunctionNames({ "EVAL" })
 public class EVAL extends LispFunction {
 
+    public static SExpression eval(SExpression sExpression) {
+        Cons argumentList = makeList(sExpression);
+
+        return lookupFunction("EVAL").call(argumentList);
+    }
+
     public static LispFunction lookupFunctionOrLambda(SExpression functionExpression) {
         LispFunction function = lookupFunction(functionExpression.toString());
 
@@ -28,8 +34,8 @@ public class EVAL extends LispFunction {
     private static LispFunction createLambdaFunction(SExpression lambdaExpression) {
         if (lambdaExpression.isFunction())
             return ((LambdaExpression) lambdaExpression).getFunction();
-        else if (LAMBDA.isLambdaExpression(lambdaExpression))
-            return LAMBDA.createFunction((Cons) lambdaExpression);
+        else if (isLambdaExpression(lambdaExpression))
+            return createFunction((Cons) lambdaExpression);
         else
             throw new UndefinedFunctionException(lambdaExpression);
     }
@@ -45,12 +51,6 @@ public class EVAL extends LispFunction {
         return ExecutionContext.getInstance().lookupSymbolValue(symbolName);
     }
 
-    public static SExpression eval(SExpression sExpression) {
-        Cons argumentList = LIST.makeList(sExpression);
-
-        return lookupFunction("EVAL").call(argumentList);
-    }
-
     private ArgumentValidator argumentValidator;
 
     public EVAL(String name) {
@@ -60,52 +60,71 @@ public class EVAL extends LispFunction {
 
     public SExpression call(Cons argumentList) {
         argumentValidator.validate(argumentList);
-
         SExpression argument = argumentList.getFirst();
 
-        if (argument.isList()) {
-            if (argument.isCons())
-                return evaluateList((Cons) argument);
-
-            return argument; // NIL
+        return evaluateExpression(argument);
     }
 
-        if (argument.isSymbol()) {
-            SExpression symbolValue = lookupSymbol(argument.toString());
+    private SExpression evaluateExpression(SExpression argument) {
+        if (argument.isList())
+            return evaluateList(argument);
 
-            if (symbolValue != null)
-                return symbolValue;
-
-            throw new UndefinedSymbolException(argument);
-        }
+        if (argument.isSymbol())
+            return evaluateSymbol(argument);
 
         return argument; // NUMBER or STRING
     }
 
-    private SExpression evaluateList(Cons list) {
+    private SExpression evaluateList(SExpression argument) {
+        if (argument.isCons())
+            return evaluateFunction((Cons) argument);
+
+        return argument; // NIL
+    }
+
+    private SExpression evaluateFunction(Cons list) {
         SExpression functionName = list.getFirst();
         SExpression arguments = list.getRest();
         LispFunction function = lookupFunctionOrLambda(functionName);
+        validateFunctionList(list, functionName);
 
-        ArgumentValidator functionListValidator = new ArgumentValidator(functionName.toString());
-        functionListValidator.validate(list);
-
-        Cons argumentList = (Cons) arguments;
-
-        if (function.evaluateArguments())
-            argumentList = evaluateArgList(argumentList);
-
-        return function.call(argumentList);
+        return callFunction(function, (Cons) arguments);
     }
 
-    private Cons evaluateArgList(Cons arguments) {
+    private void validateFunctionList(Cons list, SExpression functionName) {
+        ArgumentValidator functionListValidator = new ArgumentValidator(functionName.toString());
+        functionListValidator.validate(list);
+    }
+
+    private SExpression callFunction(LispFunction function, Cons argumentList) {
+        if (function.isArgumentListEvaluated())
+            argumentList = evaluateArgumentList(argumentList);
+
+        SExpression result = function.call(argumentList);
+
+        if (function.isMacro())
+            result = eval(result);
+
+        return result;
+    }
+
+    private Cons evaluateArgumentList(Cons arguments) {
         if (arguments.isNull())
             return NIL;
 
         SExpression first = eval(arguments.getFirst());
         SExpression rest = arguments.getRest();
 
-        return new Cons(first, evaluateArgList((Cons) rest));
+        return new Cons(first, evaluateArgumentList((Cons) rest));
+    }
+
+    private SExpression evaluateSymbol(SExpression argument) {
+        SExpression symbolValue = lookupSymbol(argument.toString());
+
+        if (symbolValue != null)
+            return symbolValue;
+
+        throw new UndefinedSymbolException(argument);
     }
 
     public static class UndefinedFunctionException extends LispException {

src/function/builtin/special/DEFMACRO.java

@@ -0,0 +1,18 @@
+package function.builtin.special;
+
+import function.*;
+import sexpression.*;
+
+@FunctionNames({ "DEFMACRO" })
+public class DEFMACRO extends Define {
+
+    public DEFMACRO(String name) {
+        super(name);
+    }
+
+    @Override
+    protected UserDefinedFunction createFunction(SExpression functionName, Cons lambdaList, Cons functionBody) {
+        return new UserDefinedMacro(functionName.toString(), lambdaList, functionBody);
+    }
+
+}

src/table/FunctionTable.java

@@ -23,6 +23,7 @@ public class FunctionTable {
         allBuiltIns.add(COND.class);
         allBuiltIns.add(CONS.class);
         allBuiltIns.add(DEFINE_SPECIAL.class);
+        allBuiltIns.add(DEFMACRO.class);
         allBuiltIns.add(DEFUN.class);
         allBuiltIns.add(DIVIDE.class);
         allBuiltIns.add(EQ.class);

test/function/LispFunctionTester.java

@@ -18,7 +18,7 @@ public class LispFunctionTester {
             }
         };
 
-        assertTrue(lispFunction.evaluateArguments());
+        assertTrue(lispFunction.isArgumentListEvaluated());
     }
 
 }

test/function/LispSpecialFunctionTester.java

@@ -18,7 +18,7 @@ public class LispSpecialFunctionTester {
             }
         };
 
-        assertFalse(lispFunction.evaluateArguments());
+        assertFalse(lispFunction.isArgumentListEvaluated());
     }
 
 }

test/function/builtin/special/DEFINE_SPECIALTester.java

@@ -60,7 +60,7 @@ public class DEFINE_SPECIALTester {
     }
 
     @Test
-    public void defineSpecialDoesNotEvaluatesArguments() {
+    public void defineSpecialDoesNotEvaluateArguments() {
         evaluateString("(define-special f (x) (car x))");
         assertSExpressionsMatch(parseString("quote"), evaluateString("(f '(1 2 3))"));
     }
@@ -174,4 +174,13 @@ public class DEFINE_SPECIALTester {
         evaluateString("(f)");
     }
 
+    @Test
+    public void resultOfSpecialFunctionIsNotEvaluated() {
+        evaluateString("(setq x 'grains)");
+        evaluateString("(define-special f (x) x)");
+        evaluateString("(f (setq x 'sprouts))");
+
+        assertSExpressionsMatch(parseString("grains"), evaluateString("x"));
+    }
+
 }

test/function/builtin/special/DEFMACROTester.java

@@ -0,0 +1,181 @@
+package function.builtin.special;
+
+import static org.junit.Assert.assertTrue;
+import static table.FunctionTable.resetFunctionTable;
+import static testutil.TestUtilities.*;
+
+import java.io.*;
+
+import org.junit.*;
+
+import environment.RuntimeEnvironment;
+import error.ErrorManager;
+import function.ArgumentValidator.*;
+import function.UserDefinedFunction.IllegalKeywordRestPositionException;
+
+public class DEFMACROTester {
+
+    private ByteArrayOutputStream outputStream;
+    private RuntimeEnvironment environment;
+
+    public DEFMACROTester() {
+        this.environment = RuntimeEnvironment.getInstance();
+    }
+
+    private void assertSomethingPrinted() {
+        assertTrue(outputStream.toByteArray().length > 0);
+    }
+
+    @Before
+    public void setUp() {
+        outputStream = new ByteArrayOutputStream();
+
+        environment.reset();
+        environment.setOutput(new PrintStream(outputStream));
+        environment.setErrorManager(new ErrorManager());
+        environment.setWarningOutputDecorator(s -> s);
+        resetFunctionTable();
+    }
+
+    @After
+    public void tearDown() {
+        environment.reset();
+        resetFunctionTable();
+    }
+
+    @Test
+    public void defmacro() {
+        String input = "(defmacro m () t)";
+
+        assertSExpressionsMatch(parseString("m"), evaluateString(input));
+        assertSExpressionsMatch(parseString("t"), evaluateString("(m)"));
+    }
+
+    @Test
+    public void defmacroWithEmptyBody() {
+        String input = "(defmacro m ())";
+
+        assertSExpressionsMatch(parseString("m"), evaluateString(input));
+        assertSExpressionsMatch(parseString("()"), evaluateString("(m)"));
+    }
+
+    @Test
+    public void defmacroDoesNotEvaluateArguments() {
+        evaluateString("(setq x 'grains)");
+        evaluateString("(defmacro m (x))");
+        evaluateString("(m (setq x 'sprouts))");
+
+        assertSExpressionsMatch(parseString("grains"), evaluateString("x"));
+    }
+
+    @Test
+    public void defmacroAdd() {
+        evaluateString("(defmacro m (x) (+ (eval x) 23))");
+        assertSExpressionsMatch(parseString("27"), evaluateString("(m (+ 2 2))"));
+    }
+
+    @Test
+    public void defmacroSetVariable() {
+        evaluateString("(defmacro m (x) (set x 23))");
+        evaluateString("(m y)");
+        assertSExpressionsMatch(parseString("23"), evaluateString("y"));
+    }
+
+    @Test
+    public void defmacroVariableCapture() {
+        evaluateString("(setq x 0)");
+        evaluateString("(defmacro m (x) (set x 23))");
+        evaluateString("(m x)");
+        assertSExpressionsMatch(parseString("0"), evaluateString("x"));
+    }
+
+    @Test
+    public void redefineMacro_DisplaysWarning() {
+        String input = "(defmacro myMacro () nil)";
+        evaluateString(input);
+        evaluateString(input);
+
+        assertSomethingPrinted();
+    }
+
+    @Test
+    public void redefineMacro_ActuallyRedefinesSpecialFunction() {
+        evaluateString("(defmacro myMacro () nil)");
+        evaluateString("(defmacro myMacro () T)");
+
+        assertSomethingPrinted();
+        assertSExpressionsMatch(parseString("t"), evaluateString("(myMacro)"));
+    }
+
+    @Test(expected = DottedArgumentListException.class)
+    public void defmacroWithDottedLambdaList() {
+        evaluateString("(funcall 'defmacro 'm (cons 'a 'b) ())");
+    }
+
+    @Test(expected = BadArgumentTypeException.class)
+    public void defmacroWithNonSymbolName() {
+        evaluateString("(defmacro 1 () ())");
+    }
+
+    @Test(expected = BadArgumentTypeException.class)
+    public void defmacroWithBadLambdaList() {
+        evaluateString("(defmacro m a ())");
+    }
+
+    @Test(expected = TooFewArgumentsException.class)
+    public void defmacroWithTooFewArguments() {
+        evaluateString("(defmacro m)");
+    }
+
+    @Test(expected = TooFewArgumentsException.class)
+    public void defmacroAndCallWithTooFewArguments() {
+        evaluateString("(defmacro m (a b))");
+        evaluateString("(m a)");
+    }
+
+    @Test(expected = TooManyArgumentsException.class)
+    public void defmacroAndCallWithTooManyArguments() {
+        evaluateString("(defmacro m (a b))");
+        evaluateString("(m a b c)");
+    }
+
+    @Test
+    public void defmacroWithKeywordRestParameter() {
+        evaluateString("(defmacro m (&rest x) (car x))");
+        assertSExpressionsMatch(parseString("1"), evaluateString("(m 1 2 3 4 5)"));
+    }
+
+    @Test
+    public void defmacroWithNormalAndKeywordRestParameter() {
+        evaluateString("(defmacro m (a &rest b) (list 'cons a (list 'quote b)))");
+        assertSExpressionsMatch(parseString("(1 2 3 4 5)"), evaluateString("(m 1 2 3 4 5)"));
+    }
+
+    @Test(expected = IllegalKeywordRestPositionException.class)
+    public void defmacroWithParametersFollowingKeywordRest() {
+        evaluateString("(defmacro m (a &rest b c) (cons a b))");
+        evaluateString("(m 1 2 3)");
+    }
+
+    @Test
+    public void defmacroWithKeywordRest_CallWithNoArguments() {
+        evaluateString("(defmacro m (&rest a) (car a))");
+        assertSExpressionsMatch(parseString("nil"), evaluateString("(m)"));
+    }
+
+    @Test(expected = TooFewArgumentsException.class)
+    public void defmacroWithNormalAndKeywordRest_CallWithNoArguments() {
+        evaluateString("(defmacro m (a &rest b) a)");
+        evaluateString("(m)");
+    }
+
+    @Test
+    public void macroIsEvaluatedAfterExpansion() {
+        evaluateString("(setq x 'grains)");
+        evaluateString("(defmacro m (x) x)");
+        evaluateString("(m (setq x 'sprouts))");
+
+        assertSExpressionsMatch(parseString("sprouts"), evaluateString("x"));
+    }
+
+}

test/function/builtin/special/DEFUNTester.java

@@ -99,16 +99,16 @@ public class DEFUNTester {
 
     @Test
     public void redefineFunction_ActuallyRedefinesFunction() {
-        evaluateString("(defun myFunction2 () nil)");
-        evaluateString("(defun myFunction2 () T)");
+        evaluateString("(defun myFunction () nil)");
+        evaluateString("(defun myFunction () T)");
 
         assertSomethingPrinted();
-        assertSExpressionsMatch(parseString("t"), evaluateString("(myFunction2)"));
+        assertSExpressionsMatch(parseString("t"), evaluateString("(myFunction)"));
     }
 
     @Test(expected = DottedArgumentListException.class)
     public void defunWithDottedLambdaList() {
-        evaluateString("(funcall 'defun 'x (cons 'a 'b) ())");
+        evaluateString("(funcall 'defun 'f (cons 'a 'b) ())");
     }
 
     @Test(expected = BadArgumentTypeException.class)
@@ -118,24 +118,24 @@ public class DEFUNTester {
 
     @Test(expected = BadArgumentTypeException.class)
     public void defunWithBadLambdaList() {
-        evaluateString("(defun x a ())");
+        evaluateString("(defun f a ())");
     }
 
     @Test(expected = TooFewArgumentsException.class)
     public void defunWithTooFewArguments() {
-        evaluateString("(defun x)");
+        evaluateString("(defun f)");
     }
 
     @Test(expected = TooFewArgumentsException.class)
     public void defunFunctionAndCallWithTooFewArguments() {
-        evaluateString("(defun x (a b))");
-        evaluateString("(x 'a)");
+        evaluateString("(defun f (a b))");
+        evaluateString("(f 'a)");
     }
 
     @Test(expected = TooManyArgumentsException.class)
     public void defunFunctionAndCallWithTooManyArguments() {
-        evaluateString("(defun x (a b))");
-        evaluateString("(x 'a 'b 'c)");
+        evaluateString("(defun f (a b))");
+        evaluateString("(f 'a 'b 'c)");
     }
 
     @Test
@@ -168,4 +168,13 @@ public class DEFUNTester {
         evaluateString("(f)");
     }
 
+    @Test
+    public void resultOfFunctionIsNotEvaluated() {
+        evaluateString("(setq x 'grains)");
+        evaluateString("(define-special f (x) 'x)");
+        evaluateString("(f (setq x 'sprouts))");
+
+        assertSExpressionsMatch(parseString("grains"), evaluateString("x"));
+    }
+
 }