Version 1.2a
/* uLisp Version 1.2a - www.ulisp.com
Copyright (c) 2016 David Johnson-Davies
Licensed under the MIT license: https://opensource.org/licenses/MIT
*/
#include
#include
// Compile options
#define checkoverflow
#define resetautorun
// C Macros
#define nil NULL
#define car(x) (((object *) (x))->car)
#define cdr(x) (((object *) (x))->cdr)
#define first(x) (((object *) (x))->car)
#define second(x) (car(cdr(x)))
#define cddr(x) (cdr(cdr(x)))
#define third(x) (car(cdr(cdr(x))))
#define fourth(x) (car(cdr(cdr(cdr(x)))))
#define push(x, y) ((y) = cons((x),(y)))
#define pop(y) ((y) = cdr(y))
#define numberp(x) ((x)->type == NUMBER)
#define streamp(x) ((x)->type == STREAM)
#define listp(x) ((x)->type >= PAIR || (x)->type == ZERO)
#define consp(x) (((x)->type >= PAIR || (x)->type == ZERO) && (x) != NULL)
#define mark(x) (car(x) = (object *)(((unsigned int)(car(x))) | 0x8000))
#define unmark(x) (car(x) = (object *)(((unsigned int)(car(x))) & 0x7FFF))
#define marked(x) ((((unsigned int)(car(x))) & 0x8000) != 0)
// 1:Show GCs 2:show symbol addresses
// #define debug1
// #define debug2
// Constants
// RAMSTART, RAMEND, and E2END are defined by the processor's ioxxx.h file
const int RAMsize = RAMEND - RAMSTART + 1;
const int workspacesize = (RAMsize - RAMsize/4 - 268)/4;
const int EEPROMsize = E2END;
const int buflen = 17; // Length of longest symbol + 1
enum type {ZERO, SYMBOL, NUMBER, STREAM, PAIR };
enum token { UNUSED, BRA, KET, QUO, DOT };
enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM };
enum function { SYMBOLS, NIL, TEE, LAMBDA, LET, LETSTAR, CLOSURE, SPECIAL_FORMS, QUOTE, DEFUN, DEFVAR,
SETQ, LOOP, PUSH, POP, INCF, DECF, DOLIST, DOTIMES, FORMILLIS, WITHI2C, WITHSPI, TAIL_FORMS, PROGN, RETURN,
IF, COND, WHEN, UNLESS, AND, OR, FUNCTIONS, NOT, NULLFN, CONS, ATOM, LISTP, CONSP, NUMBERP, STREAMP, EQ,
CAR, FIRST, CDR, REST, CAAR, CADR, SECOND, CDAR, CDDR, CAAAR, CAADR, CADAR, CADDR, THIRD, CDAAR, CDADR,
CDDAR, CDDDR, LENGTH, LIST, REVERSE, NTH, ASSOC, MEMBER, APPLY, FUNCALL, APPEND, MAPC, MAPCAR, ADD, SUBTRACT,
MULTIPLY, DIVIDE, MOD, ONEPLUS, ONEMINUS, ABS, RANDOM, MAX, MIN, NUMEQ, LESS, LESSEQ, GREATER, GREATEREQ,
NOTEQ, PLUSP, MINUSP, ZEROP, ODDP, EVENP, LOGAND, LOGIOR, LOGXOR, LOGNOT, ASH, LOGBITP, READ, EVAL, GLOBALS,
MAKUNBOUND, BREAK, PRINT, PRINC, WRITEBYTE, READBYTE, RESTARTI2C, GC, SAVEIMAGE, LOADIMAGE, PINMODE, DIGITALREAD,
DIGITALWRITE, ANALOGREAD, ANALOGWRITE, DELAY, MILLIS, NOTE, ENDFUNCTIONS };
// Typedefs
typedef struct sobject {
union {
struct {
sobject *car;
sobject *cdr;
};
struct {
enum type type;
union {
unsigned int name;
int integer;
};
};
};
} object;
typedef object *(*fn_ptr_type)(object *, object *);
typedef struct {
const char *string;
fn_ptr_type fptr;
int min;
int max;
} tbl_entry_t;
// Global variables
jmp_buf exception;
object workspace[workspacesize];
unsigned int freespace = 0;
char ReturnFlag = 0;
object *freelist;
extern uint8_t _end;
int i2cCount;
object *GlobalEnv;
object *GCStack = NULL;
char buffer[buflen+1];
char BreakLevel = 0;
char LastChar = 0;
// Forward references
object *tee;
object *tf_progn (object *form, object *env);
object *eval (object *form, object *env);
object *read();
void repl();
void printobject (object *form);
char *lookupstring (unsigned int name);
int lookupfn(unsigned int name);
int builtin(char* n);
// Set up workspace
void initworkspace () {
freelist = NULL;
for (int i=workspacesize-1; i>=0; i--) {
object *obj = &workspace[i];
car(obj) = NULL;
cdr(obj) = freelist;
freelist = obj;
freespace++;
}
}
object *myalloc() {
if (freespace == 0) error(F("No room"));
object *temp = freelist;
freelist = cdr(freelist);
freespace--;
return temp;
}
void myfree (object *obj) {
cdr(obj) = freelist;
freelist = obj;
freespace++;
}
// Make each type of object
object *number (int n) {
object *ptr = (object *) myalloc ();
ptr->type = NUMBER;
ptr->integer = n;
return ptr;
}
object *cons (object *arg1, object *arg2) {
object *ptr = (object *) myalloc ();
ptr->car = arg1;
ptr->cdr = arg2;
return ptr;
}
object *symbol (unsigned int name) {
object *ptr = (object *) myalloc ();
ptr->type = SYMBOL;
ptr->name = name;
return ptr;
}
object *stream (unsigned char streamtype, unsigned char address) {
object *ptr = (object *) myalloc ();
ptr->type = STREAM;
ptr->integer = streamtype<<8 | address;
return ptr;
}
// Garbage collection
void markobject (object *obj) {
MARK:
if (obj == NULL) return;
object* arg = car(obj);
if (marked(obj)) return;
int type = obj->type;
mark(obj);
if (type >= PAIR || type == ZERO) { // cons
markobject(arg);
obj = cdr(obj);
goto MARK;
}
}
void sweep () {
freelist = NULL;
freespace = 0;
for (int i=workspacesize-1; i>=0; i--) {
object *obj = &workspace[i];
if (!marked(obj)) {
car(obj) = NULL;
cdr(obj) = freelist;
freelist = obj;
freespace++;
} else unmark(obj);
}
}
void gc (object *form, object *env) {
#if defined(debug1)
int start = freespace;
#endif
markobject(tee);
markobject(GlobalEnv);
markobject(GCStack);
markobject(form);
markobject(env);
sweep();
#if defined(debug1)
Serial.print('{');
Serial.print(freespace - start);
Serial.println('}');
#endif
}
// Save-image and load-image
typedef struct {
unsigned int eval;
unsigned int datasize;
unsigned int globalenv;
unsigned int tee;
char data[];
} struct_image;
struct_image EEMEM image;
void movepointer (object *from, object *to) {
for (int i=0; itype) & 0x7FFF;
if (marked(obj) && type >= PAIR) {
if (car(obj) == (object *)((unsigned int)from | 0x8000))
car(obj) = (object *)((unsigned int)to | 0x8000);
if (cdr(obj) == from) cdr(obj) = to;
}
}
}
int compactimage (object **arg) {
markobject(tee);
markobject(GlobalEnv);
markobject(GCStack);
object *firstfree = workspace;
while (marked(firstfree)) firstfree++;
for (int i=0; i EEPROMsize) {
Serial.print(F("Error: Image size too large: "));
Serial.println(imagesize+2);
GCStack = NULL;
longjmp(exception, 1);
}
eeprom_write_word(&image.datasize, imagesize);
eeprom_write_word(&image.eval, (unsigned int)arg);
eeprom_write_word(&image.globalenv, (unsigned int)GlobalEnv);
eeprom_write_word(&image.tee, (unsigned int)tee);
eeprom_write_block(workspace, image.data, imagesize*4);
return imagesize+2;
}
int loadimage () {
unsigned int imagesize = eeprom_read_word(&image.datasize);
if (imagesize == 0 || imagesize == 0xFFFF) error(F("No saved image"));
GlobalEnv = (object *)eeprom_read_word(&image.globalenv);
tee = (object *)eeprom_read_word(&image.tee) ;
eeprom_read_block(workspace, image.data, imagesize*4);
gc(NULL, NULL);
return imagesize+2;
}
// Error handling
void error (const __FlashStringHelper *string) {
Serial.print(F("Error: "));
Serial.println(string);
GCStack = NULL;
longjmp(exception, 1);
}
void error2 (object *symbol, const __FlashStringHelper *string) {
Serial.print(F("Error: '"));
printobject(symbol);
Serial.print("' ");
Serial.println(string);
GCStack = NULL;
longjmp(exception, 1);
}
// Helper functions
int toradix40 (int ch) {
if (ch == 0) return 0;
if (ch >= '0' && ch <= '9') return ch-'0'+30;
ch = ch | 0x20;
if (ch >= 'a' && ch <= 'z') return ch-'a'+1;
error(F("Illegal character in symbol"));
return 0;
}
int fromradix40 (int n) {
if (n >= 1 && n <= 26) return 'a'+n-1;
if (n >= 30 && n <= 39) return '0'+n-30;
if (n == 27) return '-';
return 0;
}
int pack40 (char *buffer) {
return (((toradix40(buffer[0]) * 40) + toradix40(buffer[1])) * 40 + toradix40(buffer[2]));
}
int digitvalue (char d) {
if (d>='0' && d<='9') return d-'0';
d = d | 0x20;
if (d>='a' && d<='f') return d-'a'+10;
return 16;
}
char *name(object *obj){
buffer[3] = '\0';
if(obj->type != SYMBOL) error(F("Error in name"));
unsigned int x = obj->name;
if (x < ENDFUNCTIONS) return lookupstring(x);
for (int n=2; n>=0; n--) {
buffer[n] = fromradix40(x % 40);
x = x / 40;
}
return buffer;
}
int integer(object *obj){
if(obj->type != NUMBER) error(F("not a number"));
return obj->integer;
}
int istream(object *obj){
if(obj->type != STREAM) error(F("not a stream"));
return obj->integer;
}
int issymbol(object *obj, unsigned int n) {
return obj->type == SYMBOL && obj->name == n;
}
int eq (object *arg1, object *arg2) {
int same_object = (arg1 == arg2);
int same_symbol = (arg1->type == SYMBOL && arg2->type == SYMBOL && arg1->name == arg2->name);
int same_number = (arg1->type == NUMBER && arg2->type == NUMBER && arg1->integer == arg2->integer);
return (same_object || same_symbol || same_number);
}
// Lookup variable in environment
object *value(unsigned int n, object *env) {
while (env != NULL) {
object *item = car(env);
if(car(item)->name == n) return item;
env = cdr(env);
}
return nil;
}
object *findvalue (object *var, object *env) {
unsigned int varname = var->name;
object *pair = value(varname, env);
if (pair == NULL) pair = value(varname, GlobalEnv);
if (pair == NULL) error2(var,F("unknown variable"));
return pair;
}
object *findtwin (object *var, object *env) {
while (env != NULL) {
object *pair = car(env);
if (car(pair) == var) return pair;
env = cdr(env);
}
return NULL;
}
object *closure (int tail, object *fname, object *state, object *function, object *args, object **env) {
object *params = first(function);
function = cdr(function);
// Push state if not already in env
while (state != NULL) {
object *pair = first(state);
if (findtwin(car(pair), *env) == NULL) push(first(state), *env);
state = cdr(state);
}
// Add arguments to environment
while (params != NULL && args != NULL) {
object *var = first(params);
object *value = first(args);
if (tail) {
object *pair = findtwin(var, *env);
if (pair != NULL) cdr(pair) = value;
else push(cons(var,value), *env);
} else push(cons(var,value), *env);
params = cdr(params);
args = cdr(args);
}
if (params != NULL) error2(fname, F("has too few parameters"));
if (args != NULL) error2(fname, F("has too many parameters"));
// Do an implicit progn
return tf_progn(function, *env);
}
inline int listlength (object *list) {
int length = 0;
while (list != NULL) {
list = cdr(list);
length++;
}
return length;
}
object *apply (object *function, object *args, object **env) {
if (function->type == SYMBOL) {
unsigned int name = function->name;
int nargs = listlength(args);
if (name >= ENDFUNCTIONS) error2(function, F("is not a function"));
if (nargslookupmax(name)) error2(function, F("has too many arguments"));
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);
}
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);
}
error2(function, F("illegal function"));
return NULL;
}
// Checked car and cdr
inline object *carx (object *arg) {
if (!listp(arg)) error(F("Can't take car"));
if (arg == nil) return nil;
return car(arg);
}
inline object *cdrx (object *arg) {
if (!listp(arg)) error(F("Can't take cdr"));
if (arg == nil) return nil;
return cdr(arg);
}
// I2C interface
#if defined(__AVR_ATmega328P__)
uint8_t const TWI_SDA_PIN = 18;
uint8_t const TWI_SCL_PIN = 19;
#elif defined(__AVR_ATmega1280__) || defined(__AVR_ATmega2560__)
uint8_t const TWI_SDA_PIN = 20;
uint8_t const TWI_SCL_PIN = 21;
#elif defined(__AVR_ATmega644P__) || defined(__AVR_ATmega1284P__)
uint8_t const TWI_SDA_PIN = 17;
uint8_t const TWI_SCL_PIN = 16;
#elif defined(__AVR_ATmega32U4__)
uint8_t const TWI_SDA_PIN = 6;
uint8_t const TWI_SCL_PIN = 5;
#endif
uint32_t const F_TWI = 400000L; // Hardware I2C clock in Hz
uint8_t const TWSR_MTX_DATA_ACK = 0x28;
uint8_t const TWSR_MTX_ADR_ACK = 0x18;
uint8_t const TWSR_MRX_ADR_ACK = 0x40;
uint8_t const TWSR_START = 0x08;
uint8_t const TWSR_REP_START = 0x10;
uint8_t const I2C_READ = 1;
uint8_t const I2C_WRITE = 0;
void I2Cinit(bool enablePullup) {
TWSR = 0; // no prescaler
TWBR = (F_CPU/F_TWI - 16)/2; // set bit rate factor
if (enablePullup) {
digitalWrite(TWI_SDA_PIN, HIGH);
digitalWrite(TWI_SCL_PIN, HIGH);
}
}
uint8_t I2Cread(uint8_t last) {
TWCR = 1<type != SYMBOL) error2(var, F("is not a symbol"));
object *val = cons(symbol(LAMBDA), cdr(args));
object *pair = value(var->name,GlobalEnv);
if (pair != NULL) { cdr(pair) = val; return var; }
push(cons(var, val), GlobalEnv);
return var;
}
object *sp_defvar (object *args, object *env) {
object *var = first(args);
if (var->type != SYMBOL) error2(var, F("is not a symbol"));
object *val = eval(second(args), env);
object *pair = value(var->name,GlobalEnv);
if (pair != NULL) { cdr(pair) = val; return var; }
push(cons(var, val), GlobalEnv);
return var;
}
object *sp_setq (object *args, object *env) {
object *arg = eval(second(args), env);
object *pair = findvalue(first(args), env);
cdr(pair) = arg;
return arg;
}
object *sp_loop (object *args, object *env) {
ReturnFlag = 0;
object *start = args;
for (;;) {
args = start;
while (args != NULL) {
object *form = car(args);
object *result = eval(form,env);
if (ReturnFlag == 1) {
ReturnFlag = 0;
return result;
}
args = cdr(args);
}
}
}
object *sp_push (object *args, object *env) {
object *item = eval(first(args), env);
object *pair = findvalue(second(args), env);
push(item,cdr(pair));
return cdr(pair);
}
object *sp_pop (object *args, object *env) {
object *pair = findvalue(first(args), env);
object *result = car(cdr(pair));
pop(cdr(pair));
return result;
}
object *sp_incf (object *args, object *env) {
object *var = first(args);
object *pair = findvalue(var, env);
int result = integer(eval(var, env));
int temp = 1;
args = cdr(args);
if (args != NULL) temp = integer(eval(first(args), env));
#if defined(checkoverflow)
if (temp < 1) { if (-32768 - temp > result) error(F("'incf' arithmetic overflow")); }
else { if (32767 - temp < result) error(F("'incf' arithmetic overflow")); }
#endif
result = result + temp;
var = number(result);
cdr(pair) = var;
return var;
}
object *sp_decf (object *args, object *env) {
object *var = first(args);
object *pair = findvalue(var, env);
int result = integer(eval(var, env));
int temp = 1;
args = cdr(args);
if (args != NULL) temp = integer(eval(first(args), env));
#if defined(checkoverflow)
if (temp < 1) { if (32767 + temp < result) error(F("'decf' arithmetic overflow")); }
else { if (-32768 + temp > result) error(F("'decf' arithmetic overflow")); }
#endif
result = result - temp;
var = number(result);
cdr(pair) = var;
return var;
}
object *sp_dolist (object *args, object *env) {
object *params = first(args);
object *var = first(params);
object *list = eval(second(params), env);
if (!listp(list)) error(F("'dolist' argument is not a list"));
push(list, GCStack); // Don't GC the list
object *pair = cons(var,nil);
push(pair,env);
object *result = third(params);
object *forms = cdr(args);
while (list != NULL) {
cdr(pair) = first(list);
list = cdr(list);
eval(tf_progn(forms,env), env);
}
cdr(pair) = nil;
pop(GCStack);
return eval(result, env);
}
object *sp_dotimes (object *args, object *env) {
object *params = first(args);
object *var = first(params);
int count = integer(eval(second(params), env));
int index = 0;
object *result = third(params);
object *pair = cons(var,number(0));
push(pair,env);
object *forms = cdr(args);
while (index < count) {
cdr(pair) = number(index);
index++;
eval(tf_progn(forms,env), env);
}
cdr(pair) = number(index);
return eval(result, env);
}
object *sp_formillis (object *args, object *env) {
object *param = first(args);
unsigned long start = millis();
unsigned long now, total = 0;
if (param != NULL) total = integer(first(param));
eval(tf_progn(cdr(args),env), env);
do now = millis() - start; while (now < total);
if (now <= 32767) return number(now);
return nil;
}
object *sp_withi2c (object *args, object *env) {
object *params = first(args);
object *var = first(params);
int address = integer(eval(second(params), env));
params = cddr(params);
int read = 0; // Write
i2cCount = 0;
if (params != NULL) {
object *rw = eval(first(params), env);
if (numberp(rw)) i2cCount = integer(rw);
read = (rw != NULL);
}
I2Cinit(1); // Pullups
object *pair = cons(var, (I2Cstart(address<<1 | read)) ? stream(I2CSTREAM, address) : nil);
push(pair,env);
object *forms = cdr(args);
object *result = eval(tf_progn(forms,env), env);
I2Cstop();
return result;
}
object *sp_withspi (object *args, object *env) {
object *params = first(args);
object *var = first(params);
int pin = integer(eval(second(params), env));
object *pair = cons(var, stream(SPISTREAM, pin));
push(pair,env);
SPI.begin();
params = cddr(params);
if (params != NULL) {
int d = integer(eval(first(params), env));
if (d<1 || d>7) error(F("'with-spi' invalid divider"));
if (d == 7) SPI.setClockDivider(3);
else if (d & 1) SPI.setClockDivider((d>>1) + 4);
else SPI.setClockDivider((d>>1) - 1);
params = cdr(params);
if (params != NULL) {
SPI.setBitOrder(eval(first(params), env) == NULL);
params = cdr(params);
if (params != NULL) SPI.setDataMode(integer(eval(first(params), env)));
}
}
pinMode(pin, OUTPUT);
digitalWrite(pin, LOW);
object *forms = cdr(args);
object *result = eval(tf_progn(forms,env), env);
digitalWrite(pin, HIGH);
SPI.end();
return result;
}
// Tail-recursive forms
object *tf_progn (object *args, object *env) {
if (args == NULL) return nil;
object *more = cdr(args);
while (more != NULL) {
eval(car(args), env);
args = more;
more = cdr(args);
}
return car(args);
}
object *tf_return (object *args, object *env) {
ReturnFlag = 1;
return tf_progn(args, env);
}
object *tf_if (object *args, object *env) {
if (eval(first(args), env) != nil) return second(args);
return third(args);
}
object *tf_cond (object *args, object *env) {
while (args != NULL) {
object *clause = first(args);
object *test = eval(first(clause), env);
object *forms = cdr(clause);
if (test != nil) {
if (forms == NULL) return test; else return tf_progn(forms, env);
}
args = cdr(args);
}
return nil;
}
object *tf_when (object *args, object *env) {
if (eval(first(args), env) != nil) return tf_progn(cdr(args),env);
else return nil;
}
object *tf_unless (object *args, object *env) {
if (eval(first(args), env) != nil) return nil;
else return tf_progn(cdr(args),env);
}
object *tf_and (object *args, object *env) {
if (args == NULL) return tee;
object *more = cdr(args);
while (more != NULL) {
if (eval(car(args), env) == NULL) return nil;
args = more;
more = cdr(args);
}
return car(args);
}
object *tf_or (object *args, object *env) {
object *more = cdr(args);
while (more != NULL) {
object *result = eval(car(args), env);
if (result != NULL) return result;
args = more;
more = cdr(args);
}
return car(args);
}
// Core functions
object *fn_not (object *args, object *env) {
(void) env;
return (first(args) == nil) ? tee : nil;
}
object *fn_cons (object *args, object *env) {
(void) env;
return cons(first(args),second(args));
}
object *fn_atom (object *args, object *env) {
(void) env;
object *arg1 = first(args);
return consp(arg1) ? nil : tee;
}
object *fn_listp (object *args, object *env) {
(void) env;
object *arg1 = first(args);
return listp(arg1) ? tee : nil;
}
object *fn_consp (object *args, object *env) {
(void) env;
object *arg1 = first(args);
return consp(arg1) ? tee : nil;
}
object *fn_numberp (object *args, object *env) {
(void) env;
object *arg1 = first(args);
return numberp(arg1) ? tee : nil;
}
object *fn_streamp (object *args, object *env) {
(void) env;
object *arg1 = first(args);
return streamp(arg1) ? tee : nil;
}
object *fn_eq (object *args, object *env) {
(void) env;
object *arg1 = first(args);
object *arg2 = second(args);
return eq(arg1, arg2) ? tee : nil;
}
// List functions
object *fn_car (object *args, object *env) {
(void) env;
return carx(first(args));
}
object *fn_cdr (object *args, object *env) {
(void) env;
return cdrx(first(args));
}
object *fn_caar (object *args, object *env) {
(void) env;
return carx(carx(first(args)));
}
object *fn_cadr (object *args, object *env) {
(void) env;
return carx(cdrx(first(args)));
}
object *fn_cdar (object *args, object *env) {
(void) env;
return cdrx(carx(first(args)));
}
object *fn_cddr (object *args, object *env) {
(void) env;
return cdrx(cdrx(first(args)));
}
object *fn_caaar (object *args, object *env) {
(void) env;
return carx(carx(carx(first(args))));
}
object *fn_caadr (object *args, object *env) {
(void) env;
return carx(carx(cdrx(first(args))));
}
object *fn_cadar (object *args, object *env) {
(void) env;
return carx(cdrx(carx(first(args))));
}
object *fn_caddr (object *args, object *env) {
(void) env;
return carx(cdrx(cdrx(first(args))));
}
object *fn_cdaar (object *args, object *env) {
(void) env;
return cdrx(carx(carx(first(args))));
}
object *fn_cdadr (object *args, object *env) {
(void) env;
return cdrx(carx(cdrx(first(args))));
}
object *fn_cddar (object *args, object *env) {
(void) env;
return cdrx(cdrx(carx(first(args))));
}
object *fn_cdddr (object *args, object *env) {
(void) env;
return cdrx(cdrx(cdrx(first(args))));
}
object *fn_length (object *args, object *env) {
(void) env;
object *list = first(args);
if (!listp(list)) error(F("'length' argument is not a list"));
return number(listlength(list));
}
object *fn_list (object *args, object *env) {
(void) env;
return args;
}
object *fn_reverse (object *args, object *env) {
(void) env;
object *list = first(args);
if (!listp(list)) error(F("'reverse' argument is not a list"));
object *result = NULL;
while (list != NULL) {
push(first(list),result);
list = cdr(list);
}
return result;
}
object *fn_nth (object *args, object *env) {
(void) env;
int n = integer(first(args));
object *list = second(args);
if (!listp(list)) error(F("'nth' second argument is not a list"));
while (list != NULL) {
if (n == 0) return car(list);
list = cdr(list);
n--;
}
return nil;
}
object *fn_assoc (object *args, object *env) {
(void) env;
object *key = first(args);
object *list = second(args);
if (!listp(list)) error(F("'assoc' second argument is not a list"));
while (list != NULL) {
object *pair = first(list);
if (eq(key,car(pair))) return pair;
list = cdr(list);
}
return nil;
}
object *fn_member (object *args, object *env) {
(void) env;
object *item = first(args);
object *list = second(args);
if (!listp(list)) error(F("'member' second argument is not a list"));
while (list != NULL) {
if (eq(item,car(list))) return list;
list = cdr(list);
}
return nil;
}
object *fn_apply (object *args, object *env) {
object *previous = NULL;
object *last = args;
while (cdr(last) != NULL) {
previous = last;
last = cdr(last);
}
if (!listp(car(last))) error(F("'apply' last argument is not a list"));
cdr(previous) = car(last);
return apply(first(args), cdr(args), &env);
}
object *fn_funcall (object *args, object *env) {
return apply(first(args), cdr(args), &env);
}
object *fn_append (object *args, object *env) {
(void) env;
object *head = NULL;
object *tail = NULL;
while (args != NULL) {
object *list = first(args);
if (!listp(list)) error(F("'append' argument is not a list"));
while (list != NULL) {
object *obj = cons(first(list),NULL);
if (head == NULL) {
head = obj;
tail = obj;
} else {
cdr(tail) = obj;
tail = obj;
}
list = cdr(list);
}
args = cdr(args);
}
return head;
}
object *fn_mapc (object *args, object *env) {
object *function = first(args);
object *list1 = second(args);
object *result = list1;
if (!listp(list1)) error(F("'mapc' second argument is not a list"));
object *list2 = third(args);
if (!listp(list2)) error(F("'mapc' third argument is not a list"));
if (list2 != NULL) {
while (list1 != NULL && list2 != NULL) {
apply(function, cons(car(list1),cons(car(list2),NULL)), &env);
list1 = cdr(list1);
list2 = cdr(list2);
}
} else {
while (list1 != NULL) {
apply(function, cons(car(list1),NULL), &env);
list1 = cdr(list1);
}
}
return result;
}
object *fn_mapcar (object *args, object *env) {
object *function = first(args);
object *list1 = second(args);
if (!listp(list1)) error(F("'mapcar' second argument is not a list"));
object *list2 = third(args);
if (!listp(list2)) error(F("'mapcar' third argument is not a list"));
object *head = NULL;
object *tail = NULL;
if (list2 != NULL) {
while (list1 != NULL && list2 != NULL) {
object *result = apply(function, cons(car(list1),cons(car(list2),NULL)), &env);
object *obj = cons(result,NULL);
if (head == NULL) {
head = obj;
push(head,GCStack);
tail = obj;
} else {
cdr(tail) = obj;
tail = obj;
}
list1 = cdr(list1);
list2 = cdr(list2);
}
} else {
while (list1 != NULL) {
object *result = apply(function, cons(car(list1),NULL), &env);
object *obj = cons(result,NULL);
if (head == NULL) {
head = obj;
push(head,GCStack);
tail = obj;
} else {
cdr(tail) = obj;
tail = obj;
}
list1 = cdr(list1);
}
}
pop(GCStack);
return head;
}
// Arithmetic functions
object *fn_add (object *args, object *env) {
(void) env;
int result = 0;
while (args != NULL) {
int temp = integer(car(args));
#if defined(checkoverflow)
if (temp < 1) { if (-32768 - temp > result) error(F("'+' arithmetic overflow")); }
else { if (32767 - temp < result) error(F("'+' arithmetic overflow")); }
#endif
result = result + temp;
args = cdr(args);
}
return number(result);
}
object *fn_subtract (object *args, object *env) {
(void) env;
int result = integer(car(args));
args = cdr(args);
if (args == NULL) {
#if defined(checkoverflow)
if (result == -32768) error(F("'-' arithmetic overflow"));
#endif
return number(-result);
}
while (args != NULL) {
int temp = integer(car(args));
#if defined(checkoverflow)
if (temp < 1) { if (32767 + temp < result) error(F("'-' arithmetic overflow")); }
else { if (-32768 + temp > result) error(F("'-' arithmetic overflow")); }
#endif
result = result - temp;
args = cdr(args);
}
return number(result);
}
object *fn_multiply (object *args, object *env) {
(void) env;
int result = 1;
while (args != NULL){
#if defined(checkoverflow)
signed long temp = (signed long) result * integer(car(args));
if ((temp > 32767) || (temp < -32768)) error(F("'*' arithmetic overflow"));
result = temp;
#else
result = result * integer(car(args));
#endif
args = cdr(args);
}
return number(result);
}
object *fn_divide (object *args, object *env) {
(void) env;
int result = integer(first(args));
args = cdr(args);
while (args != NULL) {
int arg = integer(car(args));
if (arg == 0) error(F("Division by zero"));
#if defined(checkoverflow)
if ((result == -32768) && (arg == -1)) error(F("'/' arithmetic overflow"));
#endif
result = result / arg;
args = cdr(args);
}
return number(result);
}
object *fn_mod (object *args, object *env) {
(void) env;
int arg1 = integer(first(args));
int arg2 = integer(second(args));
if (arg2 == 0) error(F("Division by zero"));
int r = arg1 % arg2;
if ((arg1<0) != (arg2<0)) r = r + arg2;
return number(r);
}
object *fn_oneplus (object *args, object *env) {
(void) env;
int result = integer(first(args));
#if defined(checkoverflow)
if (result == 32767) error(F("'1+' arithmetic overflow"));
#endif
return number(result + 1);
}
object *fn_oneminus (object *args, object *env) {
(void) env;
int result = integer(first(args));
#if defined(checkoverflow)
if (result == -32768) error(F("'1-' arithmetic overflow"));
#endif
return number(result - 1);
}
object *fn_abs (object *args, object *env) {
(void) env;
int result = integer(first(args));
#if defined(checkoverflow)
if (result == -32768) error(F("'abs' arithmetic overflow"));
#endif
return number(abs(result));
}
object *fn_random (object *args, object *env) {
(void) env;
int arg = integer(first(args));
return number(random(arg));
}
object *fn_max (object *args, object *env) {
(void) env;
int result = integer(first(args));
args = cdr(args);
while (args != NULL) {
result = max(result,integer(car(args)));
args = cdr(args);
}
return number(result);
}
object *fn_min (object *args, object *env) {
(void) env;
int result = integer(first(args));
args = cdr(args);
while (args != NULL) {
result = min(result,integer(car(args)));
args = cdr(args);
}
return number(result);
}
// Arithmetic comparisons
object *fn_numeq (object *args, object *env) {
(void) env;
int arg1 = integer(first(args));
args = cdr(args);
while (args != NULL) {
int arg2 = integer(first(args));
if (!(arg1 == arg2)) return nil;
arg1 = arg2;
args = cdr(args);
}
return tee;
}
object *fn_less (object *args, object *env) {
(void) env;
int arg1 = integer(first(args));
args = cdr(args);
while (args != NULL) {
int arg2 = integer(first(args));
if (!(arg1 < arg2)) return nil;
arg1 = arg2;
args = cdr(args);
}
return tee;
}
object *fn_lesseq (object *args, object *env) {
(void) env;
int arg1 = integer(first(args));
args = cdr(args);
while (args != NULL) {
int arg2 = integer(first(args));
if (!(arg1 <= arg2)) return nil;
arg1 = arg2;
args = cdr(args);
}
return tee;
}
object *fn_greater (object *args, object *env) {
(void) env;
int arg1 = integer(first(args));
args = cdr(args);
while (args != NULL) {
int arg2 = integer(first(args));
if (!(arg1 > arg2)) return nil;
arg1 = arg2;
args = cdr(args);
}
return tee;
}
object *fn_greatereq (object *args, object *env) {
(void) env;
int arg1 = integer(first(args));
args = cdr(args);
while (args != NULL) {
int arg2 = integer(first(args));
if (!(arg1 >= arg2)) return nil;
arg1 = arg2;
args = cdr(args);
}
return tee;
}
object *fn_noteq (object *args, object *env) {
(void) env;
while (args != NULL) {
object *nargs = args;
int arg1 = integer(first(nargs));
nargs = cdr(nargs);
while (nargs != NULL) {
int arg2 = integer(first(nargs));
if (arg1 == arg2) return nil;
nargs = cdr(nargs);
}
args = cdr(args);
}
return tee;
}
object *fn_plusp (object *args, object *env) {
(void) env;
int arg = integer(first(args));
if (arg > 0) return tee;
else return nil;
}
object *fn_minusp (object *args, object *env) {
(void) env;
int arg = integer(first(args));
if (arg < 0) return tee;
else return nil;
}
object *fn_zerop (object *args, object *env) {
(void) env;
int arg = integer(first(args));
if (arg == 0) return tee;
else return nil;
}
object *fn_oddp (object *args, object *env) {
(void) env;
int arg = integer(first(args));
if ((arg & 1) == 1) return tee;
else return nil;
}
object *fn_evenp (object *args, object *env) {
(void) env;
int arg = integer(first(args));
if ((arg & 1) == 0) return tee;
else return nil;
}
// Bitwise operators
object *fn_logand (object *args, object *env) {
(void) env;
unsigned int result = 0xFFFF;
while (args != NULL) {
result = result & integer(first(args));
args = cdr(args);
}
return number(result);
}
object *fn_logior (object *args, object *env) {
(void) env;
unsigned int result = 0;
while (args != NULL) {
result = result | integer(first(args));
args = cdr(args);
}
return number(result);
}
object *fn_logxor (object *args, object *env) {
(void) env;
unsigned int result = 0;
while (args != NULL) {
result = result ^ integer(first(args));
args = cdr(args);
}
return number(result);
}
object *fn_lognot (object *args, object *env) {
(void) env;
int result = integer(car(args));
return number(~result);
}
object *fn_ash (object *args, object *env) {
(void) env;
int value = integer(first(args));
int count = integer(second(args));
if (count >= 0)
return number(value << count);
else
return number(value >> abs(count));
}
object *fn_logbitp (object *args, object *env) {
(void) env;
int index = integer(first(args));
int value = integer(second(args));
return (bitRead(value, index) == 1) ? tee : nil;
}
// System functions
object *fn_read (object *args, object *env) {
(void) args;
(void) env;
return read();
}
object *fn_eval (object *args, object *env) {
return eval(first(args), env);
}
object *fn_globals (object *args, object *env) {
(void) args;
(void) env;
object *list = GlobalEnv;
while (list != NULL) {
printobject(car(car(list)));
Serial.println();
list = cdr(list);
}
return nil;
}
object *fn_makunbound (object *args, object *env) {
(void) args;
(void) env;
object *key = first(args);
object *list = GlobalEnv;
object *prev = NULL;
while (list != NULL) {
object *pair = first(list);
if (eq(key,car(pair))) {
if (prev == NULL) GlobalEnv = cdr(list);
else cdr(prev) = cdr(list);
return key;
}
prev = list;
list = cdr(list);
}
error2(key, F("not found"));
return nil;
}
object *fn_break (object *args, object *env) {
(void) args;
Serial.println();
Serial.println(F("Break!"));
BreakLevel++;
repl(env);
BreakLevel--;
return nil;
}
object *fn_print (object *args, object *env) {
(void) env;
Serial.println();
object *obj = first(args);
printobject(obj);
Serial.print(' ');
return obj;
}
object *fn_princ (object *args, object *env) {
(void) env;
object *obj = first(args);
printobject(obj);
return obj;
}
object *fn_writebyte (object *args, object *env) {
(void) env;
object *val = first(args);
int value = integer(val);
int stream = SERIALSTREAM<<8;
args = cdr(args);
if (args != NULL) stream = istream(first(args));
if (stream>>8 == I2CSTREAM) return (I2Cwrite(value)) ? tee : nil;
else if (stream>>8 == SPISTREAM) return number(SPI.transfer(value));
else if (stream == SERIALSTREAM<<8) Serial.write(value);
else error(F("'write-byte' unknown stream type"));
return nil;
}
object *fn_readbyte (object *args, object *env) {
(void) env;
int stream = SERIALSTREAM<<8;
int last = 0;
if (args != NULL) stream = istream(first(args));
args = cdr(args);
if (args != NULL) last = (first(args) != NULL);
if (stream>>8 == I2CSTREAM) {
if (i2cCount >= 0) i2cCount--;
return number(I2Cread((i2cCount == 0) || last));
} else if (stream>>8 == SPISTREAM) return number(SPI.transfer(0));
else if (stream == SERIALSTREAM<<8) return number(Serial.read());
else error(F("'read-byte' unknown stream type"));
return nil;
}
object *fn_restarti2c (object *args, object *env) {
(void) env;
int stream = first(args)->integer;
args = cdr(args);
int read = 0; // Write
i2cCount = 0;
if (args != NULL) {
object *rw = first(args);
if (numberp(rw)) i2cCount = integer(rw);
read = (rw != NULL);
}
int address = stream & 0xFF;
if (stream>>8 == I2CSTREAM) {
if (!I2Crestart(address<<1 | read)) error(F("'i2c-restart' failed"));
}
else error(F("'restart' not i2c"));
return tee;
}
object *fn_gc (object *obj, object *env) {
unsigned long start = micros();
int initial = freespace;
gc(obj, env);
Serial.print(F("Space: "));
Serial.print(freespace - initial);
Serial.print(F(" bytes, Time: "));
Serial.print(micros() - start);
Serial.println(F(" uS"));
return nil;
}
object *fn_saveimage (object *args, object *env) {
object *var = eval(first(args), env);
return number(saveimage(var));
}
object *fn_loadimage (object *args, object *env) {
(void) args;
(void) env;
return number(loadimage());
}
// Arduino procedures
object *fn_pinmode (object *args, object *env) {
(void) env;
int pin = integer(first(args));
object *mode = second(args);
if (mode->type == NUMBER) pinMode(pin, mode->integer);
else pinMode(pin, (mode != nil));
return nil;
}
object *fn_digitalread (object *args, object *env) {
(void) env;
int pin = integer(first(args));
if(digitalRead(pin) != 0) return tee; else return nil;
}
object *fn_digitalwrite (object *args, object *env) {
(void) env;
int pin = integer(first(args));
object *mode = second(args);
digitalWrite(pin, (mode != nil));
return mode;
}
object *fn_analogread (object *args, object *env) {
(void) env;
int pin = integer(first(args));
#if defined(__AVR_ATmega328P__)
if (!(pin>=0 && pin<=5)) error(F("'analogread' invalid pin"));
#elif defined(__AVR_ATmega2560__)
if (!(pin>=0 && pin<=15)) error(F("'analogread' invalid pin"));
#endif
return number(analogRead(pin));
}
object *fn_analogwrite (object *args, object *env) {
(void) env;
int pin = integer(first(args));
#if defined(__AVR_ATmega328P__)
if (!(pin>=3 && pin<=11 && pin!=4 && pin!=7 && pin!=8)) error(F("'analogwrite' invalid pin"));
#elif defined(__AVR_ATmega2560__)
if (!((pin>=2 && pin<=13) || (pin>=44 && pin <=46))) error(F("'analogwrite' invalid pin"));
#endif
object *value = second(args);
analogWrite(pin, integer(value));
return value;
}
object *fn_delay (object *args, object *env) {
(void) env;
object *arg1 = first(args);
delay(integer(arg1));
return arg1;
}
object *fn_millis (object *args, object *env) {
(void) env;
(void) args;
unsigned long temp = millis();
#if defined(checkoverflow)
if (temp > 32767) error(F("'millis' arithmetic overflow"));
#endif
return number(temp);
}
const uint8_t scale[] PROGMEM = { 239,225,213,201,190,179,169,159,150,142,134,127};
object *fn_note (object *args, object *env) {
(void) env;
#if defined(__AVR_ATmega328P__)
if (args != NULL) {
int pin = integer(first(args));
int note = integer(second(args));
if (pin == 3) {
DDRD = DDRD | 1<6) error(F("'note' octave out of range"));
OCR2A = pgm_read_byte(&scale[note%12]);
TCCR2B = 0<6) error(F("'note' octave out of range"));
OCR2A = pgm_read_byte(&scale[note%12]);
TCCR2B = 0<6) error(F("'note' octave out of range"));
OCR2A = pgm_read_byte(&scale[note%12]);
TCCR2B = 0<type == NUMBER) return form;
if (form->type == SYMBOL) {
unsigned int name = form->name;
if (name == NIL) return nil;
object *pair = value(name, env);
if (pair != NULL) return cdr(pair);
pair = value(name, GlobalEnv);
if (pair != NULL) return cdr(pair);
else if (name <= ENDFUNCTIONS) return form;
error2(form, F("undefined"));
}
// It's a list
object *function = car(form);
object *args = cdr(form);
// List starts with a symbol?
if (function->type == SYMBOL) {
unsigned int name = function->name;
if ((name == LET) || (name == LETSTAR)) {
object *assigns = first(args);
object *forms = cdr(args);
object *newenv = env;
while (assigns != NULL) {
object *assign = car(assigns);
if (consp(assign)) push(cons(first(assign),eval(second(assign),env)), newenv);
else push(cons(assign,nil), newenv);
if (name == LETSTAR) env = newenv;
assigns = cdr(assigns);
}
env = newenv;
form = tf_progn(forms,env);
TC = 1;
goto EVAL;
}
if (name == LAMBDA) {
if (env == NULL) return form;
object *envcopy = NULL;
while (env != NULL) {
object *pair = first(env);
object *val = cdr(pair);
if (val->type == NUMBER) val = number(val->integer);
push(cons(car(pair), val), envcopy);
env = cdr(env);
}
return cons(symbol(CLOSURE), cons(envcopy,args));
}
if ((name > SPECIAL_FORMS) && (name < TAIL_FORMS)) {
return ((fn_ptr_type)lookupfn(name))(args, env);
}
if ((name > TAIL_FORMS) && (name < FUNCTIONS)) {
form = ((fn_ptr_type)lookupfn(name))(args, env);
TC = 1;
goto EVAL;
}
}
// Evaluate the parameters - result in head
object *fname = car(form);
int TCstart = TC;
object *head = cons(eval(car(form), env), NULL);
push(head, GCStack); // Don't GC the result list
object *tail = head;
form = cdr(form);
int nargs = 0;
while (form != NULL){
object *obj = cons(eval(car(form),env),NULL);
cdr(tail) = obj;
tail = obj;
form = cdr(form);
nargs++;
}
function = car(head);
args = cdr(head);
if (function->type == SYMBOL) {
unsigned int name = function->name;
if (name >= ENDFUNCTIONS) error2(fname, F("is not a function"));
if (nargslookupmax(name)) error2(fname, F("has too many arguments"));
object *result = ((fn_ptr_type)lookupfn(name))(args, env);
pop(GCStack);
return result;
}
if (listp(function) && issymbol(car(function), LAMBDA)) {
form = closure(TCstart, fname, NULL, cdr(function), args, &env);
pop(GCStack);
TC = 1;
goto EVAL;
}
if (listp(function) && issymbol(car(function), CLOSURE)) {
function = cdr(function);
form = closure(TCstart, fname, car(function), cdr(function), args, &env);
pop(GCStack);
TC = 1;
goto EVAL;
}
error2(fname, F("is an illegal function")); return nil;
}
// Input/Output
void printobject(object *form){
#if defined(debug2)
Serial.print('[');Serial.print((int)form);Serial.print(']');
#endif
if (form == NULL) Serial.print(F("nil"));
else if (listp(form) && issymbol(car(form), CLOSURE)) Serial.print(F(""));
else if (listp(form)) {
Serial.print('(');
printobject(car(form));
form = cdr(form);
while (form != NULL && listp(form)) {
Serial.print(' ');
printobject(car(form));
form = cdr(form);
}
if (form != NULL) {
Serial.print(F(" . "));
printobject(form);
}
Serial.print(')');
} else if (form->type == NUMBER) {
Serial.print(integer(form));
} else if (form->type == SYMBOL) {
Serial.print(name(form));
} else if (form->type == STREAM) {
Serial.print(F("<"));
if ((form->integer)>>8 == SPISTREAM) Serial.print(F("spi"));
else if ((form->integer)>>8 == I2CSTREAM) Serial.print(F("i2c"));
else Serial.print(F("serial"));
Serial.print(F("-stream #x"));
Serial.print(form->integer & 0xFF, HEX);
Serial.print('>');
} else
error(F("Error in print."));
}
int Getc () {
if (LastChar) {
int temp = LastChar;
LastChar = 0;
return temp;
}
while (!Serial.available());
int temp = Serial.read();
Serial.print((char)temp);
// if (temp == 13) Serial.println();
return temp;
}
object *nextitem() {
int ch = Getc();
while(isspace(ch)) ch = Getc();
if (ch == ';') {
while(ch != '(') ch = Getc();
ch = '(';
}
if (ch == '\n') ch = Getc();
if (ch == EOF) exit(0);
if (ch == ')') return (object *)KET;
if (ch == '(') return (object *)BRA;
if (ch == '\'') return (object *)QUO;
if (ch == '.') return (object *)DOT;
// Parse variable or number
int index = 0, base = 10, sign = 1;
unsigned int result = 0;
if (ch == '+') {
buffer[index++] = ch;
ch = Getc();
} else if (ch == '-') {
sign = -1;
buffer[index++] = ch;
ch = Getc();
} else if (ch == '#') {
ch = Getc() | 0x20;
if (ch == 'b') base = 2;
else if (ch == 'o') base = 8;
else if (ch == 'x') base = 16;
else error(F("Illegal character after #"));
ch = Getc();
}
int isnumber = (digitvalue(ch) ((unsigned int)32767+(1-sign)/2)) {
Serial.println();
error(F("Number out of range"));
}
return number(result*sign);
}
int x = builtin(buffer);
if (x == NIL) return nil;
if (x < ENDFUNCTIONS) return symbol(x);
else return symbol(pack40(buffer));
}
object *readrest() {
object *item = nextitem();
if(item == (object *)KET) return NULL;
if(item == (object *)DOT) {
object *arg1 = read();
if (readrest() != NULL) error(F("Malformed list"));
return arg1;
}
if(item == (object *)QUO) {
object *arg1 = read();
return cons(cons(symbol(QUOTE), cons(arg1, NULL)), readrest());
}
if(item == (object *)BRA) item = readrest();
return cons(item, readrest());
}
object *read() {
object *item = nextitem();
if (item == (object *)BRA) return readrest();
if (item == (object *)DOT) return read();
if (item == (object *)QUO) return cons(symbol(QUOTE), cons(read(), NULL));
return item;
}
void initenv() {
GlobalEnv = NULL;
tee = symbol(TEE);
}
// Setup
void setup() {
Serial.begin(9600);
while (!Serial); // wait for Serial to initialize
initworkspace();
initenv();
_end = 0xA5;
Serial.println(F("uLisp 1.2a"));
}
// Read/Evaluate/Print loop
void repl(object *env) {
for (;;) {
randomSeed(micros());
gc(NULL, env);
Serial.print(freespace);
if (BreakLevel) {
Serial.print(F(" : "));
Serial.print(BreakLevel);
}
Serial.print(F("> "));
object *line = read();
if (line == nil) { Serial.println(); return; }
Serial.println();
push(line, GCStack);
printobject(eval(line,env));
pop(GCStack);
Serial.println();
Serial.println();
}
}
void loop() {
if (!setjmp(exception)) {
#if defined(resetautorun)
object *autorun = (object *)eeprom_read_word(&image.eval);
if (autorun != NULL && (unsigned int)autorun != 0xFFFF) {
loadimage();
apply(autorun, NULL, NULL);
}
#endif
}
repl(NULL);
}