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