kyle
/
ulisp
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Version 2.7 - 20th May 2019 

Fixes #12, #13
This commit is contained in:
David Johnson-Davies 2019-05-20 10:25:50 +01:00 committed by GitHub
parent 3710e8a7da
commit d83f40652d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
1 changed files with 31 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
ulisp-arm.ino
View File

@ -1,5 +1,5 @@
/* uLisp ARM 2.6a - www.ulisp.com /* uLisp ARM 2.7 - www.ulisp.com
David Johnson-Davies - www.technoblogy.com - 19th April 2019 David Johnson-Davies - www.technoblogy.com - 20th May 2019
Licensed under the MIT license: https://opensource.org/licenses/MIT Licensed under the MIT license: https://opensource.org/licenses/MIT
*/ */
@ -392,8 +392,7 @@ int compactimage (object **arg) {
char *MakeFilename (object *arg) { char *MakeFilename (object *arg) {
char *buffer = SymbolTop; char *buffer = SymbolTop;
int max = maxbuffer(buffer); int max = maxbuffer(buffer);
buffer[0]='/'; int i = 0;
int i = 1;
do { do {
char c = nthchar(arg, i); char c = nthchar(arg, i);
if (c == '\0') break; if (c == '\0') break;
@ -649,21 +648,19 @@ void autorunimage () {
File file = SD.open("ULISP.IMG"); File file = SD.open("ULISP.IMG");
if (!file) error(PSTR("Error: Problem autorunning from SD card")); if (!file) error(PSTR("Error: Problem autorunning from SD card"));
object *autorun = (object *)SDReadInt(file); object *autorun = (object *)SDReadInt(file);
object *nullenv = NULL;
file.close(); file.close();
if (autorun != NULL) { if (autorun != NULL) {
loadimage(NULL); loadimage(NULL);
apply(autorun, NULL, &nullenv); apply(autorun, NULL, NULL);
} }
#elif defined(ARDUINO_METRO_M4) || defined(ARDUINO_ITSYBITSY_M4) || defined(ARDUINO_FEATHER_M4) #elif defined(ARDUINO_METRO_M4) || defined(ARDUINO_ITSYBITSY_M4) || defined(ARDUINO_FEATHER_M4)
if (!FlashSetup()) error(PSTR("No DataFlash found.")); if (!FlashSetup()) error(PSTR("No DataFlash found."));
object *nullenv = NULL;
FlashBeginRead(); FlashBeginRead();
object *autorun = (object *)FlashReadInt(); object *autorun = (object *)FlashReadInt();
FlashEndRead(); FlashEndRead();
if (autorun != NULL && (unsigned int)autorun != 0xFFFF) { if (autorun != NULL && (unsigned int)autorun != 0xFFFF) {
loadimage(nil); loadimage(nil);
apply(autorun, NULL, &nullenv); apply(autorun, NULL, NULL);
} }
#else #else
error(PSTR("autorun not available")); error(PSTR("autorun not available"));
@ -961,15 +958,6 @@ object *findvalue (object *var, object *env) {
return pair; return pair;
} }
object *findtwin (object *var, object *env) {
while (env != NULL) {
object *pair = car(env);
if (pair != NULL && car(pair) == var) return pair;
env = cdr(env);
}
return NULL;
}
// Handling closures // Handling closures
object *closure (int tc, object *fname, object *state, object *function, object *args, object **env) { object *closure (int tc, object *fname, object *state, object *function, object *args, object **env) {
@ -982,10 +970,14 @@ object *closure (int tc, object *fname, object *state, object *function, object
} }
object *params = first(function); object *params = first(function);
function = cdr(function); function = cdr(function);
// Push state if not already in env // Dropframe
if (tc) {
while (*env != NULL && car(*env) != NULL) pop(*env);
} else push(nil, *env);
// Push state
while (state != NULL) { while (state != NULL) {
object *pair = first(state); object *pair = first(state);
if (findtwin(car(pair), *env) == NULL) push(pair, *env); push(pair, *env);
state = cdr(state); state = cdr(state);
} }
// Add arguments to environment // Add arguments to environment
@ -1014,9 +1006,7 @@ object *closure (int tc, object *fname, object *state, object *function, object
else error2(fname, PSTR("has too few arguments")); else error2(fname, PSTR("has too few arguments"));
} else { value = first(args); args = cdr(args); } } else { value = first(args); args = cdr(args); }
} }
object *pair = findtwin(var, *env); push(cons(var,value), *env);
if (tc && (pair != NULL)) cdr(pair) = value;
else push(cons(var,value), *env);
if (trace) { pserial(' '); printobject(value, pserial); } if (trace) { pserial(' '); printobject(value, pserial); }
} }
params = cdr(params); params = cdr(params);
@ -1027,24 +1017,24 @@ object *closure (int tc, object *fname, object *state, object *function, object
return tf_progn(function, *env); return tf_progn(function, *env);
} }
object *apply (object *function, object *args, object **env) { object *apply (object *function, object *args, object *env) {
if (symbolp(function)) { if (symbolp(function)) {
symbol_t name = function->name; symbol_t name = function->name;
int nargs = listlength(args); int nargs = listlength(args);
if (name >= ENDFUNCTIONS) error2(function, PSTR("is not valid here")); if (name >= ENDFUNCTIONS) error2(function, PSTR("is not valid here"));
if (nargs<lookupmin(name)) error2(function, PSTR("has too few arguments")); if (nargs<lookupmin(name)) error2(function, PSTR("has too few arguments"));
if (nargs>lookupmax(name)) error2(function, PSTR("has too many arguments")); if (nargs>lookupmax(name)) error2(function, PSTR("has too many arguments"));
return ((fn_ptr_type)lookupfn(name))(args, *env); return ((fn_ptr_type)lookupfn(name))(args, env);
} }
if (listp(function) && issymbol(car(function), LAMBDA)) { if (listp(function) && issymbol(car(function), LAMBDA)) {
function = cdr(function); function = cdr(function);
object *result = closure(0, NULL, NULL, function, args, env); object *result = closure(0, NULL, NULL, function, args, &env);
return eval(result, *env); return eval(result, env);
} }
if (listp(function) && issymbol(car(function), CLOSURE)) { if (listp(function) && issymbol(car(function), CLOSURE)) {
function = cdr(function); function = cdr(function);
object *result = closure(0, NULL, car(function), cdr(function), args, env); object *result = closure(0, NULL, car(function), cdr(function), args, &env);
return eval(result, *env); return eval(result, env);
} }
error2(function, PSTR("is an illegal function")); error2(function, PSTR("is an illegal function"));
return NULL; return NULL;
@ -1638,11 +1628,7 @@ object *sp_withspi (object *args, object *env) {
SPI.begin(); SPI.begin();
params = cddr(params); params = cddr(params);
if (params != NULL) { if (params != NULL) {
int d = integer(eval(first(params), env)); divider = integer(eval(first(params), env));
if (d<1 || d>7) error3(WITHSPI, PSTR("invalid divider"));
if (d == 7) divider = 3;
else if (d & 1) divider = (d>>1) + 4;
else divider = (d>>1) - 1;
params = cdr(params); params = cdr(params);
if (params != NULL) { if (params != NULL) {
bitorder = (eval(first(params), env) == NULL); bitorder = (eval(first(params), env) == NULL);
@ -1653,7 +1639,7 @@ object *sp_withspi (object *args, object *env) {
pinMode(pin, OUTPUT); pinMode(pin, OUTPUT);
digitalWrite(pin, LOW); digitalWrite(pin, LOW);
SPI.setBitOrder((BitOrder)bitorder); SPI.setBitOrder((BitOrder)bitorder);
SPI.setClockDivider(divider); if (divider != 0) SPI.setClockDivider(divider);
SPI.setDataMode(mode); SPI.setDataMode(mode);
object *forms = cdr(args); object *forms = cdr(args);
object *result = eval(tf_progn(forms,env), env); object *result = eval(tf_progn(forms,env), env);
@ -1966,11 +1952,11 @@ object *fn_apply (object *args, object *env) {
} }
if (!listp(car(last))) error3(APPLY, PSTR("last argument is not a list")); if (!listp(car(last))) error3(APPLY, PSTR("last argument is not a list"));
cdr(previous) = car(last); cdr(previous) = car(last);
return apply(first(args), cdr(args), &env); return apply(first(args), cdr(args), env);
} }
object *fn_funcall (object *args, object *env) { object *fn_funcall (object *args, object *env) {
return apply(first(args), cdr(args), &env); return apply(first(args), cdr(args), env);
} }
object *fn_append (object *args, object *env) { object *fn_append (object *args, object *env) {
@ -2003,13 +1989,13 @@ object *fn_mapc (object *args, object *env) {
while (list1 != NULL && list2 != NULL) { while (list1 != NULL && list2 != NULL) {
if (improperp(list1)) error3(name, PSTR("second argument is not a proper list")); if (improperp(list1)) error3(name, PSTR("second argument is not a proper list"));
if (improperp(list2)) error3(name, PSTR("third argument is not a proper list")); if (improperp(list2)) error3(name, PSTR("third argument is not a proper list"));
apply(function, cons(car(list1),cons(car(list2),NULL)), &env); apply(function, cons(car(list1),cons(car(list2),NULL)), env);
list1 = cdr(list1); list2 = cdr(list2); list1 = cdr(list1); list2 = cdr(list2);
} }
} else { } else {
while (list1 != NULL) { while (list1 != NULL) {
if (improperp(list1)) error3(name, PSTR("second argument is not a proper list")); if (improperp(list1)) error3(name, PSTR("second argument is not a proper list"));
apply(function, cons(car(list1),NULL), &env); apply(function, cons(car(list1),NULL), env);
list1 = cdr(list1); list1 = cdr(list1);
} }
} }
@ -2029,7 +2015,7 @@ object *fn_mapcar (object *args, object *env) {
while (list1 != NULL && list2 != NULL) { while (list1 != NULL && list2 != NULL) {
if (improperp(list1)) error3(name, PSTR("second argument is not a proper list")); if (improperp(list1)) error3(name, PSTR("second argument is not a proper list"));
if (improperp(list2)) error3(name, PSTR("third argument is not a proper list")); if (improperp(list2)) error3(name, PSTR("third argument is not a proper list"));
object *result = apply(function, cons(car(list1), cons(car(list2),NULL)), &env); object *result = apply(function, cons(car(list1), cons(car(list2),NULL)), env);
object *obj = cons(result,NULL); object *obj = cons(result,NULL);
cdr(tail) = obj; cdr(tail) = obj;
tail = obj; tail = obj;
@ -2038,7 +2024,7 @@ object *fn_mapcar (object *args, object *env) {
} else if (list1 != NULL) { } else if (list1 != NULL) {
while (list1 != NULL) { while (list1 != NULL) {
if (improperp(list1)) error3(name, PSTR("second argument is not a proper list")); if (improperp(list1)) error3(name, PSTR("second argument is not a proper list"));
object *result = apply(function, cons(car(list1),NULL), &env); object *result = apply(function, cons(car(list1),NULL), env);
object *obj = cons(result,NULL); object *obj = cons(result,NULL);
cdr(tail) = obj; cdr(tail) = obj;
tail = obj; tail = obj;
@ -2062,7 +2048,7 @@ object *fn_mapcan (object *args, object *env) {
while (list1 != NULL && list2 != NULL) { while (list1 != NULL && list2 != NULL) {
if (improperp(list1)) error3(name, PSTR("second argument is not a proper list")); if (improperp(list1)) error3(name, PSTR("second argument is not a proper list"));
if (improperp(list2)) error3(name, PSTR("third argument is not a proper list")); if (improperp(list2)) error3(name, PSTR("third argument is not a proper list"));
object *result = apply(function, cons(car(list1), cons(car(list2),NULL)), &env); object *result = apply(function, cons(car(list1), cons(car(list2),NULL)), env);
while (result != NULL && (unsigned int)result >= PAIR) { while (result != NULL && (unsigned int)result >= PAIR) {
cdr(tail) = result; cdr(tail) = result;
tail = result; tail = result;
@ -2074,7 +2060,7 @@ object *fn_mapcan (object *args, object *env) {
} else if (list1 != NULL) { } else if (list1 != NULL) {
while (list1 != NULL) { while (list1 != NULL) {
if (improperp(list1)) error3(name, PSTR("second argument is not a proper list")); if (improperp(list1)) error3(name, PSTR("second argument is not a proper list"));
object *result = apply(function, cons(car(list1),NULL), &env); object *result = apply(function, cons(car(list1),NULL), env);
while (result != NULL && (unsigned int)result >= PAIR) { while (result != NULL && (unsigned int)result >= PAIR) {
cdr(tail) = result; cdr(tail) = result;
tail = result; tail = result;
@ -2677,7 +2663,7 @@ object *fn_sort (object *args, object *env) {
while (go != ptr) { while (go != ptr) {
car(compare) = car(cdr(ptr)); car(compare) = car(cdr(ptr));
car(cdr(compare)) = car(cdr(go)); car(cdr(compare)) = car(cdr(go));
if (apply(predicate, compare, &env)) break; if (apply(predicate, compare, env)) break;
go = cdr(go); go = cdr(go);
} }
if (go != ptr) { if (go != ptr) {
@ -3790,11 +3776,7 @@ object *eval (object *form, object *env) {
object *envcopy = NULL; object *envcopy = NULL;
while (env != NULL) { while (env != NULL) {
object *pair = first(env); object *pair = first(env);
if (pair != NULL) { if (pair != NULL) push(pair, envcopy);
object *val = cdr(pair);
if (integerp(val)) val = number(val->integer);
push(cons(car(pair), val), envcopy);
}
env = cdr(env); env = cdr(env);
} }
return cons(symbol(CLOSURE), cons(envcopy,args)); return cons(symbol(CLOSURE), cons(envcopy,args));
@ -4224,7 +4206,7 @@ void setup () {
initworkspace(); initworkspace();
initenv(); initenv();
initsleep(); initsleep();
pfstring(PSTR("uLisp 2.6 "), pserial); pln(pserial); pfstring(PSTR("uLisp 2.7 "), pserial); pln(pserial);
} }
// Read/Evaluate/Print loop // Read/Evaluate/Print loop