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

Add DEFMACRO special function 

Resolves #16
This commit is contained in:
Mike Cifelli 2017-03-10 15:08:42 -05:00
parent 16b9a4dd30
commit 655f49e612
19 changed files with 452 additions and 207 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
lisp/finance/interest-compounder.lisp
View File

@ -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))))))
(dlambda
(:percent-of-number (n percentage)
(if (> percentage 0)
(/ (+ (* n percentage) 50) 100)
(/ (- (* n percentage) 50) 100)))))
(defun interest-compounder (initial-principal initial-interest-rate)
(let ((private) (public)
@ -18,40 +16,36 @@
(years-passed 0))
(setq private
(eval
(dlambda
(dlambda
(:add-years (years)
(if (> years 0)
(setq years-passed (+ years-passed years))))
(:add-years (years)
(if (> years 0)
(setq years-passed (+ years-passed years))))
(:compound-interest (years)
(if (> years 0)
(begin
(setq principal
(+ principal
(call static :percent-of-number principal interest-rate)))
(call private :compound-interest (- years 1))))))))
(:compound-interest (years)
(if (> years 0)
(begin
(setq principal
(+ principal
(call static :percent-of-number principal interest-rate)))
(call private :compound-interest (- years 1)))))))
(setq public
(eval
(dlambda
(dlambda
(:get-years-passed ()
years-passed)
(:get-years-passed ()
years-passed)
(:get-principal ()
principal)
(:get-principal ()
principal)
(:get-interest-rate ()
interest-rate)
(:get-interest-rate ()
interest-rate)
(:set-interest-rate (new-interest-rate)
(setq interest-rate new-interest-rate))
(:set-interest-rate (new-interest-rate)
(setq interest-rate new-interest-rate))
(:make-contribution (contribution)
(setq principal (+ principal contribution)))
(:make-contribution (contribution)
(setq principal (+ principal contribution)))
(:move-forward-years (years)
(call private :compound-interest years)
(call private :add-years years))))))))
(:move-forward-years (years)
(call private :compound-interest years)
(call private :add-years years)))))))

4
lisp/lang/dlambda.lisp
View File

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

82
lisp/object/composition.lisp
View File

@ -3,20 +3,18 @@
(defun counter (initial-count)
(let ((count initial-count))
(eval
(dlambda
(dlambda
(:inc ()
(setq count (+ count 1)))
(:inc ()
(setq count (+ count 1)))
(:dec ()
(setq count (- count 1)))
(:dec ()
(setq count (- count 1)))
(:get ()
count)
(:get ()
count)
(:set (value)
(setq count value))))))
(:set (value)
(setq count value)))))
(defun fruit-counter (initial-count)
@ -24,50 +22,48 @@
(banana-counter (counter initial-count))
(coconut-counter (counter initial-count)))
(eval
(dlambda
(dlambda
(:inc-apples ()
(call apple-counter :inc))
(:inc-apples ()
(call apple-counter :inc))
(:dec-apples ()
(call apple-counter :dec))
(:dec-apples ()
(call apple-counter :dec))
(:get-apples ()
(call apple-counter :get))
(:get-apples ()
(call apple-counter :get))
(:set-apples (value)
(call apple-counter :set value))
(:set-apples (value)
(call apple-counter :set value))
(:inc-bananas ()
(call banana-counter :inc))
(:inc-bananas ()
(call banana-counter :inc))
(:dec-bananas ()
(call banana-counter :dec))
(:dec-bananas ()
(call banana-counter :dec))
(:get-bananas ()
(call banana-counter :get))
(:get-bananas ()
(call banana-counter :get))
(:set-bananas (value)
(call banana-counter :set value))
(:set-bananas (value)
(call banana-counter :set value))
(:inc-coconuts ()
(call coconut-counter :inc))
(:inc-coconuts ()
(call coconut-counter :inc))
(:dec-coconuts ()
(call coconut-counter :dec))
(:dec-coconuts ()
(call coconut-counter :dec))
(:get-coconuts ()
(call coconut-counter :get))
(:get-coconuts ()
(call coconut-counter :get))
(:set-coconuts (value)
(call coconut-counter :set value))
(:set-coconuts (value)
(call coconut-counter :set value))
(t (&rest arguments)
(list
(list 'apples (call apple-counter :get))
(list 'bananas (call banana-counter :get))
(list 'coconuts (call coconut-counter :get))))))))
(t (&rest arguments)
(list
(list 'apples (call apple-counter :get))
(list 'bananas (call banana-counter :get))
(list 'coconuts (call coconut-counter :get)))))))
; Create an instance

40
lisp/object/this.lisp
View File

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

12
lisp/random/structure.lisp
View File

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

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

@ -6,65 +6,57 @@
public-static)
(setq private-static
(eval
(dlambda
(dlambda
(:assertion-failed (comparison operand1 operand2)
(call private-static :print-failure comparison operand1 operand2)
nil)
(:assertion-failed (comparison operand1 operand2)
(call private-static :print-failure comparison operand1 operand2)
nil)
(:print-failure (comparison operand1 operand2)
(print '==================================================)
(print (list comparison 'comparison 'failed))
(print operand1)
(print operand2)
(print '--------------------------------------------------)))))
(:print-failure (comparison operand1 operand2)
(print '==================================================)
(print (list comparison 'comparison 'failed))
(print operand1)
(print operand2)
(print '--------------------------------------------------))))
(setq public-static
(eval
(dlambda
(dlambda
(:assert= (expected actual)
(call public-static :assert '= expected actual))
(:assert= (expected actual)
(call public-static :assert '= expected actual))
(:assert-equal (expected actual)
(call public-static :assert 'equal expected actual))
(:assert-equal (expected actual)
(call public-static :assert 'equal expected actual))
(:assert (comparison operand1 operand2)
(if (call comparison operand1 operand2)
t
(call private-static :assertion-failed comparison operand1 operand2))))))
(:assert (comparison operand1 operand2)
(if (call comparison operand1 operand2)
t
(call private-static :assertion-failed comparison operand1 operand2)))))
(defun unit-tester (suite)
(let ((private) (public)
(suite suite))
(setq private
(eval
(dlambda
(dlambda
(:run-suite (suite)
(if suite
(cons
(call private :run-test (car suite))
(call private :run-suite (cdr suite)))))
(:run-suite (suite)
(if suite
(cons
(call private :run-test (car suite))
(call private :run-suite (cdr suite)))))
(:run-test (test)
(if (call test)
(call private :indicate-success test)
(call private :indicate-failure test)))
(:run-test (test)
(if (call test)
(call private :indicate-success test)
(call private :indicate-failure test)))
(:indicate-success (test)
(print (cons t test))
t)
(:indicate-success (test)
(print (cons t test))
t)
(:indicate-failure (test)
(print (cons 'f test))
nil))))
(:indicate-failure (test)
(print (cons 'f test))
nil)))
(setq public
(eval
(dlambda
(:run ()
(apply 'and (call private :run-suite suite)))))))))
(dlambda
(:run ()
(apply 'and (call private :run-suite suite))))))))

6
src/function/LispFunction.java
View File

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

10
src/function/LispMacro.java Normal file
View File

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

2
src/function/LispSpecialFunction.java
View File

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

16
src/function/UserDefinedMacro.java Normal file
View File

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

2
src/function/UserDefinedSpecialFunction.java
View File

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

91
src/function/builtin/EVAL.java
View File

@ -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 evaluateExpression(argument);
}
return argument; // NIL
}
private SExpression evaluateExpression(SExpression argument) {
if (argument.isList())
return evaluateList(argument);
if (argument.isSymbol()) {
SExpression symbolValue = lookupSymbol(argument.toString());
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 {

18
src/function/builtin/special/DEFMACRO.java Normal file
View File

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

1
src/table/FunctionTable.java
View File

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

2
test/function/LispFunctionTester.java
View File

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

2
test/function/LispSpecialFunctionTester.java
View File

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

11
test/function/builtin/special/DEFINE_SPECIALTester.java
View File

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

181
test/function/builtin/special/DEFMACROTester.java Normal file
View File

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

29
test/function/builtin/special/DEFUNTester.java
View File

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