From 492b4f7405f9b6a8dcc6a06962e313ee381a03f8 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 25 Mar 2023 08:57:17 -0400 Subject: [PATCH 001/109] first pass --- README.md | 17 +- ulisp-esp.ino | 6265 --------------------- ulisp-esp-comments.ino => ulisp-esp32.ino | 579 +- 3 files changed, 34 insertions(+), 6827 deletions(-) delete mode 100644 ulisp-esp.ino rename ulisp-esp-comments.ino => ulisp-esp32.ino (92%) diff --git a/README.md b/README.md index 44ad026..90f06df 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,13 @@ -# ulisp-esp -A version of the Lisp programming language for ESP8266 and ESP32-based boards. -For more information see: -http://www.ulisp.com/show?21T5 +# ulisp-esp32 + +A (patched) version of the Lisp programming language for ESP32-based boards. +Heavily customized to fit my use case but most of the original remains. +For more about the original ulisp-esp see + +This is based off of uLisp 4.4. For the old patches (some of which don't work) for +uLisp 4.3a please see the [4.3a-old](https://github.com/dragoncoder047/ulisp-esp32/tree/4.3a-old) branch. + +Patches: + +* Deleted load/save/autorunimage support +* different garbage collect message diff --git a/ulisp-esp.ino b/ulisp-esp.ino deleted file mode 100644 index 9e3e592..0000000 --- a/ulisp-esp.ino +++ /dev/null @@ -1,6265 +0,0 @@ -/* uLisp ESP Release 4.4 - www.ulisp.com - David Johnson-Davies - www.technoblogy.com - 21st March 2023 - - Licensed under the MIT license: https://opensource.org/licenses/MIT -*/ - -// Lisp Library -const char LispLibrary[] PROGMEM = ""; - -// Compile options - -// #define resetautorun -#define printfreespace -// #define printgcs -// #define sdcardsupport -// #define gfxsupport -// #define lisplibrary -// #define lineeditor -// #define vt100 -// #define extensions - -// Includes - -// #include "LispLibrary.h" -#include -#include -#include -#include -#include -#if defined (ESP8266) - #include -#elif defined (ESP32) - #include -#endif - -#if defined(gfxsupport) -#define COLOR_WHITE ST77XX_WHITE -#define COLOR_BLACK ST77XX_BLACK -#include // Core graphics library -#include // Hardware-specific library for ST7789 -#if defined(ARDUINO_ESP32_DEV) -Adafruit_ST7789 tft = Adafruit_ST7789(5, 16, 19, 18); -#define TFT_BACKLITE 4 -#else -Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); -#endif -#endif - -#if defined(sdcardsupport) - #include - #define SDSIZE 172 -#else - #define SDSIZE 0 -#endif - -// Platform specific settings - -#define WORDALIGNED __attribute__((aligned (4))) -#define BUFFERSIZE 36 // Number of bits+4 - -#if defined(ESP8266) - #define WORKSPACESIZE (3928-SDSIZE) /* Cells (8*bytes) */ - #define EEPROMSIZE 4096 /* Bytes available for EEPROM */ - #define SDCARD_SS_PIN 10 - #define LED_BUILTIN 13 - -#elif defined(ARDUINO_FEATHER_ESP32) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - -#elif defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2) || defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - -#elif defined(ARDUINO_ADAFRUIT_QTPY_ESP32S2) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#elif defined(ARDUINO_ADAFRUIT_QTPY_ESP32C3) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#elif defined(ARDUINO_FEATHERS2) /* UM FeatherS2 */ - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#elif defined(ARDUINO_ESP32_DEV) /* For TTGO T-Display */ - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - -#elif defined(ARDUINO_ESP32S2_DEV) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#elif defined(ARDUINO_ESP32C3_DEV) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#elif defined(ARDUINO_ESP32S3_DEV) - #define WORKSPACESIZE (22000-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#elif defined(ESP32) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#else -#error "Board not supported!" -#endif - -// 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 push(x, y) ((y) = cons((x),(y))) -#define pop(y) ((y) = cdr(y)) - -#define integerp(x) ((x) != NULL && (x)->type == NUMBER) -#define floatp(x) ((x) != NULL && (x)->type == FLOAT) -#define symbolp(x) ((x) != NULL && (x)->type == SYMBOL) -#define stringp(x) ((x) != NULL && (x)->type == STRING) -#define characterp(x) ((x) != NULL && (x)->type == CHARACTER) -#define arrayp(x) ((x) != NULL && (x)->type == ARRAY) -#define streamp(x) ((x) != NULL && (x)->type == STREAM) - -#define mark(x) (car(x) = (object *)(((uintptr_t)(car(x))) | MARKBIT)) -#define unmark(x) (car(x) = (object *)(((uintptr_t)(car(x))) & ~MARKBIT)) -#define marked(x) ((((uintptr_t)(car(x))) & MARKBIT) != 0) -#define MARKBIT 1 - -#define setflag(x) (Flags = Flags | 1<<(x)) -#define clrflag(x) (Flags = Flags & ~(1<<(x))) -#define tstflag(x) (Flags & 1<<(x)) - -#define issp(x) (x == ' ' || x == '\n' || x == '\r' || x == '\t') -#define isbr(x) (x == ')' || x == '(' || x == '"' || x == '#') -#define longsymbolp(x) (((x)->name & 0x03) == 0) -#define twist(x) ((uint32_t)((x)<<2) | (((x) & 0xC0000000)>>30)) -#define untwist(x) (((x)>>2 & 0x3FFFFFFF) | ((x) & 0x03)<<30) -#define arraysize(x) (sizeof(x) / sizeof(x[0])) -#define PACKEDS 0x43238000 -#define BUILTINS 0xF4240000 -#define ENDFUNCTIONS 1536 - -// Constants - -const int TRACEMAX = 3; // Number of traced functions -enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; // ARRAY STRING and PAIR must be last -enum token { UNUSED, BRA, KET, QUO, DOT }; -enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM }; -enum fntypes_t { OTHER_FORMS, TAIL_FORMS, FUNCTIONS, SPECIAL_FORMS }; - -// Stream names used by printobject -const char serialstream[] PROGMEM = "serial"; -const char i2cstream[] PROGMEM = "i2c"; -const char spistream[] PROGMEM = "spi"; -const char sdstream[] PROGMEM = "sd"; -const char wifistream[] PROGMEM = "wifi"; -const char stringstream[] PROGMEM = "string"; -const char gfxstream[] PROGMEM = "gfx"; -PGM_P const streamname[] PROGMEM = {serialstream, i2cstream, spistream, sdstream, wifistream, stringstream, gfxstream}; - -// Typedefs - -typedef uint32_t symbol_t; - -typedef struct sobject { - union { - struct { - sobject *car; - sobject *cdr; - }; - struct { - unsigned int type; - union { - symbol_t name; - int integer; - int chars; // For strings - float single_float; - }; - }; - }; -} object; - -typedef object *(*fn_ptr_type)(object *, object *); -typedef void (*mapfun_t)(object *, object **); - -typedef const struct { - PGM_P string; - fn_ptr_type fptr; - uint8_t minmax; - const char *doc; -} tbl_entry_t; - -typedef int (*gfun_t)(); -typedef void (*pfun_t)(char); - -typedef uint16_t builtin_t; - -enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, LET, LETSTAR, -CLOSURE, PSTAR, QUOTE, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, -ANALOGREAD, REGISTER, FORMAT, - }; - -// Global variables - -object Workspace[WORKSPACESIZE] WORDALIGNED; - -jmp_buf toplevel_handler; -jmp_buf *handler = &toplevel_handler; -unsigned int Freespace = 0; -object *Freelist; -unsigned int I2Ccount; -unsigned int TraceFn[TRACEMAX]; -unsigned int TraceDepth[TRACEMAX]; -builtin_t Context; - -object *GlobalEnv; -object *GCStack = NULL; -object *GlobalString; -object *GlobalStringTail; -int GlobalStringIndex = 0; -uint8_t PrintCount = 0; -uint8_t BreakLevel = 0; -char LastChar = 0; -char LastPrint = 0; - -// Flags -enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, NOECHO, MUFFLEERRORS }; -volatile uint8_t Flags = 0b00001; // PRINTREADABLY set by default - -// Forward references -object *tee; -void pfstring (PGM_P s, pfun_t pfun); - -// Error handling - -void errorsub (symbol_t fname, PGM_P string) { - pfl(pserial); pfstring(PSTR("Error: "), pserial); - if (fname != sym(NIL)) { - pserial('\''); - psymbol(fname, pserial); - pserial('\''); pserial(' '); - } - pfstring(string, pserial); -} - -void errorend () { GCStack = NULL; longjmp(*handler, 1); } - -void errorsym (symbol_t fname, PGM_P string, object *symbol) { - if (!tstflag(MUFFLEERRORS)) { - errorsub(fname, string); - pserial(':'); pserial(' '); - printobject(symbol, pserial); - pln(pserial); - } - errorend(); -} - -void errorsym2 (symbol_t fname, PGM_P string) { - if (!tstflag(MUFFLEERRORS)) { - errorsub(fname, string); - pln(pserial); - } - errorend(); -} - -void error (PGM_P string, object *symbol) { - errorsym(sym(Context), string, symbol); -} - -void error2 (PGM_P string) { - errorsym2(sym(Context), string); -} - -void formaterr (object *formatstr, PGM_P string, uint8_t p) { - pln(pserial); indent(4, ' ', pserial); printstring(formatstr, pserial); pln(pserial); - indent(p+5, ' ', pserial); pserial('^'); - error2(string); - pln(pserial); - GCStack = NULL; - longjmp(*handler, 1); -} - -// Save space as these are used multiple times -const char notanumber[] PROGMEM = "argument is not a number"; -const char notaninteger[] PROGMEM = "argument is not an integer"; -const char notastring[] PROGMEM = "argument is not a string"; -const char notalist[] PROGMEM = "argument is not a list"; -const char notasymbol[] PROGMEM = "argument is not a symbol"; -const char notproper[] PROGMEM = "argument is not a proper list"; -const char toomanyargs[] PROGMEM = "too many arguments"; -const char toofewargs[] PROGMEM = "too few arguments"; -const char noargument[] PROGMEM = "missing argument"; -const char nostream[] PROGMEM = "missing stream argument"; -const char overflow[] PROGMEM = "arithmetic overflow"; -const char divisionbyzero[] PROGMEM = "division by zero"; -const char indexnegative[] PROGMEM = "index can't be negative"; -const char invalidarg[] PROGMEM = "invalid argument"; -const char invalidkey[] PROGMEM = "invalid keyword"; -const char illegalclause[] PROGMEM = "illegal clause"; -const char invalidpin[] PROGMEM = "invalid pin"; -const char oddargs[] PROGMEM = "odd number of arguments"; -const char indexrange[] PROGMEM = "index out of range"; -const char canttakecar[] PROGMEM = "can't take car"; -const char canttakecdr[] PROGMEM = "can't take cdr"; -const char unknownstreamtype[] PROGMEM = "unknown stream type"; - -// 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) error2(PSTR("no room")); - object *temp = Freelist; - Freelist = cdr(Freelist); - Freespace--; - return temp; -} - -inline void myfree (object *obj) { - car(obj) = NULL; - cdr(obj) = Freelist; - Freelist = obj; - Freespace++; -} - -// Make each type of object - -object *number (int n) { - object *ptr = myalloc(); - ptr->type = NUMBER; - ptr->integer = n; - return ptr; -} - -object *makefloat (float f) { - object *ptr = myalloc(); - ptr->type = FLOAT; - ptr->single_float = f; - return ptr; -} - -object *character (uint8_t c) { - object *ptr = myalloc(); - ptr->type = CHARACTER; - ptr->chars = c; - return ptr; -} - -object *cons (object *arg1, object *arg2) { - object *ptr = myalloc(); - ptr->car = arg1; - ptr->cdr = arg2; - return ptr; -} - -object *symbol (symbol_t name) { - object *ptr = myalloc(); - ptr->type = SYMBOL; - ptr->name = name; - return ptr; -} - -inline object *bsymbol (builtin_t name) { - return intern(twist(name+BUILTINS)); -} - -object *intern (symbol_t name) { - for (int i=0; itype == SYMBOL && obj->name == name) return obj; - } - return symbol(name); -} - -bool eqsymbols (object *obj, char *buffer) { - object *arg = cdr(obj); - int i = 0; - while (!(arg == NULL && buffer[i] == 0)) { - if (arg == NULL || buffer[i] == 0 || - arg->chars != (buffer[i]<<24 | buffer[i+1]<<16 | buffer[i+2]<<8 | buffer[i+3])) return false; - arg = car(arg); - i = i + 4; - } - return true; -} - -object *internlong (char *buffer) { - for (int i=0; itype == SYMBOL && longsymbolp(obj) && eqsymbols(obj, buffer)) return obj; - } - object *obj = lispstring(buffer); - obj->type = SYMBOL; - return obj; -} - -object *stream (uint8_t streamtype, uint8_t address) { - object *ptr = myalloc(); - ptr->type = STREAM; - ptr->integer = streamtype<<8 | address; - return ptr; -} - -object *newstring () { - object *ptr = myalloc(); - ptr->type = STRING; - ptr->chars = 0; - return ptr; -} - -// Garbage collection - -void markobject (object *obj) { - MARK: - if (obj == NULL) return; - if (marked(obj)) return; - - object* arg = car(obj); - unsigned int type = obj->type; - mark(obj); - - if (type >= PAIR || type == ZZERO) { // cons - markobject(arg); - obj = cdr(obj); - goto MARK; - } - - if (type == ARRAY) { - obj = cdr(obj); - goto MARK; - } - - if ((type == STRING) || (type == SYMBOL && longsymbolp(obj))) { - obj = cdr(obj); - while (obj != NULL) { - arg = car(obj); - mark(obj); - obj = arg; - } - } -} - -void sweep () { - Freelist = NULL; - Freespace = 0; - for (int i=WORKSPACESIZE-1; i>=0; i--) { - object *obj = &Workspace[i]; - if (!marked(obj)) myfree(obj); else unmark(obj); - } -} - -void gc (object *form, object *env) { - #if defined(printgcs) - int start = Freespace; - #endif - markobject(tee); - markobject(GlobalEnv); - markobject(GCStack); - markobject(form); - markobject(env); - sweep(); - #if defined(printgcs) - pfl(pserial); pserial('{'); pint(Freespace - start, pserial); pserial('}'); - #endif -} - -// Compact image - -void movepointer (object *from, object *to) { - for (int i=0; itype) & ~MARKBIT; - if (marked(obj) && (type >= ARRAY || type==ZZERO || (type == SYMBOL && longsymbolp(obj)))) { - if (car(obj) == (object *)((uintptr_t)from | MARKBIT)) - car(obj) = (object *)((uintptr_t)to | MARKBIT); - if (cdr(obj) == from) cdr(obj) = to; - } - } - // Fix strings and long symbols - for (int i=0; itype) & ~MARKBIT; - if (type == STRING || (type == SYMBOL && longsymbolp(obj))) { - obj = cdr(obj); - while (obj != NULL) { - if (cdr(obj) == to) cdr(obj) = from; - obj = (object *)((uintptr_t)(car(obj)) & ~MARKBIT); - } - } - } - } -} - -uintptr_t compactimage (object **arg) { - markobject(tee); - markobject(GlobalEnv); - markobject(GCStack); - object *firstfree = Workspace; - while (marked(firstfree)) firstfree++; - object *obj = &Workspace[WORKSPACESIZE-1]; - while (firstfree < obj) { - if (marked(obj)) { - car(firstfree) = car(obj); - cdr(firstfree) = cdr(obj); - unmark(obj); - movepointer(obj, firstfree); - if (GlobalEnv == obj) GlobalEnv = firstfree; - if (GCStack == obj) GCStack = firstfree; - if (*arg == obj) *arg = firstfree; - while (marked(firstfree)) firstfree++; - } - obj--; - } - sweep(); - return firstfree - Workspace; -} - -// Make SD card filename - -char *MakeFilename (object *arg, char *buffer) { - int max = BUFFERSIZE-1; - buffer[0]='/'; - int i = 1; - do { - char c = nthchar(arg, i-1); - if (c == '\0') break; - buffer[i++] = c; - } while (i>8 & 0xFF); - file.write(data>>16 & 0xFF); file.write(data>>24 & 0xFF); -} - -int SDReadInt (File file) { - uintptr_t b0 = file.read(); uintptr_t b1 = file.read(); - uintptr_t b2 = file.read(); uintptr_t b3 = file.read(); - return b0 | b1<<8 | b2<<16 | b3<<24; -} -#elif defined(LITTLEFS) -void FSWrite32 (File file, uint32_t data) { - union { uint32_t data2; uint8_t u8[4]; }; - data2 = data; - if (file.write(u8, 4) != 4) error2(PSTR("not enough room")); -} - -uint32_t FSRead32 (File file) { - union { uint32_t data; uint8_t u8[4]; }; - file.read(u8, 4); - return data; -} -#else -void EpromWriteInt(int *addr, uintptr_t data) { - EEPROM.write((*addr)++, data & 0xFF); EEPROM.write((*addr)++, data>>8 & 0xFF); - EEPROM.write((*addr)++, data>>16 & 0xFF); EEPROM.write((*addr)++, data>>24 & 0xFF); -} - -int EpromReadInt (int *addr) { - uint8_t b0 = EEPROM.read((*addr)++); uint8_t b1 = EEPROM.read((*addr)++); - uint8_t b2 = EEPROM.read((*addr)++); uint8_t b3 = EEPROM.read((*addr)++); - return b0 | b1<<8 | b2<<16 | b3<<24; -} -#endif - -unsigned int saveimage (object *arg) { -#if defined(sdcardsupport) - unsigned int imagesize = compactimage(&arg); - SD.begin(SDCARD_SS_PIN); - File file; - if (stringp(arg)) { - char buffer[BUFFERSIZE]; - file = SD.open(MakeFilename(arg, buffer), FILE_WRITE); - if (!file) error2(PSTR("problem saving to SD card or invalid filename")); - arg = NULL; - } else if (arg == NULL || listp(arg)) { - file = SD.open("/ULISP.IMG", FILE_WRITE); - if (!file) error2(PSTR("problem saving to SD card")); - } else error(invalidarg, arg); - SDWriteInt(file, (uintptr_t)arg); - SDWriteInt(file, imagesize); - SDWriteInt(file, (uintptr_t)GlobalEnv); - SDWriteInt(file, (uintptr_t)GCStack); - for (unsigned int i=0; i EEPROMSIZE) error(PSTR("image too large"), number(imagesize)); - EEPROM.begin(EEPROMSIZE); - int addr = 0; - EpromWriteInt(&addr, (uintptr_t)arg); - EpromWriteInt(&addr, imagesize); - EpromWriteInt(&addr, (uintptr_t)GlobalEnv); - EpromWriteInt(&addr, (uintptr_t)GCStack); - for (unsigned int i=0; itype; - return type >= PAIR || type == ZZERO; -} - -#define atom(x) (!consp(x)) - -bool listp (object *x) { - if (x == NULL) return true; - unsigned int type = x->type; - return type >= PAIR || type == ZZERO; -} - -#define improperp(x) (!listp(x)) - -object *quote (object *arg) { - return cons(bsymbol(QUOTE), cons(arg,NULL)); -} - -// Radix 40 encoding - -builtin_t builtin (symbol_t name) { - return (builtin_t)(untwist(name) - BUILTINS); -} - -symbol_t sym (builtin_t x) { - return twist(x + BUILTINS); -} - -int8_t toradix40 (char ch) { - if (ch == 0) return 0; - if (ch >= '0' && ch <= '9') return ch-'0'+1; - if (ch == '-') return 37; if (ch == '*') return 38; if (ch == '$') return 39; - ch = ch | 0x20; - if (ch >= 'a' && ch <= 'z') return ch-'a'+11; - return -1; // Invalid -} - -char fromradix40 (char n) { - if (n >= 1 && n <= 9) return '0'+n-1; - if (n >= 11 && n <= 36) return 'a'+n-11; - if (n == 37) return '-'; if (n == 38) return '*'; if (n == 39) return '$'; - return 0; -} - -uint32_t pack40 (char *buffer) { - int x = 0; - for (int i=0; i<6; i++) x = x * 40 + toradix40(buffer[i]); - return x; -} - -bool valid40 (char *buffer) { - if (toradix40(buffer[0]) < 11) return false; - for (int i=1; i<6; i++) if (toradix40(buffer[i]) < 0) return false; - return true; -} - -int8_t 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; -} - -int checkinteger (object *obj) { - if (!integerp(obj)) error(notaninteger, obj); - return obj->integer; -} - -int checkbitvalue (object *obj) { - if (!integerp(obj)) error(notaninteger, obj); - int n = obj->integer; - if (n & ~1) error(PSTR("argument is not a bit value"), obj); - return n; -} - -float checkintfloat (object *obj){ - if (integerp(obj)) return obj->integer; - if (!floatp(obj)) error(notanumber, obj); - return obj->single_float; -} - -int checkchar (object *obj) { - if (!characterp(obj)) error(PSTR("argument is not a character"), obj); - return obj->chars; -} - -object *checkstring (object *obj) { - if (!stringp(obj)) error(notastring, obj); - return obj; -} - -int isstream (object *obj){ - if (!streamp(obj)) error(PSTR("not a stream"), obj); - return obj->integer; -} - -int isbuiltin (object *obj, builtin_t n) { - return symbolp(obj) && obj->name == sym(n); -} - -bool builtinp (symbol_t name) { - return (untwist(name) >= BUILTINS); -} - -int checkkeyword (object *obj) { - if (!keywordp(obj)) error(PSTR("argument is not a keyword"), obj); - builtin_t kname = builtin(obj->name); - uint8_t context = getminmax(kname); - if (context != 0 && context != Context) error(invalidkey, obj); - return ((int)lookupfn(kname)); -} - -void checkargs (object *args) { - int nargs = listlength(args); - checkminmax(Context, nargs); -} - -boolean eq (object *arg1, object *arg2) { - if (arg1 == arg2) return true; // Same object - if ((arg1 == nil) || (arg2 == nil)) return false; // Not both values - if (arg1->cdr != arg2->cdr) return false; // Different values - if (symbolp(arg1) && symbolp(arg2)) return true; // Same symbol - if (integerp(arg1) && integerp(arg2)) return true; // Same integer - if (floatp(arg1) && floatp(arg2)) return true; // Same float - if (characterp(arg1) && characterp(arg2)) return true; // Same character - return false; -} - -boolean equal (object *arg1, object *arg2) { - if (stringp(arg1) && stringp(arg2)) return stringcompare(cons(arg1, cons(arg2, nil)), false, false, true); - if (consp(arg1) && consp(arg2)) return (equal(car(arg1), car(arg2)) && equal(cdr(arg1), cdr(arg2))); - return eq(arg1, arg2); -} - -int listlength (object *list) { - int length = 0; - while (list != NULL) { - if (improperp(list)) error2(notproper); - list = cdr(list); - length++; - } - return length; -} - -// Mathematical helper functions - -object *add_floats (object *args, float fresult) { - while (args != NULL) { - object *arg = car(args); - fresult = fresult + checkintfloat(arg); - args = cdr(args); - } - return makefloat(fresult); -} - -object *subtract_floats (object *args, float fresult) { - while (args != NULL) { - object *arg = car(args); - fresult = fresult - checkintfloat(arg); - args = cdr(args); - } - return makefloat(fresult); -} - -object *negate (object *arg) { - if (integerp(arg)) { - int result = arg->integer; - if (result == INT_MIN) return makefloat(-result); - else return number(-result); - } else if (floatp(arg)) return makefloat(-(arg->single_float)); - else error(notanumber, arg); - return nil; -} - -object *multiply_floats (object *args, float fresult) { - while (args != NULL) { - object *arg = car(args); - fresult = fresult * checkintfloat(arg); - args = cdr(args); - } - return makefloat(fresult); -} - -object *divide_floats (object *args, float fresult) { - while (args != NULL) { - object *arg = car(args); - float f = checkintfloat(arg); - if (f == 0.0) error2(divisionbyzero); - fresult = fresult / f; - args = cdr(args); - } - return makefloat(fresult); -} - -int myround (float number) { - return (number >= 0) ? (int)(number + 0.5) : (int)(number - 0.5); -} - -object *compare (object *args, bool lt, bool gt, bool eq) { - object *arg1 = first(args); - args = cdr(args); - while (args != NULL) { - object *arg2 = first(args); - if (integerp(arg1) && integerp(arg2)) { - if (!lt && ((arg1->integer) < (arg2->integer))) return nil; - if (!eq && ((arg1->integer) == (arg2->integer))) return nil; - if (!gt && ((arg1->integer) > (arg2->integer))) return nil; - } else { - if (!lt && (checkintfloat(arg1) < checkintfloat(arg2))) return nil; - if (!eq && (checkintfloat(arg1) == checkintfloat(arg2))) return nil; - if (!gt && (checkintfloat(arg1) > checkintfloat(arg2))) return nil; - } - arg1 = arg2; - args = cdr(args); - } - return tee; -} - -int intpower (int base, int exp) { - int result = 1; - while (exp) { - if (exp & 1) result = result * base; - exp = exp / 2; - base = base * base; - } - return result; -} - -// Association lists - -object *assoc (object *key, object *list) { - while (list != NULL) { - if (improperp(list)) error(notproper, list); - object *pair = first(list); - if (!listp(pair)) error(PSTR("element is not a list"), pair); - if (pair != NULL && eq(key,car(pair))) return pair; - list = cdr(list); - } - return nil; -} - -object *delassoc (object *key, object **alist) { - object *list = *alist; - object *prev = NULL; - while (list != NULL) { - object *pair = first(list); - if (eq(key,car(pair))) { - if (prev == NULL) *alist = cdr(list); - else cdr(prev) = cdr(list); - return key; - } - prev = list; - list = cdr(list); - } - return nil; -} - -// Array utilities - -int nextpower2 (int n) { - n--; n |= n >> 1; n |= n >> 2; n |= n >> 4; - n |= n >> 8; n |= n >> 16; n++; - return n<2 ? 2 : n; -} - -object *buildarray (int n, int s, object *def) { - int s2 = s>>1; - if (s2 == 1) { - if (n == 2) return cons(def, def); - else if (n == 1) return cons(def, NULL); - else return NULL; - } else if (n >= s2) return cons(buildarray(s2, s2, def), buildarray(n - s2, s2, def)); - else return cons(buildarray(n, s2, def), nil); -} - -object *makearray (object *dims, object *def, bool bitp) { - int size = 1; - object *dimensions = dims; - while (dims != NULL) { - int d = car(dims)->integer; - if (d < 0) error2(PSTR("dimension can't be negative")); - size = size * d; - dims = cdr(dims); - } - // Bit array identified by making first dimension negative - if (bitp) { - size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - car(dimensions) = number(-(car(dimensions)->integer)); - } - object *ptr = myalloc(); - ptr->type = ARRAY; - object *tree = nil; - if (size != 0) tree = buildarray(size, nextpower2(size), def); - ptr->cdr = cons(tree, dimensions); - return ptr; -} - -object **arrayref (object *array, int index, int size) { - int mask = nextpower2(size)>>1; - object **p = &car(cdr(array)); - while (mask) { - if ((index & mask) == 0) p = &(car(*p)); else p = &(cdr(*p)); - mask = mask>>1; - } - return p; -} - -object **getarray (object *array, object *subs, object *env, int *bit) { - int index = 0, size = 1, s; - *bit = -1; - bool bitp = false; - object *dims = cddr(array); - while (dims != NULL && subs != NULL) { - int d = car(dims)->integer; - if (d < 0) { d = -d; bitp = true; } - if (env) s = checkinteger(eval(car(subs), env)); else s = checkinteger(car(subs)); - if (s < 0 || s >= d) error(PSTR("subscript out of range"), car(subs)); - size = size * d; - index = index * d + s; - dims = cdr(dims); subs = cdr(subs); - } - if (dims != NULL) error2(PSTR("too few subscripts")); - if (subs != NULL) error2(PSTR("too many subscripts")); - if (bitp) { - size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - *bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); - index = index>>(sizeof(int)==4 ? 5 : 4); - } - return arrayref(array, index, size); -} - -void rslice (object *array, int size, int slice, object *dims, object *args) { - int d = first(dims)->integer; - for (int i = 0; i < d; i++) { - int index = slice * d + i; - if (!consp(args)) error2(PSTR("initial contents don't match array type")); - if (cdr(dims) == NULL) { - object **p = arrayref(array, index, size); - *p = car(args); - } else rslice(array, size, index, cdr(dims), car(args)); - args = cdr(args); - } -} - -object *readarray (int d, object *args) { - object *list = args; - object *dims = NULL; object *head = NULL; - int size = 1; - for (int i = 0; i < d; i++) { - if (!listp(list)) error2(PSTR("initial contents don't match array type")); - int l = listlength(list); - if (dims == NULL) { dims = cons(number(l), NULL); head = dims; } - else { cdr(dims) = cons(number(l), NULL); dims = cdr(dims); } - size = size * l; - if (list != NULL) list = car(list); - } - object *array = makearray(head, NULL, false); - rslice(array, size, 0, head, args); - return array; -} - -object *readbitarray (gfun_t gfun) { - char ch = gfun(); - object *head = NULL; - object *tail = NULL; - while (!issp(ch) && !isbr(ch)) { - if (ch != '0' && ch != '1') error2(PSTR("illegal character in bit array")); - object *cell = cons(number(ch - '0'), NULL); - if (head == NULL) head = cell; - else tail->cdr = cell; - tail = cell; - ch = gfun(); - } - LastChar = ch; - int size = listlength(head); - object *array = makearray(cons(number(size), NULL), number(0), true); - size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - int index = 0; - while (head != NULL) { - object **loc = arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size); - int bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); - *loc = number((((*loc)->integer) & ~(1<integer)<integer; - if (d < 0) d = -d; - for (int i = 0; i < d; i++) { - if (i && spaces) pfun(' '); - int index = slice * d + i; - if (cdr(dims) == NULL) { - if (bitp) pint(((*arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size))->integer)>> - (index & (sizeof(int)==4 ? 0x1F : 0x0F)) & 1, pfun); - else printobject(*arrayref(array, index, size), pfun); - } else { pfun('('); pslice(array, size, index, cdr(dims), pfun, bitp); pfun(')'); } - } -} - -void printarray (object *array, pfun_t pfun) { - object *dimensions = cddr(array); - object *dims = dimensions; - bool bitp = false; - int size = 1, n = 0; - while (dims != NULL) { - int d = car(dims)->integer; - if (d < 0) { bitp = true; d = -d; } - size = size * d; - dims = cdr(dims); n++; - } - if (bitp) size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - pfun('#'); - if (n == 1 && bitp) { pfun('*'); pslice(array, size, -1, dimensions, pfun, bitp); } - else { - if (n > 1) { pint(n, pfun); pfun('A'); } - pfun('('); pslice(array, size, 0, dimensions, pfun, bitp); pfun(')'); - } -} - -// String utilities - -void indent (uint8_t spaces, char ch, pfun_t pfun) { - for (uint8_t i=0; ichars & 0xFFFFFF) == 0) { - (*tail)->chars = (*tail)->chars | ch<<16; return; - } else if (((*tail)->chars & 0xFFFF) == 0) { - (*tail)->chars = (*tail)->chars | ch<<8; return; - } else if (((*tail)->chars & 0xFF) == 0) { - (*tail)->chars = (*tail)->chars | ch; return; - } else { - cell = myalloc(); car(*tail) = cell; - } - car(cell) = NULL; cell->chars = ch<<24; *tail = cell; -} - -object *copystring (object *arg) { - object *obj = newstring(); - object *ptr = obj; - arg = cdr(arg); - while (arg != NULL) { - object *cell = myalloc(); car(cell) = NULL; - if (cdr(obj) == NULL) cdr(obj) = cell; else car(ptr) = cell; - ptr = cell; - ptr->chars = arg->chars; - arg = car(arg); - } - return obj; -} - -object *readstring (uint8_t delim, gfun_t gfun) { - object *obj = newstring(); - object *tail = obj; - int ch = gfun(); - if (ch == -1) return nil; - while ((ch != delim) && (ch != -1)) { - if (ch == '\\') ch = gfun(); - buildstring(ch, &tail); - ch = gfun(); - } - return obj; -} - -int stringlength (object *form) { - int length = 0; - form = cdr(form); - while (form != NULL) { - int chars = form->chars; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - if (chars>>i & 0xFF) length++; - } - form = car(form); - } - return length; -} - -uint8_t nthchar (object *string, int n) { - object *arg = cdr(string); - int top; - if (sizeof(int) == 4) { top = n>>2; n = 3 - (n&3); } - else { top = n>>1; n = 1 - (n&1); } - for (int i=0; ichars)>>(n*8) & 0xFF; -} - -int gstr () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - char c = nthchar(GlobalString, GlobalStringIndex++); - if (c != 0) return c; - return '\n'; // -1? -} - -void pstr (char c) { - buildstring(c, &GlobalStringTail); -} - -object *lispstring (char *s) { - object *obj = newstring(); - object *tail = obj; - while(1) { - char ch = *s++; - if (ch == 0) break; - if (ch == '\\') ch = *s++; - buildstring(ch, &tail); - } - return obj; -} - -bool stringcompare (object *args, bool lt, bool gt, bool eq) { - object *arg1 = checkstring(first(args)); - object *arg2 = checkstring(second(args)); - arg1 = cdr(arg1); - arg2 = cdr(arg2); - while ((arg1 != NULL) || (arg2 != NULL)) { - if (arg1 == NULL) return lt; - if (arg2 == NULL) return gt; - if (arg1->chars < arg2->chars) return lt; - if (arg1->chars > arg2->chars) return gt; - arg1 = car(arg1); - arg2 = car(arg2); - } - return eq; -} - -object *documentation (object *arg, object *env) { - if (arg == NULL) return nil; - if (!symbolp(arg)) error(notasymbol, arg); - object *pair = findpair(arg, env); - if (pair != NULL) { - object *val = cdr(pair); - if (listp(val) && first(val)->name == sym(LAMBDA) && cdr(val) != NULL && cddr(val) != NULL) { - if (stringp(third(val))) return third(val); - } - } - symbol_t docname = arg->name; - if (!builtinp(docname)) return nil; - char *docstring = lookupdoc(builtin(docname)); - if (docstring == NULL) return nil; - object *obj = startstring(); - pfstring(docstring, pstr); - return obj; -} - -object *apropos (object *arg, bool print) { - char buf[17], buf2[33]; - char *part = cstring(princtostring(arg), buf, 17); - object *result = cons(NULL, NULL); - object *ptr = result; - // User-defined? - object *globals = GlobalEnv; - while (globals != NULL) { - object *pair = first(globals); - object *var = car(pair); - object *val = cdr(pair); - char *full = cstring(princtostring(var), buf2, 33); - if (strstr(full, part) != NULL) { - if (print) { - printsymbol(var, pserial); pserial(' '); pserial('('); - if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) pfstring(PSTR("user function"), pserial); - else if (consp(val) && car(val)->type == CODE) pfstring(PSTR("code"), pserial); - else pfstring(PSTR("user symbol"), pserial); - pserial(')'); pln(pserial); - } else { - cdr(ptr) = cons(var, NULL); ptr = cdr(ptr); - } - } - globals = cdr(globals); - } - // Built-in? - int entries = tablesize(0) + tablesize(1); - for (int i = 0; i < entries; i++) { - if (findsubstring(part, (builtin_t)i)) { - if (print) { - uint8_t fntype = getminmax(i)>>6; - pbuiltin((builtin_t)i, pserial); pserial(' '); pserial('('); - if (fntype == FUNCTIONS) pfstring(PSTR("function"), pserial); - else if (fntype == SPECIAL_FORMS) pfstring(PSTR("special form"), pserial); - else pfstring(PSTR("symbol/keyword"), pserial); - pserial(')'); pln(pserial); - } else { - cdr(ptr) = cons(bsymbol(i), NULL); ptr = cdr(ptr); - } - } - } - return cdr(result); -} - -char *cstring (object *form, char *buffer, int buflen) { - form = cdr(checkstring(form)); - int index = 0; - while (form != NULL) { - int chars = form->integer; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; - if (ch) { - if (index >= buflen-1) error2(PSTR("no room for string")); - buffer[index++] = ch; - } - } - form = car(form); - } - buffer[index] = '\0'; - return buffer; -} - -uint32_t ipstring (object *form) { - form = cdr(checkstring(form)); - int p = 0; - union { uint32_t ipaddress; uint8_t ipbytes[4]; } ; - ipaddress = 0; - while (form != NULL) { - int chars = form->integer; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; - if (ch) { - if (ch == '.') { p++; if (p > 3) error2(PSTR("illegal IP address")); } - else ipbytes[p] = (ipbytes[p] * 10) + ch - '0'; - } - } - form = car(form); - } - return ipaddress; -} - -// Lookup variable in environment - -object *value (symbol_t n, object *env) { - while (env != NULL) { - object *pair = car(env); - if (pair != NULL && car(pair)->name == n) return pair; - env = cdr(env); - } - return nil; -} - -object *findpair (object *var, object *env) { - symbol_t name = var->name; - object *pair = value(name, env); - if (pair == NULL) pair = value(name, GlobalEnv); - return pair; -} - -bool boundp (object *var, object *env) { - if (!symbolp(var)) error(notasymbol, var); - return (findpair(var, env) != NULL); -} - -object *findvalue (object *var, object *env) { - object *pair = findpair(var, env); - if (pair == NULL) error(PSTR("unknown variable"), var); - return pair; -} - -// Handling closures - -object *closure (int tc, symbol_t name, object *function, object *args, object **env) { - object *state = car(function); - function = cdr(function); - int trace = 0; - if (name) trace = tracing(name); - if (trace) { - indent(TraceDepth[trace-1]<<1, ' ', pserial); - pint(TraceDepth[trace-1]++, pserial); - pserial(':'); pserial(' '); pserial('('); printsymbol(symbol(name), pserial); - } - object *params = first(function); - if (!listp(params)) errorsym(name, notalist, params); - function = cdr(function); - // Dropframe - if (tc) { - if (*env != NULL && car(*env) == NULL) { - pop(*env); - while (*env != NULL && car(*env) != NULL) pop(*env); - } else push(nil, *env); - } - // Push state - while (consp(state)) { - object *pair = first(state); - push(pair, *env); - state = cdr(state); - } - // Add arguments to environment - bool optional = false; - while (params != NULL) { - object *value; - object *var = first(params); - if (isbuiltin(var, OPTIONAL)) optional = true; - else { - if (consp(var)) { - if (!optional) errorsym(name, PSTR("invalid default value"), var); - if (args == NULL) value = eval(second(var), *env); - else { value = first(args); args = cdr(args); } - var = first(var); - if (!symbolp(var)) errorsym(name, PSTR("illegal optional parameter"), var); - } else if (!symbolp(var)) { - errorsym(name, PSTR("illegal function parameter"), var); - } else if (isbuiltin(var, AMPREST)) { - params = cdr(params); - var = first(params); - value = args; - args = NULL; - } else { - if (args == NULL) { - if (optional) value = nil; - else errorsym2(name, toofewargs); - } else { value = first(args); args = cdr(args); } - } - push(cons(var,value), *env); - if (trace) { pserial(' '); printobject(value, pserial); } - } - params = cdr(params); - } - if (args != NULL) errorsym2(name, toomanyargs); - if (trace) { pserial(')'); pln(pserial); } - // Do an implicit progn - if (tc) push(nil, *env); - return tf_progn(function, *env); -} - -object *apply (object *function, object *args, object *env) { - if (symbolp(function)) { - builtin_t fname = builtin(function->name); - if ((fname < ENDFUNCTIONS) && ((getminmax(fname)>>6) == FUNCTIONS)) { - Context = fname; - checkargs(args); - return ((fn_ptr_type)lookupfn(fname))(args, env); - } else function = eval(function, env); - } - if (consp(function) && isbuiltin(car(function), LAMBDA)) { - object *result = closure(0, sym(NIL), function, args, &env); - return eval(result, env); - } - if (consp(function) && isbuiltin(car(function), CLOSURE)) { - function = cdr(function); - object *result = closure(0, sym(NIL), function, args, &env); - return eval(result, env); - } - error(PSTR("illegal function"), function); - return NULL; -} - -// In-place operations - -object **place (object *args, object *env, int *bit) { - *bit = -1; - if (atom(args)) return &cdr(findvalue(args, env)); - object* function = first(args); - if (symbolp(function)) { - symbol_t sname = function->name; - if (sname == sym(CAR) || sname == sym(FIRST)) { - object *value = eval(second(args), env); - if (!listp(value)) error(canttakecar, value); - return &car(value); - } - if (sname == sym(CDR) || sname == sym(REST)) { - object *value = eval(second(args), env); - if (!listp(value)) error(canttakecdr, value); - return &cdr(value); - } - if (sname == sym(NTH)) { - int index = checkinteger(eval(second(args), env)); - object *list = eval(third(args), env); - if (atom(list)) error(PSTR("second argument to nth is not a list"), list); - while (index > 0) { - list = cdr(list); - if (list == NULL) error2(PSTR("index to nth is out of range")); - index--; - } - return &car(list); - } - if (sname == sym(AREF)) { - object *array = eval(second(args), env); - if (!arrayp(array)) error(PSTR("first argument is not an array"), array); - return getarray(array, cddr(args), env, bit); - } - } - error2(PSTR("illegal place")); - return nil; -} - -// Checked car and cdr - -object *carx (object *arg) { - if (!listp(arg)) error(canttakecar, arg); - if (arg == nil) return nil; - return car(arg); -} - -object *cdrx (object *arg) { - if (!listp(arg)) error(canttakecdr, arg); - if (arg == nil) return nil; - return cdr(arg); -} - -object *cxxxr (object *args, uint8_t pattern) { - object *arg = first(args); - while (pattern != 1) { - if ((pattern & 1) == 0) arg = carx(arg); else arg = cdrx(arg); - pattern = pattern>>1; - } - return arg; -} - -// Mapping helper functions - -void mapcarfun (object *result, object **tail) { - object *obj = cons(result,NULL); - cdr(*tail) = obj; *tail = obj; -} - -void mapcanfun (object *result, object **tail) { - if (cdr(*tail) != NULL) error(notproper, *tail); - while (consp(result)) { - cdr(*tail) = result; *tail = result; - result = cdr(result); - } -} - -object *mapcarcan (object *args, object *env, mapfun_t fun) { - object *function = first(args); - args = cdr(args); - object *params = cons(NULL, NULL); - push(params,GCStack); - object *head = cons(NULL, NULL); - push(head,GCStack); - object *tail = head; - // Make parameters - while (true) { - object *tailp = params; - object *lists = args; - while (lists != NULL) { - object *list = car(lists); - if (list == NULL) { - pop(GCStack); pop(GCStack); - return cdr(head); - } - if (improperp(list)) error(notproper, list); - object *obj = cons(first(list),NULL); - car(lists) = cdr(list); - cdr(tailp) = obj; tailp = obj; - lists = cdr(lists); - } - object *result = apply(function, cdr(params), env); - fun(result, &tail); - } -} - -// I2C interface for one port, using Arduino Wire - -void I2Cinit (bool enablePullup) { - (void) enablePullup; - Wire.begin(); -} - -int I2Cread () { - return Wire.read(); -} - -void I2Cwrite (uint8_t data) { - Wire.write(data); -} - -bool I2Cstart (uint8_t address, uint8_t read) { - int ok = true; - if (read == 0) { - Wire.beginTransmission(address); - ok = (Wire.endTransmission(true) == 0); - Wire.beginTransmission(address); - } - else Wire.requestFrom(address, I2Ccount); - return ok; -} - -bool I2Crestart (uint8_t address, uint8_t read) { - int error = (Wire.endTransmission(false) != 0); - if (read == 0) Wire.beginTransmission(address); - else Wire.requestFrom(address, I2Ccount); - return error ? false : true; -} - -void I2Cstop (uint8_t read) { - if (read == 0) Wire.endTransmission(); // Check for error? -} - -// Streams - -inline int spiread () { return SPI.transfer(0); } -inline int serial1read () { while (!Serial1.available()) testescape(); return Serial1.read(); } -#if defined(sdcardsupport) -File SDpfile, SDgfile; -inline int SDread () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - return SDgfile.read(); -} -#endif - -WiFiClient client; -WiFiServer server(80); - -inline int WiFiread () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - return client.read(); -} - -void serialbegin (int address, int baud) { - if (address == 1) Serial1.begin((long)baud*100); - else error(PSTR("port not supported"), number(address)); -} - -void serialend (int address) { - if (address == 1) {Serial1.flush(); Serial1.end(); } -} - -gfun_t gstreamfun (object *args) { - int streamtype = SERIALSTREAM; - int address = 0; - gfun_t gfun = gserial; - if (args != NULL) { - int stream = isstream(first(args)); - streamtype = stream>>8; address = stream & 0xFF; - } - if (streamtype == I2CSTREAM) gfun = (gfun_t)I2Cread; - else if (streamtype == SPISTREAM) gfun = spiread; - else if (streamtype == SERIALSTREAM) { - if (address == 0) gfun = gserial; - else if (address == 1) gfun = serial1read; - } - #if defined(sdcardsupport) - else if (streamtype == SDSTREAM) gfun = (gfun_t)SDread; - #endif - else if (streamtype == WIFISTREAM) gfun = (gfun_t)WiFiread; - else error2(PSTR("unknown stream type")); - return gfun; -} - -inline void spiwrite (char c) { SPI.transfer(c); } -inline void serial1write (char c) { Serial1.write(c); } -inline void WiFiwrite (char c) { client.write(c); } -#if defined(sdcardsupport) -inline void SDwrite (char c) { SDpfile.write(c); } -#endif -#if defined(gfxsupport) -inline void gfxwrite (char c) { tft.write(c); } -#endif - -pfun_t pstreamfun (object *args) { - int streamtype = SERIALSTREAM; - int address = 0; - pfun_t pfun = pserial; - if (args != NULL && first(args) != NULL) { - int stream = isstream(first(args)); - streamtype = stream>>8; address = stream & 0xFF; - } - if (streamtype == I2CSTREAM) pfun = (pfun_t)I2Cwrite; - else if (streamtype == SPISTREAM) pfun = spiwrite; - else if (streamtype == SERIALSTREAM) { - if (address == 0) pfun = pserial; - else if (address == 1) pfun = serial1write; - } - else if (streamtype == STRINGSTREAM) { - pfun = pstr; - } - #if defined(sdcardsupport) - else if (streamtype == SDSTREAM) pfun = (pfun_t)SDwrite; - #endif - #if defined(gfxsupport) - else if (streamtype == GFXSTREAM) pfun = (pfun_t)gfxwrite; - #endif - else if (streamtype == WIFISTREAM) pfun = (pfun_t)WiFiwrite; - else error2(PSTR("unknown stream type")); - return pfun; -} - -// Check pins - -void checkanalogread (int pin) { -#if defined(ESP8266) - if (pin!=17) error(PSTR("invalid pin"), number(pin)); -#elif defined(ESP32) || defined(ARDUINO_ESP32_DEV) - if (!(pin==0 || pin==2 || pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) - error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_FEATHER_ESP32) - if (!(pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) - error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2) || defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) - if (!(pin==8 || (pin>=14 && pin<=18))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ADAFRUIT_QTPY_ESP32S2) - if (!((pin>=5 && pin<=9) || (pin>=16 && pin<=18))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ADAFRUIT_QTPY_ESP32C3) - if (!((pin>=0 && pin<=1) || (pin>=3 && pin<=5))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_FEATHERS2) | defined(ARDUINO_ESP32S2_DEV) - if (!((pin>=1 && pin<=20))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ESP32C3_DEV) - if (!((pin>=0 && pin<=5))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ESP32S3_DEV) - if (!((pin>=1 && pin<=20))) error(PSTR("invalid pin"), number(pin)); -#endif -} - -void checkanalogwrite (int pin) { -#if defined(ESP8266) - if (!(pin>=0 && pin<=16)) error(PSTR("invalid pin"), number(pin)); -#elif defined(ESP32) || defined(ARDUINO_FEATHER_ESP32) || defined(ARDUINO_ESP32_DEV) - if (!(pin>=25 && pin<=26)) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2) || defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) || defined(ARDUINO_ADAFRUIT_QTPY_ESP32S2) || defined(ARDUINO_FEATHERS2) || defined(ARDUINO_ESP32S2_DEV) - if (!(pin>=17 && pin<=18)) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ESP32C3_DEV) | defined(ARDUINO_ESP32S3_DEV) | defined(ARDUINO_ADAFRUIT_QTPY_ESP32C3) - error2(ANALOGWRITE, PSTR("not supported")); -#endif -} - -// Note - -void tone (int pin, int note) { - (void) pin, (void) note; -} - -void noTone (int pin) { - (void) pin; -} - -const int scale[] PROGMEM = {4186,4435,4699,4978,5274,5588,5920,6272,6645,7040,7459,7902}; - -void playnote (int pin, int note, int octave) { - int prescaler = 8 - octave - note/12; - if (prescaler<0 || prescaler>8) error(PSTR("octave out of range"), number(prescaler)); - tone(pin, pgm_read_word(&scale[note%12])>>prescaler); -} - -void nonote (int pin) { - noTone(pin); -} - -// Sleep - -void initsleep () { } - -void doze (int secs) { - delay(1000 * secs); -} - -// Prettyprint - -const int PPINDENT = 2; -const int PPWIDTH = 80; -const int GFXPPWIDTH = 52; // 320 pixel wide screen -int ppwidth = PPWIDTH; - -void pcount (char c) { - if (c == '\n') PrintCount++; - PrintCount++; -} - -uint8_t atomwidth (object *obj) { - PrintCount = 0; - printobject(obj, pcount); - return PrintCount; -} - -uint8_t basewidth (object *obj, uint8_t base) { - PrintCount = 0; - pintbase(obj->integer, base, pcount); - return PrintCount; -} - -bool quoted (object *obj) { - return (consp(obj) && car(obj) != NULL && car(obj)->name == sym(QUOTE) && consp(cdr(obj)) && cddr(obj) == NULL); -} - -int subwidth (object *obj, int w) { - if (atom(obj)) return w - atomwidth(obj); - if (quoted(obj)) obj = car(cdr(obj)); - return subwidthlist(obj, w - 1); -} - -int subwidthlist (object *form, int w) { - while (form != NULL && w >= 0) { - if (atom(form)) return w - (2 + atomwidth(form)); - w = subwidth(car(form), w - 1); - form = cdr(form); - } - return w; -} - -void superprint (object *form, int lm, pfun_t pfun) { - if (atom(form)) { - if (symbolp(form) && form->name == sym(NOTHING)) printsymbol(form, pfun); - else printobject(form, pfun); - } - else if (quoted(form)) { pfun('\''); superprint(car(cdr(form)), lm + 1, pfun); } - else if (subwidth(form, ppwidth - lm) >= 0) supersub(form, lm + PPINDENT, 0, pfun); - else supersub(form, lm + PPINDENT, 1, pfun); -} - -void supersub (object *form, int lm, int super, pfun_t pfun) { - int special = 0, separate = 1; - object *arg = car(form); - if (symbolp(arg) && builtinp(arg->name)) { - uint8_t minmax = getminmax(builtin(arg->name)); - if (minmax == 0327 || minmax == 0313) special = 2; // defun, setq, setf, defvar - else if (minmax == 0317 || minmax == 0017 || minmax == 0117 || minmax == 0123) special = 1; - } - while (form != NULL) { - if (atom(form)) { pfstring(PSTR(" . "), pfun); printobject(form, pfun); pfun(')'); return; } - else if (separate) { pfun('('); separate = 0; } - else if (special) { pfun(' '); special--; } - else if (!super) pfun(' '); - else { pln(pfun); indent(lm, ' ', pfun); } - superprint(car(form), lm, pfun); - form = cdr(form); - } - pfun(')'); return; -} - -object *edit (object *fun) { - while (1) { - if (tstflag(EXITEDITOR)) return fun; - char c = gserial(); - if (c == 'q') setflag(EXITEDITOR); - else if (c == 'b') return fun; - else if (c == 'r') fun = read(gserial); - else if (c == '\n') { pfl(pserial); superprint(fun, 0, pserial); pln(pserial); } - else if (c == 'c') fun = cons(read(gserial), fun); - else if (atom(fun)) pserial('!'); - else if (c == 'd') fun = cons(car(fun), edit(cdr(fun))); - else if (c == 'a') fun = cons(edit(car(fun)), cdr(fun)); - else if (c == 'x') fun = cdr(fun); - else pserial('?'); - } -} - -// Special forms - -object *sp_quote (object *args, object *env) { - (void) env; - checkargs(args); - return first(args); -} - -object *sp_or (object *args, object *env) { - while (args != NULL) { - object *val = eval(car(args), env); - if (val != NULL) return val; - args = cdr(args); - } - return nil; -} - -object *sp_defun (object *args, object *env) { - (void) env; - checkargs(args); - object *var = first(args); - if (!symbolp(var)) error(notasymbol, var); - object *val = cons(bsymbol(LAMBDA), cdr(args)); - object *pair = value(var->name, GlobalEnv); - if (pair != NULL) cdr(pair) = val; - else push(cons(var, val), GlobalEnv); - return var; -} - -object *sp_defvar (object *args, object *env) { - checkargs(args); - object *var = first(args); - if (!symbolp(var)) error(notasymbol, var); - object *val = NULL; - args = cdr(args); - if (args != NULL) { setflag(NOESC); val = eval(first(args), env); clrflag(NOESC); } - object *pair = value(var->name, GlobalEnv); - if (pair != NULL) cdr(pair) = val; - else push(cons(var, val), GlobalEnv); - return var; -} - -object *sp_setq (object *args, object *env) { - object *arg = nil; - while (args != NULL) { - if (cdr(args) == NULL) error2(oddargs); - object *pair = findvalue(first(args), env); - arg = eval(second(args), env); - cdr(pair) = arg; - args = cddr(args); - } - return arg; -} - -object *sp_loop (object *args, object *env) { - object *start = args; - for (;;) { - yield(); - args = start; - while (args != NULL) { - object *result = eval(car(args),env); - if (tstflag(RETURNFLAG)) { - clrflag(RETURNFLAG); - return result; - } - args = cdr(args); - } - } -} - -object *sp_return (object *args, object *env) { - object *result = eval(tf_progn(args,env), env); - setflag(RETURNFLAG); - return result; -} - -object *sp_push (object *args, object *env) { - int bit; - checkargs(args); - object *item = eval(first(args), env); - object **loc = place(second(args), env, &bit); - push(item, *loc); - return *loc; -} - -object *sp_pop (object *args, object *env) { - int bit; - checkargs(args); - object **loc = place(first(args), env, &bit); - object *result = car(*loc); - pop(*loc); - return result; -} - -// Accessors - -object *sp_incf (object *args, object *env) { - int bit; - checkargs(args); - object **loc = place(first(args), env, &bit); - args = cdr(args); - - object *x = *loc; - object *inc = (args != NULL) ? eval(first(args), env) : NULL; - - if (bit != -1) { - int increment; - if (inc == NULL) increment = 1; else increment = checkbitvalue(inc); - int newvalue = (((*loc)->integer)>>bit & 1) + increment; - - if (newvalue & ~1) error2(PSTR("result is not a bit value")); - *loc = number((((*loc)->integer) & ~(1<integer; - - if (inc == NULL) increment = 1; else increment = inc->integer; - - if (increment < 1) { - if (INT_MIN - increment > value) *loc = makefloat((float)value + (float)increment); - else *loc = number(value + increment); - } else { - if (INT_MAX - increment < value) *loc = makefloat((float)value + (float)increment); - else *loc = number(value + increment); - } - } else error2(notanumber); - return *loc; -} - -object *sp_decf (object *args, object *env) { - int bit; - checkargs(args); - object **loc = place(first(args), env, &bit); - args = cdr(args); - - object *x = *loc; - object *dec = (args != NULL) ? eval(first(args), env) : NULL; - - if (bit != -1) { - int decrement; - if (dec == NULL) decrement = 1; else decrement = checkbitvalue(dec); - int newvalue = (((*loc)->integer)>>bit & 1) - decrement; - - if (newvalue & ~1) error2(PSTR("result is not a bit value")); - *loc = number((((*loc)->integer) & ~(1<integer; - - if (dec == NULL) decrement = 1; else decrement = dec->integer; - - if (decrement < 1) { - if (INT_MAX + decrement < value) *loc = makefloat((float)value - (float)decrement); - else *loc = number(value - decrement); - } else { - if (INT_MIN + decrement > value) *loc = makefloat((float)value - (float)decrement); - else *loc = number(value - decrement); - } - } else error2(notanumber); - return *loc; -} - -object *sp_setf (object *args, object *env) { - int bit; - object *arg = nil; - while (args != NULL) { - if (cdr(args) == NULL) error2(oddargs); - object **loc = place(first(args), env, &bit); - arg = eval(second(args), env); - if (bit == -1) *loc = arg; - else *loc = number((checkinteger(*loc) & ~(1<name); - args = cdr(args); - } - int i = 0; - while (i < TRACEMAX) { - if (TraceFn[i] != 0) args = cons(symbol(TraceFn[i]), args); - i++; - } - return args; -} - -object *sp_untrace (object *args, object *env) { - (void) env; - if (args == NULL) { - int i = 0; - while (i < TRACEMAX) { - if (TraceFn[i] != 0) args = cons(symbol(TraceFn[i]), args); - TraceFn[i] = 0; - i++; - } - } else { - while (args != NULL) { - object *var = first(args); - if (!symbolp(var)) error(notasymbol, var); - untrace(var->name); - args = cdr(args); - } - } - return args; -} - -object *sp_formillis (object *args, object *env) { - if (args == NULL) error2(noargument); - object *param = first(args); - unsigned long start = millis(); - unsigned long now, total = 0; - if (param != NULL) total = checkinteger(eval(first(param), env)); - eval(tf_progn(cdr(args),env), env); - do { - now = millis() - start; - testescape(); - } while (now < total); - if (now <= INT_MAX) return number(now); - return nil; -} - -object *sp_time (object *args, object *env) { - unsigned long start = millis(); - object *result = eval(first(args), env); - unsigned long elapsed = millis() - start; - printobject(result, pserial); - pfstring(PSTR("\nTime: "), pserial); - if (elapsed < 1000) { - pint(elapsed, pserial); - pfstring(PSTR(" ms\n"), pserial); - } else { - elapsed = elapsed+50; - pint(elapsed/1000, pserial); - pserial('.'); pint((elapsed/100)%10, pserial); - pfstring(PSTR(" s\n"), pserial); - } - return bsymbol(NOTHING); -} - -object *sp_withoutputtostring (object *args, object *env) { - if (args == NULL) error2(noargument); - object *params = first(args); - if (params == NULL) error2(nostream); - object *var = first(params); - object *pair = cons(var, stream(STRINGSTREAM, 0)); - push(pair,env); - object *string = startstring(); - push(string, GCStack); - object *forms = cdr(args); - eval(tf_progn(forms,env), env); - pop(GCStack); - return string; -} - -object *sp_withserial (object *args, object *env) { - object *params = first(args); - if (params == NULL) error2(nostream); - object *var = first(params); - int address = checkinteger(eval(second(params), env)); - params = cddr(params); - int baud = 96; - if (params != NULL) baud = checkinteger(eval(first(params), env)); - object *pair = cons(var, stream(SERIALSTREAM, address)); - push(pair,env); - serialbegin(address, baud); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); - serialend(address); - return result; -} - -object *sp_withi2c (object *args, object *env) { - object *params = first(args); - if (params == NULL) error2(nostream); - object *var = first(params); - int address = checkinteger(eval(second(params), env)); - params = cddr(params); - if (address == 0 && params != NULL) params = cdr(params); // Ignore port - int read = 0; // Write - I2Ccount = 0; - if (params != NULL) { - object *rw = eval(first(params), env); - if (integerp(rw)) I2Ccount = rw->integer; - read = (rw != NULL); - } - I2Cinit(1); // Pullups - object *pair = cons(var, (I2Cstart(address, read)) ? stream(I2CSTREAM, address) : nil); - push(pair,env); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); - I2Cstop(read); - return result; -} - -object *sp_withspi (object *args, object *env) { - object *params = first(args); - if (params == NULL) error2(nostream); - object *var = first(params); - params = cdr(params); - if (params == NULL) error2(nostream); - int pin = checkinteger(eval(car(params), env)); - pinMode(pin, OUTPUT); - digitalWrite(pin, HIGH); - params = cdr(params); - int clock = 4000, mode = SPI_MODE0; // Defaults - int bitorder = MSBFIRST; - if (params != NULL) { - clock = checkinteger(eval(car(params), env)); - params = cdr(params); - if (params != NULL) { - bitorder = (checkinteger(eval(car(params), env)) == 0) ? LSBFIRST : MSBFIRST; - params = cdr(params); - if (params != NULL) { - int modeval = checkinteger(eval(car(params), env)); - mode = (modeval == 3) ? SPI_MODE3 : (modeval == 2) ? SPI_MODE2 : (modeval == 1) ? SPI_MODE1 : SPI_MODE0; - } - } - } - object *pair = cons(var, stream(SPISTREAM, pin)); - push(pair,env); - SPI.begin(); - SPI.beginTransaction(SPISettings(((unsigned long)clock * 1000), bitorder, mode)); - digitalWrite(pin, LOW); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); - digitalWrite(pin, HIGH); - SPI.endTransaction(); - return result; -} - -object *sp_withsdcard (object *args, object *env) { -#if defined(sdcardsupport) - object *params = first(args); - if (params == NULL) error2(nostream); - object *var = first(params); - params = cdr(params); - if (params == NULL) error2(PSTR("no filename specified")); - object *filename = eval(first(params), env); - params = cdr(params); - SD.begin(); - int mode = 0; - if (params != NULL && first(params) != NULL) mode = checkinteger(first(params)); - const char *oflag = FILE_READ; - if (mode == 1) oflag = FILE_APPEND; else if (mode == 2) oflag = FILE_WRITE; - if (mode >= 1) { - char buffer[BUFFERSIZE]; - SDpfile = SD.open(MakeFilename(filename, buffer), oflag); - if (!SDpfile) error2(PSTR("problem writing to SD card or invalid filename")); - } else { - char buffer[BUFFERSIZE]; - SDgfile = SD.open(MakeFilename(filename, buffer), oflag); - if (!SDgfile) error2(PSTR("problem reading from SD card or invalid filename")); - } - object *pair = cons(var, stream(SDSTREAM, 1)); - push(pair,env); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); - if (mode >= 1) SDpfile.close(); else SDgfile.close(); - return result; -#else - (void) args, (void) env; - error2(PSTR("not supported")); - return nil; -#endif -} - -// Tail-recursive forms - -object *tf_progn (object *args, object *env) { - if (args == NULL) return nil; - object *more = cdr(args); - while (more != NULL) { - object *result = eval(car(args),env); - if (tstflag(RETURNFLAG)) return result; - args = more; - more = cdr(args); - } - return car(args); -} - -object *tf_if (object *args, object *env) { - if (args == NULL || cdr(args) == NULL) error2(toofewargs); - if (eval(first(args), env) != nil) return second(args); - args = cddr(args); - return (args != NULL) ? first(args) : nil; -} - -object *tf_cond (object *args, object *env) { - while (args != NULL) { - object *clause = first(args); - if (!consp(clause)) error(illegalclause, clause); - object *test = eval(first(clause), env); - object *forms = cdr(clause); - if (test != nil) { - if (forms == NULL) return quote(test); else return tf_progn(forms, env); - } - args = cdr(args); - } - return nil; -} - -object *tf_when (object *args, object *env) { - if (args == NULL) error2(noargument); - if (eval(first(args), env) != nil) return tf_progn(cdr(args),env); - else return nil; -} - -object *tf_unless (object *args, object *env) { - if (args == NULL) error2(noargument); - if (eval(first(args), env) != nil) return nil; - else return tf_progn(cdr(args),env); -} - -object *tf_case (object *args, object *env) { - object *test = eval(first(args), env); - args = cdr(args); - while (args != NULL) { - object *clause = first(args); - if (!consp(clause)) error(illegalclause, clause); - object *key = car(clause); - object *forms = cdr(clause); - if (consp(key)) { - while (key != NULL) { - if (eq(test,car(key))) return tf_progn(forms, env); - key = cdr(key); - } - } else if (eq(test,key) || eq(key,tee)) return tf_progn(forms, env); - args = cdr(args); - } - return nil; -} - -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); -} - -// 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; - return atom(first(args)) ? tee : nil; -} - -object *fn_listp (object *args, object *env) { - (void) env; - return listp(first(args)) ? tee : nil; -} - -object *fn_consp (object *args, object *env) { - (void) env; - return consp(first(args)) ? tee : nil; -} - -object *fn_symbolp (object *args, object *env) { - (void) env; - object *arg = first(args); - return (arg == NULL || symbolp(arg)) ? tee : nil; -} - -object *fn_arrayp (object *args, object *env) { - (void) env; - return arrayp(first(args)) ? tee : nil; -} - -object *fn_boundp (object *args, object *env) { - return boundp(first(args), env) ? tee : nil; -} - -object *fn_keywordp (object *args, object *env) { - (void) env; - return keywordp(first(args)) ? tee : nil; -} - -object *fn_setfn (object *args, object *env) { - object *arg = nil; - while (args != NULL) { - if (cdr(args) == NULL) error2(oddargs); - object *pair = findvalue(first(args), env); - arg = second(args); - cdr(pair) = arg; - args = cddr(args); - } - return arg; -} - -object *fn_streamp (object *args, object *env) { - (void) env; - object *arg = first(args); - return streamp(arg) ? tee : nil; -} - -object *fn_eq (object *args, object *env) { - (void) env; - return eq(first(args), second(args)) ? tee : nil; -} - -object *fn_equal (object *args, object *env) { - (void) env; - return equal(first(args), second(args)) ? 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 cxxxr(args, 0b100); -} - -object *fn_cadr (object *args, object *env) { - (void) env; - return cxxxr(args, 0b101); -} - -object *fn_cdar (object *args, object *env) { - (void) env; - return cxxxr(args, 0b110); -} - -object *fn_cddr (object *args, object *env) { - (void) env; - return cxxxr(args, 0b111); -} - -object *fn_caaar (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1000); -} - -object *fn_caadr (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1001);; -} - -object *fn_cadar (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1010); -} - -object *fn_caddr (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1011); -} - -object *fn_cdaar (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1100); -} - -object *fn_cdadr (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1101); -} - -object *fn_cddar (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1110); -} - -object *fn_cdddr (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1111); -} - -object *fn_length (object *args, object *env) { - (void) env; - object *arg = first(args); - if (listp(arg)) return number(listlength(arg)); - if (stringp(arg)) return number(stringlength(arg)); - if (!(arrayp(arg) && cdr(cddr(arg)) == NULL)) error(PSTR("argument is not a list, 1d array, or string"), arg); - return number(abs(first(cddr(arg))->integer)); -} - -object *fn_arraydimensions (object *args, object *env) { - (void) env; - object *array = first(args); - if (!arrayp(array)) error(PSTR("argument is not an array"), array); - object *dimensions = cddr(array); - return (first(dimensions)->integer < 0) ? cons(number(-(first(dimensions)->integer)), cdr(dimensions)) : dimensions; -} - -object *fn_list (object *args, object *env) { - (void) env; - return args; -} - -object *fn_makearray (object *args, object *env) { - (void) env; - object *def = nil; - bool bitp = false; - object *dims = first(args); - if (dims == NULL) error2(PSTR("dimensions can't be nil")); - else if (atom(dims)) dims = cons(dims, NULL); - args = cdr(args); - while (args != NULL && cdr(args) != NULL) { - object *var = first(args); - if (isbuiltin(first(args), INITIALELEMENT)) def = second(args); - else if (isbuiltin(first(args), ELEMENTTYPE) && isbuiltin(second(args), BIT)) bitp = true; - else error(PSTR("argument not recognised"), var); - args = cddr(args); - } - if (bitp) { - if (def == nil) def = number(0); - else def = number(-checkbitvalue(def)); // 1 becomes all ones - } - return makearray(dims, def, bitp); -} - -object *fn_reverse (object *args, object *env) { - (void) env; - object *list = first(args); - object *result = NULL; - while (list != NULL) { - if (improperp(list)) error(notproper, list); - push(first(list),result); - list = cdr(list); - } - return result; -} - -object *fn_nth (object *args, object *env) { - (void) env; - int n = checkinteger(first(args)); - if (n < 0) error(indexnegative, first(args)); - object *list = second(args); - while (list != NULL) { - if (improperp(list)) error(notproper, list); - if (n == 0) return car(list); - list = cdr(list); - n--; - } - return nil; -} - -object *fn_aref (object *args, object *env) { - (void) env; - int bit; - object *array = first(args); - if (!arrayp(array)) error(PSTR("first argument is not an array"), array); - object *loc = *getarray(array, cdr(args), 0, &bit); - if (bit == -1) return loc; - else return number((loc->integer)>>bit & 1); -} - -object *fn_assoc (object *args, object *env) { - (void) env; - object *key = first(args); - object *list = second(args); - return assoc(key,list); -} - -object *fn_member (object *args, object *env) { - (void) env; - object *item = first(args); - object *list = second(args); - while (list != NULL) { - if (improperp(list)) error(notproper, list); - 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); - } - object *arg = car(last); - if (!listp(arg)) error(notalist, arg); - cdr(previous) = arg; - 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; - while (args != NULL) { - object *list = first(args); - if (!listp(list)) error(notalist, list); - while (consp(list)) { - object *obj = cons(car(list), cdr(list)); - if (head == NULL) head = obj; - else cdr(tail) = obj; - tail = obj; - list = cdr(list); - if (cdr(args) != NULL && improperp(list)) error(notproper, first(args)); - } - args = cdr(args); - } - return head; -} - -object *fn_mapc (object *args, object *env) { - object *function = first(args); - args = cdr(args); - object *result = first(args); - push(result,GCStack); - object *params = cons(NULL, NULL); - push(params,GCStack); - // Make parameters - while (true) { - object *tailp = params; - object *lists = args; - while (lists != NULL) { - object *list = car(lists); - if (list == NULL) { - pop(GCStack); pop(GCStack); - return result; - } - if (improperp(list)) error(notproper, list); - object *obj = cons(first(list),NULL); - car(lists) = cdr(list); - cdr(tailp) = obj; tailp = obj; - lists = cdr(lists); - } - apply(function, cdr(params), env); - } -} - -object *fn_mapcar (object *args, object *env) { - return mapcarcan(args, env, mapcarfun); -} - -object *fn_mapcan (object *args, object *env) { - return mapcarcan(args, env, mapcanfun); -} - -// Arithmetic functions - -object *fn_add (object *args, object *env) { - (void) env; - int result = 0; - while (args != NULL) { - object *arg = car(args); - if (floatp(arg)) return add_floats(args, (float)result); - else if (integerp(arg)) { - int val = arg->integer; - if (val < 1) { if (INT_MIN - val > result) return add_floats(args, (float)result); } - else { if (INT_MAX - val < result) return add_floats(args, (float)result); } - result = result + val; - } else error(notanumber, arg); - args = cdr(args); - } - return number(result); -} - -object *fn_subtract (object *args, object *env) { - (void) env; - object *arg = car(args); - args = cdr(args); - if (args == NULL) return negate(arg); - else if (floatp(arg)) return subtract_floats(args, arg->single_float); - else if (integerp(arg)) { - int result = arg->integer; - while (args != NULL) { - arg = car(args); - if (floatp(arg)) return subtract_floats(args, result); - else if (integerp(arg)) { - int val = (car(args))->integer; - if (val < 1) { if (INT_MAX + val < result) return subtract_floats(args, result); } - else { if (INT_MIN + val > result) return subtract_floats(args, result); } - result = result - val; - } else error(notanumber, arg); - args = cdr(args); - } - return number(result); - } else error(notanumber, arg); - return nil; -} - -object *fn_multiply (object *args, object *env) { - (void) env; - int result = 1; - while (args != NULL){ - object *arg = car(args); - if (floatp(arg)) return multiply_floats(args, result); - else if (integerp(arg)) { - int64_t val = result * (int64_t)(arg->integer); - if ((val > INT_MAX) || (val < INT_MIN)) return multiply_floats(args, result); - result = val; - } else error(notanumber, arg); - args = cdr(args); - } - return number(result); -} - -object *fn_divide (object *args, object *env) { - (void) env; - object* arg = first(args); - args = cdr(args); - // One argument - if (args == NULL) { - if (floatp(arg)) { - float f = arg->single_float; - if (f == 0.0) error2(PSTR("division by zero")); - return makefloat(1.0 / f); - } else if (integerp(arg)) { - int i = arg->integer; - if (i == 0) error2(PSTR("division by zero")); - else if (i == 1) return number(1); - else return makefloat(1.0 / i); - } else error(notanumber, arg); - } - // Multiple arguments - if (floatp(arg)) return divide_floats(args, arg->single_float); - else if (integerp(arg)) { - int result = arg->integer; - while (args != NULL) { - arg = car(args); - if (floatp(arg)) { - return divide_floats(args, result); - } else if (integerp(arg)) { - int i = arg->integer; - if (i == 0) error2(PSTR("division by zero")); - if ((result % i) != 0) return divide_floats(args, result); - if ((result == INT_MIN) && (i == -1)) return divide_floats(args, result); - result = result / i; - args = cdr(args); - } else error(notanumber, arg); - } - return number(result); - } else error(notanumber, arg); - return nil; -} - -object *fn_mod (object *args, object *env) { - (void) env; - object *arg1 = first(args); - object *arg2 = second(args); - if (integerp(arg1) && integerp(arg2)) { - int divisor = arg2->integer; - if (divisor == 0) error2(PSTR("division by zero")); - int dividend = arg1->integer; - int remainder = dividend % divisor; - if ((dividend<0) != (divisor<0)) remainder = remainder + divisor; - return number(remainder); - } else { - float fdivisor = checkintfloat(arg2); - if (fdivisor == 0.0) error2(PSTR("division by zero")); - float fdividend = checkintfloat(arg1); - float fremainder = fmod(fdividend , fdivisor); - if ((fdividend<0) != (fdivisor<0)) fremainder = fremainder + fdivisor; - return makefloat(fremainder); - } -} - -object *fn_oneplus (object *args, object *env) { - (void) env; - object* arg = first(args); - if (floatp(arg)) return makefloat((arg->single_float) + 1.0); - else if (integerp(arg)) { - int result = arg->integer; - if (result == INT_MAX) return makefloat((arg->integer) + 1.0); - else return number(result + 1); - } else error(notanumber, arg); - return nil; -} - -object *fn_oneminus (object *args, object *env) { - (void) env; - object* arg = first(args); - if (floatp(arg)) return makefloat((arg->single_float) - 1.0); - else if (integerp(arg)) { - int result = arg->integer; - if (result == INT_MIN) return makefloat((arg->integer) - 1.0); - else return number(result - 1); - } else error(notanumber, arg); - return nil; -} - -object *fn_abs (object *args, object *env) { - (void) env; - object *arg = first(args); - if (floatp(arg)) return makefloat(abs(arg->single_float)); - else if (integerp(arg)) { - int result = arg->integer; - if (result == INT_MIN) return makefloat(abs((float)result)); - else return number(abs(result)); - } else error(notanumber, arg); - return nil; -} - -object *fn_random (object *args, object *env) { - (void) env; - object *arg = first(args); - if (integerp(arg)) return number(random(arg->integer)); - else if (floatp(arg)) return makefloat((float)rand()/(float)(RAND_MAX/(arg->single_float))); - else error(notanumber, arg); - return nil; -} - -object *fn_maxfn (object *args, object *env) { - (void) env; - object* result = first(args); - args = cdr(args); - while (args != NULL) { - object *arg = car(args); - if (integerp(result) && integerp(arg)) { - if ((arg->integer) > (result->integer)) result = arg; - } else if ((checkintfloat(arg) > checkintfloat(result))) result = arg; - args = cdr(args); - } - return result; -} - -object *fn_minfn (object *args, object *env) { - (void) env; - object* result = first(args); - args = cdr(args); - while (args != NULL) { - object *arg = car(args); - if (integerp(result) && integerp(arg)) { - if ((arg->integer) < (result->integer)) result = arg; - } else if ((checkintfloat(arg) < checkintfloat(result))) result = arg; - args = cdr(args); - } - return result; -} - -// Arithmetic comparisons - -object *fn_noteq (object *args, object *env) { - (void) env; - while (args != NULL) { - object *nargs = args; - object *arg1 = first(nargs); - nargs = cdr(nargs); - while (nargs != NULL) { - object *arg2 = first(nargs); - if (integerp(arg1) && integerp(arg2)) { - if ((arg1->integer) == (arg2->integer)) return nil; - } else if ((checkintfloat(arg1) == checkintfloat(arg2))) return nil; - nargs = cdr(nargs); - } - args = cdr(args); - } - return tee; -} - -object *fn_numeq (object *args, object *env) { - (void) env; - return compare(args, false, false, true); -} - -object *fn_less (object *args, object *env) { - (void) env; - return compare(args, true, false, false); -} - -object *fn_lesseq (object *args, object *env) { - (void) env; - return compare(args, true, false, true); -} - -object *fn_greater (object *args, object *env) { - (void) env; - return compare(args, false, true, false); -} - -object *fn_greatereq (object *args, object *env) { - (void) env; - return compare(args, false, true, true); -} - -object *fn_plusp (object *args, object *env) { - (void) env; - object *arg = first(args); - if (floatp(arg)) return ((arg->single_float) > 0.0) ? tee : nil; - else if (integerp(arg)) return ((arg->integer) > 0) ? tee : nil; - else error(notanumber, arg); - return nil; -} - -object *fn_minusp (object *args, object *env) { - (void) env; - object *arg = first(args); - if (floatp(arg)) return ((arg->single_float) < 0.0) ? tee : nil; - else if (integerp(arg)) return ((arg->integer) < 0) ? tee : nil; - else error(notanumber, arg); - return nil; -} - -object *fn_zerop (object *args, object *env) { - (void) env; - object *arg = first(args); - if (floatp(arg)) return ((arg->single_float) == 0.0) ? tee : nil; - else if (integerp(arg)) return ((arg->integer) == 0) ? tee : nil; - else error(notanumber, arg); - return nil; -} - -object *fn_oddp (object *args, object *env) { - (void) env; - int arg = checkinteger(first(args)); - return ((arg & 1) == 1) ? tee : nil; -} - -object *fn_evenp (object *args, object *env) { - (void) env; - int arg = checkinteger(first(args)); - return ((arg & 1) == 0) ? tee : nil; -} - -// Number functions - -object *fn_integerp (object *args, object *env) { - (void) env; - return integerp(first(args)) ? tee : nil; -} - -object *fn_numberp (object *args, object *env) { - (void) env; - object *arg = first(args); - return (integerp(arg) || floatp(arg)) ? tee : nil; -} - -// Floating-point functions - -object *fn_floatfn (object *args, object *env) { - (void) env; - object *arg = first(args); - return (floatp(arg)) ? arg : makefloat((float)(arg->integer)); -} - -object *fn_floatp (object *args, object *env) { - (void) env; - return floatp(first(args)) ? tee : nil; -} - -object *fn_sin (object *args, object *env) { - (void) env; - return makefloat(sin(checkintfloat(first(args)))); -} - -object *fn_cos (object *args, object *env) { - (void) env; - return makefloat(cos(checkintfloat(first(args)))); -} - -object *fn_tan (object *args, object *env) { - (void) env; - return makefloat(tan(checkintfloat(first(args)))); -} - -object *fn_asin (object *args, object *env) { - (void) env; - return makefloat(asin(checkintfloat(first(args)))); -} - -object *fn_acos (object *args, object *env) { - (void) env; - return makefloat(acos(checkintfloat(first(args)))); -} - -object *fn_atan (object *args, object *env) { - (void) env; - object *arg = first(args); - float div = 1.0; - args = cdr(args); - if (args != NULL) div = checkintfloat(first(args)); - return makefloat(atan2(checkintfloat(arg), div)); -} - -object *fn_sinh (object *args, object *env) { - (void) env; - return makefloat(sinh(checkintfloat(first(args)))); -} - -object *fn_cosh (object *args, object *env) { - (void) env; - return makefloat(cosh(checkintfloat(first(args)))); -} - -object *fn_tanh (object *args, object *env) { - (void) env; - return makefloat(tanh(checkintfloat(first(args)))); -} - -object *fn_exp (object *args, object *env) { - (void) env; - return makefloat(exp(checkintfloat(first(args)))); -} - -object *fn_sqrt (object *args, object *env) { - (void) env; - return makefloat(sqrt(checkintfloat(first(args)))); -} - -object *fn_log (object *args, object *env) { - (void) env; - object *arg = first(args); - float fresult = log(checkintfloat(arg)); - args = cdr(args); - if (args == NULL) return makefloat(fresult); - else return makefloat(fresult / log(checkintfloat(first(args)))); -} - -object *fn_expt (object *args, object *env) { - (void) env; - object *arg1 = first(args); object *arg2 = second(args); - float float1 = checkintfloat(arg1); - float value = log(abs(float1)) * checkintfloat(arg2); - if (integerp(arg1) && integerp(arg2) && ((arg2->integer) >= 0) && (abs(value) < 21.4875)) - return number(intpower(arg1->integer, arg2->integer)); - if (float1 < 0) { - if (integerp(arg2)) return makefloat((arg2->integer & 1) ? -exp(value) : exp(value)); - else error2(PSTR("invalid result")); - } - return makefloat(exp(value)); -} - -object *fn_ceiling (object *args, object *env) { - (void) env; - object *arg = first(args); - args = cdr(args); - if (args != NULL) return number(ceil(checkintfloat(arg) / checkintfloat(first(args)))); - else return number(ceil(checkintfloat(arg))); -} - -object *fn_floor (object *args, object *env) { - (void) env; - object *arg = first(args); - args = cdr(args); - if (args != NULL) return number(floor(checkintfloat(arg) / checkintfloat(first(args)))); - else return number(floor(checkintfloat(arg))); -} - -object *fn_truncate (object *args, object *env) { - (void) env; - object *arg = first(args); - args = cdr(args); - if (args != NULL) return number((int)(checkintfloat(arg) / checkintfloat(first(args)))); - else return number((int)(checkintfloat(arg))); -} - -object *fn_round (object *args, object *env) { - (void) env; - object *arg = first(args); - args = cdr(args); - if (args != NULL) return number(myround(checkintfloat(arg) / checkintfloat(first(args)))); - else return number(myround(checkintfloat(arg))); -} - -// Characters - -object *fn_char (object *args, object *env) { - (void) env; - object *arg = first(args); - if (!stringp(arg)) error(notastring, arg); - object *n = second(args); - char c = nthchar(arg, checkinteger(n)); - if (c == 0) error(indexrange, n); - return character(c); -} - -object *fn_charcode (object *args, object *env) { - (void) env; - return number(checkchar(first(args))); -} - -object *fn_codechar (object *args, object *env) { - (void) env; - return character(checkinteger(first(args))); -} - -object *fn_characterp (object *args, object *env) { - (void) env; - return characterp(first(args)) ? tee : nil; -} - -// Strings - -object *fn_stringp (object *args, object *env) { - (void) env; - return stringp(first(args)) ? tee : nil; -} - -object *fn_stringeq (object *args, object *env) { - (void) env; - return stringcompare(args, false, false, true) ? tee : nil; -} - -object *fn_stringless (object *args, object *env) { - (void) env; - return stringcompare(args, true, false, false) ? tee : nil; -} - -object *fn_stringgreater (object *args, object *env) { - (void) env; - return stringcompare(args, false, true, false) ? tee : nil; -} - -object *fn_sort (object *args, object *env) { - if (first(args) == NULL) return nil; - object *list = cons(nil,first(args)); - push(list,GCStack); - object *predicate = second(args); - object *compare = cons(NULL, cons(NULL, NULL)); - push(compare,GCStack); - object *ptr = cdr(list); - while (cdr(ptr) != NULL) { - object *go = list; - while (go != ptr) { - car(compare) = car(cdr(ptr)); - car(cdr(compare)) = car(cdr(go)); - if (apply(predicate, compare, env)) break; - go = cdr(go); - } - if (go != ptr) { - object *obj = cdr(ptr); - cdr(ptr) = cdr(obj); - cdr(obj) = cdr(go); - cdr(go) = obj; - } else ptr = cdr(ptr); - } - pop(GCStack); pop(GCStack); - return cdr(list); -} - -object *fn_stringfn (object *args, object *env) { - return fn_princtostring(args, env); -} - -object *fn_concatenate (object *args, object *env) { - (void) env; - object *arg = first(args); - if (builtin(arg->name) != STRINGFN) error2(PSTR("only supports strings")); - args = cdr(args); - object *result = newstring(); - object *tail = result; - while (args != NULL) { - object *obj = checkstring(first(args)); - obj = cdr(obj); - while (obj != NULL) { - int quad = obj->chars; - while (quad != 0) { - char ch = quad>>((sizeof(int)-1)*8) & 0xFF; - buildstring(ch, &tail); - quad = quad<<8; - } - obj = car(obj); - } - args = cdr(args); - } - return result; -} - -object *fn_subseq (object *args, object *env) { - (void) env; - object *arg = first(args); - int start = checkinteger(second(args)), end; - if (start < 0) error(indexnegative, second(args)); - args = cddr(args); - if (listp(arg)) { - int length = listlength(arg); - if (args != NULL) end = checkinteger(car(args)); else end = length; - if (start > end || end > length) error2(indexrange); - object *result = cons(NULL, NULL); - object *ptr = result; - for (int x = 0; x < end; x++) { - if (x >= start) { cdr(ptr) = cons(car(arg), NULL); ptr = cdr(ptr); } - arg = cdr(arg); - } - return cdr(result); - } else if (stringp(arg)) { - int length = stringlength(arg); - if (args != NULL) end = checkinteger(car(args)); else end = length; - if (start > end || end > length) error2(indexrange); - object *result = newstring(); - object *tail = result; - for (int i=start; i= 0) return number(value << count); - else return number(value >> abs(count)); -} - -object *fn_logbitp (object *args, object *env) { - (void) env; - int index = checkinteger(first(args)); - int value = checkinteger(second(args)); - return (bitRead(value, index) == 1) ? tee : nil; -} - -// System functions - -object *fn_eval (object *args, object *env) { - return eval(first(args), env); -} - -object *fn_globals (object *args, object *env) { - (void) args, (void) env; - object *result = cons(NULL, NULL); - object *ptr = result; - object *arg = GlobalEnv; - while (arg != NULL) { - cdr(ptr) = cons(car(car(arg)), NULL); ptr = cdr(ptr); - arg = cdr(arg); - } - return cdr(result); -} - -object *fn_locals (object *args, object *env) { - (void) args; - return env; -} - -object *fn_makunbound (object *args, object *env) { - (void) env; - object *var = first(args); - if (!symbolp(var)) error(notasymbol, var); - delassoc(var, &GlobalEnv); - return var; -} - -object *fn_break (object *args, object *env) { - (void) args; - pfstring(PSTR("\nBreak!\n"), pserial); - BreakLevel++; - repl(env); - BreakLevel--; - return nil; -} - -object *fn_read (object *args, object *env) { - (void) env; - gfun_t gfun = gstreamfun(args); - return read(gfun); -} - -object *fn_prin1 (object *args, object *env) { - (void) env; - object *obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - printobject(obj, pfun); - return obj; -} - -object *fn_print (object *args, object *env) { - (void) env; - object *obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - pln(pfun); - printobject(obj, pfun); - pfun(' '); - return obj; -} - -object *fn_princ (object *args, object *env) { - (void) env; - object *obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - prin1object(obj, pfun); - return obj; -} - -object *fn_terpri (object *args, object *env) { - (void) env; - pfun_t pfun = pstreamfun(args); - pln(pfun); - return nil; -} - -object *fn_readbyte (object *args, object *env) { - (void) env; - gfun_t gfun = gstreamfun(args); - int c = gfun(); - return (c == -1) ? nil : number(c); -} - -object *fn_readline (object *args, object *env) { - (void) env; - gfun_t gfun = gstreamfun(args); - return readstring('\n', gfun); -} - -object *fn_writebyte (object *args, object *env) { - (void) env; - int value = checkinteger(first(args)); - pfun_t pfun = pstreamfun(cdr(args)); - (pfun)(value); - return nil; -} - -object *fn_writestring (object *args, object *env) { - (void) env; - object *obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - char temp = Flags; - clrflag(PRINTREADABLY); - printstring(obj, pfun); - Flags = temp; - return nil; -} - -object *fn_writeline (object *args, object *env) { - (void) env; - object *obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - char temp = Flags; - clrflag(PRINTREADABLY); - printstring(obj, pfun); - pln(pfun); - Flags = temp; - 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 (integerp(rw)) I2Ccount = rw->integer; - read = (rw != NULL); - } - int address = stream & 0xFF; - if (stream>>8 != I2CSTREAM) error2(PSTR("not an i2c stream")); - return I2Crestart(address, read) ? tee : nil; -} - -object *fn_gc (object *obj, object *env) { - int initial = Freespace; - unsigned long start = micros(); - gc(obj, env); - unsigned long elapsed = micros() - start; - pfstring(PSTR("Space: "), pserial); - pint(Freespace - initial, pserial); - pfstring(PSTR(" bytes, Time: "), pserial); - pint(elapsed, pserial); - pfstring(PSTR(" us\n"), pserial); - return nil; -} - -object *fn_room (object *args, object *env) { - (void) args, (void) env; - return number(Freespace); -} - -object *fn_saveimage (object *args, object *env) { - if (args != NULL) args = eval(first(args), env); - return number(saveimage(args)); -} - -object *fn_loadimage (object *args, object *env) { - (void) env; - if (args != NULL) args = first(args); - return number(loadimage(args)); -} - -object *fn_cls (object *args, object *env) { - (void) args, (void) env; - pserial(12); - return nil; -} - -// Arduino procedures - -object *fn_pinmode (object *args, object *env) { - (void) env; int pin; - object *arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else pin = checkinteger(first(args)); - int pm = INPUT; - arg = second(args); - if (keywordp(arg)) pm = checkkeyword(arg); - else if (integerp(arg)) { - int mode = arg->integer; - if (mode == 1) pm = OUTPUT; else if (mode == 2) pm = INPUT_PULLUP; - #if defined(INPUT_PULLDOWN) - else if (mode == 4) pm = INPUT_PULLDOWN; - #endif - } else if (arg != nil) pm = OUTPUT; - pinMode(pin, pm); - return nil; -} - -object *fn_digitalread (object *args, object *env) { - (void) env; - int pin; - object *arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else pin = checkinteger(arg); - if (digitalRead(pin) != 0) return tee; else return nil; -} - -object *fn_digitalwrite (object *args, object *env) { - (void) env; - int pin; - object *arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else pin = checkinteger(arg); - arg = second(args); - int mode; - if (keywordp(arg)) mode = checkkeyword(arg); - else if (integerp(arg)) mode = arg->integer ? HIGH : LOW; - else mode = (arg != nil) ? HIGH : LOW; - digitalWrite(pin, mode); - return arg; -} - -object *fn_analogread (object *args, object *env) { - (void) env; - int pin; - object *arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else { - pin = checkinteger(arg); - checkanalogread(pin); - } - return number(analogRead(pin)); -} - -object *fn_analogreadresolution (object *args, object *env) { - (void) env; - object *arg = first(args); - #if defined(ESP32) - analogReadResolution(checkinteger(arg)); - #else - error2(PSTR("not supported")); - #endif - return arg; -} - -object *fn_analogwrite (object *args, object *env) { - (void) env; - int pin; - object *arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else pin = checkinteger(arg); - checkanalogwrite(pin); - object *value = second(args); - analogWrite(pin, checkinteger(value)); - return value; -} - -object *fn_delay (object *args, object *env) { - (void) env; - object *arg1 = first(args); - delay(checkinteger(arg1)); - return arg1; -} - -object *fn_millis (object *args, object *env) { - (void) args, (void) env; - return number(millis()); -} - -object *fn_sleep (object *args, object *env) { - (void) env; - object *arg1 = first(args); - doze(checkinteger(arg1)); - return arg1; -} - -object *fn_note (object *args, object *env) { - (void) env; - static int pin = 255; - if (args != NULL) { - pin = checkinteger(first(args)); - int note = 0; - if (cddr(args) != NULL) note = checkinteger(second(args)); - int octave = 0; - if (cddr(args) != NULL) octave = checkinteger(third(args)); - playnote(pin, note, octave); - } else nonote(pin); - return nil; -} - -object *fn_register (object *args, object *env) { - (void) env; - object *arg = first(args); - int addr; - if (keywordp(arg)) addr = checkkeyword(arg); - else addr = checkinteger(first(args)); - if (cdr(args) == NULL) return number(*(uint32_t *)addr); - (*(uint32_t *)addr) = checkinteger(second(args)); - return second(args); -} - -// Tree Editor - -object *fn_edit (object *args, object *env) { - object *fun = first(args); - object *pair = findvalue(fun, env); - clrflag(EXITEDITOR); - object *arg = edit(eval(fun, env)); - cdr(pair) = arg; - return arg; -} - -// Pretty printer - -object *fn_pprint (object *args, object *env) { - (void) env; - object *obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - #if defined(gfxsupport) - if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; - #endif - pln(pfun); - superprint(obj, 0, pfun); - ppwidth = PPWIDTH; - return bsymbol(NOTHING); -} - -object *fn_pprintall (object *args, object *env) { - (void) env; - pfun_t pfun = pstreamfun(args); - #if defined(gfxsupport) - if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; - #endif - object *globals = GlobalEnv; - while (globals != NULL) { - object *pair = first(globals); - object *var = car(pair); - object *val = cdr(pair); - pln(pfun); - if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) { - superprint(cons(bsymbol(DEFUN), cons(var, cdr(val))), 0, pfun); - } else { - superprint(cons(bsymbol(DEFVAR), cons(var, cons(quote(val), NULL))), 0, pfun); - } - pln(pfun); - testescape(); - globals = cdr(globals); - } - ppwidth = PPWIDTH; - return bsymbol(NOTHING); -} - -// Format - -object *fn_format (object *args, object *env) { - (void) env; - pfun_t pfun = pserial; - object *output = first(args); - object *obj; - if (output == nil) { obj = startstring(); pfun = pstr; } - else if (output != tee) pfun = pstreamfun(args); - object *formatstr = checkstring(second(args)); - object *save = NULL; - args = cddr(args); - int len = stringlength(formatstr); - uint8_t n = 0, width = 0, w, bra = 0; - char pad = ' '; - bool tilde = false, mute = false, comma = false, quote = false; - while (n < len) { - char ch = nthchar(formatstr, n); - char ch2 = ch & ~0x20; // force to upper case - if (tilde) { - if (ch == '}') { - if (save == NULL) formaterr(formatstr, PSTR("no matching ~{"), n); - if (args == NULL) { args = cdr(save); save = NULL; } else n = bra; - mute = false; tilde = false; - } - else if (!mute) { - if (comma && quote) { pad = ch; comma = false, quote = false; } - else if (ch == '\'') { - if (comma) quote = true; - else formaterr(formatstr, PSTR("quote not valid"), n); - } - else if (ch == '~') { pfun('~'); tilde = false; } - else if (ch >= '0' && ch <= '9') width = width*10 + ch - '0'; - else if (ch == ',') comma = true; - else if (ch == '%') { pln(pfun); tilde = false; } - else if (ch == '&') { pfl(pfun); tilde = false; } - else if (ch == '^') { - if (save != NULL && args == NULL) mute = true; - tilde = false; - } - else if (ch == '{') { - if (save != NULL) formaterr(formatstr, PSTR("can't nest ~{"), n); - if (args == NULL) formaterr(formatstr, noargument, n); - if (!listp(first(args))) formaterr(formatstr, notalist, n); - save = args; args = first(args); bra = n; tilde = false; - if (args == NULL) mute = true; - } - else if (ch2 == 'A' || ch2 == 'S' || ch2 == 'D' || ch2 == 'G' || ch2 == 'X' || ch2 == 'B') { - if (args == NULL) formaterr(formatstr, noargument, n); - object *arg = first(args); args = cdr(args); - uint8_t aw = atomwidth(arg); - if (width < aw) w = 0; else w = width-aw; - tilde = false; - if (ch2 == 'A') { prin1object(arg, pfun); indent(w, pad, pfun); } - else if (ch2 == 'S') { printobject(arg, pfun); indent(w, pad, pfun); } - else if (ch2 == 'D' || ch2 == 'G') { indent(w, pad, pfun); prin1object(arg, pfun); } - else if (ch2 == 'X' || ch2 == 'B') { - if (integerp(arg)) { - uint8_t base = (ch2 == 'B') ? 2 : 16; - uint8_t hw = basewidth(arg, base); if (width < hw) w = 0; else w = width-hw; - indent(w, pad, pfun); pintbase(arg->integer, base, pfun); - } else { - indent(w, pad, pfun); prin1object(arg, pfun); - } - } - tilde = false; - } else formaterr(formatstr, PSTR("invalid directive"), n); - } - } else { - if (ch == '~') { tilde = true; pad = ' '; width = 0; comma = false; quote = false; } - else if (!mute) pfun(ch); - } - n++; - } - if (output == nil) return obj; - else return nil; -} - -// LispLibrary - -object *fn_require (object *args, object *env) { - object *arg = first(args); - object *globals = GlobalEnv; - if (!symbolp(arg)) error(notasymbol, arg); - while (globals != NULL) { - object *pair = first(globals); - object *var = car(pair); - if (symbolp(var) && var == arg) return nil; - globals = cdr(globals); - } - GlobalStringIndex = 0; - object *line = read(glibrary); - while (line != NULL) { - // Is this the definition we want - symbol_t fname = first(line)->name; - if ((fname == sym(DEFUN) || fname == sym(DEFVAR)) && symbolp(second(line)) && second(line)->name == arg->name) { - eval(line, env); - return tee; - } - line = read(glibrary); - } - return nil; -} - -object *fn_listlibrary (object *args, object *env) { - (void) args, (void) env; - GlobalStringIndex = 0; - object *line = read(glibrary); - while (line != NULL) { - builtin_t bname = builtin(first(line)->name); - if (bname == DEFUN || bname == DEFVAR) { - printsymbol(second(line), pserial); pserial(' '); - } - line = read(glibrary); - } - return bsymbol(NOTHING); -} - -// Documentation - -object *sp_help (object *args, object *env) { - if (args == NULL) error2(noargument); - object *docstring = documentation(first(args), env); - if (docstring) { - char temp = Flags; - clrflag(PRINTREADABLY); - printstring(docstring, pserial); - Flags = temp; - } - return bsymbol(NOTHING); -} - -object *fn_documentation (object *args, object *env) { - return documentation(first(args), env); -} - -object *fn_apropos (object *args, object *env) { - (void) env; - apropos(first(args), true); - return bsymbol(NOTHING); -} - -object *fn_aproposlist (object *args, object *env) { - (void) env; - return apropos(first(args), false); -} - -// Error handling - -object *sp_unwindprotect (object *args, object *env) { - if (args == NULL) error2(toofewargs); - object *current_GCStack = GCStack; - jmp_buf dynamic_handler; - jmp_buf *previous_handler = handler; - handler = &dynamic_handler; - object *protected_form = first(args); - object *result; - - bool signaled = false; - if (!setjmp(dynamic_handler)) { - result = eval(protected_form, env); - } else { - GCStack = current_GCStack; - signaled = true; - } - handler = previous_handler; - - object *protective_forms = cdr(args); - while (protective_forms != NULL) { - eval(car(protective_forms), env); - if (tstflag(RETURNFLAG)) break; - protective_forms = cdr(protective_forms); - } - - if (!signaled) return result; - GCStack = NULL; - longjmp(*handler, 1); -} - -object *sp_ignoreerrors (object *args, object *env) { - object *current_GCStack = GCStack; - jmp_buf dynamic_handler; - jmp_buf *previous_handler = handler; - handler = &dynamic_handler; - object *result = nil; - - bool muffled = tstflag(MUFFLEERRORS); - setflag(MUFFLEERRORS); - bool signaled = false; - if (!setjmp(dynamic_handler)) { - while (args != NULL) { - result = eval(car(args), env); - if (tstflag(RETURNFLAG)) break; - args = cdr(args); - } - } else { - GCStack = current_GCStack; - signaled = true; - } - handler = previous_handler; - if (!muffled) clrflag(MUFFLEERRORS); - - if (signaled) return bsymbol(NOTHING); - else return result; -} - -object *sp_error (object *args, object *env) { - object *message = eval(cons(bsymbol(FORMAT), cons(nil, args)), env); - if (!tstflag(MUFFLEERRORS)) { - char temp = Flags; - clrflag(PRINTREADABLY); - pfstring(PSTR("Error: "), pserial); printstring(message, pserial); - Flags = temp; - pln(pserial); - } - GCStack = NULL; - longjmp(*handler, 1); -} - -// Wi-Fi - -object *sp_withclient (object *args, object *env) { - object *params = first(args); - object *var = first(params); - char buffer[BUFFERSIZE]; - params = cdr(params); - int n; - if (params == NULL) { - client = server.available(); - if (!client) return nil; - n = 2; - } else { - object *address = eval(first(params), env); - object *port = eval(second(params), env); - int success; - if (stringp(address)) success = client.connect(cstring(address, buffer, BUFFERSIZE), checkinteger(port)); - else if (integerp(address)) success = client.connect(address->integer, checkinteger(port)); - else error2(PSTR("invalid address")); - if (!success) return nil; - n = 1; - } - object *pair = cons(var, stream(WIFISTREAM, n)); - push(pair,env); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); - client.stop(); - return result; -} - -object *fn_available (object *args, object *env) { - (void) env; - if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); - return number(client.available()); -} - -object *fn_wifiserver (object *args, object *env) { - (void) args, (void) env; - server.begin(); - return nil; -} - -object *fn_wifisoftap (object *args, object *env) { - (void) env; - char ssid[33], pass[65]; - if (args == NULL) return WiFi.softAPdisconnect(true) ? tee : nil; - object *first = first(args); args = cdr(args); - if (args == NULL) WiFi.softAP(cstring(first, ssid, 33)); - else { - object *second = first(args); - args = cdr(args); - int channel = 1; - bool hidden = false; - if (args != NULL) { - channel = checkinteger(first(args)); - args = cdr(args); - if (args != NULL) hidden = (first(args) != nil); - } - WiFi.softAP(cstring(first, ssid, 33), cstring(second, pass, 65), channel, hidden); - } - return lispstring((char*)WiFi.softAPIP().toString().c_str()); -} - -object *fn_connected (object *args, object *env) { - (void) env; - if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); - return client.connected() ? tee : nil; -} - -object *fn_wifilocalip (object *args, object *env) { - (void) args, (void) env; - return lispstring((char*)WiFi.localIP().toString().c_str()); -} - -object *fn_wificonnect (object *args, object *env) { - (void) env; - char ssid[33], pass[65]; - if (args == NULL) { WiFi.disconnect(true); return nil; } - if (cdr(args) == NULL) WiFi.begin(cstring(first(args), ssid, 33)); - else WiFi.begin(cstring(first(args), ssid, 33), cstring(second(args), pass, 65)); - int result = WiFi.waitForConnectResult(); - if (result == WL_CONNECTED) return lispstring((char*)WiFi.localIP().toString().c_str()); - else if (result == WL_NO_SSID_AVAIL) error2(PSTR("network not found")); - else if (result == WL_CONNECT_FAILED) error2(PSTR("connection failed")); - else error2(PSTR("unable to connect")); - return nil; -} - -// Graphics functions - -object *sp_withgfx (object *args, object *env) { -#if defined(gfxsupport) - object *params = first(args); - object *var = first(params); - object *pair = cons(var, stream(GFXSTREAM, 1)); - push(pair,env); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); - return result; -#else - (void) args, (void) env; - error2(PSTR("not supported")); - return nil; -#endif -} - -object *fn_drawpixel (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t colour = COLOR_WHITE; - if (cddr(args) != NULL) colour = checkinteger(third(args)); - tft.drawPixel(checkinteger(first(args)), checkinteger(second(args)), colour); - #else - (void) args; - #endif - return nil; -} - -object *fn_drawline (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[4], colour = COLOR_WHITE; - for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawLine(params[0], params[1], params[2], params[3], colour); - #else - (void) args; - #endif - return nil; -} - -object *fn_drawrect (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[4], colour = COLOR_WHITE; - for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawRect(params[0], params[1], params[2], params[3], colour); - #else - (void) args; - #endif - return nil; -} - -object *fn_fillrect (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[4], colour = COLOR_WHITE; - for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.fillRect(params[0], params[1], params[2], params[3], colour); - #else - (void) args; - #endif - return nil; -} - -object *fn_drawcircle (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[3], colour = COLOR_WHITE; - for (int i=0; i<3; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawCircle(params[0], params[1], params[2], colour); - #else - (void) args; - #endif - return nil; -} - -object *fn_fillcircle (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[3], colour = COLOR_WHITE; - for (int i=0; i<3; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.fillCircle(params[0], params[1], params[2], colour); - #else - (void) args; - #endif - return nil; -} - -object *fn_drawroundrect (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[5], colour = COLOR_WHITE; - for (int i=0; i<5; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawRoundRect(params[0], params[1], params[2], params[3], params[4], colour); - #else - (void) args; - #endif - return nil; -} - -object *fn_fillroundrect (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[5], colour = COLOR_WHITE; - for (int i=0; i<5; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.fillRoundRect(params[0], params[1], params[2], params[3], params[4], colour); - #else - (void) args; - #endif - return nil; -} - -object *fn_drawtriangle (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[6], colour = COLOR_WHITE; - for (int i=0; i<6; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawTriangle(params[0], params[1], params[2], params[3], params[4], params[5], colour); - #else - (void) args; - #endif - return nil; -} - -object *fn_filltriangle (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[6], colour = COLOR_WHITE; - for (int i=0; i<6; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.fillTriangle(params[0], params[1], params[2], params[3], params[4], params[5], colour); - #else - (void) args; - #endif - return nil; -} - -object *fn_drawchar (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t colour = COLOR_WHITE, bg = COLOR_BLACK, size = 1; - object *more = cdr(cddr(args)); - if (more != NULL) { - colour = checkinteger(car(more)); - more = cdr(more); - if (more != NULL) { - bg = checkinteger(car(more)); - more = cdr(more); - if (more != NULL) size = checkinteger(car(more)); - } - } - tft.drawChar(checkinteger(first(args)), checkinteger(second(args)), checkchar(third(args)), - colour, bg, size); - #else - (void) args; - #endif - return nil; -} - -object *fn_setcursor (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - tft.setCursor(checkinteger(first(args)), checkinteger(second(args))); - #else - (void) args; - #endif - return nil; -} - -object *fn_settextcolor (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - if (cdr(args) != NULL) tft.setTextColor(checkinteger(first(args)), checkinteger(second(args))); - else tft.setTextColor(checkinteger(first(args))); - #else - (void) args; - #endif - return nil; -} - -object *fn_settextsize (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - tft.setTextSize(checkinteger(first(args))); - #else - (void) args; - #endif - return nil; -} - -object *fn_settextwrap (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - tft.setTextWrap(first(args) != NULL); - #else - (void) args; - #endif - return nil; -} - -object *fn_fillscreen (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t colour = COLOR_BLACK; - if (args != NULL) colour = checkinteger(first(args)); - tft.fillScreen(colour); - #else - (void) args; - #endif - return nil; -} - -object *fn_setrotation (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - tft.setRotation(checkinteger(first(args))); - #else - (void) args; - #endif - return nil; -} - -object *fn_invertdisplay (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - tft.invertDisplay(first(args) != NULL); - #else - (void) args; - #endif - return nil; -} - -// Built-in symbol names -const char string0[] PROGMEM = "nil"; -const char string1[] PROGMEM = "t"; -const char string2[] PROGMEM = "nothing"; -const char string3[] PROGMEM = "&optional"; -const char string4[] PROGMEM = ":initial-element"; -const char string5[] PROGMEM = ":element-type"; -const char string6[] PROGMEM = "bit"; -const char string7[] PROGMEM = "&rest"; -const char string8[] PROGMEM = "lambda"; -const char string9[] PROGMEM = "let"; -const char string10[] PROGMEM = "let*"; -const char string11[] PROGMEM = "closure"; -const char string12[] PROGMEM = "*pc*"; -const char string13[] PROGMEM = "quote"; -const char string14[] PROGMEM = "defun"; -const char string15[] PROGMEM = "defvar"; -const char string16[] PROGMEM = "car"; -const char string17[] PROGMEM = "first"; -const char string18[] PROGMEM = "cdr"; -const char string19[] PROGMEM = "rest"; -const char string20[] PROGMEM = "nth"; -const char string21[] PROGMEM = "aref"; -const char string22[] PROGMEM = "string"; -const char string23[] PROGMEM = "pinmode"; -const char string24[] PROGMEM = "digitalwrite"; -const char string25[] PROGMEM = "analogread"; -const char string26[] PROGMEM = "register"; -const char string27[] PROGMEM = "format"; -const char string28[] PROGMEM = "or"; -const char string29[] PROGMEM = "setq"; -const char string30[] PROGMEM = "loop"; -const char string31[] PROGMEM = "return"; -const char string32[] PROGMEM = "push"; -const char string33[] PROGMEM = "pop"; -const char string34[] PROGMEM = "incf"; -const char string35[] PROGMEM = "decf"; -const char string36[] PROGMEM = "setf"; -const char string37[] PROGMEM = "dolist"; -const char string38[] PROGMEM = "dotimes"; -const char string39[] PROGMEM = "trace"; -const char string40[] PROGMEM = "untrace"; -const char string41[] PROGMEM = "for-millis"; -const char string42[] PROGMEM = "time"; -const char string43[] PROGMEM = "with-output-to-string"; -const char string44[] PROGMEM = "with-serial"; -const char string45[] PROGMEM = "with-i2c"; -const char string46[] PROGMEM = "with-spi"; -const char string47[] PROGMEM = "with-sd-card"; -const char string48[] PROGMEM = "progn"; -const char string49[] PROGMEM = "if"; -const char string50[] PROGMEM = "cond"; -const char string51[] PROGMEM = "when"; -const char string52[] PROGMEM = "unless"; -const char string53[] PROGMEM = "case"; -const char string54[] PROGMEM = "and"; -const char string55[] PROGMEM = "not"; -const char string56[] PROGMEM = "null"; -const char string57[] PROGMEM = "cons"; -const char string58[] PROGMEM = "atom"; -const char string59[] PROGMEM = "listp"; -const char string60[] PROGMEM = "consp"; -const char string61[] PROGMEM = "symbolp"; -const char string62[] PROGMEM = "arrayp"; -const char string63[] PROGMEM = "boundp"; -const char string64[] PROGMEM = "keywordp"; -const char string65[] PROGMEM = "set"; -const char string66[] PROGMEM = "streamp"; -const char string67[] PROGMEM = "eq"; -const char string68[] PROGMEM = "equal"; -const char string69[] PROGMEM = "caar"; -const char string70[] PROGMEM = "cadr"; -const char string71[] PROGMEM = "second"; -const char string72[] PROGMEM = "cdar"; -const char string73[] PROGMEM = "cddr"; -const char string74[] PROGMEM = "caaar"; -const char string75[] PROGMEM = "caadr"; -const char string76[] PROGMEM = "cadar"; -const char string77[] PROGMEM = "caddr"; -const char string78[] PROGMEM = "third"; -const char string79[] PROGMEM = "cdaar"; -const char string80[] PROGMEM = "cdadr"; -const char string81[] PROGMEM = "cddar"; -const char string82[] PROGMEM = "cdddr"; -const char string83[] PROGMEM = "length"; -const char string84[] PROGMEM = "array-dimensions"; -const char string85[] PROGMEM = "list"; -const char string86[] PROGMEM = "make-array"; -const char string87[] PROGMEM = "reverse"; -const char string88[] PROGMEM = "assoc"; -const char string89[] PROGMEM = "member"; -const char string90[] PROGMEM = "apply"; -const char string91[] PROGMEM = "funcall"; -const char string92[] PROGMEM = "append"; -const char string93[] PROGMEM = "mapc"; -const char string94[] PROGMEM = "mapcar"; -const char string95[] PROGMEM = "mapcan"; -const char string96[] PROGMEM = "+"; -const char string97[] PROGMEM = "-"; -const char string98[] PROGMEM = "*"; -const char string99[] PROGMEM = "/"; -const char string100[] PROGMEM = "mod"; -const char string101[] PROGMEM = "1+"; -const char string102[] PROGMEM = "1-"; -const char string103[] PROGMEM = "abs"; -const char string104[] PROGMEM = "random"; -const char string105[] PROGMEM = "max"; -const char string106[] PROGMEM = "min"; -const char string107[] PROGMEM = "/="; -const char string108[] PROGMEM = "="; -const char string109[] PROGMEM = "<"; -const char string110[] PROGMEM = "<="; -const char string111[] PROGMEM = ">"; -const char string112[] PROGMEM = ">="; -const char string113[] PROGMEM = "plusp"; -const char string114[] PROGMEM = "minusp"; -const char string115[] PROGMEM = "zerop"; -const char string116[] PROGMEM = "oddp"; -const char string117[] PROGMEM = "evenp"; -const char string118[] PROGMEM = "integerp"; -const char string119[] PROGMEM = "numberp"; -const char string120[] PROGMEM = "float"; -const char string121[] PROGMEM = "floatp"; -const char string122[] PROGMEM = "sin"; -const char string123[] PROGMEM = "cos"; -const char string124[] PROGMEM = "tan"; -const char string125[] PROGMEM = "asin"; -const char string126[] PROGMEM = "acos"; -const char string127[] PROGMEM = "atan"; -const char string128[] PROGMEM = "sinh"; -const char string129[] PROGMEM = "cosh"; -const char string130[] PROGMEM = "tanh"; -const char string131[] PROGMEM = "exp"; -const char string132[] PROGMEM = "sqrt"; -const char string133[] PROGMEM = "log"; -const char string134[] PROGMEM = "expt"; -const char string135[] PROGMEM = "ceiling"; -const char string136[] PROGMEM = "floor"; -const char string137[] PROGMEM = "truncate"; -const char string138[] PROGMEM = "round"; -const char string139[] PROGMEM = "char"; -const char string140[] PROGMEM = "char-code"; -const char string141[] PROGMEM = "code-char"; -const char string142[] PROGMEM = "characterp"; -const char string143[] PROGMEM = "stringp"; -const char string144[] PROGMEM = "string="; -const char string145[] PROGMEM = "string<"; -const char string146[] PROGMEM = "string>"; -const char string147[] PROGMEM = "sort"; -const char string148[] PROGMEM = "concatenate"; -const char string149[] PROGMEM = "subseq"; -const char string150[] PROGMEM = "search"; -const char string151[] PROGMEM = "read-from-string"; -const char string152[] PROGMEM = "princ-to-string"; -const char string153[] PROGMEM = "prin1-to-string"; -const char string154[] PROGMEM = "logand"; -const char string155[] PROGMEM = "logior"; -const char string156[] PROGMEM = "logxor"; -const char string157[] PROGMEM = "lognot"; -const char string158[] PROGMEM = "ash"; -const char string159[] PROGMEM = "logbitp"; -const char string160[] PROGMEM = "eval"; -const char string161[] PROGMEM = "globals"; -const char string162[] PROGMEM = "locals"; -const char string163[] PROGMEM = "makunbound"; -const char string164[] PROGMEM = "break"; -const char string165[] PROGMEM = "read"; -const char string166[] PROGMEM = "prin1"; -const char string167[] PROGMEM = "print"; -const char string168[] PROGMEM = "princ"; -const char string169[] PROGMEM = "terpri"; -const char string170[] PROGMEM = "read-byte"; -const char string171[] PROGMEM = "read-line"; -const char string172[] PROGMEM = "write-byte"; -const char string173[] PROGMEM = "write-string"; -const char string174[] PROGMEM = "write-line"; -const char string175[] PROGMEM = "restart-i2c"; -const char string176[] PROGMEM = "gc"; -const char string177[] PROGMEM = "room"; -const char string178[] PROGMEM = "save-image"; -const char string179[] PROGMEM = "load-image"; -const char string180[] PROGMEM = "cls"; -const char string181[] PROGMEM = "digitalread"; -const char string182[] PROGMEM = "analogreadresolution"; -const char string183[] PROGMEM = "analogwrite"; -const char string184[] PROGMEM = "delay"; -const char string185[] PROGMEM = "millis"; -const char string186[] PROGMEM = "sleep"; -const char string187[] PROGMEM = "note"; -const char string188[] PROGMEM = "edit"; -const char string189[] PROGMEM = "pprint"; -const char string190[] PROGMEM = "pprintall"; -const char string191[] PROGMEM = "require"; -const char string192[] PROGMEM = "list-library"; -const char string193[] PROGMEM = "?"; -const char string194[] PROGMEM = "documentation"; -const char string195[] PROGMEM = "apropos"; -const char string196[] PROGMEM = "apropos-list"; -const char string197[] PROGMEM = "unwind-protect"; -const char string198[] PROGMEM = "ignore-errors"; -const char string199[] PROGMEM = "error"; -const char string200[] PROGMEM = "with-client"; -const char string201[] PROGMEM = "available"; -const char string202[] PROGMEM = "wifi-server"; -const char string203[] PROGMEM = "wifi-softap"; -const char string204[] PROGMEM = "connected"; -const char string205[] PROGMEM = "wifi-localip"; -const char string206[] PROGMEM = "wifi-connect"; -const char string207[] PROGMEM = "with-gfx"; -const char string208[] PROGMEM = "draw-pixel"; -const char string209[] PROGMEM = "draw-line"; -const char string210[] PROGMEM = "draw-rect"; -const char string211[] PROGMEM = "fill-rect"; -const char string212[] PROGMEM = "draw-circle"; -const char string213[] PROGMEM = "fill-circle"; -const char string214[] PROGMEM = "draw-round-rect"; -const char string215[] PROGMEM = "fill-round-rect"; -const char string216[] PROGMEM = "draw-triangle"; -const char string217[] PROGMEM = "fill-triangle"; -const char string218[] PROGMEM = "draw-char"; -const char string219[] PROGMEM = "set-cursor"; -const char string220[] PROGMEM = "set-text-color"; -const char string221[] PROGMEM = "set-text-size"; -const char string222[] PROGMEM = "set-text-wrap"; -const char string223[] PROGMEM = "fill-screen"; -const char string224[] PROGMEM = "set-rotation"; -const char string225[] PROGMEM = "invert-display"; -const char string226[] PROGMEM = ":led-builtin"; -const char string227[] PROGMEM = ":high"; -const char string228[] PROGMEM = ":low"; -#if defined(ESP8266) -const char string229[] PROGMEM = ":input"; -const char string230[] PROGMEM = ":input-pullup"; -const char string231[] PROGMEM = ":output"; -#elif defined(ESP32) -const char string229[] PROGMEM = ":input"; -const char string230[] PROGMEM = ":input-pullup"; -const char string231[] PROGMEM = ":input-pulldown"; -const char string232[] PROGMEM = ":output"; -#endif - -// Documentation strings -const char doc0[] PROGMEM = "nil\n" -"A symbol equivalent to the empty list (). Also represents false."; -const char doc1[] PROGMEM = "t\n" -"A symbol representing true."; -const char doc2[] PROGMEM = "nothing\n" -"A symbol with no value.\n" -"It is useful if you want to suppress printing the result of evaluating a function."; -const char doc3[] PROGMEM = "&optional\n" -"Can be followed by one or more optional parameters in a lambda or defun parameter list."; -const char doc7[] PROGMEM = "&rest\n" -"Can be followed by a parameter in a lambda or defun parameter list,\n" -"and is assigned a list of the corresponding arguments."; -const char doc8[] PROGMEM = "(lambda (parameter*) form*)\n" -"Creates an unnamed function with parameters. The body is evaluated with the parameters as local variables\n" -"whose initial values are defined by the values of the forms after the lambda form."; -const char doc9[] PROGMEM = "(let ((var value) ... ) forms*)\n" -"Declares local variables with values, and evaluates the forms with those local variables."; -const char doc10[] PROGMEM = "(let* ((var value) ... ) forms*)\n" -"Declares local variables with values, and evaluates the forms with those local variables.\n" -"Each declaration can refer to local variables that have been defined earlier in the let*."; -const char doc14[] PROGMEM = "(defun name (parameters) form*)\n" -"Defines a function."; -const char doc15[] PROGMEM = "(defvar variable form)\n" -"Defines a global variable."; -const char doc16[] PROGMEM = "(car list)\n" -"Returns the first item in a list."; -const char doc18[] PROGMEM = "(cdr list)\n" -"Returns a list with the first item removed."; -const char doc20[] PROGMEM = "(nth number list)\n" -"Returns the nth item in list, counting from zero."; -const char doc21[] PROGMEM = "(aref array index [index*])\n" -"Returns an element from the specified array."; -const char doc22[] PROGMEM = "(string item)\n" -"Converts its argument to a string."; -const char doc23[] PROGMEM = "(pinmode pin mode)\n" -"Sets the input/output mode of an Arduino pin number, and returns nil.\n" -"The mode parameter can be an integer, a keyword, or t or nil."; -const char doc24[] PROGMEM = "(digitalwrite pin state)\n" -"Sets the state of the specified Arduino pin number."; -const char doc25[] PROGMEM = "(analogread pin)\n" -"Reads the specified Arduino analogue pin number and returns the value."; -const char doc26[] PROGMEM = "(register address [value])\n" -"Reads or writes the value of a peripheral register.\n" -"If value is not specified the function returns the value of the register at address.\n" -"If value is specified the value is written to the register at address and the function returns value."; -const char doc27[] PROGMEM = "(format output controlstring [arguments]*)\n" -"Outputs its arguments formatted according to the format directives in controlstring."; -const char doc28[] PROGMEM = "(or item*)\n" -"Evaluates its arguments until one returns non-nil, and returns its value."; -const char doc29[] PROGMEM = "(setq symbol value [symbol value]*)\n" -"For each pair of arguments assigns the value of the second argument\n" -"to the variable specified in the first argument."; -const char doc30[] PROGMEM = "(loop forms*)\n" -"Executes its arguments repeatedly until one of the arguments calls (return),\n" -"which then causes an exit from the loop."; -const char doc31[] PROGMEM = "(return [value])\n" -"Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value."; -const char doc32[] PROGMEM = "(push item place)\n" -"Modifies the value of place, which should be a list, to add item onto the front of the list,\n" -"and returns the new list."; -const char doc33[] PROGMEM = "(pop place)\n" -"Modifies the value of place, which should be a list, to remove its first item, and returns that item."; -const char doc34[] PROGMEM = "(incf place [number])\n" -"Increments a place, which should have an numeric value, and returns the result.\n" -"The third argument is an optional increment which defaults to 1."; -const char doc35[] PROGMEM = "(decf place [number])\n" -"Decrements a place, which should have an numeric value, and returns the result.\n" -"The third argument is an optional decrement which defaults to 1."; -const char doc36[] PROGMEM = "(setf place value [place value]*)\n" -"For each pair of arguments modifies a place to the result of evaluating value."; -const char doc37[] PROGMEM = "(dolist (var list [result]) form*)\n" -"Sets the local variable var to each element of list in turn, and executes the forms.\n" -"It then returns result, or nil if result is omitted."; -const char doc38[] PROGMEM = "(dotimes (var number [result]) form*)\n" -"Executes the forms number times, with the local variable var set to each integer from 0 to number-1 in turn.\n" -"It then returns result, or nil if result is omitted."; -const char doc39[] PROGMEM = "(trace [function]*)\n" -"Turns on tracing of up to TRACEMAX user-defined functions,\n" -"and returns a list of the functions currently being traced."; -const char doc40[] PROGMEM = "(untrace [function]*)\n" -"Turns off tracing of up to TRACEMAX user-defined functions, and returns a list of the functions untraced.\n" -"If no functions are specified it untraces all functions."; -const char doc41[] PROGMEM = "(for-millis ([number]) form*)\n" -"Executes the forms and then waits until a total of number milliseconds have elapsed.\n" -"Returns the total number of milliseconds taken."; -const char doc42[] PROGMEM = "(time form)\n" -"Prints the value returned by the form, and the time taken to evaluate the form\n" -"in milliseconds or seconds."; -const char doc43[] PROGMEM = "(with-output-to-string (str) form*)\n" -"Returns a string containing the output to the stream variable str."; -const char doc44[] PROGMEM = "(with-serial (str port [baud]) form*)\n" -"Evaluates the forms with str bound to a serial-stream using port.\n" -"The optional baud gives the baud rate divided by 100, default 96."; -const char doc45[] PROGMEM = "(with-i2c (str [port] address [read-p]) form*)\n" -"Evaluates the forms with str bound to an i2c-stream defined by address.\n" -"If read-p is nil or omitted the stream is written to, otherwise it specifies the number of bytes\n" -"to be read from the stream. The port if specified is ignored."; -const char doc46[] PROGMEM = "(with-spi (str pin [clock] [bitorder] [mode]) form*)\n" -"Evaluates the forms with str bound to an spi-stream.\n" -"The parameters specify the enable pin, clock in kHz (default 4000),\n" -"bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0)."; -const char doc47[] PROGMEM = "(with-sd-card (str filename [mode]) form*)\n" -"Evaluates the forms with str bound to an sd-stream reading from or writing to the file filename.\n" -"If mode is omitted the file is read, otherwise 0 means read, 1 write-append, or 2 write-overwrite."; -const char doc48[] PROGMEM = "(progn form*)\n" -"Evaluates several forms grouped together into a block, and returns the result of evaluating the last form."; -const char doc49[] PROGMEM = "(if test then [else])\n" -"Evaluates test. If it's non-nil the form then is evaluated and returned;\n" -"otherwise the form else is evaluated and returned."; -const char doc50[] PROGMEM = "(cond ((test form*) (test form*) ... ))\n" -"Each argument is a list consisting of a test optionally followed by one or more forms.\n" -"If the test evaluates to non-nil the forms are evaluated, and the last value is returned as the result of the cond.\n" -"If the test evaluates to nil, none of the forms are evaluated, and the next argument is processed in the same way."; -const char doc51[] PROGMEM = "(when test form*)\n" -"Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned."; -const char doc52[] PROGMEM = "(unless test form*)\n" -"Evaluates the test. If it's nil the forms are evaluated and the last value is returned."; -const char doc53[] PROGMEM = "(case keyform ((key form*) (key form*) ... ))\n" -"Evaluates a keyform to produce a test key, and then tests this against a series of arguments,\n" -"each of which is a list containing a key optionally followed by one or more forms."; -const char doc54[] PROGMEM = "(and item*)\n" -"Evaluates its arguments until one returns nil, and returns the last value."; -const char doc55[] PROGMEM = "(not item)\n" -"Returns t if its argument is nil, or nil otherwise. Equivalent to null."; -const char doc57[] PROGMEM = "(cons item item)\n" -"If the second argument is a list, cons returns a new list with item added to the front of the list.\n" -"If the second argument isn't a list cons returns a dotted pair."; -const char doc58[] PROGMEM = "(atom item)\n" -"Returns t if its argument is a single number, symbol, or nil."; -const char doc59[] PROGMEM = "(listp item)\n" -"Returns t if its argument is a list."; -const char doc60[] PROGMEM = "(consp item)\n" -"Returns t if its argument is a non-null list."; -const char doc61[] PROGMEM = "(symbolp item)\n" -"Returns t if its argument is a symbol."; -const char doc62[] PROGMEM = "(arrayp item)\n" -"Returns t if its argument is an array."; -const char doc63[] PROGMEM = "(boundp item)\n" -"Returns t if its argument is a symbol with a value."; -const char doc64[] PROGMEM = "(keywordp item)\n" -"Returns t if its argument is a keyword."; -const char doc65[] PROGMEM = "(set symbol value [symbol value]*)\n" -"For each pair of arguments, assigns the value of the second argument to the value of the first argument."; -const char doc66[] PROGMEM = "(streamp item)\n" -"Returns t if its argument is a stream."; -const char doc67[] PROGMEM = "(eq item item)\n" -"Tests whether the two arguments are the same symbol, same character, equal numbers,\n" -"or point to the same cons, and returns t or nil as appropriate."; -const char doc68[] PROGMEM = "(equal item item)\n" -"Tests whether the two arguments are the same symbol, same character, equal numbers,\n" -"or point to the same cons, and returns t or nil as appropriate."; -const char doc69[] PROGMEM = "(caar list)"; -const char doc70[] PROGMEM = "(cadr list)"; -const char doc72[] PROGMEM = "(cdar list)\n" -"Equivalent to (cdr (car list))."; -const char doc73[] PROGMEM = "(cddr list)\n" -"Equivalent to (cdr (cdr list))."; -const char doc74[] PROGMEM = "(caaar list)\n" -"Equivalent to (car (car (car list)))."; -const char doc75[] PROGMEM = "(caadr list)\n" -"Equivalent to (car (car (cdar list)))."; -const char doc76[] PROGMEM = "(cadar list)\n" -"Equivalent to (car (cdr (car list)))."; -const char doc77[] PROGMEM = "(caddr list)\n" -"Equivalent to (car (cdr (cdr list)))."; -const char doc79[] PROGMEM = "(cdaar list)\n" -"Equivalent to (cdar (car (car list)))."; -const char doc80[] PROGMEM = "(cdadr list)\n" -"Equivalent to (cdr (car (cdr list)))."; -const char doc81[] PROGMEM = "(cddar list)\n" -"Equivalent to (cdr (cdr (car list)))."; -const char doc82[] PROGMEM = "(cdddr list)\n" -"Equivalent to (cdr (cdr (cdr list)))."; -const char doc83[] PROGMEM = "(length item)\n" -"Returns the number of items in a list, the length of a string, or the length of a one-dimensional array."; -const char doc84[] PROGMEM = "(array-dimensions item)\n" -"Returns a list of the dimensions of an array."; -const char doc85[] PROGMEM = "(list item*)\n" -"Returns a list of the values of its arguments."; -const char doc86[] PROGMEM = "(make-array size [:initial-element element] [:element-type 'bit])\n" -"If size is an integer it creates a one-dimensional array with elements from 0 to size-1.\n" -"If size is a list of n integers it creates an n-dimensional array with those dimensions.\n" -"If :element-type 'bit is specified the array is a bit array."; -const char doc87[] PROGMEM = "(reverse list)\n" -"Returns a list with the elements of list in reverse order."; -const char doc88[] PROGMEM = "(assoc key list)\n" -"Looks up a key in an association list of (key . value) pairs,\n" -"and returns the matching pair, or nil if no pair is found."; -const char doc89[] PROGMEM = "(member item list)\n" -"Searches for an item in a list, using eq, and returns the list starting from the first occurrence of the item,\n" -"or nil if it is not found."; -const char doc90[] PROGMEM = "(apply function list)\n" -"Returns the result of evaluating function, with the list of arguments specified by the second parameter."; -const char doc91[] PROGMEM = "(funcall function argument*)\n" -"Evaluates function with the specified arguments."; -const char doc92[] PROGMEM = "(append list*)\n" -"Joins its arguments, which should be lists, into a single list."; -const char doc93[] PROGMEM = "(mapc function list1 [list]*)\n" -"Applies the function to each element in one or more lists, ignoring the results.\n" -"It returns the first list argument."; -const char doc94[] PROGMEM = "(mapcar function list1 [list]*)\n" -"Applies the function to each element in one or more lists, and returns the resulting list."; -const char doc95[] PROGMEM = "(mapcan function list1 [list]*)\n" -"Applies the function to each element in one or more lists. The results should be lists,\n" -"and these are appended together to give the value returned."; -const char doc96[] PROGMEM = "(+ number*)\n" -"Adds its arguments together.\n" -"If each argument is an integer, and the running total doesn't overflow, the result is an integer,\n" -"otherwise a floating-point number."; -const char doc97[] PROGMEM = "(- number*)\n" -"If there is one argument, negates the argument.\n" -"If there are two or more arguments, subtracts the second and subsequent arguments from the first argument.\n" -"If each argument is an integer, and the running total doesn't overflow, returns the result as an integer,\n" -"otherwise a floating-point number."; -const char doc98[] PROGMEM = "(* number*)\n" -"Multiplies its arguments together.\n" -"If each argument is an integer, and the running total doesn't overflow, the result is an integer,\n" -"otherwise it's a floating-point number."; -const char doc99[] PROGMEM = "(/ number*)\n" -"Divides the first argument by the second and subsequent arguments.\n" -"If each argument is an integer, and each division produces an exact result, the result is an integer;\n" -"otherwise it's a floating-point number."; -const char doc100[] PROGMEM = "(mod number number)\n" -"Returns its first argument modulo the second argument.\n" -"If both arguments are integers the result is an integer; otherwise it's a floating-point number."; -const char doc101[] PROGMEM = "(1+ number)\n" -"Adds one to its argument and returns it.\n" -"If the argument is an integer the result is an integer if possible;\n" -"otherwise it's a floating-point number."; -const char doc102[] PROGMEM = "(1- number)\n" -"Subtracts one from its argument and returns it.\n" -"If the argument is an integer the result is an integer if possible;\n" -"otherwise it's a floating-point number."; -const char doc103[] PROGMEM = "(abs number)\n" -"Returns the absolute, positive value of its argument.\n" -"If the argument is an integer the result will be returned as an integer if possible,\n" -"otherwise a floating-point number."; -const char doc104[] PROGMEM = "(random number)\n" -"If number is an integer returns a random number between 0 and one less than its argument.\n" -"Otherwise returns a floating-point number between zero and number."; -const char doc105[] PROGMEM = "(max number*)\n" -"Returns the maximum of one or more arguments."; -const char doc106[] PROGMEM = "(min number*)\n" -"Returns the minimum of one or more arguments."; -const char doc107[] PROGMEM = "(/= number*)\n" -"Returns t if none of the arguments are equal, or nil if two or more arguments are equal."; -const char doc108[] PROGMEM = "(= number*)\n" -"Returns t if all the arguments, which must be numbers, are numerically equal, and nil otherwise."; -const char doc109[] PROGMEM = "(< number*)\n" -"Returns t if each argument is less than the next argument, and nil otherwise."; -const char doc110[] PROGMEM = "(<= number*)\n" -"Returns t if each argument is less than or equal to the next argument, and nil otherwise."; -const char doc111[] PROGMEM = "(> number*)\n" -"Returns t if each argument is greater than the next argument, and nil otherwise."; -const char doc112[] PROGMEM = "(>= number*)\n" -"Returns t if each argument is greater than or equal to the next argument, and nil otherwise."; -const char doc113[] PROGMEM = "(plusp number)\n" -"Returns t if the argument is greater than zero, or nil otherwise."; -const char doc114[] PROGMEM = "(minusp number)\n" -"Returns t if the argument is less than zero, or nil otherwise."; -const char doc115[] PROGMEM = "(zerop number)\n" -"Returns t if the argument is zero."; -const char doc116[] PROGMEM = "(oddp number)\n" -"Returns t if the integer argument is odd."; -const char doc117[] PROGMEM = "(evenp number)\n" -"Returns t if the integer argument is even."; -const char doc118[] PROGMEM = "(integerp number)\n" -"Returns t if the argument is an integer."; -const char doc119[] PROGMEM = "(numberp number)\n" -"Returns t if the argument is a number."; -const char doc120[] PROGMEM = "(float number)\n" -"Returns its argument converted to a floating-point number."; -const char doc121[] PROGMEM = "(floatp number)\n" -"Returns t if the argument is a floating-point number."; -const char doc122[] PROGMEM = "(sin number)\n" -"Returns sin(number)."; -const char doc123[] PROGMEM = "(cos number)\n" -"Returns cos(number)."; -const char doc124[] PROGMEM = "(tan number)\n" -"Returns tan(number)."; -const char doc125[] PROGMEM = "(asin number)\n" -"Returns asin(number)."; -const char doc126[] PROGMEM = "(acos number)\n" -"Returns acos(number)."; -const char doc127[] PROGMEM = "(atan number1 [number2])\n" -"Returns the arc tangent of number1/number2, in radians. If number2 is omitted it defaults to 1."; -const char doc128[] PROGMEM = "(sinh number)\n" -"Returns sinh(number)."; -const char doc129[] PROGMEM = "(cosh number)\n" -"Returns cosh(number)."; -const char doc130[] PROGMEM = "(tanh number)\n" -"Returns tanh(number)."; -const char doc131[] PROGMEM = "(exp number)\n" -"Returns exp(number)."; -const char doc132[] PROGMEM = "(sqrt number)\n" -"Returns sqrt(number)."; -const char doc133[] PROGMEM = "(number [base])\n" -"Returns the logarithm of number to the specified base. If base is omitted it defaults to e."; -const char doc134[] PROGMEM = "(expt number power)\n" -"Returns number raised to the specified power.\n" -"Returns the result as an integer if the arguments are integers and the result will be within range,\n" -"otherwise a floating-point number."; -const char doc135[] PROGMEM = "(ceiling number [divisor])\n" -"Returns ceil(number/divisor). If omitted, divisor is 1."; -const char doc136[] PROGMEM = "(floor number [divisor])\n" -"Returns floor(number/divisor). If omitted, divisor is 1."; -const char doc137[] PROGMEM = "(truncate number)\n" -"Returns t if the argument is a floating-point number."; -const char doc138[] PROGMEM = "(round number)\n" -"Returns t if the argument is a floating-point number."; -const char doc139[] PROGMEM = "(char string n)\n" -"Returns the nth character in a string, counting from zero."; -const char doc140[] PROGMEM = "(char-code character)\n" -"Returns the ASCII code for a character, as an integer."; -const char doc141[] PROGMEM = "(code-char integer)\n" -"Returns the character for the specified ASCII code."; -const char doc142[] PROGMEM = "(characterp item)\n" -"Returns t if the argument is a character and nil otherwise."; -const char doc143[] PROGMEM = "(stringp item)\n" -"Returns t if the argument is a string and nil otherwise."; -const char doc144[] PROGMEM = "(string= string string)\n" -"Tests whether two strings are the same."; -const char doc145[] PROGMEM = "(string< string string)\n" -"Returns t if the first string is alphabetically less than the second string, and nil otherwise."; -const char doc146[] PROGMEM = "(string> string string)\n" -"Returns t if the first string is alphabetically greater than the second string, and nil otherwise."; -const char doc147[] PROGMEM = "(sort list test)\n" -"Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list."; -const char doc148[] PROGMEM = "(concatenate 'string string*)\n" -"Joins together the strings given in the second and subsequent arguments, and returns a single string."; -const char doc149[] PROGMEM = "(subseq seq start [end])\n" -"Returns a subsequence of a list or string from item start to item end-1."; -const char doc150[] PROGMEM = "(search pattern target)\n" -"Returns the index of the first occurrence of pattern in target,\n" -"which can be lists or strings, or nil if it's not found."; -const char doc151[] PROGMEM = "(read-from-string string)\n" -"Reads an atom or list from the specified string and returns it."; -const char doc152[] PROGMEM = "(princ-to-string item)\n" -"Prints its argument to a string, and returns the string.\n" -"Characters and strings are printed without quotation marks or escape characters."; -const char doc153[] PROGMEM = "(prin1-to-string item [stream])\n" -"Prints its argument to a string, and returns the string.\n" -"Characters and strings are printed with quotation marks and escape characters,\n" -"in a format that will be suitable for read-from-string."; -const char doc154[] PROGMEM = "(logand [value*])\n" -"Returns the bitwise & of the values."; -const char doc155[] PROGMEM = "(logior [value*])\n" -"Returns the bitwise | of the values."; -const char doc156[] PROGMEM = "(logxor [value*])\n" -"Returns the bitwise ^ of the values."; -const char doc157[] PROGMEM = "(prin1-to-string item [stream])\n" -"Prints its argument to a string, and returns the string.\n" -"Characters and strings are printed with quotation marks and escape characters,\n" -"in a format that will be suitable for read-from-string."; -const char doc158[] PROGMEM = "(ash value shift)\n" -"Returns the result of bitwise shifting value by shift bits. If shift is positive, value is shifted to the left."; -const char doc159[] PROGMEM = "(logbitp bit value)\n" -"Returns t if bit number bit in value is a '1', and nil if it is a '0'."; -const char doc160[] PROGMEM = "(eval form*)\n" -"Evaluates its argument an extra time."; -const char doc161[] PROGMEM = "(globals)\n" -"Returns a list of global variables."; -const char doc162[] PROGMEM = "(locals)\n" -"Returns an association list of local variables and their values."; -const char doc163[] PROGMEM = "(makunbound symbol)\n" -"Removes the value of the symbol from GlobalEnv and returns the symbol."; -const char doc164[] PROGMEM = "(break)\n" -"Inserts a breakpoint in the program. When evaluated prints Break! and reenters the REPL."; -const char doc165[] PROGMEM = "(read [stream])\n" -"Reads an atom or list from the serial input and returns it.\n" -"If stream is specified the item is read from the specified stream."; -const char doc166[] PROGMEM = "(prin1 item [stream])\n" -"Prints its argument, and returns its value.\n" -"Strings are printed with quotation marks and escape characters."; -const char doc167[] PROGMEM = "(print item [stream])\n" -"Prints its argument with quotation marks and escape characters, on a new line, and followed by a space.\n" -"If stream is specified the argument is printed to the specified stream."; -const char doc168[] PROGMEM = "(princ item [stream])\n" -"Prints its argument, and returns its value.\n" -"Characters and strings are printed without quotation marks or escape characters."; -const char doc169[] PROGMEM = "(terpri [stream])\n" -"Prints a new line, and returns nil.\n" -"If stream is specified the new line is written to the specified stream."; -const char doc170[] PROGMEM = "(read-byte stream)\n" -"Reads a byte from a stream and returns it."; -const char doc171[] PROGMEM = "(read-line [stream])\n" -"Reads characters from the serial input up to a newline character, and returns them as a string, excluding the newline.\n" -"If stream is specified the line is read from the specified stream."; -const char doc172[] PROGMEM = "(write-byte number [stream])\n" -"Writes a byte to a stream."; -const char doc173[] PROGMEM = "(write-string string [stream])\n" -"Writes a string. If stream is specified the string is written to the stream."; -const char doc174[] PROGMEM = "(write-line string [stream])\n" -"Writes a string terminated by a newline character. If stream is specified the string is written to the stream."; -const char doc175[] PROGMEM = "(restart-i2c stream [read-p])\n" -"Restarts an i2c-stream.\n" -"If read-p is nil or omitted the stream is written to.\n" -"If read-p is an integer it specifies the number of bytes to be read from the stream."; -const char doc176[] PROGMEM = "(gc)\n" -"Forces a garbage collection and prints the number of objects collected, and the time taken."; -const char doc177[] PROGMEM = "(room)\n" -"Returns the number of free Lisp cells remaining."; -const char doc178[] PROGMEM = "(save-image [symbol])\n" -"Saves the current uLisp image to non-volatile memory or SD card so it can be loaded using load-image."; -const char doc179[] PROGMEM = "(load-image [filename])\n" -"Loads a saved uLisp image from non-volatile memory or SD card."; -const char doc180[] PROGMEM = "(cls)\n" -"Prints a clear-screen character."; -const char doc181[] PROGMEM = "(digitalread pin)\n" -"Reads the state of the specified Arduino pin number and returns t (high) or nil (low)."; -const char doc182[] PROGMEM = "(analogreadresolution bits)\n" -"Specifies the resolution for the analogue inputs on platforms that support it.\n" -"The default resolution on all platforms is 10 bits."; -const char doc183[] PROGMEM = "(analogwrite pin value)\n" -"Writes the value to the specified Arduino pin number."; -const char doc184[] PROGMEM = "(delay number)\n" -"Delays for a specified number of milliseconds."; -const char doc185[] PROGMEM = "(millis)\n" -"Returns the time in milliseconds that uLisp has been running."; -const char doc186[] PROGMEM = "(sleep secs)\n" -"Puts the processor into a low-power sleep mode for secs.\n" -"Only supported on some platforms. On other platforms it does delay(1000*secs)."; -const char doc187[] PROGMEM = "(note [pin] [note] [octave])\n" -"Generates a square wave on pin.\n" -"The argument note represents the note in the well-tempered scale, from 0 to 11,\n" -"where 0 represents C, 1 represents C#, and so on.\n" -"The argument octave can be from 3 to 6. If omitted it defaults to 0."; -const char doc188[] PROGMEM = "(edit 'function)\n" -"Calls the Lisp tree editor to allow you to edit a function definition."; -const char doc189[] PROGMEM = "(pprint item [str])\n" -"Prints its argument, using the pretty printer, to display it formatted in a structured way.\n" -"If str is specified it prints to the specified stream. It returns no value."; -const char doc190[] PROGMEM = "(pprintall [str])\n" -"Pretty-prints the definition of every function and variable defined in the uLisp workspace.\n" -"If str is specified it prints to the specified stream. It returns no value."; -const char doc191[] PROGMEM = "(require 'symbol)\n" -"Loads the definition of a function defined with defun, or a variable defined with defvar, from the Lisp Library.\n" -"It returns t if it was loaded, or nil if the symbol is already defined or isn't defined in the Lisp Library."; -const char doc192[] PROGMEM = "(list-library)\n" -"Prints a list of the functions defined in the List Library."; -const char doc193[] PROGMEM = "(? item)\n" -"Prints the documentation string of a built-in or user-defined function."; -const char doc194[] PROGMEM = "(documentation 'symbol [type])\n" -"Returns the documentation string of a built-in or user-defined function. The type argument is ignored."; -const char doc195[] PROGMEM = "(apropos item)\n" -"Prints the user-defined and built-in functions whose names contain the specified string or symbol."; -const char doc196[] PROGMEM = "(apropos-list item)\n" -"Returns a list of user-defined and built-in functions whose names contain the specified string or symbol."; -const char doc197[] PROGMEM = "(unwind-protect form1 [forms]*)\n" -"Evaluates form1 and forms in order and returns the value of form1,\n" -"but guarantees to evaluate forms even if an error occurs in form1."; -const char doc198[] PROGMEM = "(ignore-errors [forms]*)\n" -"Evaluates forms ignoring errors."; -const char doc199[] PROGMEM = "(error controlstring [arguments]*)\n" -"Signals an error. The message is printed by format using the controlstring and arguments."; -const char doc200[] PROGMEM = "(with-client (str [address port]) form*)\n" -"Evaluates the forms with str bound to a wifi-stream."; -const char doc201[] PROGMEM = "(available stream)\n" -"Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available."; -const char doc202[] PROGMEM = "(wifi-server)\n" -"Starts a Wi-Fi server running. It returns nil."; -const char doc203[] PROGMEM = "(wifi-softap ssid [password channel hidden])\n" -"Set up a soft access point to establish a Wi-Fi network.\n" -"Returns the IP address as a string or nil if unsuccessful."; -const char doc204[] PROGMEM = "(connected stream)\n" -"Returns t or nil to indicate if the client on stream is connected."; -const char doc205[] PROGMEM = "(wifi-localip)\n" -"Returns the IP address of the local network as a string."; -const char doc206[] PROGMEM = "(wifi-connect [ssid pass])\n" -"Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string."; -const char doc207[] PROGMEM = "(with-gfx (str) form*)\n" -"Evaluates the forms with str bound to an gfx-stream so you can print text\n" -"to the graphics display using the standard uLisp print commands."; -const char doc208[] PROGMEM = "(draw-pixel x y [colour])\n" -"Draws a pixel at coordinates (x,y) in colour, or white if omitted."; -const char doc209[] PROGMEM = "(draw-line x0 y0 x1 y1 [colour])\n" -"Draws a line from (x0,y0) to (x1,y1) in colour, or white if omitted."; -const char doc210[] PROGMEM = "(draw-rect x y w h [colour])\n" -"Draws an outline rectangle with its top left corner at (x,y), with width w,\n" -"and with height h. The outline is drawn in colour, or white if omitted."; -const char doc211[] PROGMEM = "(fill-rect x y w h [colour])\n" -"Draws a filled rectangle with its top left corner at (x,y), with width w,\n" -"and with height h. The outline is drawn in colour, or white if omitted."; -const char doc212[] PROGMEM = "(draw-circle x y r [colour])\n" -"Draws an outline circle with its centre at (x, y) and with radius r.\n" -"The circle is drawn in colour, or white if omitted."; -const char doc213[] PROGMEM = "(fill-circle x y r [colour])\n" -"Draws a filled circle with its centre at (x, y) and with radius r.\n" -"The circle is drawn in colour, or white if omitted."; -const char doc214[] PROGMEM = "(draw-round-rect x y w h radius [colour])\n" -"Draws an outline rounded rectangle with its top left corner at (x,y), with width w,\n" -"height h, and corner radius radius. The outline is drawn in colour, or white if omitted."; -const char doc215[] PROGMEM = "(fill-round-rect x y w h radius [colour])\n" -"Draws a filled rounded rectangle with its top left corner at (x,y), with width w,\n" -"height h, and corner radius radius. The outline is drawn in colour, or white if omitted."; -const char doc216[] PROGMEM = "(draw-triangle x0 y0 x1 y1 x2 y2 [colour])\n" -"Draws an outline triangle between (x1,y1), (x2,y2), and (x3,y3).\n" -"The outline is drawn in colour, or white if omitted."; -const char doc217[] PROGMEM = "(fill-triangle x0 y0 x1 y1 x2 y2 [colour])\n" -"Draws a filled triangle between (x1,y1), (x2,y2), and (x3,y3).\n" -"The outline is drawn in colour, or white if omitted."; -const char doc218[] PROGMEM = "(draw-char x y char [colour background size])\n" -"Draws the character char with its top left corner at (x,y).\n" -"The character is drawn in a 5 x 7 pixel font in colour against background,\n" -"which default to white and black respectively.\n" -"The character can optionally be scaled by size."; -const char doc219[] PROGMEM = "(set-cursor x y)\n" -"Sets the start point for text plotting to (x, y)."; -const char doc220[] PROGMEM = "(set-text-color colour [background])\n" -"Sets the text colour for text plotted using (with-gfx ...)."; -const char doc221[] PROGMEM = "(set-text-size scale)\n" -"Scales text by the specified size, default 1."; -const char doc222[] PROGMEM = "(set-text-wrap boolean)\n" -"Specified whether text wraps at the right-hand edge of the display; the default is t."; -const char doc223[] PROGMEM = "(fill-screen [colour])\n" -"Fills or clears the screen with colour, default black."; -const char doc224[] PROGMEM = "(set-rotation option)\n" -"Sets the display orientation for subsequent graphics commands; values are 0, 1, 2, or 3."; -const char doc225[] PROGMEM = "(invert-display boolean)\n" -"Mirror-images the display."; - -// Built-in symbol lookup table -const tbl_entry_t lookup_table[] PROGMEM = { - { string0, NULL, 0000, doc0 }, - { string1, NULL, 0000, doc1 }, - { string2, NULL, 0000, doc2 }, - { string3, NULL, 0000, doc3 }, - { string4, NULL, 0000, NULL }, - { string5, NULL, 0000, NULL }, - { string6, NULL, 0000, NULL }, - { string7, NULL, 0000, doc7 }, - { string8, NULL, 0017, doc8 }, - { string9, NULL, 0017, doc9 }, - { string10, NULL, 0017, doc10 }, - { string11, NULL, 0017, NULL }, - { string12, NULL, 0007, NULL }, - { string13, sp_quote, 0311, NULL }, - { string14, sp_defun, 0327, doc14 }, - { string15, sp_defvar, 0313, doc15 }, - { string16, fn_car, 0211, doc16 }, - { string17, fn_car, 0211, NULL }, - { string18, fn_cdr, 0211, doc18 }, - { string19, fn_cdr, 0211, NULL }, - { string20, fn_nth, 0222, doc20 }, - { string21, fn_aref, 0227, doc21 }, - { string22, fn_stringfn, 0211, doc22 }, - { string23, fn_pinmode, 0222, doc23 }, - { string24, fn_digitalwrite, 0222, doc24 }, - { string25, fn_analogread, 0211, doc25 }, - { string26, fn_register, 0212, doc26 }, - { string27, fn_format, 0227, doc27 }, - { string28, sp_or, 0307, doc28 }, - { string29, sp_setq, 0327, doc29 }, - { string30, sp_loop, 0307, doc30 }, - { string31, sp_return, 0307, doc31 }, - { string32, sp_push, 0322, doc32 }, - { string33, sp_pop, 0311, doc33 }, - { string34, sp_incf, 0312, doc34 }, - { string35, sp_decf, 0312, doc35 }, - { string36, sp_setf, 0327, doc36 }, - { string37, sp_dolist, 0317, doc37 }, - { string38, sp_dotimes, 0317, doc38 }, - { string39, sp_trace, 0301, doc39 }, - { string40, sp_untrace, 0301, doc40 }, - { string41, sp_formillis, 0317, doc41 }, - { string42, sp_time, 0311, doc42 }, - { string43, sp_withoutputtostring, 0317, doc43 }, - { string44, sp_withserial, 0317, doc44 }, - { string45, sp_withi2c, 0317, doc45 }, - { string46, sp_withspi, 0317, doc46 }, - { string47, sp_withsdcard, 0327, doc47 }, - { string48, tf_progn, 0107, doc48 }, - { string49, tf_if, 0123, doc49 }, - { string50, tf_cond, 0107, doc50 }, - { string51, tf_when, 0117, doc51 }, - { string52, tf_unless, 0117, doc52 }, - { string53, tf_case, 0117, doc53 }, - { string54, tf_and, 0107, doc54 }, - { string55, fn_not, 0211, doc55 }, - { string56, fn_not, 0211, NULL }, - { string57, fn_cons, 0222, doc57 }, - { string58, fn_atom, 0211, doc58 }, - { string59, fn_listp, 0211, doc59 }, - { string60, fn_consp, 0211, doc60 }, - { string61, fn_symbolp, 0211, doc61 }, - { string62, fn_arrayp, 0211, doc62 }, - { string63, fn_boundp, 0211, doc63 }, - { string64, fn_keywordp, 0211, doc64 }, - { string65, fn_setfn, 0227, doc65 }, - { string66, fn_streamp, 0211, doc66 }, - { string67, fn_eq, 0222, doc67 }, - { string68, fn_equal, 0222, doc68 }, - { string69, fn_caar, 0211, doc69 }, - { string70, fn_cadr, 0211, doc70 }, - { string71, fn_cadr, 0211, NULL }, - { string72, fn_cdar, 0211, doc72 }, - { string73, fn_cddr, 0211, doc73 }, - { string74, fn_caaar, 0211, doc74 }, - { string75, fn_caadr, 0211, doc75 }, - { string76, fn_cadar, 0211, doc76 }, - { string77, fn_caddr, 0211, doc77 }, - { string78, fn_caddr, 0211, NULL }, - { string79, fn_cdaar, 0211, doc79 }, - { string80, fn_cdadr, 0211, doc80 }, - { string81, fn_cddar, 0211, doc81 }, - { string82, fn_cdddr, 0211, doc82 }, - { string83, fn_length, 0211, doc83 }, - { string84, fn_arraydimensions, 0211, doc84 }, - { string85, fn_list, 0207, doc85 }, - { string86, fn_makearray, 0215, doc86 }, - { string87, fn_reverse, 0211, doc87 }, - { string88, fn_assoc, 0222, doc88 }, - { string89, fn_member, 0222, doc89 }, - { string90, fn_apply, 0227, doc90 }, - { string91, fn_funcall, 0217, doc91 }, - { string92, fn_append, 0207, doc92 }, - { string93, fn_mapc, 0227, doc93 }, - { string94, fn_mapcar, 0227, doc94 }, - { string95, fn_mapcan, 0227, doc95 }, - { string96, fn_add, 0207, doc96 }, - { string97, fn_subtract, 0217, doc97 }, - { string98, fn_multiply, 0207, doc98 }, - { string99, fn_divide, 0217, doc99 }, - { string100, fn_mod, 0222, doc100 }, - { string101, fn_oneplus, 0211, doc101 }, - { string102, fn_oneminus, 0211, doc102 }, - { string103, fn_abs, 0211, doc103 }, - { string104, fn_random, 0211, doc104 }, - { string105, fn_maxfn, 0217, doc105 }, - { string106, fn_minfn, 0217, doc106 }, - { string107, fn_noteq, 0217, doc107 }, - { string108, fn_numeq, 0217, doc108 }, - { string109, fn_less, 0217, doc109 }, - { string110, fn_lesseq, 0217, doc110 }, - { string111, fn_greater, 0217, doc111 }, - { string112, fn_greatereq, 0217, doc112 }, - { string113, fn_plusp, 0211, doc113 }, - { string114, fn_minusp, 0211, doc114 }, - { string115, fn_zerop, 0211, doc115 }, - { string116, fn_oddp, 0211, doc116 }, - { string117, fn_evenp, 0211, doc117 }, - { string118, fn_integerp, 0211, doc118 }, - { string119, fn_numberp, 0211, doc119 }, - { string120, fn_floatfn, 0211, doc120 }, - { string121, fn_floatp, 0211, doc121 }, - { string122, fn_sin, 0211, doc122 }, - { string123, fn_cos, 0211, doc123 }, - { string124, fn_tan, 0211, doc124 }, - { string125, fn_asin, 0211, doc125 }, - { string126, fn_acos, 0211, doc126 }, - { string127, fn_atan, 0212, doc127 }, - { string128, fn_sinh, 0211, doc128 }, - { string129, fn_cosh, 0211, doc129 }, - { string130, fn_tanh, 0211, doc130 }, - { string131, fn_exp, 0211, doc131 }, - { string132, fn_sqrt, 0211, doc132 }, - { string133, fn_log, 0212, doc133 }, - { string134, fn_expt, 0222, doc134 }, - { string135, fn_ceiling, 0212, doc135 }, - { string136, fn_floor, 0212, doc136 }, - { string137, fn_truncate, 0212, doc137 }, - { string138, fn_round, 0212, doc138 }, - { string139, fn_char, 0222, doc139 }, - { string140, fn_charcode, 0211, doc140 }, - { string141, fn_codechar, 0211, doc141 }, - { string142, fn_characterp, 0211, doc142 }, - { string143, fn_stringp, 0211, doc143 }, - { string144, fn_stringeq, 0222, doc144 }, - { string145, fn_stringless, 0222, doc145 }, - { string146, fn_stringgreater, 0222, doc146 }, - { string147, fn_sort, 0222, doc147 }, - { string148, fn_concatenate, 0217, doc148 }, - { string149, fn_subseq, 0223, doc149 }, - { string150, fn_search, 0222, doc150 }, - { string151, fn_readfromstring, 0211, doc151 }, - { string152, fn_princtostring, 0211, doc152 }, - { string153, fn_prin1tostring, 0211, doc153 }, - { string154, fn_logand, 0207, doc154 }, - { string155, fn_logior, 0207, doc155 }, - { string156, fn_logxor, 0207, doc156 }, - { string157, fn_lognot, 0211, doc157 }, - { string158, fn_ash, 0222, doc158 }, - { string159, fn_logbitp, 0222, doc159 }, - { string160, fn_eval, 0211, doc160 }, - { string161, fn_globals, 0200, doc161 }, - { string162, fn_locals, 0200, doc162 }, - { string163, fn_makunbound, 0211, doc163 }, - { string164, fn_break, 0200, doc164 }, - { string165, fn_read, 0201, doc165 }, - { string166, fn_prin1, 0212, doc166 }, - { string167, fn_print, 0212, doc167 }, - { string168, fn_princ, 0212, doc168 }, - { string169, fn_terpri, 0201, doc169 }, - { string170, fn_readbyte, 0202, doc170 }, - { string171, fn_readline, 0201, doc171 }, - { string172, fn_writebyte, 0212, doc172 }, - { string173, fn_writestring, 0212, doc173 }, - { string174, fn_writeline, 0212, doc174 }, - { string175, fn_restarti2c, 0212, doc175 }, - { string176, fn_gc, 0200, doc176 }, - { string177, fn_room, 0200, doc177 }, - { string178, fn_saveimage, 0201, doc178 }, - { string179, fn_loadimage, 0201, doc179 }, - { string180, fn_cls, 0200, doc180 }, - { string181, fn_digitalread, 0211, doc181 }, - { string182, fn_analogreadresolution, 0211, doc182 }, - { string183, fn_analogwrite, 0222, doc183 }, - { string184, fn_delay, 0211, doc184 }, - { string185, fn_millis, 0200, doc185 }, - { string186, fn_sleep, 0201, doc186 }, - { string187, fn_note, 0203, doc187 }, - { string188, fn_edit, 0211, doc188 }, - { string189, fn_pprint, 0212, doc189 }, - { string190, fn_pprintall, 0201, doc190 }, - { string191, fn_require, 0211, doc191 }, - { string192, fn_listlibrary, 0200, doc192 }, - { string193, sp_help, 0311, doc193 }, - { string194, fn_documentation, 0212, doc194 }, - { string195, fn_apropos, 0211, doc195 }, - { string196, fn_aproposlist, 0211, doc196 }, - { string197, sp_unwindprotect, 0307, doc197 }, - { string198, sp_ignoreerrors, 0307, doc198 }, - { string199, sp_error, 0317, doc199 }, - { string200, sp_withclient, 0312, doc200 }, - { string201, fn_available, 0211, doc201 }, - { string202, fn_wifiserver, 0200, doc202 }, - { string203, fn_wifisoftap, 0204, doc203 }, - { string204, fn_connected, 0211, doc204 }, - { string205, fn_wifilocalip, 0200, doc205 }, - { string206, fn_wificonnect, 0203, doc206 }, - { string207, sp_withgfx, 0317, doc207 }, - { string208, fn_drawpixel, 0223, doc208 }, - { string209, fn_drawline, 0245, doc209 }, - { string210, fn_drawrect, 0245, doc210 }, - { string211, fn_fillrect, 0245, doc211 }, - { string212, fn_drawcircle, 0234, doc212 }, - { string213, fn_fillcircle, 0234, doc213 }, - { string214, fn_drawroundrect, 0256, doc214 }, - { string215, fn_fillroundrect, 0256, doc215 }, - { string216, fn_drawtriangle, 0267, doc216 }, - { string217, fn_filltriangle, 0267, doc217 }, - { string218, fn_drawchar, 0236, doc218 }, - { string219, fn_setcursor, 0222, doc219 }, - { string220, fn_settextcolor, 0212, doc220 }, - { string221, fn_settextsize, 0211, doc221 }, - { string222, fn_settextwrap, 0211, doc222 }, - { string223, fn_fillscreen, 0201, doc223 }, - { string224, fn_setrotation, 0211, doc224 }, - { string225, fn_invertdisplay, 0211, doc225 }, - { string226, (fn_ptr_type)LED_BUILTIN, 0, NULL }, - { string227, (fn_ptr_type)HIGH, DIGITALWRITE, NULL }, - { string228, (fn_ptr_type)LOW, DIGITALWRITE, NULL }, -#if defined(ESP8266) - { string229, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string230, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string231, (fn_ptr_type)OUTPUT, PINMODE, NULL }, -#elif defined(ESP32) - { string229, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string230, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string231, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, - { string232, (fn_ptr_type)OUTPUT, PINMODE, NULL }, -#endif -}; - -#if !defined(extensions) -// Table cross-reference functions - -tbl_entry_t *tables[] = {lookup_table, NULL}; -const unsigned int tablesizes[] = { arraysize(lookup_table), 0 }; - -const tbl_entry_t *table (int n) { - return tables[n]; -} - -unsigned int tablesize (int n) { - return tablesizes[n]; -} -#endif - -// Table lookup functions - -builtin_t lookupbuiltin (char* c) { - unsigned int end = 0, start; - for (int n=0; n<2; n++) { - start = end; - int entries = tablesize(n); - end = end + entries; - for (int i=0; i> 3) & 0x07)) error2(toofewargs); - if ((minmax & 0x07) != 0x07 && nargs>(minmax & 0x07)) error2(toomanyargs); -} - -char *lookupdoc (builtin_t name) { - int n = namename))) return false; - builtin_t name = builtin(obj->name); - int n = name 4000) { delay(1); start = millis(); } -#else - (void) start; -#endif - // Enough space? - if (Freespace <= WORKSPACESIZE>>4) gc(form, env); - // Escape - if (tstflag(ESCAPE)) { clrflag(ESCAPE); error2(PSTR("escape!"));} - if (!tstflag(NOESC)) testescape(); - - if (form == NULL) return nil; - - if (form->type >= NUMBER && form->type <= STRING) return form; - - if (symbolp(form)) { - symbol_t name = form->name; - object *pair = value(name, env); - if (pair != NULL) return cdr(pair); - pair = value(name, GlobalEnv); - if (pair != NULL) return cdr(pair); - else if (builtinp(name)) return form; - error(PSTR("undefined"), form); - } - - // It's a list - object *function = car(form); - object *args = cdr(form); - - if (function == NULL) error(PSTR("illegal function"), nil); - if (!listp(args)) error(PSTR("can't evaluate a dotted pair"), args); - - // List starts with a builtin symbol? - if (symbolp(function) && builtinp(function->name)) { - builtin_t name = builtin(function->name); - - if ((name == LET) || (name == LETSTAR)) { - int TCstart = TC; - if (args == NULL) error2(noargument); - object *assigns = first(args); - if (!listp(assigns)) error(notalist, assigns); - object *forms = cdr(args); - object *newenv = env; - push(newenv, GCStack); - while (assigns != NULL) { - object *assign = car(assigns); - if (!consp(assign)) push(cons(assign,nil), newenv); - else if (cdr(assign) == NULL) push(cons(first(assign),nil), newenv); - else push(cons(first(assign),eval(second(assign),env)), newenv); - car(GCStack) = newenv; - if (name == LETSTAR) env = newenv; - assigns = cdr(assigns); - } - env = newenv; - pop(GCStack); - form = tf_progn(forms,env); - TC = TCstart; - goto EVAL; - } - - if (name == LAMBDA) { - if (env == NULL) return form; - object *envcopy = NULL; - while (env != NULL) { - object *pair = first(env); - if (pair != NULL) push(pair, envcopy); - env = cdr(env); - } - return cons(bsymbol(CLOSURE), cons(envcopy,args)); - } - uint8_t fntype = getminmax(name)>>6; - - if (fntype == SPECIAL_FORMS) { - Context = name; - return ((fn_ptr_type)lookupfn(name))(args, env); - } - - if (fntype == TAIL_FORMS) { - Context = name; - form = ((fn_ptr_type)lookupfn(name))(args, env); - TC = 1; - goto EVAL; - } - if (fntype == OTHER_FORMS) error(PSTR("can't be used as a function"), function); - } - - // Evaluate the parameters - result in head - object *fname = car(form); - int TCstart = TC; - object *head = cons(eval(fname, 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 (symbolp(function)) { - builtin_t bname = builtin(function->name); - if (!builtinp(function->name)) error(PSTR("not valid here"), fname); - Context = bname; - checkminmax(bname, nargs); - object *result = ((fn_ptr_type)lookupfn(bname))(args, env); - pop(GCStack); - return result; - } - - if (consp(function)) { - symbol_t name = sym(NIL); - if (!listp(fname)) name = fname->name; - - if (isbuiltin(car(function), LAMBDA)) { - form = closure(TCstart, name, function, args, &env); - pop(GCStack); - int trace = tracing(fname->name); - if (trace) { - object *result = eval(form, env); - indent((--(TraceDepth[trace-1]))<<1, ' ', pserial); - pint(TraceDepth[trace-1], pserial); - pserial(':'); pserial(' '); - printobject(fname, pserial); pfstring(PSTR(" returned "), pserial); - printobject(result, pserial); pln(pserial); - return result; - } else { - TC = 1; - goto EVAL; - } - } - - if (isbuiltin(car(function), CLOSURE)) { - function = cdr(function); - form = closure(TCstart, name, function, args, &env); - pop(GCStack); - TC = 1; - goto EVAL; - } - - } - error(PSTR("illegal function"), fname); return nil; -} - -// Print functions - -void pserial (char c) { - LastPrint = c; - if (c == '\n') Serial.write('\r'); - Serial.write(c); -} - -const char ControlCodes[] PROGMEM = "Null\0SOH\0STX\0ETX\0EOT\0ENQ\0ACK\0Bell\0Backspace\0Tab\0Newline\0VT\0" -"Page\0Return\0SO\0SI\0DLE\0DC1\0DC2\0DC3\0DC4\0NAK\0SYN\0ETB\0CAN\0EM\0SUB\0Escape\0FS\0GS\0RS\0US\0Space\0"; - -void pcharacter (uint8_t c, pfun_t pfun) { - if (!tstflag(PRINTREADABLY)) pfun(c); - else { - pfun('#'); pfun('\\'); - if (c <= 32) { - PGM_P p = ControlCodes; - while (c > 0) {p = p + strlen_P(p) + 1; c--; } - pfstring(p, pfun); - } else if (c < 127) pfun(c); - else pint(c, pfun); - } -} - -void pstring (char *s, pfun_t pfun) { - while (*s) pfun(*s++); -} - -void plispstring (object *form, pfun_t pfun) { - plispstr(form->name, pfun); -} - -void plispstr (symbol_t name, pfun_t pfun) { - object *form = (object *)name; - while (form != NULL) { - int chars = form->chars; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; - if (tstflag(PRINTREADABLY) && (ch == '"' || ch == '\\')) pfun('\\'); - if (ch) pfun(ch); - } - form = car(form); - } -} - -void printstring (object *form, pfun_t pfun) { - if (tstflag(PRINTREADABLY)) pfun('"'); - plispstr(form->name, pfun); - if (tstflag(PRINTREADABLY)) pfun('"'); -} - -void pbuiltin (builtin_t name, pfun_t pfun) { - int p = 0; - int n = name0; d = d/40) { - uint32_t j = x/d; - char c = fromradix40(j); - if (c == 0) return; - pfun(c); x = x - j*d; - } -} - -void printsymbol (object *form, pfun_t pfun) { - psymbol(form->name, pfun); -} - -void psymbol (symbol_t name, pfun_t pfun) { - if ((name & 0x03) == 0) plispstr(name, pfun); - else { - uint32_t value = untwist(name); - if (value < PACKEDS) error2(PSTR("invalid symbol")); - else if (value >= BUILTINS) pbuiltin((builtin_t)(value-BUILTINS), pfun); - else pradix40(name, pfun); - } -} - -void pfstring (PGM_P s, pfun_t pfun) { - int p = 0; - while (1) { - char c = pgm_read_byte(&s[p++]); - if (c == 0) return; - pfun(c); - } -} - -void pint (int i, pfun_t pfun) { - uint32_t j = i; - if (i<0) { pfun('-'); j=-i; } - pintbase(j, 10, pfun); -} - -void pintbase (uint32_t i, uint8_t base, pfun_t pfun) { - int lead = 0; uint32_t p = 1000000000; - if (base == 2) p = 0x80000000; else if (base == 16) p = 0x10000000; - for (uint32_t d=p; d>0; d=d/base) { - uint32_t j = i/d; - if (j!=0 || lead || d==1) { pfun((j<10) ? j+'0' : j+'W'); lead=1;} - i = i - j*d; - } -} - -void pmantissa (float f, pfun_t pfun) { - int sig = floor(log10(f)); - int mul = pow(10, 5 - sig); - int i = round(f * mul); - bool point = false; - if (i == 1000000) { i = 100000; sig++; } - if (sig < 0) { - pfun('0'); pfun('.'); point = true; - for (int j=0; j < - sig - 1; j++) pfun('0'); - } - mul = 100000; - for (int j=0; j<7; j++) { - int d = (int)(i / mul); - pfun(d + '0'); - i = i - d * mul; - if (i == 0) { - if (!point) { - for (int k=j; k= 0) { pfun('.'); point = true; } - mul = mul / 10; - } -} - -void pfloat (float f, pfun_t pfun) { - if (isnan(f)) { pfstring(PSTR("NaN"), pfun); return; } - if (f == 0.0) { pfun('0'); return; } - if (isinf(f)) { pfstring(PSTR("Inf"), pfun); return; } - if (f < 0) { pfun('-'); f = -f; } - // Calculate exponent - int e = 0; - if (f < 1e-3 || f >= 1e5) { - e = floor(log(f) / 2.302585); // log10 gives wrong result - f = f / pow(10, e); - } - - pmantissa (f, pfun); - - // Exponent - if (e != 0) { - pfun('e'); - pint(e, pfun); - } -} - -inline void pln (pfun_t pfun) { - pfun('\n'); -} - -void pfl (pfun_t pfun) { - if (LastPrint != '\n') pfun('\n'); -} - -void plist (object *form, pfun_t pfun) { - pfun('('); - printobject(car(form), pfun); - form = cdr(form); - while (form != NULL && listp(form)) { - pfun(' '); - printobject(car(form), pfun); - form = cdr(form); - } - if (form != NULL) { - pfstring(PSTR(" . "), pfun); - printobject(form, pfun); - } - pfun(')'); -} - -void pstream (object *form, pfun_t pfun) { - pfun('<'); - PGM_P s = (char*)pgm_read_ptr(&streamname[(form->integer)>>8]); - pfstring(s, pfun); - pfstring(PSTR("-stream "), pfun); - pint(form->integer & 0xFF, pfun); - pfun('>'); -} - -void printobject (object *form, pfun_t pfun) { - if (form == NULL) pfstring(PSTR("nil"), pfun); - else if (listp(form) && isbuiltin(car(form), CLOSURE)) pfstring(PSTR(""), pfun); - else if (listp(form)) plist(form, pfun); - else if (integerp(form)) pint(form->integer, pfun); - else if (floatp(form)) pfloat(form->single_float, pfun); - else if (symbolp(form)) { if (form->name != sym(NOTHING)) printsymbol(form, pfun); } - else if (characterp(form)) pcharacter(form->chars, pfun); - else if (stringp(form)) printstring(form, pfun); - else if (arrayp(form)) printarray(form, pfun); - else if (streamp(form)) pstream(form, pfun); - else error2(PSTR("error in print")); -} - -void prin1object (object *form, pfun_t pfun) { - char temp = Flags; - clrflag(PRINTREADABLY); - printobject(form, pfun); - Flags = temp; -} - -// Read functions - -int glibrary () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - char c = pgm_read_byte(&LispLibrary[GlobalStringIndex++]); - return (c != 0) ? c : -1; // -1? -} - -void loadfromlibrary (object *env) { - GlobalStringIndex = 0; - object *line = read(glibrary); - while (line != NULL) { - push(line, GCStack); - eval(line, env); - pop(GCStack); - line = read(glibrary); - } -} - -// For line editor -const int TerminalWidth = 80; -volatile int WritePtr = 0, ReadPtr = 0; -const int KybdBufSize = 333; // 42*8 - 3 -char KybdBuf[KybdBufSize]; -volatile uint8_t KybdAvailable = 0; - -// Parenthesis highlighting -void esc (int p, char c) { - Serial.write('\e'); Serial.write('['); - Serial.write((char)('0'+ p/100)); - Serial.write((char)('0'+ (p/10) % 10)); - Serial.write((char)('0'+ p % 10)); - Serial.write(c); -} - -void hilight (char c) { - Serial.write('\e'); Serial.write('['); Serial.write(c); Serial.write('m'); -} - -void Highlight (int p, int wp, uint8_t invert) { - wp = wp + 2; // Prompt -#if defined (printfreespace) - int f = Freespace; - while (f) { wp++; f=f/10; } -#endif - int line = wp/TerminalWidth; - int col = wp%TerminalWidth; - int targetline = (wp - p)/TerminalWidth; - int targetcol = (wp - p)%TerminalWidth; - int up = line-targetline, left = col-targetcol; - if (p) { - if (up) esc(up, 'A'); - if (col > targetcol) esc(left, 'D'); else esc(-left, 'C'); - if (invert) hilight('7'); - Serial.write('('); Serial.write('\b'); - // Go back - if (up) esc(up, 'B'); // Down - if (col > targetcol) esc(left, 'C'); else esc(-left, 'D'); - Serial.write('\b'); Serial.write(')'); - if (invert) hilight('0'); - } -} - -void processkey (char c) { - if (c == 27) { setflag(ESCAPE); return; } // Escape key -#if defined(vt100) - static int parenthesis = 0, wp = 0; - // Undo previous parenthesis highlight - Highlight(parenthesis, wp, 0); - parenthesis = 0; -#endif - // Edit buffer - if (c == '\n' || c == '\r') { - pserial('\n'); - KybdAvailable = 1; - ReadPtr = 0; - return; - } - if (c == 8 || c == 0x7f) { // Backspace key - if (WritePtr > 0) { - WritePtr--; - Serial.write(8); Serial.write(' '); Serial.write(8); - if (WritePtr) c = KybdBuf[WritePtr-1]; - } - } else if (WritePtr < KybdBufSize) { - KybdBuf[WritePtr++] = c; - Serial.write(c); - } -#if defined(vt100) - // Do new parenthesis highlight - if (c == ')') { - int search = WritePtr-1, level = 0; - while (search >= 0 && parenthesis == 0) { - c = KybdBuf[search--]; - if (c == ')') level++; - if (c == '(') { - level--; - if (level == 0) {parenthesis = WritePtr-search-1; wp = WritePtr; } - } - } - Highlight(parenthesis, wp, 1); - } -#endif - return; -} - -int gserial () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } -#if defined(lineeditor) - while (!KybdAvailable) { - while (!Serial.available()); - char temp = Serial.read(); - processkey(temp); - } - if (ReadPtr != WritePtr) return KybdBuf[ReadPtr++]; - KybdAvailable = 0; - WritePtr = 0; - return '\n'; -#else - unsigned long start = millis(); - while (!Serial.available()) { delay(1); if (millis() - start > 1000) clrflag(NOECHO); } - char temp = Serial.read(); - if (temp != '\n' && !tstflag(NOECHO)) pserial(temp); - return temp; -#endif -} - -object *nextitem (gfun_t gfun) { - int ch = gfun(); - while(issp(ch)) ch = gfun(); - - if (ch == ';') { - do { ch = gfun(); if (ch == ';' || ch == '(') setflag(NOECHO); } - while(ch != '('); - } - if (ch == '\n') ch = gfun(); - if (ch == -1) return nil; - if (ch == ')') return (object *)KET; - if (ch == '(') return (object *)BRA; - if (ch == '\'') return (object *)QUO; - - // Parse string - if (ch == '"') return readstring('"', gfun); - - // Parse symbol, character, or number - int index = 0, base = 10, sign = 1; - char buffer[BUFFERSIZE]; - int bufmax = BUFFERSIZE-3; // Max index - unsigned int result = 0; - bool isfloat = false; - float fresult = 0.0; - - if (ch == '+') { - buffer[index++] = ch; - ch = gfun(); - } else if (ch == '-') { - sign = -1; - buffer[index++] = ch; - ch = gfun(); - } else if (ch == '.') { - buffer[index++] = ch; - ch = gfun(); - if (ch == ' ') return (object *)DOT; - isfloat = true; - } - - // Parse reader macros - else if (ch == '#') { - ch = gfun(); - char ch2 = ch & ~0x20; // force to upper case - if (ch == '\\') { // Character - base = 0; ch = gfun(); - if (issp(ch) || isbr(ch)) return character(ch); - else LastChar = ch; - } else if (ch == '|') { - do { while (gfun() != '|'); } - while (gfun() != '#'); - return nextitem(gfun); - } else if (ch2 == 'B') base = 2; - else if (ch2 == 'O') base = 8; - else if (ch2 == 'X') base = 16; - else if (ch == '\'') return nextitem(gfun); - else if (ch == '.') { - setflag(NOESC); - object *result = eval(read(gfun), NULL); - clrflag(NOESC); - return result; - } - else if (ch == '(') { LastChar = ch; return readarray(1, read(gfun)); } - else if (ch == '*') return readbitarray(gfun); - else if (ch >= '1' && ch <= '9' && (gfun() & ~0x20) == 'A') return readarray(ch - '0', read(gfun)); - else error2(PSTR("illegal character after #")); - ch = gfun(); - } - int valid; // 0=undecided, -1=invalid, +1=valid - if (ch == '.') valid = 0; else if (digitvalue(ch) ((unsigned int)INT_MAX+(1-sign)/2)) - return makefloat((float)result*sign); - return number(result*sign); - } else if (base == 0) { - if (index == 1) return character(buffer[0]); - PGM_P p = ControlCodes; char c = 0; - while (c < 33) { - if (strcasecmp_P(buffer, p) == 0) return character(c); - p = p + strlen_P(p) + 1; c++; - } - if (index == 3) return character((buffer[0]*10+buffer[1])*10+buffer[2]-5328); - error2(PSTR("unknown character")); - } - - builtin_t x = lookupbuiltin(buffer); - if (x == NIL) return nil; - if (x != ENDFUNCTIONS) return bsymbol(x); - else if ((index <= 6) && valid40(buffer)) return intern(twist(pack40(buffer))); - buffer[index+1] = '\0'; buffer[index+2] = '\0'; buffer[index+3] = '\0'; // For internlong - return internlong(buffer); -} - -object *readrest (gfun_t gfun) { - object *item = nextitem(gfun); - object *head = NULL; - object *tail = NULL; - - while (item != (object *)KET) { - if (item == (object *)BRA) { - item = readrest(gfun); - } else if (item == (object *)QUO) { - item = cons(bsymbol(QUOTE), cons(read(gfun), NULL)); - } else if (item == (object *)DOT) { - tail->cdr = read(gfun); - if (readrest(gfun) != NULL) error2(PSTR("malformed list")); - return head; - } else { - object *cell = cons(item, NULL); - if (head == NULL) head = cell; - else tail->cdr = cell; - tail = cell; - item = nextitem(gfun); - } - } - return head; -} - -object *read (gfun_t gfun) { - object *item = nextitem(gfun); - if (item == (object *)KET) error2(PSTR("incomplete list")); - if (item == (object *)BRA) return readrest(gfun); - if (item == (object *)DOT) return read(gfun); - if (item == (object *)QUO) return cons(bsymbol(QUOTE), cons(read(gfun), NULL)); - return item; -} - -// Setup - -void initenv () { - GlobalEnv = NULL; - tee = bsymbol(TEE); -} - -void initgfx () { - #if defined(gfxsupport) - tft.init(135, 240); - #if defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) - pinMode(TFT_I2C_POWER, OUTPUT); - digitalWrite(TFT_I2C_POWER, HIGH); - tft.setRotation(3); - #else - tft.setRotation(1); - #endif - tft.fillScreen(ST77XX_BLACK); - pinMode(TFT_BACKLITE, OUTPUT); - digitalWrite(TFT_BACKLITE, HIGH); - #endif -} - -void setup () { - Serial.begin(9600); - int start = millis(); - while ((millis() - start) < 5000) { if (Serial) break; } - initworkspace(); - initenv(); - initsleep(); - initgfx(); - pfstring(PSTR("uLisp 4.4 "), pserial); pln(pserial); -} - -// Read/Evaluate/Print loop - -void repl (object *env) { - for (;;) { - randomSeed(micros()); - gc(NULL, env); - #if defined(printfreespace) - pint(Freespace, pserial); - #endif - if (BreakLevel) { - pfstring(PSTR(" : "), pserial); - pint(BreakLevel, pserial); - } - pserial('>'); pserial(' '); - Context = 0; - object *line = read(gserial); - if (BreakLevel && line == nil) { pln(pserial); return; } - if (line == (object *)KET) error2(PSTR("unmatched right bracket")); - push(line, GCStack); - pfl(pserial); - line = eval(line, env); - pfl(pserial); - printobject(line, pserial); - pop(GCStack); - pfl(pserial); - pln(pserial); - } -} - -void loop () { - if (!setjmp(toplevel_handler)) { - #if defined(resetautorun) - volatile int autorun = 12; // Fudge to keep code size the same - #else - volatile int autorun = 13; - #endif - if (autorun == 12) autorunimage(); - } - ulispreset(); - repl(NULL); -} - -void ulispreset () { - // Come here after error - delay(100); while (Serial.available()) Serial.read(); - clrflag(NOESC); BreakLevel = 0; - for (int i=0; i #include #include -#if defined (ESP8266) - #include -#elif defined (ESP32) - #include -#endif +#include #if defined(gfxsupport) #define COLOR_WHITE ST77XX_WHITE @@ -46,112 +39,23 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #endif #endif -#if defined(sdcardsupport) - #include - #define SDSIZE 172 -#else - #define SDSIZE 0 -#endif +#include +#define SDSIZE 172 // Platform specific settings #define WORDALIGNED __attribute__((aligned (4))) #define BUFFERSIZE 36 // Number of bits+4 -#if defined(ESP8266) - #define WORKSPACESIZE (3928-SDSIZE) /* Cells (8*bytes) */ - #define EEPROMSIZE 4096 /* Bytes available for EEPROM */ - #define SDCARD_SS_PIN 10 - #define LED_BUILTIN 13 - -#elif defined(ARDUINO_FEATHER_ESP32) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - -#elif defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2) || defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - -#elif defined(ARDUINO_ADAFRUIT_QTPY_ESP32S2) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#elif defined(ARDUINO_ADAFRUIT_QTPY_ESP32C3) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#elif defined(ARDUINO_FEATHERS2) /* UM FeatherS2 */ - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#elif defined(ARDUINO_ESP32_DEV) /* For TTGO T-Display */ - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - -#elif defined(ARDUINO_ESP32S2_DEV) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#elif defined(ARDUINO_ESP32C3_DEV) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#elif defined(ARDUINO_ESP32S3_DEV) - #define WORKSPACESIZE (22000-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#elif defined(ESP32) - #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ - #define LITTLEFS - #include "FS.h" - #include - #define analogWrite(x,y) dacWrite((x),(y)) - #define SDCARD_SS_PIN 13 - #define LED_BUILTIN 13 - -#else -#error "Board not supported!" +#define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ +#define LITTLEFS +#include "FS.h" +#include +#ifndef analogWrite +#define analogWrite(x,y) dacWrite((x),(y)) #endif + // C Macros #define nil NULL @@ -595,6 +499,7 @@ void sweep () { void gc (object *form, object *env) { #if defined(printgcs) int start = Freespace; + static int GC_Count = 0; #endif markobject(tee); markobject(GlobalEnv); @@ -603,301 +508,16 @@ void gc (object *form, object *env) { markobject(env); sweep(); #if defined(printgcs) - pfl(pserial); pserial('{'); pint(Freespace - start, pserial); pserial('}'); + GC_Count++; + pfl(pserial); + pfstring(PSTR("{GC #"), pserial); + pint(GC_Count, pserial); + pfstring(PSTR(": "), pserial); + pint(Freespace - start, pserial); + pfstring(PSTR(" freed}"), pserial); #endif } -// Compact image - -/* - movepointer - corrects pointers to an object that has moved from 'from' to 'to' -*/ -void movepointer (object *from, object *to) { - for (int i=0; itype) & ~MARKBIT; - if (marked(obj) && (type >= ARRAY || type==ZZERO || (type == SYMBOL && longsymbolp(obj)))) { - if (car(obj) == (object *)((uintptr_t)from | MARKBIT)) - car(obj) = (object *)((uintptr_t)to | MARKBIT); - if (cdr(obj) == from) cdr(obj) = to; - } - } - // Fix strings and long symbols - for (int i=0; itype) & ~MARKBIT; - if (type == STRING || (type == SYMBOL && longsymbolp(obj))) { - obj = cdr(obj); - while (obj != NULL) { - if (cdr(obj) == to) cdr(obj) = from; - obj = (object *)((uintptr_t)(car(obj)) & ~MARKBIT); - } - } - } - } -} - -/* - compactimage - compacts the image by moving objects to the lowest possible position in the workspace -*/ -uintptr_t compactimage (object **arg) { - markobject(tee); - markobject(GlobalEnv); - markobject(GCStack); - object *firstfree = Workspace; - while (marked(firstfree)) firstfree++; - object *obj = &Workspace[WORKSPACESIZE-1]; - while (firstfree < obj) { - if (marked(obj)) { - car(firstfree) = car(obj); - cdr(firstfree) = cdr(obj); - unmark(obj); - movepointer(obj, firstfree); - if (GlobalEnv == obj) GlobalEnv = firstfree; - if (GCStack == obj) GCStack = firstfree; - if (*arg == obj) *arg = firstfree; - while (marked(firstfree)) firstfree++; - } - obj--; - } - sweep(); - return firstfree - Workspace; -} - -// Make SD card filename - -char *MakeFilename (object *arg, char *buffer) { - int max = BUFFERSIZE-1; - buffer[0]='/'; - int i = 1; - do { - char c = nthchar(arg, i-1); - if (c == '\0') break; - buffer[i++] = c; - } while (i>8 & 0xFF); - file.write(data>>16 & 0xFF); file.write(data>>24 & 0xFF); -} - -int SDReadInt (File file) { - uintptr_t b0 = file.read(); uintptr_t b1 = file.read(); - uintptr_t b2 = file.read(); uintptr_t b3 = file.read(); - return b0 | b1<<8 | b2<<16 | b3<<24; -} -#elif defined(LITTLEFS) -void FSWrite32 (File file, uint32_t data) { - union { uint32_t data2; uint8_t u8[4]; }; - data2 = data; - if (file.write(u8, 4) != 4) error2(PSTR("not enough room")); -} - -uint32_t FSRead32 (File file) { - union { uint32_t data; uint8_t u8[4]; }; - file.read(u8, 4); - return data; -} -#else -void EpromWriteInt(int *addr, uintptr_t data) { - EEPROM.write((*addr)++, data & 0xFF); EEPROM.write((*addr)++, data>>8 & 0xFF); - EEPROM.write((*addr)++, data>>16 & 0xFF); EEPROM.write((*addr)++, data>>24 & 0xFF); -} - -int EpromReadInt (int *addr) { - uint8_t b0 = EEPROM.read((*addr)++); uint8_t b1 = EEPROM.read((*addr)++); - uint8_t b2 = EEPROM.read((*addr)++); uint8_t b3 = EEPROM.read((*addr)++); - return b0 | b1<<8 | b2<<16 | b3<<24; -} -#endif - -unsigned int saveimage (object *arg) { -#if defined(sdcardsupport) - unsigned int imagesize = compactimage(&arg); - SD.begin(SDCARD_SS_PIN); - File file; - if (stringp(arg)) { - char buffer[BUFFERSIZE]; - file = SD.open(MakeFilename(arg, buffer), FILE_WRITE); - if (!file) error2(PSTR("problem saving to SD card or invalid filename")); - arg = NULL; - } else if (arg == NULL || listp(arg)) { - file = SD.open("/ULISP.IMG", FILE_WRITE); - if (!file) error2(PSTR("problem saving to SD card")); - } else error(invalidarg, arg); - SDWriteInt(file, (uintptr_t)arg); - SDWriteInt(file, imagesize); - SDWriteInt(file, (uintptr_t)GlobalEnv); - SDWriteInt(file, (uintptr_t)GCStack); - for (unsigned int i=0; i EEPROMSIZE) error(PSTR("image too large"), number(imagesize)); - EEPROM.begin(EEPROMSIZE); - int addr = 0; - EpromWriteInt(&addr, (uintptr_t)arg); - EpromWriteInt(&addr, imagesize); - EpromWriteInt(&addr, (uintptr_t)GlobalEnv); - EpromWriteInt(&addr, (uintptr_t)GCStack); - for (unsigned int i=0; i 4000) { delay(1); start = millis(); } -#else - (void) start; -#endif // Enough space? if (Freespace <= WORKSPACESIZE>>4) gc(form, env); // Escape @@ -7248,99 +6820,6 @@ void loadfromlibrary (object *env) { } } -// For line editor -const int TerminalWidth = 80; -volatile int WritePtr = 0, ReadPtr = 0; -const int KybdBufSize = 333; // 42*8 - 3 -char KybdBuf[KybdBufSize]; -volatile uint8_t KybdAvailable = 0; - -// Parenthesis highlighting -void esc (int p, char c) { - Serial.write('\e'); Serial.write('['); - Serial.write((char)('0'+ p/100)); - Serial.write((char)('0'+ (p/10) % 10)); - Serial.write((char)('0'+ p % 10)); - Serial.write(c); -} - -void hilight (char c) { - Serial.write('\e'); Serial.write('['); Serial.write(c); Serial.write('m'); -} - -/* - Highlight - handles parenthesis highlighting with the line editor -*/ -void Highlight (int p, int wp, uint8_t invert) { - wp = wp + 2; // Prompt -#if defined (printfreespace) - int f = Freespace; - while (f) { wp++; f=f/10; } -#endif - int line = wp/TerminalWidth; - int col = wp%TerminalWidth; - int targetline = (wp - p)/TerminalWidth; - int targetcol = (wp - p)%TerminalWidth; - int up = line-targetline, left = col-targetcol; - if (p) { - if (up) esc(up, 'A'); - if (col > targetcol) esc(left, 'D'); else esc(-left, 'C'); - if (invert) hilight('7'); - Serial.write('('); Serial.write('\b'); - // Go back - if (up) esc(up, 'B'); // Down - if (col > targetcol) esc(left, 'C'); else esc(-left, 'D'); - Serial.write('\b'); Serial.write(')'); - if (invert) hilight('0'); - } -} - -/* - processkey - handles keys in the line editor -*/ -void processkey (char c) { - if (c == 27) { setflag(ESCAPE); return; } // Escape key -#if defined(vt100) - static int parenthesis = 0, wp = 0; - // Undo previous parenthesis highlight - Highlight(parenthesis, wp, 0); - parenthesis = 0; -#endif - // Edit buffer - if (c == '\n' || c == '\r') { - pserial('\n'); - KybdAvailable = 1; - ReadPtr = 0; - return; - } - if (c == 8 || c == 0x7f) { // Backspace key - if (WritePtr > 0) { - WritePtr--; - Serial.write(8); Serial.write(' '); Serial.write(8); - if (WritePtr) c = KybdBuf[WritePtr-1]; - } - } else if (WritePtr < KybdBufSize) { - KybdBuf[WritePtr++] = c; - Serial.write(c); - } -#if defined(vt100) - // Do new parenthesis highlight - if (c == ')') { - int search = WritePtr-1, level = 0; - while (search >= 0 && parenthesis == 0) { - c = KybdBuf[search--]; - if (c == ')') level++; - if (c == '(') { - level--; - if (level == 0) {parenthesis = WritePtr-search-1; wp = WritePtr; } - } - } - Highlight(parenthesis, wp, 1); - } -#endif - return; -} - /* gserial - gets a character from the serial port */ @@ -7350,17 +6829,6 @@ int gserial () { LastChar = 0; return temp; } -#if defined(lineeditor) - while (!KybdAvailable) { - while (!Serial.available()); - char temp = Serial.read(); - processkey(temp); - } - if (ReadPtr != WritePtr) return KybdBuf[ReadPtr++]; - KybdAvailable = 0; - WritePtr = 0; - return '\n'; -#else unsigned long start = millis(); while (!Serial.available()) { delay(1); if (millis() - start > 1000) clrflag(NOECHO); } char temp = Serial.read(); @@ -7619,12 +7087,7 @@ void repl (object *env) { */ void loop () { if (!setjmp(toplevel_handler)) { - #if defined(resetautorun) - volatile int autorun = 12; // Fudge to keep code size the same - #else - volatile int autorun = 13; - #endif - if (autorun == 12) autorunimage(); + ; // noop } ulispreset(); repl(NULL); From 59f16afe246a14c338d40d67dfb0db907fb36571 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 25 Mar 2023 11:45:22 -0400 Subject: [PATCH 002/109] move to c and h --- ulisp-esp32.ino | 7065 +---------------------------------------------- ulisp.c | 6984 ++++++++++++++++++++++++++++++++++++++++++++++ ulisp.h | 965 +++++++ 3 files changed, 7950 insertions(+), 7064 deletions(-) create mode 100644 ulisp.c create mode 100644 ulisp.h diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index 922f568..e444924 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -17,7024 +17,7 @@ const char LispLibrary[] PROGMEM = ""; // #define extensions // Includes - -// #include "LispLibrary.h" -#include -#include -#include -#include -#include -#include - -#if defined(gfxsupport) -#define COLOR_WHITE ST77XX_WHITE -#define COLOR_BLACK ST77XX_BLACK -#include // Core graphics library -#include // Hardware-specific library for ST7789 -#if defined(ARDUINO_ESP32_DEV) -Adafruit_ST7789 tft = Adafruit_ST7789(5, 16, 19, 18); -#define TFT_BACKLITE 4 -#else -Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); -#endif -#endif - -#include -#define SDSIZE 172 - -// Platform specific settings - -#define WORDALIGNED __attribute__((aligned (4))) -#define BUFFERSIZE 36 // Number of bits+4 - -#define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ -#define LITTLEFS -#include "FS.h" -#include -#ifndef analogWrite -#define analogWrite(x,y) dacWrite((x),(y)) -#endif - - -// 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 push(x, y) ((y) = cons((x),(y))) -#define pop(y) ((y) = cdr(y)) - -#define integerp(x) ((x) != NULL && (x)->type == NUMBER) -#define floatp(x) ((x) != NULL && (x)->type == FLOAT) -#define symbolp(x) ((x) != NULL && (x)->type == SYMBOL) -#define stringp(x) ((x) != NULL && (x)->type == STRING) -#define characterp(x) ((x) != NULL && (x)->type == CHARACTER) -#define arrayp(x) ((x) != NULL && (x)->type == ARRAY) -#define streamp(x) ((x) != NULL && (x)->type == STREAM) - -#define mark(x) (car(x) = (object *)(((uintptr_t)(car(x))) | MARKBIT)) -#define unmark(x) (car(x) = (object *)(((uintptr_t)(car(x))) & ~MARKBIT)) -#define marked(x) ((((uintptr_t)(car(x))) & MARKBIT) != 0) -#define MARKBIT 1 - -#define setflag(x) (Flags = Flags | 1<<(x)) -#define clrflag(x) (Flags = Flags & ~(1<<(x))) -#define tstflag(x) (Flags & 1<<(x)) - -#define issp(x) (x == ' ' || x == '\n' || x == '\r' || x == '\t') -#define isbr(x) (x == ')' || x == '(' || x == '"' || x == '#') -#define longsymbolp(x) (((x)->name & 0x03) == 0) -#define twist(x) ((uint32_t)((x)<<2) | (((x) & 0xC0000000)>>30)) -#define untwist(x) (((x)>>2 & 0x3FFFFFFF) | ((x) & 0x03)<<30) -#define arraysize(x) (sizeof(x) / sizeof(x[0])) -#define PACKEDS 0x43238000 -#define BUILTINS 0xF4240000 -#define ENDFUNCTIONS 1536 - -// Constants - -const int TRACEMAX = 3; // Number of traced functions -enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; // ARRAY STRING and PAIR must be last -enum token { UNUSED, BRA, KET, QUO, DOT }; -enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM }; -enum fntypes_t { OTHER_FORMS, TAIL_FORMS, FUNCTIONS, SPECIAL_FORMS }; - -// Stream names used by printobject -const char serialstream[] PROGMEM = "serial"; -const char i2cstream[] PROGMEM = "i2c"; -const char spistream[] PROGMEM = "spi"; -const char sdstream[] PROGMEM = "sd"; -const char wifistream[] PROGMEM = "wifi"; -const char stringstream[] PROGMEM = "string"; -const char gfxstream[] PROGMEM = "gfx"; -PGM_P const streamname[] PROGMEM = {serialstream, i2cstream, spistream, sdstream, wifistream, stringstream, gfxstream}; - -// Typedefs - -typedef uint32_t symbol_t; - -typedef struct sobject { - union { - struct { - sobject *car; - sobject *cdr; - }; - struct { - unsigned int type; - union { - symbol_t name; - int integer; - int chars; // For strings - float single_float; - }; - }; - }; -} object; - -typedef object *(*fn_ptr_type)(object *, object *); -typedef void (*mapfun_t)(object *, object **); - -typedef const struct { - PGM_P string; - fn_ptr_type fptr; - uint8_t minmax; - const char *doc; -} tbl_entry_t; - -typedef int (*gfun_t)(); -typedef void (*pfun_t)(char); - -typedef uint16_t builtin_t; - -enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, LET, LETSTAR, -CLOSURE, PSTAR, QUOTE, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, -ANALOGREAD, REGISTER, FORMAT, - }; - -// Global variables - -object Workspace[WORKSPACESIZE] WORDALIGNED; - -jmp_buf toplevel_handler; -jmp_buf *handler = &toplevel_handler; -unsigned int Freespace = 0; -object *Freelist; -unsigned int I2Ccount; -unsigned int TraceFn[TRACEMAX]; -unsigned int TraceDepth[TRACEMAX]; -builtin_t Context; - -object *GlobalEnv; -object *GCStack = NULL; -object *GlobalString; -object *GlobalStringTail; -int GlobalStringIndex = 0; -uint8_t PrintCount = 0; -uint8_t BreakLevel = 0; -char LastChar = 0; -char LastPrint = 0; - -// Flags -enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, NOECHO, MUFFLEERRORS }; -volatile uint8_t Flags = 0b00001; // PRINTREADABLY set by default - -// Forward references -object *tee; -void pfstring (PGM_P s, pfun_t pfun); - -// Error handling - -/* - errorsub - used by all the error routines. - Prints: "Error: 'fname' string", where fname is the name of the Lisp function in which the error occurred. -*/ -void errorsub (symbol_t fname, PGM_P string) { - pfl(pserial); pfstring(PSTR("Error: "), pserial); - if (fname != sym(NIL)) { - pserial('\''); - psymbol(fname, pserial); - pserial('\''); pserial(' '); - } - pfstring(string, pserial); -} - -void errorend () { GCStack = NULL; longjmp(*handler, 1); } - -/* - errorsym - prints an error message and reenters the REPL. - Prints: "Error: 'fname' string: symbol", where fname is the name of the user Lisp function in which the error occurred, - and symbol is the object generating the error. -*/ -void errorsym (symbol_t fname, PGM_P string, object *symbol) { - if (!tstflag(MUFFLEERRORS)) { - errorsub(fname, string); - pserial(':'); pserial(' '); - printobject(symbol, pserial); - pln(pserial); - } - errorend(); -} - -/* - errorsym2 - prints an error message and reenters the REPL. - Prints: "Error: 'fname' string", where fname is the name of the user Lisp function in which the error occurred. -*/ -void errorsym2 (symbol_t fname, PGM_P string) { - if (!tstflag(MUFFLEERRORS)) { - errorsub(fname, string); - pln(pserial); - } - errorend(); -} - -/* - error - prints an error message and reenters the REPL. - Prints: "Error: 'Context' string: symbol", where Context is the name of the built-in Lisp function in which the error occurred, - and symbol is the object generating the error. -*/ -void error (PGM_P string, object *symbol) { - errorsym(sym(Context), string, symbol); -} - -/* - error2 - prints an error message and reenters the REPL. - Prints: "Error: 'Context' string", where Context is the name of the built-in Lisp function in which the error occurred. -*/ -void error2 (PGM_P string) { - errorsym2(sym(Context), string); -} - -/* - formaterr - displays a format error with a ^ pointing to the error -*/ -void formaterr (object *formatstr, PGM_P string, uint8_t p) { - pln(pserial); indent(4, ' ', pserial); printstring(formatstr, pserial); pln(pserial); - indent(p+5, ' ', pserial); pserial('^'); - error2(string); - pln(pserial); - GCStack = NULL; - longjmp(*handler, 1); -} - -// Save space as these are used multiple times -const char notanumber[] PROGMEM = "argument is not a number"; -const char notaninteger[] PROGMEM = "argument is not an integer"; -const char notastring[] PROGMEM = "argument is not a string"; -const char notalist[] PROGMEM = "argument is not a list"; -const char notasymbol[] PROGMEM = "argument is not a symbol"; -const char notproper[] PROGMEM = "argument is not a proper list"; -const char toomanyargs[] PROGMEM = "too many arguments"; -const char toofewargs[] PROGMEM = "too few arguments"; -const char noargument[] PROGMEM = "missing argument"; -const char nostream[] PROGMEM = "missing stream argument"; -const char overflow[] PROGMEM = "arithmetic overflow"; -const char divisionbyzero[] PROGMEM = "division by zero"; -const char indexnegative[] PROGMEM = "index can't be negative"; -const char invalidarg[] PROGMEM = "invalid argument"; -const char invalidkey[] PROGMEM = "invalid keyword"; -const char illegalclause[] PROGMEM = "illegal clause"; -const char invalidpin[] PROGMEM = "invalid pin"; -const char oddargs[] PROGMEM = "odd number of arguments"; -const char indexrange[] PROGMEM = "index out of range"; -const char canttakecar[] PROGMEM = "can't take car"; -const char canttakecdr[] PROGMEM = "can't take cdr"; -const char unknownstreamtype[] PROGMEM = "unknown stream type"; - -// Set up workspace - -/* - initworkspace - initialises the workspace into a linked list of free objects -*/ -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++; - } -} - -/* - myalloc - returns the first object from the linked list of free objects -*/ -object *myalloc () { - if (Freespace == 0) error2(PSTR("no room")); - object *temp = Freelist; - Freelist = cdr(Freelist); - Freespace--; - return temp; -} - -/* - myfree - adds obj to the linked list of free objects. - inline makes gc significantly faster -*/ -inline void myfree (object *obj) { - car(obj) = NULL; - cdr(obj) = Freelist; - Freelist = obj; - Freespace++; -} - -// Make each type of object - -/* - number - make an integer object with value n and return it -*/ -object *number (int n) { - object *ptr = myalloc(); - ptr->type = NUMBER; - ptr->integer = n; - return ptr; -} - -/* - makefloat - make a floating point object with value f and return it -*/ -object *makefloat (float f) { - object *ptr = myalloc(); - ptr->type = FLOAT; - ptr->single_float = f; - return ptr; -} - -/* - character - make a character object with value c and return it -*/ -object *character (uint8_t c) { - object *ptr = myalloc(); - ptr->type = CHARACTER; - ptr->chars = c; - return ptr; -} - -/* - cons - make a cons with arg1 and arg2 return it -*/ -object *cons (object *arg1, object *arg2) { - object *ptr = myalloc(); - ptr->car = arg1; - ptr->cdr = arg2; - return ptr; -} - -/* - symbol - make a symbol object with value name and return it -*/ -object *symbol (symbol_t name) { - object *ptr = myalloc(); - ptr->type = SYMBOL; - ptr->name = name; - return ptr; -} - -/* - bsymbol - make a built-in symbol -*/ -inline object *bsymbol (builtin_t name) { - return intern(twist(name+BUILTINS)); -} - -/* - intern - looks through the workspace for an existing occurrence of symbol name and returns it, - otherwise calls symbol(name) to create a new symbol. -*/ -object *intern (symbol_t name) { - for (int i=0; itype == SYMBOL && obj->name == name) return obj; - } - return symbol(name); -} - -/* - eqsymbols - compares the long string/symbol obj with the string in buffer. -*/ -bool eqsymbols (object *obj, char *buffer) { - object *arg = cdr(obj); - int i = 0; - while (!(arg == NULL && buffer[i] == 0)) { - if (arg == NULL || buffer[i] == 0 || - arg->chars != (buffer[i]<<24 | buffer[i+1]<<16 | buffer[i+2]<<8 | buffer[i+3])) return false; - arg = car(arg); - i = i + 4; - } - return true; -} - -/* - internlong - looks through the workspace for an existing occurrence of the long symbol in buffer and returns it, - otherwise calls lispstring(buffer) to create a new symbol. -*/ -object *internlong (char *buffer) { - for (int i=0; itype == SYMBOL && longsymbolp(obj) && eqsymbols(obj, buffer)) return obj; - } - object *obj = lispstring(buffer); - obj->type = SYMBOL; - return obj; -} - -/* - stream - makes a stream object defined by streamtype and address, and returns it -*/ -object *stream (uint8_t streamtype, uint8_t address) { - object *ptr = myalloc(); - ptr->type = STREAM; - ptr->integer = streamtype<<8 | address; - return ptr; -} - -/* - newstring - makes an empty string object and returns it -*/ -object *newstring () { - object *ptr = myalloc(); - ptr->type = STRING; - ptr->chars = 0; - return ptr; -} - -// Garbage collection - -/* - markobject - recursively marks reachable objects, starting from obj -*/ -void markobject (object *obj) { - MARK: - if (obj == NULL) return; - if (marked(obj)) return; - - object* arg = car(obj); - unsigned int type = obj->type; - mark(obj); - - if (type >= PAIR || type == ZZERO) { // cons - markobject(arg); - obj = cdr(obj); - goto MARK; - } - - if (type == ARRAY) { - obj = cdr(obj); - goto MARK; - } - - if ((type == STRING) || (type == SYMBOL && longsymbolp(obj))) { - obj = cdr(obj); - while (obj != NULL) { - arg = car(obj); - mark(obj); - obj = arg; - } - } -} - -/* - sweep - goes through the workspace freeing objects that have not been marked, - and unmarks marked objects -*/ -void sweep () { - Freelist = NULL; - Freespace = 0; - for (int i=WORKSPACESIZE-1; i>=0; i--) { - object *obj = &Workspace[i]; - if (!marked(obj)) myfree(obj); else unmark(obj); - } -} - -/* - gc - performs garbage collection by calling markobject() on each of the pointers to objects in use, - followed by sweep() to free unused objects. -*/ -void gc (object *form, object *env) { - #if defined(printgcs) - int start = Freespace; - static int GC_Count = 0; - #endif - markobject(tee); - markobject(GlobalEnv); - markobject(GCStack); - markobject(form); - markobject(env); - sweep(); - #if defined(printgcs) - GC_Count++; - pfl(pserial); - pfstring(PSTR("{GC #"), pserial); - pint(GC_Count, pserial); - pfstring(PSTR(": "), pserial); - pint(Freespace - start, pserial); - pfstring(PSTR(" freed}"), pserial); - #endif -} - -// Tracing - -/* - tracing - returns a number between 1 and TRACEMAX if name is being traced, or 0 otherwise -*/ -int tracing (symbol_t name) { - int i = 0; - while (i < TRACEMAX) { - if (TraceFn[i] == name) return i+1; - i++; - } - return 0; -} - -/* - trace - enables tracing of symbol name and adds it to the array TraceFn[]. -*/ -void trace (symbol_t name) { - if (tracing(name)) error(PSTR("already being traced"), symbol(name)); - int i = 0; - while (i < TRACEMAX) { - if (TraceFn[i] == 0) { TraceFn[i] = name; TraceDepth[i] = 0; return; } - i++; - } - error2(PSTR("already tracing 3 functions")); -} - -/* - untrace - disables tracing of symbol name and removes it from the array TraceFn[]. -*/ -void untrace (symbol_t name) { - int i = 0; - while (i < TRACEMAX) { - if (TraceFn[i] == name) { TraceFn[i] = 0; return; } - i++; - } - error(PSTR("not tracing"), symbol(name)); -} - -// Helper functions - -/* - consp - implements Lisp consp -*/ -bool consp (object *x) { - if (x == NULL) return false; - unsigned int type = x->type; - return type >= PAIR || type == ZZERO; -} - -/* - atom - implements Lisp atom -*/ -#define atom(x) (!consp(x)) - -/* - listp - implements Lisp listp -*/ -bool listp (object *x) { - if (x == NULL) return true; - unsigned int type = x->type; - return type >= PAIR || type == ZZERO; -} - -/* - improperp - tests whether x is an improper list -*/ -#define improperp(x) (!listp(x)) - -object *quote (object *arg) { - return cons(bsymbol(QUOTE), cons(arg,NULL)); -} - -// Radix 40 encoding - -/* - builtin - converts a symbol name to builtin -*/ -builtin_t builtin (symbol_t name) { - return (builtin_t)(untwist(name) - BUILTINS); -} - -/* - sym - converts a builtin to a symbol name -*/ -symbol_t sym (builtin_t x) { - return twist(x + BUILTINS); -} - -/* - toradix40 - returns a number from 0 to 39 if the character can be encoded, or -1 otherwise. -*/ -int8_t toradix40 (char ch) { - if (ch == 0) return 0; - if (ch >= '0' && ch <= '9') return ch-'0'+1; - if (ch == '-') return 37; if (ch == '*') return 38; if (ch == '$') return 39; - ch = ch | 0x20; - if (ch >= 'a' && ch <= 'z') return ch-'a'+11; - return -1; // Invalid -} - -/* - fromradix40 - returns the character encoded by the number n. -*/ -char fromradix40 (char n) { - if (n >= 1 && n <= 9) return '0'+n-1; - if (n >= 11 && n <= 36) return 'a'+n-11; - if (n == 37) return '-'; if (n == 38) return '*'; if (n == 39) return '$'; - return 0; -} - -/* - pack40 - packs six radix40-encoded characters from buffer into a 32-bit number and returns it. -*/ -uint32_t pack40 (char *buffer) { - int x = 0; - for (int i=0; i<6; i++) x = x * 40 + toradix40(buffer[i]); - return x; -} - -/* - valid40 - returns true if the symbol in buffer can be encoded as six radix40-encoded characters. -*/ -bool valid40 (char *buffer) { - if (toradix40(buffer[0]) < 11) return false; - for (int i=1; i<6; i++) if (toradix40(buffer[i]) < 0) return false; - return true; -} - -/* - digitvalue - returns the numerical value of a hexadecimal digit, or 16 if invalid. -*/ -int8_t 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; -} - -/* - checkinteger - check that obj is an integer and return it -*/ -int checkinteger (object *obj) { - if (!integerp(obj)) error(notaninteger, obj); - return obj->integer; -} - -/* - checkbitvalue - check that obj is an integer equal to 0 or 1 and return it -*/ -int checkbitvalue (object *obj) { - if (!integerp(obj)) error(notaninteger, obj); - int n = obj->integer; - if (n & ~1) error(PSTR("argument is not a bit value"), obj); - return n; -} - -/* - checkintfloat - check that obj is an integer or floating-point number and return the number -*/ -float checkintfloat (object *obj){ - if (integerp(obj)) return obj->integer; - if (!floatp(obj)) error(notanumber, obj); - return obj->single_float; -} - -/* - checkchar - check that obj is a character and return the character -*/ -int checkchar (object *obj) { - if (!characterp(obj)) error(PSTR("argument is not a character"), obj); - return obj->chars; -} - -/* - checkstring - check that obj is a string -*/ -object *checkstring (object *obj) { - if (!stringp(obj)) error(notastring, obj); - return obj; -} - -int isstream (object *obj){ - if (!streamp(obj)) error(PSTR("not a stream"), obj); - return obj->integer; -} - -int isbuiltin (object *obj, builtin_t n) { - return symbolp(obj) && obj->name == sym(n); -} - -bool builtinp (symbol_t name) { - return (untwist(name) >= BUILTINS); -} - -int checkkeyword (object *obj) { - if (!keywordp(obj)) error(PSTR("argument is not a keyword"), obj); - builtin_t kname = builtin(obj->name); - uint8_t context = getminmax(kname); - if (context != 0 && context != Context) error(invalidkey, obj); - return ((int)lookupfn(kname)); -} - -/* - checkargs - checks that the number of objects in the list args - is within the range specified in the symbol lookup table -*/ -void checkargs (object *args) { - int nargs = listlength(args); - checkminmax(Context, nargs); -} - -/* - eq - implements Lisp eq -*/ -boolean eq (object *arg1, object *arg2) { - if (arg1 == arg2) return true; // Same object - if ((arg1 == nil) || (arg2 == nil)) return false; // Not both values - if (arg1->cdr != arg2->cdr) return false; // Different values - if (symbolp(arg1) && symbolp(arg2)) return true; // Same symbol - if (integerp(arg1) && integerp(arg2)) return true; // Same integer - if (floatp(arg1) && floatp(arg2)) return true; // Same float - if (characterp(arg1) && characterp(arg2)) return true; // Same character - return false; -} - -/* - equal - implements Lisp equal -*/ -boolean equal (object *arg1, object *arg2) { - if (stringp(arg1) && stringp(arg2)) return stringcompare(cons(arg1, cons(arg2, nil)), false, false, true); - if (consp(arg1) && consp(arg2)) return (equal(car(arg1), car(arg2)) && equal(cdr(arg1), cdr(arg2))); - return eq(arg1, arg2); -} - -/* - listlength - returns the length of a list -*/ -int listlength (object *list) { - int length = 0; - while (list != NULL) { - if (improperp(list)) error2(notproper); - list = cdr(list); - length++; - } - return length; -} - -// Mathematical helper functions - -/* - add_floats - used by fn_add - Converts the numbers in args to floats, adds them to fresult, and returns the sum as a Lisp float. -*/ -object *add_floats (object *args, float fresult) { - while (args != NULL) { - object *arg = car(args); - fresult = fresult + checkintfloat(arg); - args = cdr(args); - } - return makefloat(fresult); -} - -/* - subtract_floats - used by fn_subtract with more than one argument - Converts the numbers in args to floats, subtracts them from fresult, and returns the result as a Lisp float. -*/ -object *subtract_floats (object *args, float fresult) { - while (args != NULL) { - object *arg = car(args); - fresult = fresult - checkintfloat(arg); - args = cdr(args); - } - return makefloat(fresult); -} - -/* - negate - used by fn_subtract with one argument - If the result is an integer, and negating it doesn't overflow, keep the result as an integer. - Otherwise convert the result to a float, negate it, and return the result as a Lisp float. -*/ -object *negate (object *arg) { - if (integerp(arg)) { - int result = arg->integer; - if (result == INT_MIN) return makefloat(-result); - else return number(-result); - } else if (floatp(arg)) return makefloat(-(arg->single_float)); - else error(notanumber, arg); - return nil; -} - -/* - multiply_floats - used by fn_multiply - Converts the numbers in args to floats, adds them to fresult, and returns the result as a Lisp float. -*/ -object *multiply_floats (object *args, float fresult) { - while (args != NULL) { - object *arg = car(args); - fresult = fresult * checkintfloat(arg); - args = cdr(args); - } - return makefloat(fresult); -} - -/* - divide_floats - used by fn_divide - Converts the numbers in args to floats, divides fresult by them, and returns the result as a Lisp float. -*/ -object *divide_floats (object *args, float fresult) { - while (args != NULL) { - object *arg = car(args); - float f = checkintfloat(arg); - if (f == 0.0) error2(divisionbyzero); - fresult = fresult / f; - args = cdr(args); - } - return makefloat(fresult); -} - -/* - myround - rounds - Returns t if the argument is a floating-point number. -*/ -int myround (float number) { - return (number >= 0) ? (int)(number + 0.5) : (int)(number - 0.5); -} - -/* - compare - a generic compare function - Used to implement the other comparison functions. - If lt is true the result is true if each argument is less than the next argument. - If gt is true the result is true if each argument is greater than the next argument. - If eq is true the result is true if each argument is equal to the next argument. -*/ -object *compare (object *args, bool lt, bool gt, bool eq) { - object *arg1 = first(args); - args = cdr(args); - while (args != NULL) { - object *arg2 = first(args); - if (integerp(arg1) && integerp(arg2)) { - if (!lt && ((arg1->integer) < (arg2->integer))) return nil; - if (!eq && ((arg1->integer) == (arg2->integer))) return nil; - if (!gt && ((arg1->integer) > (arg2->integer))) return nil; - } else { - if (!lt && (checkintfloat(arg1) < checkintfloat(arg2))) return nil; - if (!eq && (checkintfloat(arg1) == checkintfloat(arg2))) return nil; - if (!gt && (checkintfloat(arg1) > checkintfloat(arg2))) return nil; - } - arg1 = arg2; - args = cdr(args); - } - return tee; -} - -/* - intpower - calculates base to the power exp as an integer -*/ -int intpower (int base, int exp) { - int result = 1; - while (exp) { - if (exp & 1) result = result * base; - exp = exp / 2; - base = base * base; - } - return result; -} - -// Association lists - -/* - assoc - looks for key in an association list and returns the matching pair, or nil if not found -*/ -object *assoc (object *key, object *list) { - while (list != NULL) { - if (improperp(list)) error(notproper, list); - object *pair = first(list); - if (!listp(pair)) error(PSTR("element is not a list"), pair); - if (pair != NULL && eq(key,car(pair))) return pair; - list = cdr(list); - } - return nil; -} - -/* - delassoc - deletes the pair matching key from an association list and returns the key, or nil if not found -*/ -object *delassoc (object *key, object **alist) { - object *list = *alist; - object *prev = NULL; - while (list != NULL) { - object *pair = first(list); - if (eq(key,car(pair))) { - if (prev == NULL) *alist = cdr(list); - else cdr(prev) = cdr(list); - return key; - } - prev = list; - list = cdr(list); - } - return nil; -} - -// Array utilities - -/* - nextpower2 - returns the smallest power of 2 that is equal to or greater than n -*/ -int nextpower2 (int n) { - n--; n |= n >> 1; n |= n >> 2; n |= n >> 4; - n |= n >> 8; n |= n >> 16; n++; - return n<2 ? 2 : n; -} - -/* - buildarray - builds an array with n elements using a tree of size s which must be a power of 2 - The elements are initialised to the default def -*/ -object *buildarray (int n, int s, object *def) { - int s2 = s>>1; - if (s2 == 1) { - if (n == 2) return cons(def, def); - else if (n == 1) return cons(def, NULL); - else return NULL; - } else if (n >= s2) return cons(buildarray(s2, s2, def), buildarray(n - s2, s2, def)); - else return cons(buildarray(n, s2, def), nil); -} - -object *makearray (object *dims, object *def, bool bitp) { - int size = 1; - object *dimensions = dims; - while (dims != NULL) { - int d = car(dims)->integer; - if (d < 0) error2(PSTR("dimension can't be negative")); - size = size * d; - dims = cdr(dims); - } - // Bit array identified by making first dimension negative - if (bitp) { - size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - car(dimensions) = number(-(car(dimensions)->integer)); - } - object *ptr = myalloc(); - ptr->type = ARRAY; - object *tree = nil; - if (size != 0) tree = buildarray(size, nextpower2(size), def); - ptr->cdr = cons(tree, dimensions); - return ptr; -} - -/* - arrayref - returns a pointer to the element specified by index in the array of size s -*/ -object **arrayref (object *array, int index, int size) { - int mask = nextpower2(size)>>1; - object **p = &car(cdr(array)); - while (mask) { - if ((index & mask) == 0) p = &(car(*p)); else p = &(cdr(*p)); - mask = mask>>1; - } - return p; -} - -/* - getarray - gets a pointer to an element in a multi-dimensional array, given a list of the subscripts subs - If the first subscript is negative it's a bit array and bit is set to the bit number -*/ -object **getarray (object *array, object *subs, object *env, int *bit) { - int index = 0, size = 1, s; - *bit = -1; - bool bitp = false; - object *dims = cddr(array); - while (dims != NULL && subs != NULL) { - int d = car(dims)->integer; - if (d < 0) { d = -d; bitp = true; } - if (env) s = checkinteger(eval(car(subs), env)); else s = checkinteger(car(subs)); - if (s < 0 || s >= d) error(PSTR("subscript out of range"), car(subs)); - size = size * d; - index = index * d + s; - dims = cdr(dims); subs = cdr(subs); - } - if (dims != NULL) error2(PSTR("too few subscripts")); - if (subs != NULL) error2(PSTR("too many subscripts")); - if (bitp) { - size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - *bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); - index = index>>(sizeof(int)==4 ? 5 : 4); - } - return arrayref(array, index, size); -} - -/* - rslice - reads a slice of an array recursively -*/ -void rslice (object *array, int size, int slice, object *dims, object *args) { - int d = first(dims)->integer; - for (int i = 0; i < d; i++) { - int index = slice * d + i; - if (!consp(args)) error2(PSTR("initial contents don't match array type")); - if (cdr(dims) == NULL) { - object **p = arrayref(array, index, size); - *p = car(args); - } else rslice(array, size, index, cdr(dims), car(args)); - args = cdr(args); - } -} - -/* - readarray - reads a list structure from args and converts it to a d-dimensional array. - Uses rslice for each of the slices of the array. -*/ -object *readarray (int d, object *args) { - object *list = args; - object *dims = NULL; object *head = NULL; - int size = 1; - for (int i = 0; i < d; i++) { - if (!listp(list)) error2(PSTR("initial contents don't match array type")); - int l = listlength(list); - if (dims == NULL) { dims = cons(number(l), NULL); head = dims; } - else { cdr(dims) = cons(number(l), NULL); dims = cdr(dims); } - size = size * l; - if (list != NULL) list = car(list); - } - object *array = makearray(head, NULL, false); - rslice(array, size, 0, head, args); - return array; -} - -/* - readbitarray - reads an item in the format #*1010101000110 by reading it and returning a list of integers, - and then converting that to a bit array -*/ -object *readbitarray (gfun_t gfun) { - char ch = gfun(); - object *head = NULL; - object *tail = NULL; - while (!issp(ch) && !isbr(ch)) { - if (ch != '0' && ch != '1') error2(PSTR("illegal character in bit array")); - object *cell = cons(number(ch - '0'), NULL); - if (head == NULL) head = cell; - else tail->cdr = cell; - tail = cell; - ch = gfun(); - } - LastChar = ch; - int size = listlength(head); - object *array = makearray(cons(number(size), NULL), number(0), true); - size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - int index = 0; - while (head != NULL) { - object **loc = arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size); - int bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); - *loc = number((((*loc)->integer) & ~(1<integer)<integer; - if (d < 0) d = -d; - for (int i = 0; i < d; i++) { - if (i && spaces) pfun(' '); - int index = slice * d + i; - if (cdr(dims) == NULL) { - if (bitp) pint(((*arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size))->integer)>> - (index & (sizeof(int)==4 ? 0x1F : 0x0F)) & 1, pfun); - else printobject(*arrayref(array, index, size), pfun); - } else { pfun('('); pslice(array, size, index, cdr(dims), pfun, bitp); pfun(')'); } - } -} - -/* - printarray - prints an array in the appropriate Lisp format -*/ -void printarray (object *array, pfun_t pfun) { - object *dimensions = cddr(array); - object *dims = dimensions; - bool bitp = false; - int size = 1, n = 0; - while (dims != NULL) { - int d = car(dims)->integer; - if (d < 0) { bitp = true; d = -d; } - size = size * d; - dims = cdr(dims); n++; - } - if (bitp) size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - pfun('#'); - if (n == 1 && bitp) { pfun('*'); pslice(array, size, -1, dimensions, pfun, bitp); } - else { - if (n > 1) { pint(n, pfun); pfun('A'); } - pfun('('); pslice(array, size, 0, dimensions, pfun, bitp); pfun(')'); - } -} - -// String utilities - -void indent (uint8_t spaces, char ch, pfun_t pfun) { - for (uint8_t i=0; ichars & 0xFFFFFF) == 0) { - (*tail)->chars = (*tail)->chars | ch<<16; return; - } else if (((*tail)->chars & 0xFFFF) == 0) { - (*tail)->chars = (*tail)->chars | ch<<8; return; - } else if (((*tail)->chars & 0xFF) == 0) { - (*tail)->chars = (*tail)->chars | ch; return; - } else { - cell = myalloc(); car(*tail) = cell; - } - car(cell) = NULL; cell->chars = ch<<24; *tail = cell; -} - -/* - copystring - returns a copy of a Lisp string -*/ -object *copystring (object *arg) { - object *obj = newstring(); - object *ptr = obj; - arg = cdr(arg); - while (arg != NULL) { - object *cell = myalloc(); car(cell) = NULL; - if (cdr(obj) == NULL) cdr(obj) = cell; else car(ptr) = cell; - ptr = cell; - ptr->chars = arg->chars; - arg = car(arg); - } - return obj; -} - -/* - readstring - reads characters from an input stream up to delimiter delim - and returns a Lisp string -*/ -object *readstring (uint8_t delim, gfun_t gfun) { - object *obj = newstring(); - object *tail = obj; - int ch = gfun(); - if (ch == -1) return nil; - while ((ch != delim) && (ch != -1)) { - if (ch == '\\') ch = gfun(); - buildstring(ch, &tail); - ch = gfun(); - } - return obj; -} - -/* - stringlength - returns the length of a Lisp string - Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word -*/ -int stringlength (object *form) { - int length = 0; - form = cdr(form); - while (form != NULL) { - int chars = form->chars; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - if (chars>>i & 0xFF) length++; - } - form = car(form); - } - return length; -} - -/* - nthchar - returns the nth character from a Lisp string - Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word -*/ -uint8_t nthchar (object *string, int n) { - object *arg = cdr(string); - int top; - if (sizeof(int) == 4) { top = n>>2; n = 3 - (n&3); } - else { top = n>>1; n = 1 - (n&1); } - for (int i=0; ichars)>>(n*8) & 0xFF; -} - -/* - gstr - reads a character from a string stream -*/ -int gstr () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - char c = nthchar(GlobalString, GlobalStringIndex++); - if (c != 0) return c; - return '\n'; // -1? -} - -/* - pstr - prints a character to a string stream -*/ -void pstr (char c) { - buildstring(c, &GlobalStringTail); -} - -/* - lispstring - converts a C string to a Lisp string -*/ -object *lispstring (char *s) { - object *obj = newstring(); - object *tail = obj; - while(1) { - char ch = *s++; - if (ch == 0) break; - if (ch == '\\') ch = *s++; - buildstring(ch, &tail); - } - return obj; -} - -/* - stringcompare - a generic string compare function - Used to implement the other string comparison functions. - If lt is true the result is true if each argument is less than the next argument. - If gt is true the result is true if each argument is greater than the next argument. - If eq is true the result is true if each argument is equal to the next argument. -*/ -bool stringcompare (object *args, bool lt, bool gt, bool eq) { - object *arg1 = checkstring(first(args)); - object *arg2 = checkstring(second(args)); - arg1 = cdr(arg1); - arg2 = cdr(arg2); - while ((arg1 != NULL) || (arg2 != NULL)) { - if (arg1 == NULL) return lt; - if (arg2 == NULL) return gt; - if (arg1->chars < arg2->chars) return lt; - if (arg1->chars > arg2->chars) return gt; - arg1 = car(arg1); - arg2 = car(arg2); - } - return eq; -} - -/* - documentation - returns the documentation string of a built-in or user-defined function. -*/ -object *documentation (object *arg, object *env) { - if (arg == NULL) return nil; - if (!symbolp(arg)) error(notasymbol, arg); - object *pair = findpair(arg, env); - if (pair != NULL) { - object *val = cdr(pair); - if (listp(val) && first(val)->name == sym(LAMBDA) && cdr(val) != NULL && cddr(val) != NULL) { - if (stringp(third(val))) return third(val); - } - } - symbol_t docname = arg->name; - if (!builtinp(docname)) return nil; - char *docstring = lookupdoc(builtin(docname)); - if (docstring == NULL) return nil; - object *obj = startstring(); - pfstring(docstring, pstr); - return obj; -} - -/* - apropos - finds the user-defined and built-in functions whose names contain the specified string or symbol, - and prints them if print is true, or returns them in a list. -*/ -object *apropos (object *arg, bool print) { - char buf[17], buf2[33]; - char *part = cstring(princtostring(arg), buf, 17); - object *result = cons(NULL, NULL); - object *ptr = result; - // User-defined? - object *globals = GlobalEnv; - while (globals != NULL) { - object *pair = first(globals); - object *var = car(pair); - object *val = cdr(pair); - char *full = cstring(princtostring(var), buf2, 33); - if (strstr(full, part) != NULL) { - if (print) { - printsymbol(var, pserial); pserial(' '); pserial('('); - if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) pfstring(PSTR("user function"), pserial); - else if (consp(val) && car(val)->type == CODE) pfstring(PSTR("code"), pserial); - else pfstring(PSTR("user symbol"), pserial); - pserial(')'); pln(pserial); - } else { - cdr(ptr) = cons(var, NULL); ptr = cdr(ptr); - } - } - globals = cdr(globals); - } - // Built-in? - int entries = tablesize(0) + tablesize(1); - for (int i = 0; i < entries; i++) { - if (findsubstring(part, (builtin_t)i)) { - if (print) { - uint8_t fntype = getminmax(i)>>6; - pbuiltin((builtin_t)i, pserial); pserial(' '); pserial('('); - if (fntype == FUNCTIONS) pfstring(PSTR("function"), pserial); - else if (fntype == SPECIAL_FORMS) pfstring(PSTR("special form"), pserial); - else pfstring(PSTR("symbol/keyword"), pserial); - pserial(')'); pln(pserial); - } else { - cdr(ptr) = cons(bsymbol(i), NULL); ptr = cdr(ptr); - } - } - } - return cdr(result); -} - -/* - cstring - converts a Lisp string to a C string in buffer and returns buffer - Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word -*/ -char *cstring (object *form, char *buffer, int buflen) { - form = cdr(checkstring(form)); - int index = 0; - while (form != NULL) { - int chars = form->integer; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; - if (ch) { - if (index >= buflen-1) error2(PSTR("no room for string")); - buffer[index++] = ch; - } - } - form = car(form); - } - buffer[index] = '\0'; - return buffer; -} - -/* - ipstring - parses an IP address from a Lisp string and returns it as an IPAddress type (uint32_t) - Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word -*/ -uint32_t ipstring (object *form) { - form = cdr(checkstring(form)); - int p = 0; - union { uint32_t ipaddress; uint8_t ipbytes[4]; } ; - ipaddress = 0; - while (form != NULL) { - int chars = form->integer; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; - if (ch) { - if (ch == '.') { p++; if (p > 3) error2(PSTR("illegal IP address")); } - else ipbytes[p] = (ipbytes[p] * 10) + ch - '0'; - } - } - form = car(form); - } - return ipaddress; -} - -// Lookup variable in environment - -object *value (symbol_t n, object *env) { - while (env != NULL) { - object *pair = car(env); - if (pair != NULL && car(pair)->name == n) return pair; - env = cdr(env); - } - return nil; -} - -/* - findpair - returns the (var . value) pair bound to variable var in the local or global environment -*/ -object *findpair (object *var, object *env) { - symbol_t name = var->name; - object *pair = value(name, env); - if (pair == NULL) pair = value(name, GlobalEnv); - return pair; -} - -/* - boundp - tests whether var is bound to a value -*/ -bool boundp (object *var, object *env) { - if (!symbolp(var)) error(notasymbol, var); - return (findpair(var, env) != NULL); -} - -/* - findvalue - returns the value bound to variable var, or gives an error if unbound -*/ -object *findvalue (object *var, object *env) { - object *pair = findpair(var, env); - if (pair == NULL) error(PSTR("unknown variable"), var); - return pair; -} - -// Handling closures - -object *closure (int tc, symbol_t name, object *function, object *args, object **env) { - object *state = car(function); - function = cdr(function); - int trace = 0; - if (name) trace = tracing(name); - if (trace) { - indent(TraceDepth[trace-1]<<1, ' ', pserial); - pint(TraceDepth[trace-1]++, pserial); - pserial(':'); pserial(' '); pserial('('); printsymbol(symbol(name), pserial); - } - object *params = first(function); - if (!listp(params)) errorsym(name, notalist, params); - function = cdr(function); - // Dropframe - if (tc) { - if (*env != NULL && car(*env) == NULL) { - pop(*env); - while (*env != NULL && car(*env) != NULL) pop(*env); - } else push(nil, *env); - } - // Push state - while (consp(state)) { - object *pair = first(state); - push(pair, *env); - state = cdr(state); - } - // Add arguments to environment - bool optional = false; - while (params != NULL) { - object *value; - object *var = first(params); - if (isbuiltin(var, OPTIONAL)) optional = true; - else { - if (consp(var)) { - if (!optional) errorsym(name, PSTR("invalid default value"), var); - if (args == NULL) value = eval(second(var), *env); - else { value = first(args); args = cdr(args); } - var = first(var); - if (!symbolp(var)) errorsym(name, PSTR("illegal optional parameter"), var); - } else if (!symbolp(var)) { - errorsym(name, PSTR("illegal function parameter"), var); - } else if (isbuiltin(var, AMPREST)) { - params = cdr(params); - var = first(params); - value = args; - args = NULL; - } else { - if (args == NULL) { - if (optional) value = nil; - else errorsym2(name, toofewargs); - } else { value = first(args); args = cdr(args); } - } - push(cons(var,value), *env); - if (trace) { pserial(' '); printobject(value, pserial); } - } - params = cdr(params); - } - if (args != NULL) errorsym2(name, toomanyargs); - if (trace) { pserial(')'); pln(pserial); } - // Do an implicit progn - if (tc) push(nil, *env); - return tf_progn(function, *env); -} - -object *apply (object *function, object *args, object *env) { - if (symbolp(function)) { - builtin_t fname = builtin(function->name); - if ((fname < ENDFUNCTIONS) && ((getminmax(fname)>>6) == FUNCTIONS)) { - Context = fname; - checkargs(args); - return ((fn_ptr_type)lookupfn(fname))(args, env); - } else function = eval(function, env); - } - if (consp(function) && isbuiltin(car(function), LAMBDA)) { - object *result = closure(0, sym(NIL), function, args, &env); - return eval(result, env); - } - if (consp(function) && isbuiltin(car(function), CLOSURE)) { - function = cdr(function); - object *result = closure(0, sym(NIL), function, args, &env); - return eval(result, env); - } - error(PSTR("illegal function"), function); - return NULL; -} - -// In-place operations - -/* - place - returns a pointer to an object referenced in the second argument of an - in-place operation such as setf. bit is used to indicate the bit position in a bit array -*/ -object **place (object *args, object *env, int *bit) { - *bit = -1; - if (atom(args)) return &cdr(findvalue(args, env)); - object* function = first(args); - if (symbolp(function)) { - symbol_t sname = function->name; - if (sname == sym(CAR) || sname == sym(FIRST)) { - object *value = eval(second(args), env); - if (!listp(value)) error(canttakecar, value); - return &car(value); - } - if (sname == sym(CDR) || sname == sym(REST)) { - object *value = eval(second(args), env); - if (!listp(value)) error(canttakecdr, value); - return &cdr(value); - } - if (sname == sym(NTH)) { - int index = checkinteger(eval(second(args), env)); - object *list = eval(third(args), env); - if (atom(list)) error(PSTR("second argument to nth is not a list"), list); - while (index > 0) { - list = cdr(list); - if (list == NULL) error2(PSTR("index to nth is out of range")); - index--; - } - return &car(list); - } - if (sname == sym(AREF)) { - object *array = eval(second(args), env); - if (!arrayp(array)) error(PSTR("first argument is not an array"), array); - return getarray(array, cddr(args), env, bit); - } - } - error2(PSTR("illegal place")); - return nil; -} - -// Checked car and cdr - -/* - carx - car with error checking -*/ -object *carx (object *arg) { - if (!listp(arg)) error(canttakecar, arg); - if (arg == nil) return nil; - return car(arg); -} - -/* - cdrx - cdr with error checking -*/ -object *cdrx (object *arg) { - if (!listp(arg)) error(canttakecdr, arg); - if (arg == nil) return nil; - return cdr(arg); -} - -/* - cxxxr - implements a general cxxxr function, - pattern is a sequence of bits 0b1xxx where x is 0 for a and 1 for d. -*/ -object *cxxxr (object *args, uint8_t pattern) { - object *arg = first(args); - while (pattern != 1) { - if ((pattern & 1) == 0) arg = carx(arg); else arg = cdrx(arg); - pattern = pattern>>1; - } - return arg; -} - -// Mapping helper functions - -/* - mapcarfun - function specifying how to combine the results in mapcar -*/ -void mapcarfun (object *result, object **tail) { - object *obj = cons(result,NULL); - cdr(*tail) = obj; *tail = obj; -} - -/* - mapcanfun - function specifying how to combine the results in mapcan -*/ -void mapcanfun (object *result, object **tail) { - if (cdr(*tail) != NULL) error(notproper, *tail); - while (consp(result)) { - cdr(*tail) = result; *tail = result; - result = cdr(result); - } -} - -/* - mapcarcan - function used by marcar and mapcan - It takes the arguments, the env, and a function specifying how the results are combined. -*/ -object *mapcarcan (object *args, object *env, mapfun_t fun) { - object *function = first(args); - args = cdr(args); - object *params = cons(NULL, NULL); - push(params,GCStack); - object *head = cons(NULL, NULL); - push(head,GCStack); - object *tail = head; - // Make parameters - while (true) { - object *tailp = params; - object *lists = args; - while (lists != NULL) { - object *list = car(lists); - if (list == NULL) { - pop(GCStack); pop(GCStack); - return cdr(head); - } - if (improperp(list)) error(notproper, list); - object *obj = cons(first(list),NULL); - car(lists) = cdr(list); - cdr(tailp) = obj; tailp = obj; - lists = cdr(lists); - } - object *result = apply(function, cdr(params), env); - fun(result, &tail); - } -} - -// I2C interface for one port, using Arduino Wire - -void I2Cinit (bool enablePullup) { - (void) enablePullup; - Wire.begin(); -} - -int I2Cread () { - return Wire.read(); -} - -void I2Cwrite (uint8_t data) { - Wire.write(data); -} - -bool I2Cstart (uint8_t address, uint8_t read) { - int ok = true; - if (read == 0) { - Wire.beginTransmission(address); - ok = (Wire.endTransmission(true) == 0); - Wire.beginTransmission(address); - } - else Wire.requestFrom(address, I2Ccount); - return ok; -} - -bool I2Crestart (uint8_t address, uint8_t read) { - int error = (Wire.endTransmission(false) != 0); - if (read == 0) Wire.beginTransmission(address); - else Wire.requestFrom(address, I2Ccount); - return error ? false : true; -} - -void I2Cstop (uint8_t read) { - if (read == 0) Wire.endTransmission(); // Check for error? -} - -// Streams - -inline int spiread () { return SPI.transfer(0); } -inline int serial1read () { while (!Serial1.available()) testescape(); return Serial1.read(); } -#if defined(sdcardsupport) -File SDpfile, SDgfile; -inline int SDread () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - return SDgfile.read(); -} -#endif - -WiFiClient client; -WiFiServer server(80); - -inline int WiFiread () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - return client.read(); -} - -void serialbegin (int address, int baud) { - if (address == 1) Serial1.begin((long)baud*100); - else error(PSTR("port not supported"), number(address)); -} - -void serialend (int address) { - if (address == 1) {Serial1.flush(); Serial1.end(); } -} - -gfun_t gstreamfun (object *args) { - int streamtype = SERIALSTREAM; - int address = 0; - gfun_t gfun = gserial; - if (args != NULL) { - int stream = isstream(first(args)); - streamtype = stream>>8; address = stream & 0xFF; - } - if (streamtype == I2CSTREAM) gfun = (gfun_t)I2Cread; - else if (streamtype == SPISTREAM) gfun = spiread; - else if (streamtype == SERIALSTREAM) { - if (address == 0) gfun = gserial; - else if (address == 1) gfun = serial1read; - } - #if defined(sdcardsupport) - else if (streamtype == SDSTREAM) gfun = (gfun_t)SDread; - #endif - else if (streamtype == WIFISTREAM) gfun = (gfun_t)WiFiread; - else error2(PSTR("unknown stream type")); - return gfun; -} - -inline void spiwrite (char c) { SPI.transfer(c); } -inline void serial1write (char c) { Serial1.write(c); } -inline void WiFiwrite (char c) { client.write(c); } -#if defined(sdcardsupport) -inline void SDwrite (char c) { SDpfile.write(c); } -#endif -#if defined(gfxsupport) -inline void gfxwrite (char c) { tft.write(c); } -#endif - -pfun_t pstreamfun (object *args) { - int streamtype = SERIALSTREAM; - int address = 0; - pfun_t pfun = pserial; - if (args != NULL && first(args) != NULL) { - int stream = isstream(first(args)); - streamtype = stream>>8; address = stream & 0xFF; - } - if (streamtype == I2CSTREAM) pfun = (pfun_t)I2Cwrite; - else if (streamtype == SPISTREAM) pfun = spiwrite; - else if (streamtype == SERIALSTREAM) { - if (address == 0) pfun = pserial; - else if (address == 1) pfun = serial1write; - } - else if (streamtype == STRINGSTREAM) { - pfun = pstr; - } - #if defined(sdcardsupport) - else if (streamtype == SDSTREAM) pfun = (pfun_t)SDwrite; - #endif - #if defined(gfxsupport) - else if (streamtype == GFXSTREAM) pfun = (pfun_t)gfxwrite; - #endif - else if (streamtype == WIFISTREAM) pfun = (pfun_t)WiFiwrite; - else error2(PSTR("unknown stream type")); - return pfun; -} - -// Check pins - -void checkanalogread (int pin) { -#if defined(ESP8266) - if (pin!=17) error(PSTR("invalid pin"), number(pin)); -#elif defined(ESP32) || defined(ARDUINO_ESP32_DEV) - if (!(pin==0 || pin==2 || pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) - error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_FEATHER_ESP32) - if (!(pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) - error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2) || defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) - if (!(pin==8 || (pin>=14 && pin<=18))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ADAFRUIT_QTPY_ESP32S2) - if (!((pin>=5 && pin<=9) || (pin>=16 && pin<=18))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ADAFRUIT_QTPY_ESP32C3) - if (!((pin>=0 && pin<=1) || (pin>=3 && pin<=5))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_FEATHERS2) | defined(ARDUINO_ESP32S2_DEV) - if (!((pin>=1 && pin<=20))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ESP32C3_DEV) - if (!((pin>=0 && pin<=5))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ESP32S3_DEV) - if (!((pin>=1 && pin<=20))) error(PSTR("invalid pin"), number(pin)); -#endif -} - -void checkanalogwrite (int pin) { -#if defined(ESP8266) - if (!(pin>=0 && pin<=16)) error(PSTR("invalid pin"), number(pin)); -#elif defined(ESP32) || defined(ARDUINO_FEATHER_ESP32) || defined(ARDUINO_ESP32_DEV) - if (!(pin>=25 && pin<=26)) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2) || defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) || defined(ARDUINO_ADAFRUIT_QTPY_ESP32S2) || defined(ARDUINO_FEATHERS2) || defined(ARDUINO_ESP32S2_DEV) - if (!(pin>=17 && pin<=18)) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ESP32C3_DEV) | defined(ARDUINO_ESP32S3_DEV) | defined(ARDUINO_ADAFRUIT_QTPY_ESP32C3) - error2(ANALOGWRITE, PSTR("not supported")); -#endif -} - -// Note - -void tone (int pin, int note) { - (void) pin, (void) note; -} - -void noTone (int pin) { - (void) pin; -} - -const int scale[] PROGMEM = {4186,4435,4699,4978,5274,5588,5920,6272,6645,7040,7459,7902}; - -void playnote (int pin, int note, int octave) { - int prescaler = 8 - octave - note/12; - if (prescaler<0 || prescaler>8) error(PSTR("octave out of range"), number(prescaler)); - tone(pin, pgm_read_word(&scale[note%12])>>prescaler); -} - -void nonote (int pin) { - noTone(pin); -} - -// Sleep - -void initsleep () { } - -void doze (int secs) { - delay(1000 * secs); -} - -// Prettyprint - -const int PPINDENT = 2; -const int PPWIDTH = 80; -const int GFXPPWIDTH = 52; // 320 pixel wide screen -int ppwidth = PPWIDTH; - -void pcount (char c) { - if (c == '\n') PrintCount++; - PrintCount++; -} - -/* - atomwidth - calculates the character width of an atom -*/ -uint8_t atomwidth (object *obj) { - PrintCount = 0; - printobject(obj, pcount); - return PrintCount; -} - -uint8_t basewidth (object *obj, uint8_t base) { - PrintCount = 0; - pintbase(obj->integer, base, pcount); - return PrintCount; -} - -bool quoted (object *obj) { - return (consp(obj) && car(obj) != NULL && car(obj)->name == sym(QUOTE) && consp(cdr(obj)) && cddr(obj) == NULL); -} - -int subwidth (object *obj, int w) { - if (atom(obj)) return w - atomwidth(obj); - if (quoted(obj)) obj = car(cdr(obj)); - return subwidthlist(obj, w - 1); -} - -int subwidthlist (object *form, int w) { - while (form != NULL && w >= 0) { - if (atom(form)) return w - (2 + atomwidth(form)); - w = subwidth(car(form), w - 1); - form = cdr(form); - } - return w; -} - -/* - superprint - the main pretty-print subroutine -*/ -void superprint (object *form, int lm, pfun_t pfun) { - if (atom(form)) { - if (symbolp(form) && form->name == sym(NOTHING)) printsymbol(form, pfun); - else printobject(form, pfun); - } - else if (quoted(form)) { pfun('\''); superprint(car(cdr(form)), lm + 1, pfun); } - else if (subwidth(form, ppwidth - lm) >= 0) supersub(form, lm + PPINDENT, 0, pfun); - else supersub(form, lm + PPINDENT, 1, pfun); -} - -/* - supersub - subroutine used by pprint -*/ -void supersub (object *form, int lm, int super, pfun_t pfun) { - int special = 0, separate = 1; - object *arg = car(form); - if (symbolp(arg) && builtinp(arg->name)) { - uint8_t minmax = getminmax(builtin(arg->name)); - if (minmax == 0327 || minmax == 0313) special = 2; // defun, setq, setf, defvar - else if (minmax == 0317 || minmax == 0017 || minmax == 0117 || minmax == 0123) special = 1; - } - while (form != NULL) { - if (atom(form)) { pfstring(PSTR(" . "), pfun); printobject(form, pfun); pfun(')'); return; } - else if (separate) { pfun('('); separate = 0; } - else if (special) { pfun(' '); special--; } - else if (!super) pfun(' '); - else { pln(pfun); indent(lm, ' ', pfun); } - superprint(car(form), lm, pfun); - form = cdr(form); - } - pfun(')'); return; -} - -/* - edit - the Lisp tree editor - Steps through a function definition, editing it a bit at a time, using single-key editing commands. -*/ -object *edit (object *fun) { - while (1) { - if (tstflag(EXITEDITOR)) return fun; - char c = gserial(); - if (c == 'q') setflag(EXITEDITOR); - else if (c == 'b') return fun; - else if (c == 'r') fun = read(gserial); - else if (c == '\n') { pfl(pserial); superprint(fun, 0, pserial); pln(pserial); } - else if (c == 'c') fun = cons(read(gserial), fun); - else if (atom(fun)) pserial('!'); - else if (c == 'd') fun = cons(car(fun), edit(cdr(fun))); - else if (c == 'a') fun = cons(edit(car(fun)), cdr(fun)); - else if (c == 'x') fun = cdr(fun); - else pserial('?'); - } -} - -// Special forms - -object *sp_quote (object *args, object *env) { - (void) env; - checkargs(args); - return first(args); -} - -/* - (or item*) - Evaluates its arguments until one returns non-nil, and returns its value. -*/ -object *sp_or (object *args, object *env) { - while (args != NULL) { - object *val = eval(car(args), env); - if (val != NULL) return val; - args = cdr(args); - } - return nil; -} - -/* - (defun name (parameters) form*) - Defines a function. -*/ -object *sp_defun (object *args, object *env) { - (void) env; - checkargs(args); - object *var = first(args); - if (!symbolp(var)) error(notasymbol, var); - object *val = cons(bsymbol(LAMBDA), cdr(args)); - object *pair = value(var->name, GlobalEnv); - if (pair != NULL) cdr(pair) = val; - else push(cons(var, val), GlobalEnv); - return var; -} - -/* - (defvar variable form) - Defines a global variable. -*/ -object *sp_defvar (object *args, object *env) { - checkargs(args); - object *var = first(args); - if (!symbolp(var)) error(notasymbol, var); - object *val = NULL; - args = cdr(args); - if (args != NULL) { setflag(NOESC); val = eval(first(args), env); clrflag(NOESC); } - object *pair = value(var->name, GlobalEnv); - if (pair != NULL) cdr(pair) = val; - else push(cons(var, val), GlobalEnv); - return var; -} - -/* - (setq symbol value [symbol value]*) - For each pair of arguments assigns the value of the second argument - to the variable specified in the first argument. -*/ -object *sp_setq (object *args, object *env) { - object *arg = nil; - while (args != NULL) { - if (cdr(args) == NULL) error2(oddargs); - object *pair = findvalue(first(args), env); - arg = eval(second(args), env); - cdr(pair) = arg; - args = cddr(args); - } - return arg; -} - -/* - (loop forms*) - Executes its arguments repeatedly until one of the arguments calls (return), - which then causes an exit from the loop. -*/ -object *sp_loop (object *args, object *env) { - object *start = args; - for (;;) { - yield(); - args = start; - while (args != NULL) { - object *result = eval(car(args),env); - if (tstflag(RETURNFLAG)) { - clrflag(RETURNFLAG); - return result; - } - args = cdr(args); - } - } -} - -/* - (return [value]) - Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value. -*/ -object *sp_return (object *args, object *env) { - object *result = eval(tf_progn(args,env), env); - setflag(RETURNFLAG); - return result; -} - -/* - (push item place) - Modifies the value of place, which should be a list, to add item onto the front of the list, - and returns the new list. -*/ -object *sp_push (object *args, object *env) { - int bit; - checkargs(args); - object *item = eval(first(args), env); - object **loc = place(second(args), env, &bit); - push(item, *loc); - return *loc; -} - -/* - (pop place) - Modifies the value of place, which should be a list, to remove its first item, and returns that item. -*/ -object *sp_pop (object *args, object *env) { - int bit; - checkargs(args); - object **loc = place(first(args), env, &bit); - object *result = car(*loc); - pop(*loc); - return result; -} - -// Accessors - -/* - (incf place [number]) - Increments a place, which should have an numeric value, and returns the result. - The third argument is an optional increment which defaults to 1. -*/ -object *sp_incf (object *args, object *env) { - int bit; - checkargs(args); - object **loc = place(first(args), env, &bit); - args = cdr(args); - - object *x = *loc; - object *inc = (args != NULL) ? eval(first(args), env) : NULL; - - if (bit != -1) { - int increment; - if (inc == NULL) increment = 1; else increment = checkbitvalue(inc); - int newvalue = (((*loc)->integer)>>bit & 1) + increment; - - if (newvalue & ~1) error2(PSTR("result is not a bit value")); - *loc = number((((*loc)->integer) & ~(1<integer; - - if (inc == NULL) increment = 1; else increment = inc->integer; - - if (increment < 1) { - if (INT_MIN - increment > value) *loc = makefloat((float)value + (float)increment); - else *loc = number(value + increment); - } else { - if (INT_MAX - increment < value) *loc = makefloat((float)value + (float)increment); - else *loc = number(value + increment); - } - } else error2(notanumber); - return *loc; -} - -/* - (decf place [number]) - Decrements a place, which should have an numeric value, and returns the result. - The third argument is an optional decrement which defaults to 1. -*/ -object *sp_decf (object *args, object *env) { - int bit; - checkargs(args); - object **loc = place(first(args), env, &bit); - args = cdr(args); - - object *x = *loc; - object *dec = (args != NULL) ? eval(first(args), env) : NULL; - - if (bit != -1) { - int decrement; - if (dec == NULL) decrement = 1; else decrement = checkbitvalue(dec); - int newvalue = (((*loc)->integer)>>bit & 1) - decrement; - - if (newvalue & ~1) error2(PSTR("result is not a bit value")); - *loc = number((((*loc)->integer) & ~(1<integer; - - if (dec == NULL) decrement = 1; else decrement = dec->integer; - - if (decrement < 1) { - if (INT_MAX + decrement < value) *loc = makefloat((float)value - (float)decrement); - else *loc = number(value - decrement); - } else { - if (INT_MIN + decrement > value) *loc = makefloat((float)value - (float)decrement); - else *loc = number(value - decrement); - } - } else error2(notanumber); - return *loc; -} - -/* - (setf place value [place value]*) - For each pair of arguments modifies a place to the result of evaluating value. -*/ -object *sp_setf (object *args, object *env) { - int bit; - object *arg = nil; - while (args != NULL) { - if (cdr(args) == NULL) error2(oddargs); - object **loc = place(first(args), env, &bit); - arg = eval(second(args), env); - if (bit == -1) *loc = arg; - else *loc = number((checkinteger(*loc) & ~(1<name); - args = cdr(args); - } - int i = 0; - while (i < TRACEMAX) { - if (TraceFn[i] != 0) args = cons(symbol(TraceFn[i]), args); - i++; - } - return args; -} - -/* - (untrace [function]*) - Turns off tracing of up to TRACEMAX user-defined functions, and returns a list of the functions untraced. - If no functions are specified it untraces all functions. -*/ -object *sp_untrace (object *args, object *env) { - (void) env; - if (args == NULL) { - int i = 0; - while (i < TRACEMAX) { - if (TraceFn[i] != 0) args = cons(symbol(TraceFn[i]), args); - TraceFn[i] = 0; - i++; - } - } else { - while (args != NULL) { - object *var = first(args); - if (!symbolp(var)) error(notasymbol, var); - untrace(var->name); - args = cdr(args); - } - } - return args; -} - -/* - (for-millis ([number]) form*) - Executes the forms and then waits until a total of number milliseconds have elapsed. - Returns the total number of milliseconds taken. -*/ -object *sp_formillis (object *args, object *env) { - if (args == NULL) error2(noargument); - object *param = first(args); - unsigned long start = millis(); - unsigned long now, total = 0; - if (param != NULL) total = checkinteger(eval(first(param), env)); - eval(tf_progn(cdr(args),env), env); - do { - now = millis() - start; - testescape(); - } while (now < total); - if (now <= INT_MAX) return number(now); - return nil; -} - -/* - (time form) - Prints the value returned by the form, and the time taken to evaluate the form - in milliseconds or seconds. -*/ -object *sp_time (object *args, object *env) { - unsigned long start = millis(); - object *result = eval(first(args), env); - unsigned long elapsed = millis() - start; - printobject(result, pserial); - pfstring(PSTR("\nTime: "), pserial); - if (elapsed < 1000) { - pint(elapsed, pserial); - pfstring(PSTR(" ms\n"), pserial); - } else { - elapsed = elapsed+50; - pint(elapsed/1000, pserial); - pserial('.'); pint((elapsed/100)%10, pserial); - pfstring(PSTR(" s\n"), pserial); - } - return bsymbol(NOTHING); -} - -/* - (with-output-to-string (str) form*) - Returns a string containing the output to the stream variable str. -*/ -object *sp_withoutputtostring (object *args, object *env) { - if (args == NULL) error2(noargument); - object *params = first(args); - if (params == NULL) error2(nostream); - object *var = first(params); - object *pair = cons(var, stream(STRINGSTREAM, 0)); - push(pair,env); - object *string = startstring(); - push(string, GCStack); - object *forms = cdr(args); - eval(tf_progn(forms,env), env); - pop(GCStack); - return string; -} - -/* - (with-serial (str port [baud]) form*) - Evaluates the forms with str bound to a serial-stream using port. - The optional baud gives the baud rate divided by 100, default 96. -*/ -object *sp_withserial (object *args, object *env) { - object *params = first(args); - if (params == NULL) error2(nostream); - object *var = first(params); - int address = checkinteger(eval(second(params), env)); - params = cddr(params); - int baud = 96; - if (params != NULL) baud = checkinteger(eval(first(params), env)); - object *pair = cons(var, stream(SERIALSTREAM, address)); - push(pair,env); - serialbegin(address, baud); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); - serialend(address); - return result; -} - -/* - (with-i2c (str [port] address [read-p]) form*) - Evaluates the forms with str bound to an i2c-stream defined by address. - If read-p is nil or omitted the stream is written to, otherwise it specifies the number of bytes - to be read from the stream. The port if specified is ignored. -*/ -object *sp_withi2c (object *args, object *env) { - object *params = first(args); - if (params == NULL) error2(nostream); - object *var = first(params); - int address = checkinteger(eval(second(params), env)); - params = cddr(params); - if (address == 0 && params != NULL) params = cdr(params); // Ignore port - int read = 0; // Write - I2Ccount = 0; - if (params != NULL) { - object *rw = eval(first(params), env); - if (integerp(rw)) I2Ccount = rw->integer; - read = (rw != NULL); - } - I2Cinit(1); // Pullups - object *pair = cons(var, (I2Cstart(address, read)) ? stream(I2CSTREAM, address) : nil); - push(pair,env); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); - I2Cstop(read); - return result; -} - -/* - (with-spi (str pin [clock] [bitorder] [mode]) form*) - Evaluates the forms with str bound to an spi-stream. - The parameters specify the enable pin, clock in kHz (default 4000), - bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0). -*/ -object *sp_withspi (object *args, object *env) { - object *params = first(args); - if (params == NULL) error2(nostream); - object *var = first(params); - params = cdr(params); - if (params == NULL) error2(nostream); - int pin = checkinteger(eval(car(params), env)); - pinMode(pin, OUTPUT); - digitalWrite(pin, HIGH); - params = cdr(params); - int clock = 4000, mode = SPI_MODE0; // Defaults - int bitorder = MSBFIRST; - if (params != NULL) { - clock = checkinteger(eval(car(params), env)); - params = cdr(params); - if (params != NULL) { - bitorder = (checkinteger(eval(car(params), env)) == 0) ? LSBFIRST : MSBFIRST; - params = cdr(params); - if (params != NULL) { - int modeval = checkinteger(eval(car(params), env)); - mode = (modeval == 3) ? SPI_MODE3 : (modeval == 2) ? SPI_MODE2 : (modeval == 1) ? SPI_MODE1 : SPI_MODE0; - } - } - } - object *pair = cons(var, stream(SPISTREAM, pin)); - push(pair,env); - SPI.begin(); - SPI.beginTransaction(SPISettings(((unsigned long)clock * 1000), bitorder, mode)); - digitalWrite(pin, LOW); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); - digitalWrite(pin, HIGH); - SPI.endTransaction(); - return result; -} - -/* - (with-sd-card (str filename [mode]) form*) - Evaluates the forms with str bound to an sd-stream reading from or writing to the file filename. - If mode is omitted the file is read, otherwise 0 means read, 1 write-append, or 2 write-overwrite. -*/ -object *sp_withsdcard (object *args, object *env) { -#if defined(sdcardsupport) - object *params = first(args); - if (params == NULL) error2(nostream); - object *var = first(params); - params = cdr(params); - if (params == NULL) error2(PSTR("no filename specified")); - object *filename = eval(first(params), env); - params = cdr(params); - SD.begin(); - int mode = 0; - if (params != NULL && first(params) != NULL) mode = checkinteger(first(params)); - const char *oflag = FILE_READ; - if (mode == 1) oflag = FILE_APPEND; else if (mode == 2) oflag = FILE_WRITE; - if (mode >= 1) { - char buffer[BUFFERSIZE]; - SDpfile = SD.open(MakeFilename(filename, buffer), oflag); - if (!SDpfile) error2(PSTR("problem writing to SD card or invalid filename")); - } else { - char buffer[BUFFERSIZE]; - SDgfile = SD.open(MakeFilename(filename, buffer), oflag); - if (!SDgfile) error2(PSTR("problem reading from SD card or invalid filename")); - } - object *pair = cons(var, stream(SDSTREAM, 1)); - push(pair,env); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); - if (mode >= 1) SDpfile.close(); else SDgfile.close(); - return result; -#else - (void) args, (void) env; - error2(PSTR("not supported")); - return nil; -#endif -} - -// Tail-recursive forms - -/* - (progn form*) - Evaluates several forms grouped together into a block, and returns the result of evaluating the last form. -*/ -object *tf_progn (object *args, object *env) { - if (args == NULL) return nil; - object *more = cdr(args); - while (more != NULL) { - object *result = eval(car(args),env); - if (tstflag(RETURNFLAG)) return result; - args = more; - more = cdr(args); - } - return car(args); -} - -/* - (if test then [else]) - Evaluates test. If it's non-nil the form then is evaluated and returned; - otherwise the form else is evaluated and returned. -*/ -object *tf_if (object *args, object *env) { - if (args == NULL || cdr(args) == NULL) error2(toofewargs); - if (eval(first(args), env) != nil) return second(args); - args = cddr(args); - return (args != NULL) ? first(args) : nil; -} - -/* - (cond ((test form*) (test form*) ... )) - Each argument is a list consisting of a test optionally followed by one or more forms. - If the test evaluates to non-nil the forms are evaluated, and the last value is returned as the result of the cond. - If the test evaluates to nil, none of the forms are evaluated, and the next argument is processed in the same way. -*/ -object *tf_cond (object *args, object *env) { - while (args != NULL) { - object *clause = first(args); - if (!consp(clause)) error(illegalclause, clause); - object *test = eval(first(clause), env); - object *forms = cdr(clause); - if (test != nil) { - if (forms == NULL) return quote(test); else return tf_progn(forms, env); - } - args = cdr(args); - } - return nil; -} - -/* - (when test form*) - Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned. -*/ -object *tf_when (object *args, object *env) { - if (args == NULL) error2(noargument); - if (eval(first(args), env) != nil) return tf_progn(cdr(args),env); - else return nil; -} - -/* - (unless test form*) - Evaluates the test. If it's nil the forms are evaluated and the last value is returned. -*/ -object *tf_unless (object *args, object *env) { - if (args == NULL) error2(noargument); - if (eval(first(args), env) != nil) return nil; - else return tf_progn(cdr(args),env); -} - -/* - (case keyform ((key form*) (key form*) ... )) - Evaluates a keyform to produce a test key, and then tests this against a series of arguments, - each of which is a list containing a key optionally followed by one or more forms. -*/ -object *tf_case (object *args, object *env) { - object *test = eval(first(args), env); - args = cdr(args); - while (args != NULL) { - object *clause = first(args); - if (!consp(clause)) error(illegalclause, clause); - object *key = car(clause); - object *forms = cdr(clause); - if (consp(key)) { - while (key != NULL) { - if (eq(test,car(key))) return tf_progn(forms, env); - key = cdr(key); - } - } else if (eq(test,key) || eq(key,tee)) return tf_progn(forms, env); - args = cdr(args); - } - return nil; -} - -/* - (and item*) - Evaluates its arguments until one returns nil, and returns the last value. -*/ -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); -} - -// Core functions - -/* - (not item) - Returns t if its argument is nil, or nil otherwise. Equivalent to null. -*/ -object *fn_not (object *args, object *env) { - (void) env; - return (first(args) == nil) ? tee : nil; -} - -/* - (cons item item) - If the second argument is a list, cons returns a new list with item added to the front of the list. - If the second argument isn't a list cons returns a dotted pair. -*/ -object *fn_cons (object *args, object *env) { - (void) env; - return cons(first(args), second(args)); -} - -/* - (atom item) - Returns t if its argument is a single number, symbol, or nil. -*/ -object *fn_atom (object *args, object *env) { - (void) env; - return atom(first(args)) ? tee : nil; -} - -/* - (listp item) - Returns t if its argument is a list. -*/ -object *fn_listp (object *args, object *env) { - (void) env; - return listp(first(args)) ? tee : nil; -} - -/* - (consp item) - Returns t if its argument is a non-null list. -*/ -object *fn_consp (object *args, object *env) { - (void) env; - return consp(first(args)) ? tee : nil; -} - -/* - (symbolp item) - Returns t if its argument is a symbol. -*/ -object *fn_symbolp (object *args, object *env) { - (void) env; - object *arg = first(args); - return (arg == NULL || symbolp(arg)) ? tee : nil; -} - -/* - (arrayp item) - Returns t if its argument is an array. -*/ -object *fn_arrayp (object *args, object *env) { - (void) env; - return arrayp(first(args)) ? tee : nil; -} - -/* - (boundp item) - Returns t if its argument is a symbol with a value. -*/ -object *fn_boundp (object *args, object *env) { - return boundp(first(args), env) ? tee : nil; -} - -/* - (keywordp item) - Returns t if its argument is a keyword. -*/ -object *fn_keywordp (object *args, object *env) { - (void) env; - return keywordp(first(args)) ? tee : nil; -} - -/* - (set symbol value [symbol value]*) - For each pair of arguments, assigns the value of the second argument to the value of the first argument. -*/ -object *fn_setfn (object *args, object *env) { - object *arg = nil; - while (args != NULL) { - if (cdr(args) == NULL) error2(oddargs); - object *pair = findvalue(first(args), env); - arg = second(args); - cdr(pair) = arg; - args = cddr(args); - } - return arg; -} - -/* - (streamp item) - Returns t if its argument is a stream. -*/ -object *fn_streamp (object *args, object *env) { - (void) env; - object *arg = first(args); - return streamp(arg) ? tee : nil; -} - -/* - (eq item item) - Tests whether the two arguments are the same symbol, same character, equal numbers, - or point to the same cons, and returns t or nil as appropriate. -*/ -object *fn_eq (object *args, object *env) { - (void) env; - return eq(first(args), second(args)) ? tee : nil; -} - -/* - (equal item item) - Tests whether the two arguments are the same symbol, same character, equal numbers, - or point to the same cons, and returns t or nil as appropriate. -*/ -object *fn_equal (object *args, object *env) { - (void) env; - return equal(first(args), second(args)) ? tee : nil; -} - -// List functions - -/* - (car list) - Returns the first item in a list. -*/ -object *fn_car (object *args, object *env) { - (void) env; - return carx(first(args)); -} - -/* - (cdr list) - Returns a list with the first item removed. -*/ -object *fn_cdr (object *args, object *env) { - (void) env; - return cdrx(first(args)); -} - -/* - (caar list) -*/ -object *fn_caar (object *args, object *env) { - (void) env; - return cxxxr(args, 0b100); -} - -/* - (cadr list) -*/ -object *fn_cadr (object *args, object *env) { - (void) env; - return cxxxr(args, 0b101); -} - -/* - (cdar list) - Equivalent to (cdr (car list)). -*/ -object *fn_cdar (object *args, object *env) { - (void) env; - return cxxxr(args, 0b110); -} - -/* - (cddr list) - Equivalent to (cdr (cdr list)). -*/ -object *fn_cddr (object *args, object *env) { - (void) env; - return cxxxr(args, 0b111); -} - -/* - (caaar list) - Equivalent to (car (car (car list))). -*/ -object *fn_caaar (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1000); -} - -/* - (caadr list) - Equivalent to (car (car (cdar list))). -*/ -object *fn_caadr (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1001);; -} - -/* - (cadar list) - Equivalent to (car (cdr (car list))). -*/ -object *fn_cadar (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1010); -} - -/* - (caddr list) - Equivalent to (car (cdr (cdr list))). -*/ -object *fn_caddr (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1011); -} - -/* - (cdaar list) - Equivalent to (cdar (car (car list))). -*/ -object *fn_cdaar (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1100); -} - -/* - (cdadr list) - Equivalent to (cdr (car (cdr list))). -*/ -object *fn_cdadr (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1101); -} - -/* - (cddar list) - Equivalent to (cdr (cdr (car list))). -*/ -object *fn_cddar (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1110); -} - -/* - (cdddr list) - Equivalent to (cdr (cdr (cdr list))). -*/ -object *fn_cdddr (object *args, object *env) { - (void) env; - return cxxxr(args, 0b1111); -} - -/* - (length item) - Returns the number of items in a list, the length of a string, or the length of a one-dimensional array. -*/ -object *fn_length (object *args, object *env) { - (void) env; - object *arg = first(args); - if (listp(arg)) return number(listlength(arg)); - if (stringp(arg)) return number(stringlength(arg)); - if (!(arrayp(arg) && cdr(cddr(arg)) == NULL)) error(PSTR("argument is not a list, 1d array, or string"), arg); - return number(abs(first(cddr(arg))->integer)); -} - -/* - (array-dimensions item) - Returns a list of the dimensions of an array. -*/ -object *fn_arraydimensions (object *args, object *env) { - (void) env; - object *array = first(args); - if (!arrayp(array)) error(PSTR("argument is not an array"), array); - object *dimensions = cddr(array); - return (first(dimensions)->integer < 0) ? cons(number(-(first(dimensions)->integer)), cdr(dimensions)) : dimensions; -} - -/* - (list item*) - Returns a list of the values of its arguments. -*/ -object *fn_list (object *args, object *env) { - (void) env; - return args; -} - -/* - (make-array size [:initial-element element] [:element-type 'bit]) - If size is an integer it creates a one-dimensional array with elements from 0 to size-1. - If size is a list of n integers it creates an n-dimensional array with those dimensions. - If :element-type 'bit is specified the array is a bit array. -*/ -object *fn_makearray (object *args, object *env) { - (void) env; - object *def = nil; - bool bitp = false; - object *dims = first(args); - if (dims == NULL) error2(PSTR("dimensions can't be nil")); - else if (atom(dims)) dims = cons(dims, NULL); - args = cdr(args); - while (args != NULL && cdr(args) != NULL) { - object *var = first(args); - if (isbuiltin(first(args), INITIALELEMENT)) def = second(args); - else if (isbuiltin(first(args), ELEMENTTYPE) && isbuiltin(second(args), BIT)) bitp = true; - else error(PSTR("argument not recognised"), var); - args = cddr(args); - } - if (bitp) { - if (def == nil) def = number(0); - else def = number(-checkbitvalue(def)); // 1 becomes all ones - } - return makearray(dims, def, bitp); -} - -/* - (reverse list) - Returns a list with the elements of list in reverse order. -*/ -object *fn_reverse (object *args, object *env) { - (void) env; - object *list = first(args); - object *result = NULL; - while (list != NULL) { - if (improperp(list)) error(notproper, list); - push(first(list),result); - list = cdr(list); - } - return result; -} - -/* - (nth number list) - Returns the nth item in list, counting from zero. -*/ -object *fn_nth (object *args, object *env) { - (void) env; - int n = checkinteger(first(args)); - if (n < 0) error(indexnegative, first(args)); - object *list = second(args); - while (list != NULL) { - if (improperp(list)) error(notproper, list); - if (n == 0) return car(list); - list = cdr(list); - n--; - } - return nil; -} - -/* - (aref array index [index*]) - Returns an element from the specified array. -*/ -object *fn_aref (object *args, object *env) { - (void) env; - int bit; - object *array = first(args); - if (!arrayp(array)) error(PSTR("first argument is not an array"), array); - object *loc = *getarray(array, cdr(args), 0, &bit); - if (bit == -1) return loc; - else return number((loc->integer)>>bit & 1); -} - -/* - (assoc key list) - Looks up a key in an association list of (key . value) pairs, - and returns the matching pair, or nil if no pair is found. -*/ -object *fn_assoc (object *args, object *env) { - (void) env; - object *key = first(args); - object *list = second(args); - return assoc(key,list); -} - -/* - (member item list) - Searches for an item in a list, using eq, and returns the list starting from the first occurrence of the item, - or nil if it is not found. -*/ -object *fn_member (object *args, object *env) { - (void) env; - object *item = first(args); - object *list = second(args); - while (list != NULL) { - if (improperp(list)) error(notproper, list); - if (eq(item,car(list))) return list; - list = cdr(list); - } - return nil; -} - -/* - (apply function list) - Returns the result of evaluating function, with the list of arguments specified by the second parameter. -*/ -object *fn_apply (object *args, object *env) { - object *previous = NULL; - object *last = args; - while (cdr(last) != NULL) { - previous = last; - last = cdr(last); - } - object *arg = car(last); - if (!listp(arg)) error(notalist, arg); - cdr(previous) = arg; - return apply(first(args), cdr(args), env); -} - -/* - (funcall function argument*) - Evaluates function with the specified arguments. -*/ -object *fn_funcall (object *args, object *env) { - return apply(first(args), cdr(args), env); -} - -/* - (append list*) - Joins its arguments, which should be lists, into a single list. -*/ -object *fn_append (object *args, object *env) { - (void) env; - object *head = NULL; - object *tail; - while (args != NULL) { - object *list = first(args); - if (!listp(list)) error(notalist, list); - while (consp(list)) { - object *obj = cons(car(list), cdr(list)); - if (head == NULL) head = obj; - else cdr(tail) = obj; - tail = obj; - list = cdr(list); - if (cdr(args) != NULL && improperp(list)) error(notproper, first(args)); - } - args = cdr(args); - } - return head; -} - -/* - (mapc function list1 [list]*) - Applies the function to each element in one or more lists, ignoring the results. - It returns the first list argument. -*/ -object *fn_mapc (object *args, object *env) { - object *function = first(args); - args = cdr(args); - object *result = first(args); - push(result,GCStack); - object *params = cons(NULL, NULL); - push(params,GCStack); - // Make parameters - while (true) { - object *tailp = params; - object *lists = args; - while (lists != NULL) { - object *list = car(lists); - if (list == NULL) { - pop(GCStack); pop(GCStack); - return result; - } - if (improperp(list)) error(notproper, list); - object *obj = cons(first(list),NULL); - car(lists) = cdr(list); - cdr(tailp) = obj; tailp = obj; - lists = cdr(lists); - } - apply(function, cdr(params), env); - } -} - -/* - (mapcar function list1 [list]*) - Applies the function to each element in one or more lists, and returns the resulting list. -*/ -object *fn_mapcar (object *args, object *env) { - return mapcarcan(args, env, mapcarfun); -} - -/* - (mapcan function list1 [list]*) - Applies the function to each element in one or more lists. The results should be lists, - and these are appended together to give the value returned. -*/ -object *fn_mapcan (object *args, object *env) { - return mapcarcan(args, env, mapcanfun); -} - -// Arithmetic functions - -/* - (+ number*) - Adds its arguments together. - If each argument is an integer, and the running total doesn't overflow, the result is an integer, - otherwise a floating-point number. -*/ -object *fn_add (object *args, object *env) { - (void) env; - int result = 0; - while (args != NULL) { - object *arg = car(args); - if (floatp(arg)) return add_floats(args, (float)result); - else if (integerp(arg)) { - int val = arg->integer; - if (val < 1) { if (INT_MIN - val > result) return add_floats(args, (float)result); } - else { if (INT_MAX - val < result) return add_floats(args, (float)result); } - result = result + val; - } else error(notanumber, arg); - args = cdr(args); - } - return number(result); -} - -/* - (- number*) - If there is one argument, negates the argument. - If there are two or more arguments, subtracts the second and subsequent arguments from the first argument. - If each argument is an integer, and the running total doesn't overflow, returns the result as an integer, - otherwise a floating-point number. -*/ -object *fn_subtract (object *args, object *env) { - (void) env; - object *arg = car(args); - args = cdr(args); - if (args == NULL) return negate(arg); - else if (floatp(arg)) return subtract_floats(args, arg->single_float); - else if (integerp(arg)) { - int result = arg->integer; - while (args != NULL) { - arg = car(args); - if (floatp(arg)) return subtract_floats(args, result); - else if (integerp(arg)) { - int val = (car(args))->integer; - if (val < 1) { if (INT_MAX + val < result) return subtract_floats(args, result); } - else { if (INT_MIN + val > result) return subtract_floats(args, result); } - result = result - val; - } else error(notanumber, arg); - args = cdr(args); - } - return number(result); - } else error(notanumber, arg); - return nil; -} - -/* - (* number*) - Multiplies its arguments together. - If each argument is an integer, and the running total doesn't overflow, the result is an integer, - otherwise it's a floating-point number. -*/ -object *fn_multiply (object *args, object *env) { - (void) env; - int result = 1; - while (args != NULL){ - object *arg = car(args); - if (floatp(arg)) return multiply_floats(args, result); - else if (integerp(arg)) { - int64_t val = result * (int64_t)(arg->integer); - if ((val > INT_MAX) || (val < INT_MIN)) return multiply_floats(args, result); - result = val; - } else error(notanumber, arg); - args = cdr(args); - } - return number(result); -} - -/* - (/ number*) - Divides the first argument by the second and subsequent arguments. - If each argument is an integer, and each division produces an exact result, the result is an integer; - otherwise it's a floating-point number. -*/ -object *fn_divide (object *args, object *env) { - (void) env; - object* arg = first(args); - args = cdr(args); - // One argument - if (args == NULL) { - if (floatp(arg)) { - float f = arg->single_float; - if (f == 0.0) error2(PSTR("division by zero")); - return makefloat(1.0 / f); - } else if (integerp(arg)) { - int i = arg->integer; - if (i == 0) error2(PSTR("division by zero")); - else if (i == 1) return number(1); - else return makefloat(1.0 / i); - } else error(notanumber, arg); - } - // Multiple arguments - if (floatp(arg)) return divide_floats(args, arg->single_float); - else if (integerp(arg)) { - int result = arg->integer; - while (args != NULL) { - arg = car(args); - if (floatp(arg)) { - return divide_floats(args, result); - } else if (integerp(arg)) { - int i = arg->integer; - if (i == 0) error2(PSTR("division by zero")); - if ((result % i) != 0) return divide_floats(args, result); - if ((result == INT_MIN) && (i == -1)) return divide_floats(args, result); - result = result / i; - args = cdr(args); - } else error(notanumber, arg); - } - return number(result); - } else error(notanumber, arg); - return nil; -} - -/* - (mod number number) - Returns its first argument modulo the second argument. - If both arguments are integers the result is an integer; otherwise it's a floating-point number. -*/ -object *fn_mod (object *args, object *env) { - (void) env; - object *arg1 = first(args); - object *arg2 = second(args); - if (integerp(arg1) && integerp(arg2)) { - int divisor = arg2->integer; - if (divisor == 0) error2(PSTR("division by zero")); - int dividend = arg1->integer; - int remainder = dividend % divisor; - if ((dividend<0) != (divisor<0)) remainder = remainder + divisor; - return number(remainder); - } else { - float fdivisor = checkintfloat(arg2); - if (fdivisor == 0.0) error2(PSTR("division by zero")); - float fdividend = checkintfloat(arg1); - float fremainder = fmod(fdividend , fdivisor); - if ((fdividend<0) != (fdivisor<0)) fremainder = fremainder + fdivisor; - return makefloat(fremainder); - } -} - -/* - (1+ number) - Adds one to its argument and returns it. - If the argument is an integer the result is an integer if possible; - otherwise it's a floating-point number. -*/ -object *fn_oneplus (object *args, object *env) { - (void) env; - object* arg = first(args); - if (floatp(arg)) return makefloat((arg->single_float) + 1.0); - else if (integerp(arg)) { - int result = arg->integer; - if (result == INT_MAX) return makefloat((arg->integer) + 1.0); - else return number(result + 1); - } else error(notanumber, arg); - return nil; -} - -/* - (1- number) - Subtracts one from its argument and returns it. - If the argument is an integer the result is an integer if possible; - otherwise it's a floating-point number. -*/ -object *fn_oneminus (object *args, object *env) { - (void) env; - object* arg = first(args); - if (floatp(arg)) return makefloat((arg->single_float) - 1.0); - else if (integerp(arg)) { - int result = arg->integer; - if (result == INT_MIN) return makefloat((arg->integer) - 1.0); - else return number(result - 1); - } else error(notanumber, arg); - return nil; -} - -/* - (abs number) - Returns the absolute, positive value of its argument. - If the argument is an integer the result will be returned as an integer if possible, - otherwise a floating-point number. -*/ -object *fn_abs (object *args, object *env) { - (void) env; - object *arg = first(args); - if (floatp(arg)) return makefloat(abs(arg->single_float)); - else if (integerp(arg)) { - int result = arg->integer; - if (result == INT_MIN) return makefloat(abs((float)result)); - else return number(abs(result)); - } else error(notanumber, arg); - return nil; -} - -/* - (random number) - If number is an integer returns a random number between 0 and one less than its argument. - Otherwise returns a floating-point number between zero and number. -*/ -object *fn_random (object *args, object *env) { - (void) env; - object *arg = first(args); - if (integerp(arg)) return number(random(arg->integer)); - else if (floatp(arg)) return makefloat((float)rand()/(float)(RAND_MAX/(arg->single_float))); - else error(notanumber, arg); - return nil; -} - -/* - (max number*) - Returns the maximum of one or more arguments. -*/ -object *fn_maxfn (object *args, object *env) { - (void) env; - object* result = first(args); - args = cdr(args); - while (args != NULL) { - object *arg = car(args); - if (integerp(result) && integerp(arg)) { - if ((arg->integer) > (result->integer)) result = arg; - } else if ((checkintfloat(arg) > checkintfloat(result))) result = arg; - args = cdr(args); - } - return result; -} - -/* - (min number*) - Returns the minimum of one or more arguments. -*/ -object *fn_minfn (object *args, object *env) { - (void) env; - object* result = first(args); - args = cdr(args); - while (args != NULL) { - object *arg = car(args); - if (integerp(result) && integerp(arg)) { - if ((arg->integer) < (result->integer)) result = arg; - } else if ((checkintfloat(arg) < checkintfloat(result))) result = arg; - args = cdr(args); - } - return result; -} - -// Arithmetic comparisons - -/* - (/= number*) - Returns t if none of the arguments are equal, or nil if two or more arguments are equal. -*/ -object *fn_noteq (object *args, object *env) { - (void) env; - while (args != NULL) { - object *nargs = args; - object *arg1 = first(nargs); - nargs = cdr(nargs); - while (nargs != NULL) { - object *arg2 = first(nargs); - if (integerp(arg1) && integerp(arg2)) { - if ((arg1->integer) == (arg2->integer)) return nil; - } else if ((checkintfloat(arg1) == checkintfloat(arg2))) return nil; - nargs = cdr(nargs); - } - args = cdr(args); - } - return tee; -} - -/* - (= number*) - Returns t if all the arguments, which must be numbers, are numerically equal, and nil otherwise. -*/ -object *fn_numeq (object *args, object *env) { - (void) env; - return compare(args, false, false, true); -} - -/* - (< number*) - Returns t if each argument is less than the next argument, and nil otherwise. -*/ -object *fn_less (object *args, object *env) { - (void) env; - return compare(args, true, false, false); -} - -/* - (<= number*) - Returns t if each argument is less than or equal to the next argument, and nil otherwise. -*/ -object *fn_lesseq (object *args, object *env) { - (void) env; - return compare(args, true, false, true); -} - -/* - (> number*) - Returns t if each argument is greater than the next argument, and nil otherwise. -*/ -object *fn_greater (object *args, object *env) { - (void) env; - return compare(args, false, true, false); -} - -/* - (>= number*) - Returns t if each argument is greater than or equal to the next argument, and nil otherwise. -*/ -object *fn_greatereq (object *args, object *env) { - (void) env; - return compare(args, false, true, true); -} - -/* - (plusp number) - Returns t if the argument is greater than zero, or nil otherwise. -*/ -object *fn_plusp (object *args, object *env) { - (void) env; - object *arg = first(args); - if (floatp(arg)) return ((arg->single_float) > 0.0) ? tee : nil; - else if (integerp(arg)) return ((arg->integer) > 0) ? tee : nil; - else error(notanumber, arg); - return nil; -} - -/* - (minusp number) - Returns t if the argument is less than zero, or nil otherwise. -*/ -object *fn_minusp (object *args, object *env) { - (void) env; - object *arg = first(args); - if (floatp(arg)) return ((arg->single_float) < 0.0) ? tee : nil; - else if (integerp(arg)) return ((arg->integer) < 0) ? tee : nil; - else error(notanumber, arg); - return nil; -} - -/* - (zerop number) - Returns t if the argument is zero. -*/ -object *fn_zerop (object *args, object *env) { - (void) env; - object *arg = first(args); - if (floatp(arg)) return ((arg->single_float) == 0.0) ? tee : nil; - else if (integerp(arg)) return ((arg->integer) == 0) ? tee : nil; - else error(notanumber, arg); - return nil; -} - -/* - (oddp number) - Returns t if the integer argument is odd. -*/ -object *fn_oddp (object *args, object *env) { - (void) env; - int arg = checkinteger(first(args)); - return ((arg & 1) == 1) ? tee : nil; -} - -/* - (evenp number) - Returns t if the integer argument is even. -*/ -object *fn_evenp (object *args, object *env) { - (void) env; - int arg = checkinteger(first(args)); - return ((arg & 1) == 0) ? tee : nil; -} - -// Number functions - -/* - (integerp number) - Returns t if the argument is an integer. -*/ -object *fn_integerp (object *args, object *env) { - (void) env; - return integerp(first(args)) ? tee : nil; -} - -/* - (numberp number) - Returns t if the argument is a number. -*/ -object *fn_numberp (object *args, object *env) { - (void) env; - object *arg = first(args); - return (integerp(arg) || floatp(arg)) ? tee : nil; -} - -// Floating-point functions - -/* - (float number) - Returns its argument converted to a floating-point number. -*/ -object *fn_floatfn (object *args, object *env) { - (void) env; - object *arg = first(args); - return (floatp(arg)) ? arg : makefloat((float)(arg->integer)); -} - -/* - (floatp number) - Returns t if the argument is a floating-point number. -*/ -object *fn_floatp (object *args, object *env) { - (void) env; - return floatp(first(args)) ? tee : nil; -} - -/* - (sin number) - Returns sin(number). -*/ -object *fn_sin (object *args, object *env) { - (void) env; - return makefloat(sin(checkintfloat(first(args)))); -} - -/* - (cos number) - Returns cos(number). -*/ -object *fn_cos (object *args, object *env) { - (void) env; - return makefloat(cos(checkintfloat(first(args)))); -} - -/* - (tan number) - Returns tan(number). -*/ -object *fn_tan (object *args, object *env) { - (void) env; - return makefloat(tan(checkintfloat(first(args)))); -} - -/* - (asin number) - Returns asin(number). -*/ -object *fn_asin (object *args, object *env) { - (void) env; - return makefloat(asin(checkintfloat(first(args)))); -} - -/* - (acos number) - Returns acos(number). -*/ -object *fn_acos (object *args, object *env) { - (void) env; - return makefloat(acos(checkintfloat(first(args)))); -} - -/* - (atan number1 [number2]) - Returns the arc tangent of number1/number2, in radians. If number2 is omitted it defaults to 1. -*/ -object *fn_atan (object *args, object *env) { - (void) env; - object *arg = first(args); - float div = 1.0; - args = cdr(args); - if (args != NULL) div = checkintfloat(first(args)); - return makefloat(atan2(checkintfloat(arg), div)); -} - -/* - (sinh number) - Returns sinh(number). -*/ -object *fn_sinh (object *args, object *env) { - (void) env; - return makefloat(sinh(checkintfloat(first(args)))); -} - -/* - (cosh number) - Returns cosh(number). -*/ -object *fn_cosh (object *args, object *env) { - (void) env; - return makefloat(cosh(checkintfloat(first(args)))); -} - -/* - (tanh number) - Returns tanh(number). -*/ -object *fn_tanh (object *args, object *env) { - (void) env; - return makefloat(tanh(checkintfloat(first(args)))); -} - -/* - (exp number) - Returns exp(number). -*/ -object *fn_exp (object *args, object *env) { - (void) env; - return makefloat(exp(checkintfloat(first(args)))); -} - -/* - (sqrt number) - Returns sqrt(number). -*/ -object *fn_sqrt (object *args, object *env) { - (void) env; - return makefloat(sqrt(checkintfloat(first(args)))); -} - -/* - (number [base]) - Returns the logarithm of number to the specified base. If base is omitted it defaults to e. -*/ -object *fn_log (object *args, object *env) { - (void) env; - object *arg = first(args); - float fresult = log(checkintfloat(arg)); - args = cdr(args); - if (args == NULL) return makefloat(fresult); - else return makefloat(fresult / log(checkintfloat(first(args)))); -} - -/* - (expt number power) - Returns number raised to the specified power. - Returns the result as an integer if the arguments are integers and the result will be within range, - otherwise a floating-point number. -*/ -object *fn_expt (object *args, object *env) { - (void) env; - object *arg1 = first(args); object *arg2 = second(args); - float float1 = checkintfloat(arg1); - float value = log(abs(float1)) * checkintfloat(arg2); - if (integerp(arg1) && integerp(arg2) && ((arg2->integer) >= 0) && (abs(value) < 21.4875)) - return number(intpower(arg1->integer, arg2->integer)); - if (float1 < 0) { - if (integerp(arg2)) return makefloat((arg2->integer & 1) ? -exp(value) : exp(value)); - else error2(PSTR("invalid result")); - } - return makefloat(exp(value)); -} - -/* - (ceiling number [divisor]) - Returns ceil(number/divisor). If omitted, divisor is 1. -*/ -object *fn_ceiling (object *args, object *env) { - (void) env; - object *arg = first(args); - args = cdr(args); - if (args != NULL) return number(ceil(checkintfloat(arg) / checkintfloat(first(args)))); - else return number(ceil(checkintfloat(arg))); -} - -/* - (floor number [divisor]) - Returns floor(number/divisor). If omitted, divisor is 1. -*/ -object *fn_floor (object *args, object *env) { - (void) env; - object *arg = first(args); - args = cdr(args); - if (args != NULL) return number(floor(checkintfloat(arg) / checkintfloat(first(args)))); - else return number(floor(checkintfloat(arg))); -} - -/* - (truncate number) - Returns t if the argument is a floating-point number. -*/ -object *fn_truncate (object *args, object *env) { - (void) env; - object *arg = first(args); - args = cdr(args); - if (args != NULL) return number((int)(checkintfloat(arg) / checkintfloat(first(args)))); - else return number((int)(checkintfloat(arg))); -} - -/* - (round number) - Returns t if the argument is a floating-point number. -*/ -object *fn_round (object *args, object *env) { - (void) env; - object *arg = first(args); - args = cdr(args); - if (args != NULL) return number(myround(checkintfloat(arg) / checkintfloat(first(args)))); - else return number(myround(checkintfloat(arg))); -} - -// Characters - -/* - (char string n) - Returns the nth character in a string, counting from zero. -*/ -object *fn_char (object *args, object *env) { - (void) env; - object *arg = first(args); - if (!stringp(arg)) error(notastring, arg); - object *n = second(args); - char c = nthchar(arg, checkinteger(n)); - if (c == 0) error(indexrange, n); - return character(c); -} - -/* - (char-code character) - Returns the ASCII code for a character, as an integer. -*/ -object *fn_charcode (object *args, object *env) { - (void) env; - return number(checkchar(first(args))); -} - -/* - (code-char integer) - Returns the character for the specified ASCII code. -*/ -object *fn_codechar (object *args, object *env) { - (void) env; - return character(checkinteger(first(args))); -} - -/* - (characterp item) - Returns t if the argument is a character and nil otherwise. -*/ -object *fn_characterp (object *args, object *env) { - (void) env; - return characterp(first(args)) ? tee : nil; -} - -// Strings - -/* - (stringp item) - Returns t if the argument is a string and nil otherwise. -*/ -object *fn_stringp (object *args, object *env) { - (void) env; - return stringp(first(args)) ? tee : nil; -} - -/* - (string= string string) - Tests whether two strings are the same. -*/ -object *fn_stringeq (object *args, object *env) { - (void) env; - return stringcompare(args, false, false, true) ? tee : nil; -} - -/* - (string< string string) - Returns t if the first string is alphabetically less than the second string, and nil otherwise. -*/ -object *fn_stringless (object *args, object *env) { - (void) env; - return stringcompare(args, true, false, false) ? tee : nil; -} - -/* - (string> string string) - Returns t if the first string is alphabetically greater than the second string, and nil otherwise. -*/ -object *fn_stringgreater (object *args, object *env) { - (void) env; - return stringcompare(args, false, true, false) ? tee : nil; -} - -/* - (sort list test) - Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list. -*/ -object *fn_sort (object *args, object *env) { - if (first(args) == NULL) return nil; - object *list = cons(nil,first(args)); - push(list,GCStack); - object *predicate = second(args); - object *compare = cons(NULL, cons(NULL, NULL)); - push(compare,GCStack); - object *ptr = cdr(list); - while (cdr(ptr) != NULL) { - object *go = list; - while (go != ptr) { - car(compare) = car(cdr(ptr)); - car(cdr(compare)) = car(cdr(go)); - if (apply(predicate, compare, env)) break; - go = cdr(go); - } - if (go != ptr) { - object *obj = cdr(ptr); - cdr(ptr) = cdr(obj); - cdr(obj) = cdr(go); - cdr(go) = obj; - } else ptr = cdr(ptr); - } - pop(GCStack); pop(GCStack); - return cdr(list); -} - -/* - (string item) - Converts its argument to a string. -*/ -object *fn_stringfn (object *args, object *env) { - return fn_princtostring(args, env); -} - -/* - (concatenate 'string string*) - Joins together the strings given in the second and subsequent arguments, and returns a single string. -*/ -object *fn_concatenate (object *args, object *env) { - (void) env; - object *arg = first(args); - if (builtin(arg->name) != STRINGFN) error2(PSTR("only supports strings")); - args = cdr(args); - object *result = newstring(); - object *tail = result; - while (args != NULL) { - object *obj = checkstring(first(args)); - obj = cdr(obj); - while (obj != NULL) { - int quad = obj->chars; - while (quad != 0) { - char ch = quad>>((sizeof(int)-1)*8) & 0xFF; - buildstring(ch, &tail); - quad = quad<<8; - } - obj = car(obj); - } - args = cdr(args); - } - return result; -} - -/* - (subseq seq start [end]) - Returns a subsequence of a list or string from item start to item end-1. -*/ -object *fn_subseq (object *args, object *env) { - (void) env; - object *arg = first(args); - int start = checkinteger(second(args)), end; - if (start < 0) error(indexnegative, second(args)); - args = cddr(args); - if (listp(arg)) { - int length = listlength(arg); - if (args != NULL) end = checkinteger(car(args)); else end = length; - if (start > end || end > length) error2(indexrange); - object *result = cons(NULL, NULL); - object *ptr = result; - for (int x = 0; x < end; x++) { - if (x >= start) { cdr(ptr) = cons(car(arg), NULL); ptr = cdr(ptr); } - arg = cdr(arg); - } - return cdr(result); - } else if (stringp(arg)) { - int length = stringlength(arg); - if (args != NULL) end = checkinteger(car(args)); else end = length; - if (start > end || end > length) error2(indexrange); - object *result = newstring(); - object *tail = result; - for (int i=start; i= 0) return number(value << count); - else return number(value >> abs(count)); -} - -/* - (logbitp bit value) - Returns t if bit number bit in value is a '1', and nil if it is a '0'. -*/ -object *fn_logbitp (object *args, object *env) { - (void) env; - int index = checkinteger(first(args)); - int value = checkinteger(second(args)); - return (bitRead(value, index) == 1) ? tee : nil; -} - -// System functions - -/* - (eval form*) - Evaluates its argument an extra time. -*/ -object *fn_eval (object *args, object *env) { - return eval(first(args), env); -} - -/* - (globals) - Returns a list of global variables. -*/ -object *fn_globals (object *args, object *env) { - (void) args, (void) env; - object *result = cons(NULL, NULL); - object *ptr = result; - object *arg = GlobalEnv; - while (arg != NULL) { - cdr(ptr) = cons(car(car(arg)), NULL); ptr = cdr(ptr); - arg = cdr(arg); - } - return cdr(result); -} - -/* - (locals) - Returns an association list of local variables and their values. -*/ -object *fn_locals (object *args, object *env) { - (void) args; - return env; -} - -/* - (makunbound symbol) - Removes the value of the symbol from GlobalEnv and returns the symbol. -*/ -object *fn_makunbound (object *args, object *env) { - (void) env; - object *var = first(args); - if (!symbolp(var)) error(notasymbol, var); - delassoc(var, &GlobalEnv); - return var; -} - -/* - (break) - Inserts a breakpoint in the program. When evaluated prints Break! and reenters the REPL. -*/ -object *fn_break (object *args, object *env) { - (void) args; - pfstring(PSTR("\nBreak!\n"), pserial); - BreakLevel++; - repl(env); - BreakLevel--; - return nil; -} - -/* - (read [stream]) - Reads an atom or list from the serial input and returns it. - If stream is specified the item is read from the specified stream. -*/ -object *fn_read (object *args, object *env) { - (void) env; - gfun_t gfun = gstreamfun(args); - return read(gfun); -} - -/* - (prin1 item [stream]) - Prints its argument, and returns its value. - Strings are printed with quotation marks and escape characters. -*/ -object *fn_prin1 (object *args, object *env) { - (void) env; - object *obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - printobject(obj, pfun); - return obj; -} - -/* - (print item [stream]) - Prints its argument with quotation marks and escape characters, on a new line, and followed by a space. - If stream is specified the argument is printed to the specified stream. -*/ -object *fn_print (object *args, object *env) { - (void) env; - object *obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - pln(pfun); - printobject(obj, pfun); - pfun(' '); - return obj; -} - -/* - (princ item [stream]) - Prints its argument, and returns its value. - Characters and strings are printed without quotation marks or escape characters. -*/ -object *fn_princ (object *args, object *env) { - (void) env; - object *obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - prin1object(obj, pfun); - return obj; -} - -/* - (terpri [stream]) - Prints a new line, and returns nil. - If stream is specified the new line is written to the specified stream. -*/ -object *fn_terpri (object *args, object *env) { - (void) env; - pfun_t pfun = pstreamfun(args); - pln(pfun); - return nil; -} - -/* - (read-byte stream) - Reads a byte from a stream and returns it. -*/ -object *fn_readbyte (object *args, object *env) { - (void) env; - gfun_t gfun = gstreamfun(args); - int c = gfun(); - return (c == -1) ? nil : number(c); -} - -/* - (read-line [stream]) - Reads characters from the serial input up to a newline character, and returns them as a string, excluding the newline. - If stream is specified the line is read from the specified stream. -*/ -object *fn_readline (object *args, object *env) { - (void) env; - gfun_t gfun = gstreamfun(args); - return readstring('\n', gfun); -} - -/* - (write-byte number [stream]) - Writes a byte to a stream. -*/ -object *fn_writebyte (object *args, object *env) { - (void) env; - int value = checkinteger(first(args)); - pfun_t pfun = pstreamfun(cdr(args)); - (pfun)(value); - return nil; -} - -/* - (write-string string [stream]) - Writes a string. If stream is specified the string is written to the stream. -*/ -object *fn_writestring (object *args, object *env) { - (void) env; - object *obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - char temp = Flags; - clrflag(PRINTREADABLY); - printstring(obj, pfun); - Flags = temp; - return nil; -} - -/* - (write-line string [stream]) - Writes a string terminated by a newline character. If stream is specified the string is written to the stream. -*/ -object *fn_writeline (object *args, object *env) { - (void) env; - object *obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - char temp = Flags; - clrflag(PRINTREADABLY); - printstring(obj, pfun); - pln(pfun); - Flags = temp; - return nil; -} - -/* - (restart-i2c stream [read-p]) - Restarts an i2c-stream. - If read-p is nil or omitted the stream is written to. - If read-p is an integer it specifies the number of bytes to be read from the stream. -*/ -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 (integerp(rw)) I2Ccount = rw->integer; - read = (rw != NULL); - } - int address = stream & 0xFF; - if (stream>>8 != I2CSTREAM) error2(PSTR("not an i2c stream")); - return I2Crestart(address, read) ? tee : nil; -} - -/* - (gc) - Forces a garbage collection and prints the number of objects collected, and the time taken. -*/ -object *fn_gc (object *obj, object *env) { - int initial = Freespace; - unsigned long start = micros(); - gc(obj, env); - unsigned long elapsed = micros() - start; - pfstring(PSTR("Space: "), pserial); - pint(Freespace - initial, pserial); - pfstring(PSTR(" bytes, Time: "), pserial); - pint(elapsed, pserial); - pfstring(PSTR(" us\n"), pserial); - return nil; -} - -/* - (room) - Returns the number of free Lisp cells remaining. -*/ -object *fn_room (object *args, object *env) { - (void) args, (void) env; - return number(Freespace); -} - -/* - (cls) - Prints a clear-screen character. -*/ -object *fn_cls (object *args, object *env) { - (void) args, (void) env; - pserial(12); - return nil; -} - -// Arduino procedures - -/* - (pinmode pin mode) - Sets the input/output mode of an Arduino pin number, and returns nil. - The mode parameter can be an integer, a keyword, or t or nil. -*/ -object *fn_pinmode (object *args, object *env) { - (void) env; int pin; - object *arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else pin = checkinteger(first(args)); - int pm = INPUT; - arg = second(args); - if (keywordp(arg)) pm = checkkeyword(arg); - else if (integerp(arg)) { - int mode = arg->integer; - if (mode == 1) pm = OUTPUT; else if (mode == 2) pm = INPUT_PULLUP; - #if defined(INPUT_PULLDOWN) - else if (mode == 4) pm = INPUT_PULLDOWN; - #endif - } else if (arg != nil) pm = OUTPUT; - pinMode(pin, pm); - return nil; -} - -/* - (digitalread pin) - Reads the state of the specified Arduino pin number and returns t (high) or nil (low). -*/ -object *fn_digitalread (object *args, object *env) { - (void) env; - int pin; - object *arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else pin = checkinteger(arg); - if (digitalRead(pin) != 0) return tee; else return nil; -} - -/* - (digitalwrite pin state) - Sets the state of the specified Arduino pin number. -*/ -object *fn_digitalwrite (object *args, object *env) { - (void) env; - int pin; - object *arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else pin = checkinteger(arg); - arg = second(args); - int mode; - if (keywordp(arg)) mode = checkkeyword(arg); - else if (integerp(arg)) mode = arg->integer ? HIGH : LOW; - else mode = (arg != nil) ? HIGH : LOW; - digitalWrite(pin, mode); - return arg; -} - -/* - (analogread pin) - Reads the specified Arduino analogue pin number and returns the value. -*/ -object *fn_analogread (object *args, object *env) { - (void) env; - int pin; - object *arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else { - pin = checkinteger(arg); - checkanalogread(pin); - } - return number(analogRead(pin)); -} - -/* - (analogreadresolution bits) - Specifies the resolution for the analogue inputs on platforms that support it. - The default resolution on all platforms is 10 bits. -*/ -object *fn_analogreadresolution (object *args, object *env) { - (void) env; - object *arg = first(args); - #if defined(ESP32) - analogReadResolution(checkinteger(arg)); - #else - error2(PSTR("not supported")); - #endif - return arg; -} - -/* - (analogwrite pin value) - Writes the value to the specified Arduino pin number. -*/ -object *fn_analogwrite (object *args, object *env) { - (void) env; - int pin; - object *arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else pin = checkinteger(arg); - checkanalogwrite(pin); - object *value = second(args); - analogWrite(pin, checkinteger(value)); - return value; -} - -/* - (delay number) - Delays for a specified number of milliseconds. -*/ -object *fn_delay (object *args, object *env) { - (void) env; - object *arg1 = first(args); - delay(checkinteger(arg1)); - return arg1; -} - -/* - (millis) - Returns the time in milliseconds that uLisp has been running. -*/ -object *fn_millis (object *args, object *env) { - (void) args, (void) env; - return number(millis()); -} - -/* - (sleep secs) - Puts the processor into a low-power sleep mode for secs. - Only supported on some platforms. On other platforms it does delay(1000*secs). -*/ -object *fn_sleep (object *args, object *env) { - (void) env; - object *arg1 = first(args); - doze(checkinteger(arg1)); - return arg1; -} - -/* - (note [pin] [note] [octave]) - Generates a square wave on pin. - The argument note represents the note in the well-tempered scale, from 0 to 11, - where 0 represents C, 1 represents C#, and so on. - The argument octave can be from 3 to 6. If omitted it defaults to 0. -*/ -object *fn_note (object *args, object *env) { - (void) env; - static int pin = 255; - if (args != NULL) { - pin = checkinteger(first(args)); - int note = 0; - if (cddr(args) != NULL) note = checkinteger(second(args)); - int octave = 0; - if (cddr(args) != NULL) octave = checkinteger(third(args)); - playnote(pin, note, octave); - } else nonote(pin); - return nil; -} - -/* - (register address [value]) - Reads or writes the value of a peripheral register. - If value is not specified the function returns the value of the register at address. - If value is specified the value is written to the register at address and the function returns value. -*/ -object *fn_register (object *args, object *env) { - (void) env; - object *arg = first(args); - int addr; - if (keywordp(arg)) addr = checkkeyword(arg); - else addr = checkinteger(first(args)); - if (cdr(args) == NULL) return number(*(uint32_t *)addr); - (*(uint32_t *)addr) = checkinteger(second(args)); - return second(args); -} - -// Tree Editor - -/* - (edit 'function) - Calls the Lisp tree editor to allow you to edit a function definition. -*/ -object *fn_edit (object *args, object *env) { - object *fun = first(args); - object *pair = findvalue(fun, env); - clrflag(EXITEDITOR); - object *arg = edit(eval(fun, env)); - cdr(pair) = arg; - return arg; -} - -// Pretty printer - -/* - (pprint item [str]) - Prints its argument, using the pretty printer, to display it formatted in a structured way. - If str is specified it prints to the specified stream. It returns no value. -*/ -object *fn_pprint (object *args, object *env) { - (void) env; - object *obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - #if defined(gfxsupport) - if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; - #endif - pln(pfun); - superprint(obj, 0, pfun); - ppwidth = PPWIDTH; - return bsymbol(NOTHING); -} - -/* - (pprintall [str]) - Pretty-prints the definition of every function and variable defined in the uLisp workspace. - If str is specified it prints to the specified stream. It returns no value. -*/ -object *fn_pprintall (object *args, object *env) { - (void) env; - pfun_t pfun = pstreamfun(args); - #if defined(gfxsupport) - if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; - #endif - object *globals = GlobalEnv; - while (globals != NULL) { - object *pair = first(globals); - object *var = car(pair); - object *val = cdr(pair); - pln(pfun); - if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) { - superprint(cons(bsymbol(DEFUN), cons(var, cdr(val))), 0, pfun); - } else { - superprint(cons(bsymbol(DEFVAR), cons(var, cons(quote(val), NULL))), 0, pfun); - } - pln(pfun); - testescape(); - globals = cdr(globals); - } - ppwidth = PPWIDTH; - return bsymbol(NOTHING); -} - -// Format - -/* - (format output controlstring [arguments]*) - Outputs its arguments formatted according to the format directives in controlstring. -*/ -object *fn_format (object *args, object *env) { - (void) env; - pfun_t pfun = pserial; - object *output = first(args); - object *obj; - if (output == nil) { obj = startstring(); pfun = pstr; } - else if (output != tee) pfun = pstreamfun(args); - object *formatstr = checkstring(second(args)); - object *save = NULL; - args = cddr(args); - int len = stringlength(formatstr); - uint8_t n = 0, width = 0, w, bra = 0; - char pad = ' '; - bool tilde = false, mute = false, comma = false, quote = false; - while (n < len) { - char ch = nthchar(formatstr, n); - char ch2 = ch & ~0x20; // force to upper case - if (tilde) { - if (ch == '}') { - if (save == NULL) formaterr(formatstr, PSTR("no matching ~{"), n); - if (args == NULL) { args = cdr(save); save = NULL; } else n = bra; - mute = false; tilde = false; - } - else if (!mute) { - if (comma && quote) { pad = ch; comma = false, quote = false; } - else if (ch == '\'') { - if (comma) quote = true; - else formaterr(formatstr, PSTR("quote not valid"), n); - } - else if (ch == '~') { pfun('~'); tilde = false; } - else if (ch >= '0' && ch <= '9') width = width*10 + ch - '0'; - else if (ch == ',') comma = true; - else if (ch == '%') { pln(pfun); tilde = false; } - else if (ch == '&') { pfl(pfun); tilde = false; } - else if (ch == '^') { - if (save != NULL && args == NULL) mute = true; - tilde = false; - } - else if (ch == '{') { - if (save != NULL) formaterr(formatstr, PSTR("can't nest ~{"), n); - if (args == NULL) formaterr(formatstr, noargument, n); - if (!listp(first(args))) formaterr(formatstr, notalist, n); - save = args; args = first(args); bra = n; tilde = false; - if (args == NULL) mute = true; - } - else if (ch2 == 'A' || ch2 == 'S' || ch2 == 'D' || ch2 == 'G' || ch2 == 'X' || ch2 == 'B') { - if (args == NULL) formaterr(formatstr, noargument, n); - object *arg = first(args); args = cdr(args); - uint8_t aw = atomwidth(arg); - if (width < aw) w = 0; else w = width-aw; - tilde = false; - if (ch2 == 'A') { prin1object(arg, pfun); indent(w, pad, pfun); } - else if (ch2 == 'S') { printobject(arg, pfun); indent(w, pad, pfun); } - else if (ch2 == 'D' || ch2 == 'G') { indent(w, pad, pfun); prin1object(arg, pfun); } - else if (ch2 == 'X' || ch2 == 'B') { - if (integerp(arg)) { - uint8_t base = (ch2 == 'B') ? 2 : 16; - uint8_t hw = basewidth(arg, base); if (width < hw) w = 0; else w = width-hw; - indent(w, pad, pfun); pintbase(arg->integer, base, pfun); - } else { - indent(w, pad, pfun); prin1object(arg, pfun); - } - } - tilde = false; - } else formaterr(formatstr, PSTR("invalid directive"), n); - } - } else { - if (ch == '~') { tilde = true; pad = ' '; width = 0; comma = false; quote = false; } - else if (!mute) pfun(ch); - } - n++; - } - if (output == nil) return obj; - else return nil; -} - -// LispLibrary - -/* - (require 'symbol) - Loads the definition of a function defined with defun, or a variable defined with defvar, from the Lisp Library. - It returns t if it was loaded, or nil if the symbol is already defined or isn't defined in the Lisp Library. -*/ -object *fn_require (object *args, object *env) { - object *arg = first(args); - object *globals = GlobalEnv; - if (!symbolp(arg)) error(notasymbol, arg); - while (globals != NULL) { - object *pair = first(globals); - object *var = car(pair); - if (symbolp(var) && var == arg) return nil; - globals = cdr(globals); - } - GlobalStringIndex = 0; - object *line = read(glibrary); - while (line != NULL) { - // Is this the definition we want - symbol_t fname = first(line)->name; - if ((fname == sym(DEFUN) || fname == sym(DEFVAR)) && symbolp(second(line)) && second(line)->name == arg->name) { - eval(line, env); - return tee; - } - line = read(glibrary); - } - return nil; -} - -/* - (list-library) - Prints a list of the functions defined in the List Library. -*/ -object *fn_listlibrary (object *args, object *env) { - (void) args, (void) env; - GlobalStringIndex = 0; - object *line = read(glibrary); - while (line != NULL) { - builtin_t bname = builtin(first(line)->name); - if (bname == DEFUN || bname == DEFVAR) { - printsymbol(second(line), pserial); pserial(' '); - } - line = read(glibrary); - } - return bsymbol(NOTHING); -} - -// Documentation - -/* - (? item) - Prints the documentation string of a built-in or user-defined function. -*/ -object *sp_help (object *args, object *env) { - if (args == NULL) error2(noargument); - object *docstring = documentation(first(args), env); - if (docstring) { - char temp = Flags; - clrflag(PRINTREADABLY); - printstring(docstring, pserial); - Flags = temp; - } - return bsymbol(NOTHING); -} - -/* - (documentation 'symbol [type]) - Returns the documentation string of a built-in or user-defined function. The type argument is ignored. -*/ -object *fn_documentation (object *args, object *env) { - return documentation(first(args), env); -} - -/* - (apropos item) - Prints the user-defined and built-in functions whose names contain the specified string or symbol. -*/ -object *fn_apropos (object *args, object *env) { - (void) env; - apropos(first(args), true); - return bsymbol(NOTHING); -} - -/* - (apropos-list item) - Returns a list of user-defined and built-in functions whose names contain the specified string or symbol. -*/ -object *fn_aproposlist (object *args, object *env) { - (void) env; - return apropos(first(args), false); -} - -// Error handling - -/* - (unwind-protect form1 [forms]*) - Evaluates form1 and forms in order and returns the value of form1, - but guarantees to evaluate forms even if an error occurs in form1. -*/ -object *sp_unwindprotect (object *args, object *env) { - if (args == NULL) error2(toofewargs); - object *current_GCStack = GCStack; - jmp_buf dynamic_handler; - jmp_buf *previous_handler = handler; - handler = &dynamic_handler; - object *protected_form = first(args); - object *result; - - bool signaled = false; - if (!setjmp(dynamic_handler)) { - result = eval(protected_form, env); - } else { - GCStack = current_GCStack; - signaled = true; - } - handler = previous_handler; - - object *protective_forms = cdr(args); - while (protective_forms != NULL) { - eval(car(protective_forms), env); - if (tstflag(RETURNFLAG)) break; - protective_forms = cdr(protective_forms); - } - - if (!signaled) return result; - GCStack = NULL; - longjmp(*handler, 1); -} - -/* - (ignore-errors [forms]*) - Evaluates forms ignoring errors. -*/ -object *sp_ignoreerrors (object *args, object *env) { - object *current_GCStack = GCStack; - jmp_buf dynamic_handler; - jmp_buf *previous_handler = handler; - handler = &dynamic_handler; - object *result = nil; - - bool muffled = tstflag(MUFFLEERRORS); - setflag(MUFFLEERRORS); - bool signaled = false; - if (!setjmp(dynamic_handler)) { - while (args != NULL) { - result = eval(car(args), env); - if (tstflag(RETURNFLAG)) break; - args = cdr(args); - } - } else { - GCStack = current_GCStack; - signaled = true; - } - handler = previous_handler; - if (!muffled) clrflag(MUFFLEERRORS); - - if (signaled) return bsymbol(NOTHING); - else return result; -} - -/* - (error controlstring [arguments]*) - Signals an error. The message is printed by format using the controlstring and arguments. -*/ -object *sp_error (object *args, object *env) { - object *message = eval(cons(bsymbol(FORMAT), cons(nil, args)), env); - if (!tstflag(MUFFLEERRORS)) { - char temp = Flags; - clrflag(PRINTREADABLY); - pfstring(PSTR("Error: "), pserial); printstring(message, pserial); - Flags = temp; - pln(pserial); - } - GCStack = NULL; - longjmp(*handler, 1); -} - -// Wi-Fi - -/* - (with-client (str [address port]) form*) - Evaluates the forms with str bound to a wifi-stream. -*/ -object *sp_withclient (object *args, object *env) { - object *params = first(args); - object *var = first(params); - char buffer[BUFFERSIZE]; - params = cdr(params); - int n; - if (params == NULL) { - client = server.available(); - if (!client) return nil; - n = 2; - } else { - object *address = eval(first(params), env); - object *port = eval(second(params), env); - int success; - if (stringp(address)) success = client.connect(cstring(address, buffer, BUFFERSIZE), checkinteger(port)); - else if (integerp(address)) success = client.connect(address->integer, checkinteger(port)); - else error2(PSTR("invalid address")); - if (!success) return nil; - n = 1; - } - object *pair = cons(var, stream(WIFISTREAM, n)); - push(pair,env); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); - client.stop(); - return result; -} - -/* - (available stream) - Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available. -*/ -object *fn_available (object *args, object *env) { - (void) env; - if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); - return number(client.available()); -} - -/* - (wifi-server) - Starts a Wi-Fi server running. It returns nil. -*/ -object *fn_wifiserver (object *args, object *env) { - (void) args, (void) env; - server.begin(); - return nil; -} - -/* - (wifi-softap ssid [password channel hidden]) - Set up a soft access point to establish a Wi-Fi network. - Returns the IP address as a string or nil if unsuccessful. -*/ -object *fn_wifisoftap (object *args, object *env) { - (void) env; - char ssid[33], pass[65]; - if (args == NULL) return WiFi.softAPdisconnect(true) ? tee : nil; - object *first = first(args); args = cdr(args); - if (args == NULL) WiFi.softAP(cstring(first, ssid, 33)); - else { - object *second = first(args); - args = cdr(args); - int channel = 1; - bool hidden = false; - if (args != NULL) { - channel = checkinteger(first(args)); - args = cdr(args); - if (args != NULL) hidden = (first(args) != nil); - } - WiFi.softAP(cstring(first, ssid, 33), cstring(second, pass, 65), channel, hidden); - } - return lispstring((char*)WiFi.softAPIP().toString().c_str()); -} - -/* - (connected stream) - Returns t or nil to indicate if the client on stream is connected. -*/ -object *fn_connected (object *args, object *env) { - (void) env; - if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); - return client.connected() ? tee : nil; -} - -/* - (wifi-localip) - Returns the IP address of the local network as a string. -*/ -object *fn_wifilocalip (object *args, object *env) { - (void) args, (void) env; - return lispstring((char*)WiFi.localIP().toString().c_str()); -} - -/* - (wifi-connect [ssid pass]) - Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string. -*/ -object *fn_wificonnect (object *args, object *env) { - (void) env; - char ssid[33], pass[65]; - if (args == NULL) { WiFi.disconnect(true); return nil; } - if (cdr(args) == NULL) WiFi.begin(cstring(first(args), ssid, 33)); - else WiFi.begin(cstring(first(args), ssid, 33), cstring(second(args), pass, 65)); - int result = WiFi.waitForConnectResult(); - if (result == WL_CONNECTED) return lispstring((char*)WiFi.localIP().toString().c_str()); - else if (result == WL_NO_SSID_AVAIL) error2(PSTR("network not found")); - else if (result == WL_CONNECT_FAILED) error2(PSTR("connection failed")); - else error2(PSTR("unable to connect")); - return nil; -} - -// Graphics functions - -/* - (with-gfx (str) form*) - Evaluates the forms with str bound to an gfx-stream so you can print text - to the graphics display using the standard uLisp print commands. -*/ -object *sp_withgfx (object *args, object *env) { -#if defined(gfxsupport) - object *params = first(args); - object *var = first(params); - object *pair = cons(var, stream(GFXSTREAM, 1)); - push(pair,env); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); - return result; -#else - (void) args, (void) env; - error2(PSTR("not supported")); - return nil; -#endif -} - -/* - (draw-pixel x y [colour]) - Draws a pixel at coordinates (x,y) in colour, or white if omitted. -*/ -object *fn_drawpixel (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t colour = COLOR_WHITE; - if (cddr(args) != NULL) colour = checkinteger(third(args)); - tft.drawPixel(checkinteger(first(args)), checkinteger(second(args)), colour); - #else - (void) args; - #endif - return nil; -} - -/* - (draw-line x0 y0 x1 y1 [colour]) - Draws a line from (x0,y0) to (x1,y1) in colour, or white if omitted. -*/ -object *fn_drawline (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[4], colour = COLOR_WHITE; - for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawLine(params[0], params[1], params[2], params[3], colour); - #else - (void) args; - #endif - return nil; -} - -/* - (draw-rect x y w h [colour]) - Draws an outline rectangle with its top left corner at (x,y), with width w, - and with height h. The outline is drawn in colour, or white if omitted. -*/ -object *fn_drawrect (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[4], colour = COLOR_WHITE; - for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawRect(params[0], params[1], params[2], params[3], colour); - #else - (void) args; - #endif - return nil; -} - -/* - (fill-rect x y w h [colour]) - Draws a filled rectangle with its top left corner at (x,y), with width w, - and with height h. The outline is drawn in colour, or white if omitted. -*/ -object *fn_fillrect (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[4], colour = COLOR_WHITE; - for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.fillRect(params[0], params[1], params[2], params[3], colour); - #else - (void) args; - #endif - return nil; -} - -/* - (draw-circle x y r [colour]) - Draws an outline circle with its centre at (x, y) and with radius r. - The circle is drawn in colour, or white if omitted. -*/ -object *fn_drawcircle (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[3], colour = COLOR_WHITE; - for (int i=0; i<3; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawCircle(params[0], params[1], params[2], colour); - #else - (void) args; - #endif - return nil; -} - -/* - (fill-circle x y r [colour]) - Draws a filled circle with its centre at (x, y) and with radius r. - The circle is drawn in colour, or white if omitted. -*/ -object *fn_fillcircle (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[3], colour = COLOR_WHITE; - for (int i=0; i<3; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.fillCircle(params[0], params[1], params[2], colour); - #else - (void) args; - #endif - return nil; -} - -/* - (draw-round-rect x y w h radius [colour]) - Draws an outline rounded rectangle with its top left corner at (x,y), with width w, - height h, and corner radius radius. The outline is drawn in colour, or white if omitted. -*/ -object *fn_drawroundrect (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[5], colour = COLOR_WHITE; - for (int i=0; i<5; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawRoundRect(params[0], params[1], params[2], params[3], params[4], colour); - #else - (void) args; - #endif - return nil; -} - -/* - (fill-round-rect x y w h radius [colour]) - Draws a filled rounded rectangle with its top left corner at (x,y), with width w, - height h, and corner radius radius. The outline is drawn in colour, or white if omitted. -*/ -object *fn_fillroundrect (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[5], colour = COLOR_WHITE; - for (int i=0; i<5; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.fillRoundRect(params[0], params[1], params[2], params[3], params[4], colour); - #else - (void) args; - #endif - return nil; -} - -/* - (draw-triangle x0 y0 x1 y1 x2 y2 [colour]) - Draws an outline triangle between (x1,y1), (x2,y2), and (x3,y3). - The outline is drawn in colour, or white if omitted. -*/ -object *fn_drawtriangle (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[6], colour = COLOR_WHITE; - for (int i=0; i<6; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawTriangle(params[0], params[1], params[2], params[3], params[4], params[5], colour); - #else - (void) args; - #endif - return nil; -} - -/* - (fill-triangle x0 y0 x1 y1 x2 y2 [colour]) - Draws a filled triangle between (x1,y1), (x2,y2), and (x3,y3). - The outline is drawn in colour, or white if omitted. -*/ -object *fn_filltriangle (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[6], colour = COLOR_WHITE; - for (int i=0; i<6; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.fillTriangle(params[0], params[1], params[2], params[3], params[4], params[5], colour); - #else - (void) args; - #endif - return nil; -} - -/* - (draw-char x y char [colour background size]) - Draws the character char with its top left corner at (x,y). - The character is drawn in a 5 x 7 pixel font in colour against background, - which default to white and black respectively. - The character can optionally be scaled by size. -*/ -object *fn_drawchar (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t colour = COLOR_WHITE, bg = COLOR_BLACK, size = 1; - object *more = cdr(cddr(args)); - if (more != NULL) { - colour = checkinteger(car(more)); - more = cdr(more); - if (more != NULL) { - bg = checkinteger(car(more)); - more = cdr(more); - if (more != NULL) size = checkinteger(car(more)); - } - } - tft.drawChar(checkinteger(first(args)), checkinteger(second(args)), checkchar(third(args)), - colour, bg, size); - #else - (void) args; - #endif - return nil; -} - -/* - (set-cursor x y) - Sets the start point for text plotting to (x, y). -*/ -object *fn_setcursor (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - tft.setCursor(checkinteger(first(args)), checkinteger(second(args))); - #else - (void) args; - #endif - return nil; -} - -/* - (set-text-color colour [background]) - Sets the text colour for text plotted using (with-gfx ...). -*/ -object *fn_settextcolor (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - if (cdr(args) != NULL) tft.setTextColor(checkinteger(first(args)), checkinteger(second(args))); - else tft.setTextColor(checkinteger(first(args))); - #else - (void) args; - #endif - return nil; -} - -/* - (set-text-size scale) - Scales text by the specified size, default 1. -*/ -object *fn_settextsize (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - tft.setTextSize(checkinteger(first(args))); - #else - (void) args; - #endif - return nil; -} - -/* - (set-text-wrap boolean) - Specified whether text wraps at the right-hand edge of the display; the default is t. -*/ -object *fn_settextwrap (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - tft.setTextWrap(first(args) != NULL); - #else - (void) args; - #endif - return nil; -} - -/* - (fill-screen [colour]) - Fills or clears the screen with colour, default black. -*/ -object *fn_fillscreen (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - uint16_t colour = COLOR_BLACK; - if (args != NULL) colour = checkinteger(first(args)); - tft.fillScreen(colour); - #else - (void) args; - #endif - return nil; -} - -/* - (set-rotation option) - Sets the display orientation for subsequent graphics commands; values are 0, 1, 2, or 3. -*/ -object *fn_setrotation (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - tft.setRotation(checkinteger(first(args))); - #else - (void) args; - #endif - return nil; -} - -/* - (invert-display boolean) - Mirror-images the display. -*/ -object *fn_invertdisplay (object *args, object *env) { - (void) env; - #if defined(gfxsupport) - tft.invertDisplay(first(args) != NULL); - #else - (void) args; - #endif - return nil; -} - -// Built-in symbol names -const char string0[] PROGMEM = "nil"; -const char string1[] PROGMEM = "t"; -const char string2[] PROGMEM = "nothing"; -const char string3[] PROGMEM = "&optional"; -const char string4[] PROGMEM = ":initial-element"; -const char string5[] PROGMEM = ":element-type"; -const char string6[] PROGMEM = "bit"; -const char string7[] PROGMEM = "&rest"; -const char string8[] PROGMEM = "lambda"; -const char string9[] PROGMEM = "let"; -const char string10[] PROGMEM = "let*"; -const char string11[] PROGMEM = "closure"; -const char string12[] PROGMEM = "*pc*"; -const char string13[] PROGMEM = "quote"; -const char string14[] PROGMEM = "defun"; -const char string15[] PROGMEM = "defvar"; -const char string16[] PROGMEM = "car"; -const char string17[] PROGMEM = "first"; -const char string18[] PROGMEM = "cdr"; -const char string19[] PROGMEM = "rest"; -const char string20[] PROGMEM = "nth"; -const char string21[] PROGMEM = "aref"; -const char string22[] PROGMEM = "string"; -const char string23[] PROGMEM = "pinmode"; -const char string24[] PROGMEM = "digitalwrite"; -const char string25[] PROGMEM = "analogread"; -const char string26[] PROGMEM = "register"; -const char string27[] PROGMEM = "format"; -const char string28[] PROGMEM = "or"; -const char string29[] PROGMEM = "setq"; -const char string30[] PROGMEM = "loop"; -const char string31[] PROGMEM = "return"; -const char string32[] PROGMEM = "push"; -const char string33[] PROGMEM = "pop"; -const char string34[] PROGMEM = "incf"; -const char string35[] PROGMEM = "decf"; -const char string36[] PROGMEM = "setf"; -const char string37[] PROGMEM = "dolist"; -const char string38[] PROGMEM = "dotimes"; -const char string39[] PROGMEM = "trace"; -const char string40[] PROGMEM = "untrace"; -const char string41[] PROGMEM = "for-millis"; -const char string42[] PROGMEM = "time"; -const char string43[] PROGMEM = "with-output-to-string"; -const char string44[] PROGMEM = "with-serial"; -const char string45[] PROGMEM = "with-i2c"; -const char string46[] PROGMEM = "with-spi"; -const char string47[] PROGMEM = "with-sd-card"; -const char string48[] PROGMEM = "progn"; -const char string49[] PROGMEM = "if"; -const char string50[] PROGMEM = "cond"; -const char string51[] PROGMEM = "when"; -const char string52[] PROGMEM = "unless"; -const char string53[] PROGMEM = "case"; -const char string54[] PROGMEM = "and"; -const char string55[] PROGMEM = "not"; -const char string56[] PROGMEM = "null"; -const char string57[] PROGMEM = "cons"; -const char string58[] PROGMEM = "atom"; -const char string59[] PROGMEM = "listp"; -const char string60[] PROGMEM = "consp"; -const char string61[] PROGMEM = "symbolp"; -const char string62[] PROGMEM = "arrayp"; -const char string63[] PROGMEM = "boundp"; -const char string64[] PROGMEM = "keywordp"; -const char string65[] PROGMEM = "set"; -const char string66[] PROGMEM = "streamp"; -const char string67[] PROGMEM = "eq"; -const char string68[] PROGMEM = "equal"; -const char string69[] PROGMEM = "caar"; -const char string70[] PROGMEM = "cadr"; -const char string71[] PROGMEM = "second"; -const char string72[] PROGMEM = "cdar"; -const char string73[] PROGMEM = "cddr"; -const char string74[] PROGMEM = "caaar"; -const char string75[] PROGMEM = "caadr"; -const char string76[] PROGMEM = "cadar"; -const char string77[] PROGMEM = "caddr"; -const char string78[] PROGMEM = "third"; -const char string79[] PROGMEM = "cdaar"; -const char string80[] PROGMEM = "cdadr"; -const char string81[] PROGMEM = "cddar"; -const char string82[] PROGMEM = "cdddr"; -const char string83[] PROGMEM = "length"; -const char string84[] PROGMEM = "array-dimensions"; -const char string85[] PROGMEM = "list"; -const char string86[] PROGMEM = "make-array"; -const char string87[] PROGMEM = "reverse"; -const char string88[] PROGMEM = "assoc"; -const char string89[] PROGMEM = "member"; -const char string90[] PROGMEM = "apply"; -const char string91[] PROGMEM = "funcall"; -const char string92[] PROGMEM = "append"; -const char string93[] PROGMEM = "mapc"; -const char string94[] PROGMEM = "mapcar"; -const char string95[] PROGMEM = "mapcan"; -const char string96[] PROGMEM = "+"; -const char string97[] PROGMEM = "-"; -const char string98[] PROGMEM = "*"; -const char string99[] PROGMEM = "/"; -const char string100[] PROGMEM = "mod"; -const char string101[] PROGMEM = "1+"; -const char string102[] PROGMEM = "1-"; -const char string103[] PROGMEM = "abs"; -const char string104[] PROGMEM = "random"; -const char string105[] PROGMEM = "max"; -const char string106[] PROGMEM = "min"; -const char string107[] PROGMEM = "/="; -const char string108[] PROGMEM = "="; -const char string109[] PROGMEM = "<"; -const char string110[] PROGMEM = "<="; -const char string111[] PROGMEM = ">"; -const char string112[] PROGMEM = ">="; -const char string113[] PROGMEM = "plusp"; -const char string114[] PROGMEM = "minusp"; -const char string115[] PROGMEM = "zerop"; -const char string116[] PROGMEM = "oddp"; -const char string117[] PROGMEM = "evenp"; -const char string118[] PROGMEM = "integerp"; -const char string119[] PROGMEM = "numberp"; -const char string120[] PROGMEM = "float"; -const char string121[] PROGMEM = "floatp"; -const char string122[] PROGMEM = "sin"; -const char string123[] PROGMEM = "cos"; -const char string124[] PROGMEM = "tan"; -const char string125[] PROGMEM = "asin"; -const char string126[] PROGMEM = "acos"; -const char string127[] PROGMEM = "atan"; -const char string128[] PROGMEM = "sinh"; -const char string129[] PROGMEM = "cosh"; -const char string130[] PROGMEM = "tanh"; -const char string131[] PROGMEM = "exp"; -const char string132[] PROGMEM = "sqrt"; -const char string133[] PROGMEM = "log"; -const char string134[] PROGMEM = "expt"; -const char string135[] PROGMEM = "ceiling"; -const char string136[] PROGMEM = "floor"; -const char string137[] PROGMEM = "truncate"; -const char string138[] PROGMEM = "round"; -const char string139[] PROGMEM = "char"; -const char string140[] PROGMEM = "char-code"; -const char string141[] PROGMEM = "code-char"; -const char string142[] PROGMEM = "characterp"; -const char string143[] PROGMEM = "stringp"; -const char string144[] PROGMEM = "string="; -const char string145[] PROGMEM = "string<"; -const char string146[] PROGMEM = "string>"; -const char string147[] PROGMEM = "sort"; -const char string148[] PROGMEM = "concatenate"; -const char string149[] PROGMEM = "subseq"; -const char string150[] PROGMEM = "search"; -const char string151[] PROGMEM = "read-from-string"; -const char string152[] PROGMEM = "princ-to-string"; -const char string153[] PROGMEM = "prin1-to-string"; -const char string154[] PROGMEM = "logand"; -const char string155[] PROGMEM = "logior"; -const char string156[] PROGMEM = "logxor"; -const char string157[] PROGMEM = "lognot"; -const char string158[] PROGMEM = "ash"; -const char string159[] PROGMEM = "logbitp"; -const char string160[] PROGMEM = "eval"; -const char string161[] PROGMEM = "globals"; -const char string162[] PROGMEM = "locals"; -const char string163[] PROGMEM = "makunbound"; -const char string164[] PROGMEM = "break"; -const char string165[] PROGMEM = "read"; -const char string166[] PROGMEM = "prin1"; -const char string167[] PROGMEM = "print"; -const char string168[] PROGMEM = "princ"; -const char string169[] PROGMEM = "terpri"; -const char string170[] PROGMEM = "read-byte"; -const char string171[] PROGMEM = "read-line"; -const char string172[] PROGMEM = "write-byte"; -const char string173[] PROGMEM = "write-string"; -const char string174[] PROGMEM = "write-line"; -const char string175[] PROGMEM = "restart-i2c"; -const char string176[] PROGMEM = "gc"; -const char string177[] PROGMEM = "room"; -const char string180[] PROGMEM = "cls"; -const char string181[] PROGMEM = "digitalread"; -const char string182[] PROGMEM = "analogreadresolution"; -const char string183[] PROGMEM = "analogwrite"; -const char string184[] PROGMEM = "delay"; -const char string185[] PROGMEM = "millis"; -const char string186[] PROGMEM = "sleep"; -const char string187[] PROGMEM = "note"; -const char string188[] PROGMEM = "edit"; -const char string189[] PROGMEM = "pprint"; -const char string190[] PROGMEM = "pprintall"; -const char string191[] PROGMEM = "require"; -const char string192[] PROGMEM = "list-library"; -const char string193[] PROGMEM = "?"; -const char string194[] PROGMEM = "documentation"; -const char string195[] PROGMEM = "apropos"; -const char string196[] PROGMEM = "apropos-list"; -const char string197[] PROGMEM = "unwind-protect"; -const char string198[] PROGMEM = "ignore-errors"; -const char string199[] PROGMEM = "error"; -const char string200[] PROGMEM = "with-client"; -const char string201[] PROGMEM = "available"; -const char string202[] PROGMEM = "wifi-server"; -const char string203[] PROGMEM = "wifi-softap"; -const char string204[] PROGMEM = "connected"; -const char string205[] PROGMEM = "wifi-localip"; -const char string206[] PROGMEM = "wifi-connect"; -const char string207[] PROGMEM = "with-gfx"; -const char string208[] PROGMEM = "draw-pixel"; -const char string209[] PROGMEM = "draw-line"; -const char string210[] PROGMEM = "draw-rect"; -const char string211[] PROGMEM = "fill-rect"; -const char string212[] PROGMEM = "draw-circle"; -const char string213[] PROGMEM = "fill-circle"; -const char string214[] PROGMEM = "draw-round-rect"; -const char string215[] PROGMEM = "fill-round-rect"; -const char string216[] PROGMEM = "draw-triangle"; -const char string217[] PROGMEM = "fill-triangle"; -const char string218[] PROGMEM = "draw-char"; -const char string219[] PROGMEM = "set-cursor"; -const char string220[] PROGMEM = "set-text-color"; -const char string221[] PROGMEM = "set-text-size"; -const char string222[] PROGMEM = "set-text-wrap"; -const char string223[] PROGMEM = "fill-screen"; -const char string224[] PROGMEM = "set-rotation"; -const char string225[] PROGMEM = "invert-display"; -const char string226[] PROGMEM = ":led-builtin"; -const char string227[] PROGMEM = ":high"; -const char string228[] PROGMEM = ":low"; -const char string229[] PROGMEM = ":input"; -const char string230[] PROGMEM = ":input-pullup"; -const char string231[] PROGMEM = ":input-pulldown"; -const char string232[] PROGMEM = ":output"; - -// Documentation strings -const char doc0[] PROGMEM = "nil\n" -"A symbol equivalent to the empty list (). Also represents false."; -const char doc1[] PROGMEM = "t\n" -"A symbol representing true."; -const char doc2[] PROGMEM = "nothing\n" -"A symbol with no value.\n" -"It is useful if you want to suppress printing the result of evaluating a function."; -const char doc3[] PROGMEM = "&optional\n" -"Can be followed by one or more optional parameters in a lambda or defun parameter list."; -const char doc7[] PROGMEM = "&rest\n" -"Can be followed by a parameter in a lambda or defun parameter list,\n" -"and is assigned a list of the corresponding arguments."; -const char doc8[] PROGMEM = "(lambda (parameter*) form*)\n" -"Creates an unnamed function with parameters. The body is evaluated with the parameters as local variables\n" -"whose initial values are defined by the values of the forms after the lambda form."; -const char doc9[] PROGMEM = "(let ((var value) ... ) forms*)\n" -"Declares local variables with values, and evaluates the forms with those local variables."; -const char doc10[] PROGMEM = "(let* ((var value) ... ) forms*)\n" -"Declares local variables with values, and evaluates the forms with those local variables.\n" -"Each declaration can refer to local variables that have been defined earlier in the let*."; -const char doc14[] PROGMEM = "(defun name (parameters) form*)\n" -"Defines a function."; -const char doc15[] PROGMEM = "(defvar variable form)\n" -"Defines a global variable."; -const char doc16[] PROGMEM = "(car list)\n" -"Returns the first item in a list."; -const char doc18[] PROGMEM = "(cdr list)\n" -"Returns a list with the first item removed."; -const char doc20[] PROGMEM = "(nth number list)\n" -"Returns the nth item in list, counting from zero."; -const char doc21[] PROGMEM = "(aref array index [index*])\n" -"Returns an element from the specified array."; -const char doc22[] PROGMEM = "(string item)\n" -"Converts its argument to a string."; -const char doc23[] PROGMEM = "(pinmode pin mode)\n" -"Sets the input/output mode of an Arduino pin number, and returns nil.\n" -"The mode parameter can be an integer, a keyword, or t or nil."; -const char doc24[] PROGMEM = "(digitalwrite pin state)\n" -"Sets the state of the specified Arduino pin number."; -const char doc25[] PROGMEM = "(analogread pin)\n" -"Reads the specified Arduino analogue pin number and returns the value."; -const char doc26[] PROGMEM = "(register address [value])\n" -"Reads or writes the value of a peripheral register.\n" -"If value is not specified the function returns the value of the register at address.\n" -"If value is specified the value is written to the register at address and the function returns value."; -const char doc27[] PROGMEM = "(format output controlstring [arguments]*)\n" -"Outputs its arguments formatted according to the format directives in controlstring."; -const char doc28[] PROGMEM = "(or item*)\n" -"Evaluates its arguments until one returns non-nil, and returns its value."; -const char doc29[] PROGMEM = "(setq symbol value [symbol value]*)\n" -"For each pair of arguments assigns the value of the second argument\n" -"to the variable specified in the first argument."; -const char doc30[] PROGMEM = "(loop forms*)\n" -"Executes its arguments repeatedly until one of the arguments calls (return),\n" -"which then causes an exit from the loop."; -const char doc31[] PROGMEM = "(return [value])\n" -"Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value."; -const char doc32[] PROGMEM = "(push item place)\n" -"Modifies the value of place, which should be a list, to add item onto the front of the list,\n" -"and returns the new list."; -const char doc33[] PROGMEM = "(pop place)\n" -"Modifies the value of place, which should be a list, to remove its first item, and returns that item."; -const char doc34[] PROGMEM = "(incf place [number])\n" -"Increments a place, which should have an numeric value, and returns the result.\n" -"The third argument is an optional increment which defaults to 1."; -const char doc35[] PROGMEM = "(decf place [number])\n" -"Decrements a place, which should have an numeric value, and returns the result.\n" -"The third argument is an optional decrement which defaults to 1."; -const char doc36[] PROGMEM = "(setf place value [place value]*)\n" -"For each pair of arguments modifies a place to the result of evaluating value."; -const char doc37[] PROGMEM = "(dolist (var list [result]) form*)\n" -"Sets the local variable var to each element of list in turn, and executes the forms.\n" -"It then returns result, or nil if result is omitted."; -const char doc38[] PROGMEM = "(dotimes (var number [result]) form*)\n" -"Executes the forms number times, with the local variable var set to each integer from 0 to number-1 in turn.\n" -"It then returns result, or nil if result is omitted."; -const char doc39[] PROGMEM = "(trace [function]*)\n" -"Turns on tracing of up to TRACEMAX user-defined functions,\n" -"and returns a list of the functions currently being traced."; -const char doc40[] PROGMEM = "(untrace [function]*)\n" -"Turns off tracing of up to TRACEMAX user-defined functions, and returns a list of the functions untraced.\n" -"If no functions are specified it untraces all functions."; -const char doc41[] PROGMEM = "(for-millis ([number]) form*)\n" -"Executes the forms and then waits until a total of number milliseconds have elapsed.\n" -"Returns the total number of milliseconds taken."; -const char doc42[] PROGMEM = "(time form)\n" -"Prints the value returned by the form, and the time taken to evaluate the form\n" -"in milliseconds or seconds."; -const char doc43[] PROGMEM = "(with-output-to-string (str) form*)\n" -"Returns a string containing the output to the stream variable str."; -const char doc44[] PROGMEM = "(with-serial (str port [baud]) form*)\n" -"Evaluates the forms with str bound to a serial-stream using port.\n" -"The optional baud gives the baud rate divided by 100, default 96."; -const char doc45[] PROGMEM = "(with-i2c (str [port] address [read-p]) form*)\n" -"Evaluates the forms with str bound to an i2c-stream defined by address.\n" -"If read-p is nil or omitted the stream is written to, otherwise it specifies the number of bytes\n" -"to be read from the stream. The port if specified is ignored."; -const char doc46[] PROGMEM = "(with-spi (str pin [clock] [bitorder] [mode]) form*)\n" -"Evaluates the forms with str bound to an spi-stream.\n" -"The parameters specify the enable pin, clock in kHz (default 4000),\n" -"bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0)."; -const char doc47[] PROGMEM = "(with-sd-card (str filename [mode]) form*)\n" -"Evaluates the forms with str bound to an sd-stream reading from or writing to the file filename.\n" -"If mode is omitted the file is read, otherwise 0 means read, 1 write-append, or 2 write-overwrite."; -const char doc48[] PROGMEM = "(progn form*)\n" -"Evaluates several forms grouped together into a block, and returns the result of evaluating the last form."; -const char doc49[] PROGMEM = "(if test then [else])\n" -"Evaluates test. If it's non-nil the form then is evaluated and returned;\n" -"otherwise the form else is evaluated and returned."; -const char doc50[] PROGMEM = "(cond ((test form*) (test form*) ... ))\n" -"Each argument is a list consisting of a test optionally followed by one or more forms.\n" -"If the test evaluates to non-nil the forms are evaluated, and the last value is returned as the result of the cond.\n" -"If the test evaluates to nil, none of the forms are evaluated, and the next argument is processed in the same way."; -const char doc51[] PROGMEM = "(when test form*)\n" -"Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned."; -const char doc52[] PROGMEM = "(unless test form*)\n" -"Evaluates the test. If it's nil the forms are evaluated and the last value is returned."; -const char doc53[] PROGMEM = "(case keyform ((key form*) (key form*) ... ))\n" -"Evaluates a keyform to produce a test key, and then tests this against a series of arguments,\n" -"each of which is a list containing a key optionally followed by one or more forms."; -const char doc54[] PROGMEM = "(and item*)\n" -"Evaluates its arguments until one returns nil, and returns the last value."; -const char doc55[] PROGMEM = "(not item)\n" -"Returns t if its argument is nil, or nil otherwise. Equivalent to null."; -const char doc57[] PROGMEM = "(cons item item)\n" -"If the second argument is a list, cons returns a new list with item added to the front of the list.\n" -"If the second argument isn't a list cons returns a dotted pair."; -const char doc58[] PROGMEM = "(atom item)\n" -"Returns t if its argument is a single number, symbol, or nil."; -const char doc59[] PROGMEM = "(listp item)\n" -"Returns t if its argument is a list."; -const char doc60[] PROGMEM = "(consp item)\n" -"Returns t if its argument is a non-null list."; -const char doc61[] PROGMEM = "(symbolp item)\n" -"Returns t if its argument is a symbol."; -const char doc62[] PROGMEM = "(arrayp item)\n" -"Returns t if its argument is an array."; -const char doc63[] PROGMEM = "(boundp item)\n" -"Returns t if its argument is a symbol with a value."; -const char doc64[] PROGMEM = "(keywordp item)\n" -"Returns t if its argument is a keyword."; -const char doc65[] PROGMEM = "(set symbol value [symbol value]*)\n" -"For each pair of arguments, assigns the value of the second argument to the value of the first argument."; -const char doc66[] PROGMEM = "(streamp item)\n" -"Returns t if its argument is a stream."; -const char doc67[] PROGMEM = "(eq item item)\n" -"Tests whether the two arguments are the same symbol, same character, equal numbers,\n" -"or point to the same cons, and returns t or nil as appropriate."; -const char doc68[] PROGMEM = "(equal item item)\n" -"Tests whether the two arguments are the same symbol, same character, equal numbers,\n" -"or point to the same cons, and returns t or nil as appropriate."; -const char doc69[] PROGMEM = "(caar list)"; -const char doc70[] PROGMEM = "(cadr list)"; -const char doc72[] PROGMEM = "(cdar list)\n" -"Equivalent to (cdr (car list))."; -const char doc73[] PROGMEM = "(cddr list)\n" -"Equivalent to (cdr (cdr list))."; -const char doc74[] PROGMEM = "(caaar list)\n" -"Equivalent to (car (car (car list)))."; -const char doc75[] PROGMEM = "(caadr list)\n" -"Equivalent to (car (car (cdar list)))."; -const char doc76[] PROGMEM = "(cadar list)\n" -"Equivalent to (car (cdr (car list)))."; -const char doc77[] PROGMEM = "(caddr list)\n" -"Equivalent to (car (cdr (cdr list)))."; -const char doc79[] PROGMEM = "(cdaar list)\n" -"Equivalent to (cdar (car (car list)))."; -const char doc80[] PROGMEM = "(cdadr list)\n" -"Equivalent to (cdr (car (cdr list)))."; -const char doc81[] PROGMEM = "(cddar list)\n" -"Equivalent to (cdr (cdr (car list)))."; -const char doc82[] PROGMEM = "(cdddr list)\n" -"Equivalent to (cdr (cdr (cdr list)))."; -const char doc83[] PROGMEM = "(length item)\n" -"Returns the number of items in a list, the length of a string, or the length of a one-dimensional array."; -const char doc84[] PROGMEM = "(array-dimensions item)\n" -"Returns a list of the dimensions of an array."; -const char doc85[] PROGMEM = "(list item*)\n" -"Returns a list of the values of its arguments."; -const char doc86[] PROGMEM = "(make-array size [:initial-element element] [:element-type 'bit])\n" -"If size is an integer it creates a one-dimensional array with elements from 0 to size-1.\n" -"If size is a list of n integers it creates an n-dimensional array with those dimensions.\n" -"If :element-type 'bit is specified the array is a bit array."; -const char doc87[] PROGMEM = "(reverse list)\n" -"Returns a list with the elements of list in reverse order."; -const char doc88[] PROGMEM = "(assoc key list)\n" -"Looks up a key in an association list of (key . value) pairs,\n" -"and returns the matching pair, or nil if no pair is found."; -const char doc89[] PROGMEM = "(member item list)\n" -"Searches for an item in a list, using eq, and returns the list starting from the first occurrence of the item,\n" -"or nil if it is not found."; -const char doc90[] PROGMEM = "(apply function list)\n" -"Returns the result of evaluating function, with the list of arguments specified by the second parameter."; -const char doc91[] PROGMEM = "(funcall function argument*)\n" -"Evaluates function with the specified arguments."; -const char doc92[] PROGMEM = "(append list*)\n" -"Joins its arguments, which should be lists, into a single list."; -const char doc93[] PROGMEM = "(mapc function list1 [list]*)\n" -"Applies the function to each element in one or more lists, ignoring the results.\n" -"It returns the first list argument."; -const char doc94[] PROGMEM = "(mapcar function list1 [list]*)\n" -"Applies the function to each element in one or more lists, and returns the resulting list."; -const char doc95[] PROGMEM = "(mapcan function list1 [list]*)\n" -"Applies the function to each element in one or more lists. The results should be lists,\n" -"and these are appended together to give the value returned."; -const char doc96[] PROGMEM = "(+ number*)\n" -"Adds its arguments together.\n" -"If each argument is an integer, and the running total doesn't overflow, the result is an integer,\n" -"otherwise a floating-point number."; -const char doc97[] PROGMEM = "(- number*)\n" -"If there is one argument, negates the argument.\n" -"If there are two or more arguments, subtracts the second and subsequent arguments from the first argument.\n" -"If each argument is an integer, and the running total doesn't overflow, returns the result as an integer,\n" -"otherwise a floating-point number."; -const char doc98[] PROGMEM = "(* number*)\n" -"Multiplies its arguments together.\n" -"If each argument is an integer, and the running total doesn't overflow, the result is an integer,\n" -"otherwise it's a floating-point number."; -const char doc99[] PROGMEM = "(/ number*)\n" -"Divides the first argument by the second and subsequent arguments.\n" -"If each argument is an integer, and each division produces an exact result, the result is an integer;\n" -"otherwise it's a floating-point number."; -const char doc100[] PROGMEM = "(mod number number)\n" -"Returns its first argument modulo the second argument.\n" -"If both arguments are integers the result is an integer; otherwise it's a floating-point number."; -const char doc101[] PROGMEM = "(1+ number)\n" -"Adds one to its argument and returns it.\n" -"If the argument is an integer the result is an integer if possible;\n" -"otherwise it's a floating-point number."; -const char doc102[] PROGMEM = "(1- number)\n" -"Subtracts one from its argument and returns it.\n" -"If the argument is an integer the result is an integer if possible;\n" -"otherwise it's a floating-point number."; -const char doc103[] PROGMEM = "(abs number)\n" -"Returns the absolute, positive value of its argument.\n" -"If the argument is an integer the result will be returned as an integer if possible,\n" -"otherwise a floating-point number."; -const char doc104[] PROGMEM = "(random number)\n" -"If number is an integer returns a random number between 0 and one less than its argument.\n" -"Otherwise returns a floating-point number between zero and number."; -const char doc105[] PROGMEM = "(max number*)\n" -"Returns the maximum of one or more arguments."; -const char doc106[] PROGMEM = "(min number*)\n" -"Returns the minimum of one or more arguments."; -const char doc107[] PROGMEM = "(/= number*)\n" -"Returns t if none of the arguments are equal, or nil if two or more arguments are equal."; -const char doc108[] PROGMEM = "(= number*)\n" -"Returns t if all the arguments, which must be numbers, are numerically equal, and nil otherwise."; -const char doc109[] PROGMEM = "(< number*)\n" -"Returns t if each argument is less than the next argument, and nil otherwise."; -const char doc110[] PROGMEM = "(<= number*)\n" -"Returns t if each argument is less than or equal to the next argument, and nil otherwise."; -const char doc111[] PROGMEM = "(> number*)\n" -"Returns t if each argument is greater than the next argument, and nil otherwise."; -const char doc112[] PROGMEM = "(>= number*)\n" -"Returns t if each argument is greater than or equal to the next argument, and nil otherwise."; -const char doc113[] PROGMEM = "(plusp number)\n" -"Returns t if the argument is greater than zero, or nil otherwise."; -const char doc114[] PROGMEM = "(minusp number)\n" -"Returns t if the argument is less than zero, or nil otherwise."; -const char doc115[] PROGMEM = "(zerop number)\n" -"Returns t if the argument is zero."; -const char doc116[] PROGMEM = "(oddp number)\n" -"Returns t if the integer argument is odd."; -const char doc117[] PROGMEM = "(evenp number)\n" -"Returns t if the integer argument is even."; -const char doc118[] PROGMEM = "(integerp number)\n" -"Returns t if the argument is an integer."; -const char doc119[] PROGMEM = "(numberp number)\n" -"Returns t if the argument is a number."; -const char doc120[] PROGMEM = "(float number)\n" -"Returns its argument converted to a floating-point number."; -const char doc121[] PROGMEM = "(floatp number)\n" -"Returns t if the argument is a floating-point number."; -const char doc122[] PROGMEM = "(sin number)\n" -"Returns sin(number)."; -const char doc123[] PROGMEM = "(cos number)\n" -"Returns cos(number)."; -const char doc124[] PROGMEM = "(tan number)\n" -"Returns tan(number)."; -const char doc125[] PROGMEM = "(asin number)\n" -"Returns asin(number)."; -const char doc126[] PROGMEM = "(acos number)\n" -"Returns acos(number)."; -const char doc127[] PROGMEM = "(atan number1 [number2])\n" -"Returns the arc tangent of number1/number2, in radians. If number2 is omitted it defaults to 1."; -const char doc128[] PROGMEM = "(sinh number)\n" -"Returns sinh(number)."; -const char doc129[] PROGMEM = "(cosh number)\n" -"Returns cosh(number)."; -const char doc130[] PROGMEM = "(tanh number)\n" -"Returns tanh(number)."; -const char doc131[] PROGMEM = "(exp number)\n" -"Returns exp(number)."; -const char doc132[] PROGMEM = "(sqrt number)\n" -"Returns sqrt(number)."; -const char doc133[] PROGMEM = "(number [base])\n" -"Returns the logarithm of number to the specified base. If base is omitted it defaults to e."; -const char doc134[] PROGMEM = "(expt number power)\n" -"Returns number raised to the specified power.\n" -"Returns the result as an integer if the arguments are integers and the result will be within range,\n" -"otherwise a floating-point number."; -const char doc135[] PROGMEM = "(ceiling number [divisor])\n" -"Returns ceil(number/divisor). If omitted, divisor is 1."; -const char doc136[] PROGMEM = "(floor number [divisor])\n" -"Returns floor(number/divisor). If omitted, divisor is 1."; -const char doc137[] PROGMEM = "(truncate number)\n" -"Returns t if the argument is a floating-point number."; -const char doc138[] PROGMEM = "(round number)\n" -"Returns t if the argument is a floating-point number."; -const char doc139[] PROGMEM = "(char string n)\n" -"Returns the nth character in a string, counting from zero."; -const char doc140[] PROGMEM = "(char-code character)\n" -"Returns the ASCII code for a character, as an integer."; -const char doc141[] PROGMEM = "(code-char integer)\n" -"Returns the character for the specified ASCII code."; -const char doc142[] PROGMEM = "(characterp item)\n" -"Returns t if the argument is a character and nil otherwise."; -const char doc143[] PROGMEM = "(stringp item)\n" -"Returns t if the argument is a string and nil otherwise."; -const char doc144[] PROGMEM = "(string= string string)\n" -"Tests whether two strings are the same."; -const char doc145[] PROGMEM = "(string< string string)\n" -"Returns t if the first string is alphabetically less than the second string, and nil otherwise."; -const char doc146[] PROGMEM = "(string> string string)\n" -"Returns t if the first string is alphabetically greater than the second string, and nil otherwise."; -const char doc147[] PROGMEM = "(sort list test)\n" -"Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list."; -const char doc148[] PROGMEM = "(concatenate 'string string*)\n" -"Joins together the strings given in the second and subsequent arguments, and returns a single string."; -const char doc149[] PROGMEM = "(subseq seq start [end])\n" -"Returns a subsequence of a list or string from item start to item end-1."; -const char doc150[] PROGMEM = "(search pattern target)\n" -"Returns the index of the first occurrence of pattern in target,\n" -"which can be lists or strings, or nil if it's not found."; -const char doc151[] PROGMEM = "(read-from-string string)\n" -"Reads an atom or list from the specified string and returns it."; -const char doc152[] PROGMEM = "(princ-to-string item)\n" -"Prints its argument to a string, and returns the string.\n" -"Characters and strings are printed without quotation marks or escape characters."; -const char doc153[] PROGMEM = "(prin1-to-string item [stream])\n" -"Prints its argument to a string, and returns the string.\n" -"Characters and strings are printed with quotation marks and escape characters,\n" -"in a format that will be suitable for read-from-string."; -const char doc154[] PROGMEM = "(logand [value*])\n" -"Returns the bitwise & of the values."; -const char doc155[] PROGMEM = "(logior [value*])\n" -"Returns the bitwise | of the values."; -const char doc156[] PROGMEM = "(logxor [value*])\n" -"Returns the bitwise ^ of the values."; -const char doc157[] PROGMEM = "(prin1-to-string item [stream])\n" -"Prints its argument to a string, and returns the string.\n" -"Characters and strings are printed with quotation marks and escape characters,\n" -"in a format that will be suitable for read-from-string."; -const char doc158[] PROGMEM = "(ash value shift)\n" -"Returns the result of bitwise shifting value by shift bits. If shift is positive, value is shifted to the left."; -const char doc159[] PROGMEM = "(logbitp bit value)\n" -"Returns t if bit number bit in value is a '1', and nil if it is a '0'."; -const char doc160[] PROGMEM = "(eval form*)\n" -"Evaluates its argument an extra time."; -const char doc161[] PROGMEM = "(globals)\n" -"Returns a list of global variables."; -const char doc162[] PROGMEM = "(locals)\n" -"Returns an association list of local variables and their values."; -const char doc163[] PROGMEM = "(makunbound symbol)\n" -"Removes the value of the symbol from GlobalEnv and returns the symbol."; -const char doc164[] PROGMEM = "(break)\n" -"Inserts a breakpoint in the program. When evaluated prints Break! and reenters the REPL."; -const char doc165[] PROGMEM = "(read [stream])\n" -"Reads an atom or list from the serial input and returns it.\n" -"If stream is specified the item is read from the specified stream."; -const char doc166[] PROGMEM = "(prin1 item [stream])\n" -"Prints its argument, and returns its value.\n" -"Strings are printed with quotation marks and escape characters."; -const char doc167[] PROGMEM = "(print item [stream])\n" -"Prints its argument with quotation marks and escape characters, on a new line, and followed by a space.\n" -"If stream is specified the argument is printed to the specified stream."; -const char doc168[] PROGMEM = "(princ item [stream])\n" -"Prints its argument, and returns its value.\n" -"Characters and strings are printed without quotation marks or escape characters."; -const char doc169[] PROGMEM = "(terpri [stream])\n" -"Prints a new line, and returns nil.\n" -"If stream is specified the new line is written to the specified stream."; -const char doc170[] PROGMEM = "(read-byte stream)\n" -"Reads a byte from a stream and returns it."; -const char doc171[] PROGMEM = "(read-line [stream])\n" -"Reads characters from the serial input up to a newline character, and returns them as a string, excluding the newline.\n" -"If stream is specified the line is read from the specified stream."; -const char doc172[] PROGMEM = "(write-byte number [stream])\n" -"Writes a byte to a stream."; -const char doc173[] PROGMEM = "(write-string string [stream])\n" -"Writes a string. If stream is specified the string is written to the stream."; -const char doc174[] PROGMEM = "(write-line string [stream])\n" -"Writes a string terminated by a newline character. If stream is specified the string is written to the stream."; -const char doc175[] PROGMEM = "(restart-i2c stream [read-p])\n" -"Restarts an i2c-stream.\n" -"If read-p is nil or omitted the stream is written to.\n" -"If read-p is an integer it specifies the number of bytes to be read from the stream."; -const char doc176[] PROGMEM = "(gc)\n" -"Forces a garbage collection and prints the number of objects collected, and the time taken."; -const char doc177[] PROGMEM = "(room)\n" -"Returns the number of free Lisp cells remaining."; -const char doc180[] PROGMEM = "(cls)\n" -"Prints a clear-screen character."; -const char doc181[] PROGMEM = "(digitalread pin)\n" -"Reads the state of the specified Arduino pin number and returns t (high) or nil (low)."; -const char doc182[] PROGMEM = "(analogreadresolution bits)\n" -"Specifies the resolution for the analogue inputs on platforms that support it.\n" -"The default resolution on all platforms is 10 bits."; -const char doc183[] PROGMEM = "(analogwrite pin value)\n" -"Writes the value to the specified Arduino pin number."; -const char doc184[] PROGMEM = "(delay number)\n" -"Delays for a specified number of milliseconds."; -const char doc185[] PROGMEM = "(millis)\n" -"Returns the time in milliseconds that uLisp has been running."; -const char doc186[] PROGMEM = "(sleep secs)\n" -"Puts the processor into a low-power sleep mode for secs.\n" -"Only supported on some platforms. On other platforms it does delay(1000*secs)."; -const char doc187[] PROGMEM = "(note [pin] [note] [octave])\n" -"Generates a square wave on pin.\n" -"The argument note represents the note in the well-tempered scale, from 0 to 11,\n" -"where 0 represents C, 1 represents C#, and so on.\n" -"The argument octave can be from 3 to 6. If omitted it defaults to 0."; -const char doc188[] PROGMEM = "(edit 'function)\n" -"Calls the Lisp tree editor to allow you to edit a function definition."; -const char doc189[] PROGMEM = "(pprint item [str])\n" -"Prints its argument, using the pretty printer, to display it formatted in a structured way.\n" -"If str is specified it prints to the specified stream. It returns no value."; -const char doc190[] PROGMEM = "(pprintall [str])\n" -"Pretty-prints the definition of every function and variable defined in the uLisp workspace.\n" -"If str is specified it prints to the specified stream. It returns no value."; -const char doc191[] PROGMEM = "(require 'symbol)\n" -"Loads the definition of a function defined with defun, or a variable defined with defvar, from the Lisp Library.\n" -"It returns t if it was loaded, or nil if the symbol is already defined or isn't defined in the Lisp Library."; -const char doc192[] PROGMEM = "(list-library)\n" -"Prints a list of the functions defined in the List Library."; -const char doc193[] PROGMEM = "(? item)\n" -"Prints the documentation string of a built-in or user-defined function."; -const char doc194[] PROGMEM = "(documentation 'symbol [type])\n" -"Returns the documentation string of a built-in or user-defined function. The type argument is ignored."; -const char doc195[] PROGMEM = "(apropos item)\n" -"Prints the user-defined and built-in functions whose names contain the specified string or symbol."; -const char doc196[] PROGMEM = "(apropos-list item)\n" -"Returns a list of user-defined and built-in functions whose names contain the specified string or symbol."; -const char doc197[] PROGMEM = "(unwind-protect form1 [forms]*)\n" -"Evaluates form1 and forms in order and returns the value of form1,\n" -"but guarantees to evaluate forms even if an error occurs in form1."; -const char doc198[] PROGMEM = "(ignore-errors [forms]*)\n" -"Evaluates forms ignoring errors."; -const char doc199[] PROGMEM = "(error controlstring [arguments]*)\n" -"Signals an error. The message is printed by format using the controlstring and arguments."; -const char doc200[] PROGMEM = "(with-client (str [address port]) form*)\n" -"Evaluates the forms with str bound to a wifi-stream."; -const char doc201[] PROGMEM = "(available stream)\n" -"Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available."; -const char doc202[] PROGMEM = "(wifi-server)\n" -"Starts a Wi-Fi server running. It returns nil."; -const char doc203[] PROGMEM = "(wifi-softap ssid [password channel hidden])\n" -"Set up a soft access point to establish a Wi-Fi network.\n" -"Returns the IP address as a string or nil if unsuccessful."; -const char doc204[] PROGMEM = "(connected stream)\n" -"Returns t or nil to indicate if the client on stream is connected."; -const char doc205[] PROGMEM = "(wifi-localip)\n" -"Returns the IP address of the local network as a string."; -const char doc206[] PROGMEM = "(wifi-connect [ssid pass])\n" -"Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string."; -const char doc207[] PROGMEM = "(with-gfx (str) form*)\n" -"Evaluates the forms with str bound to an gfx-stream so you can print text\n" -"to the graphics display using the standard uLisp print commands."; -const char doc208[] PROGMEM = "(draw-pixel x y [colour])\n" -"Draws a pixel at coordinates (x,y) in colour, or white if omitted."; -const char doc209[] PROGMEM = "(draw-line x0 y0 x1 y1 [colour])\n" -"Draws a line from (x0,y0) to (x1,y1) in colour, or white if omitted."; -const char doc210[] PROGMEM = "(draw-rect x y w h [colour])\n" -"Draws an outline rectangle with its top left corner at (x,y), with width w,\n" -"and with height h. The outline is drawn in colour, or white if omitted."; -const char doc211[] PROGMEM = "(fill-rect x y w h [colour])\n" -"Draws a filled rectangle with its top left corner at (x,y), with width w,\n" -"and with height h. The outline is drawn in colour, or white if omitted."; -const char doc212[] PROGMEM = "(draw-circle x y r [colour])\n" -"Draws an outline circle with its centre at (x, y) and with radius r.\n" -"The circle is drawn in colour, or white if omitted."; -const char doc213[] PROGMEM = "(fill-circle x y r [colour])\n" -"Draws a filled circle with its centre at (x, y) and with radius r.\n" -"The circle is drawn in colour, or white if omitted."; -const char doc214[] PROGMEM = "(draw-round-rect x y w h radius [colour])\n" -"Draws an outline rounded rectangle with its top left corner at (x,y), with width w,\n" -"height h, and corner radius radius. The outline is drawn in colour, or white if omitted."; -const char doc215[] PROGMEM = "(fill-round-rect x y w h radius [colour])\n" -"Draws a filled rounded rectangle with its top left corner at (x,y), with width w,\n" -"height h, and corner radius radius. The outline is drawn in colour, or white if omitted."; -const char doc216[] PROGMEM = "(draw-triangle x0 y0 x1 y1 x2 y2 [colour])\n" -"Draws an outline triangle between (x1,y1), (x2,y2), and (x3,y3).\n" -"The outline is drawn in colour, or white if omitted."; -const char doc217[] PROGMEM = "(fill-triangle x0 y0 x1 y1 x2 y2 [colour])\n" -"Draws a filled triangle between (x1,y1), (x2,y2), and (x3,y3).\n" -"The outline is drawn in colour, or white if omitted."; -const char doc218[] PROGMEM = "(draw-char x y char [colour background size])\n" -"Draws the character char with its top left corner at (x,y).\n" -"The character is drawn in a 5 x 7 pixel font in colour against background,\n" -"which default to white and black respectively.\n" -"The character can optionally be scaled by size."; -const char doc219[] PROGMEM = "(set-cursor x y)\n" -"Sets the start point for text plotting to (x, y)."; -const char doc220[] PROGMEM = "(set-text-color colour [background])\n" -"Sets the text colour for text plotted using (with-gfx ...)."; -const char doc221[] PROGMEM = "(set-text-size scale)\n" -"Scales text by the specified size, default 1."; -const char doc222[] PROGMEM = "(set-text-wrap boolean)\n" -"Specified whether text wraps at the right-hand edge of the display; the default is t."; -const char doc223[] PROGMEM = "(fill-screen [colour])\n" -"Fills or clears the screen with colour, default black."; -const char doc224[] PROGMEM = "(set-rotation option)\n" -"Sets the display orientation for subsequent graphics commands; values are 0, 1, 2, or 3."; -const char doc225[] PROGMEM = "(invert-display boolean)\n" -"Mirror-images the display."; - -// Built-in symbol lookup table -const tbl_entry_t lookup_table[] PROGMEM = { - { string0, NULL, 0000, doc0 }, - { string1, NULL, 0000, doc1 }, - { string2, NULL, 0000, doc2 }, - { string3, NULL, 0000, doc3 }, - { string4, NULL, 0000, NULL }, - { string5, NULL, 0000, NULL }, - { string6, NULL, 0000, NULL }, - { string7, NULL, 0000, doc7 }, - { string8, NULL, 0017, doc8 }, - { string9, NULL, 0017, doc9 }, - { string10, NULL, 0017, doc10 }, - { string11, NULL, 0017, NULL }, - { string12, NULL, 0007, NULL }, - { string13, sp_quote, 0311, NULL }, - { string14, sp_defun, 0327, doc14 }, - { string15, sp_defvar, 0313, doc15 }, - { string16, fn_car, 0211, doc16 }, - { string17, fn_car, 0211, NULL }, - { string18, fn_cdr, 0211, doc18 }, - { string19, fn_cdr, 0211, NULL }, - { string20, fn_nth, 0222, doc20 }, - { string21, fn_aref, 0227, doc21 }, - { string22, fn_stringfn, 0211, doc22 }, - { string23, fn_pinmode, 0222, doc23 }, - { string24, fn_digitalwrite, 0222, doc24 }, - { string25, fn_analogread, 0211, doc25 }, - { string26, fn_register, 0212, doc26 }, - { string27, fn_format, 0227, doc27 }, - { string28, sp_or, 0307, doc28 }, - { string29, sp_setq, 0327, doc29 }, - { string30, sp_loop, 0307, doc30 }, - { string31, sp_return, 0307, doc31 }, - { string32, sp_push, 0322, doc32 }, - { string33, sp_pop, 0311, doc33 }, - { string34, sp_incf, 0312, doc34 }, - { string35, sp_decf, 0312, doc35 }, - { string36, sp_setf, 0327, doc36 }, - { string37, sp_dolist, 0317, doc37 }, - { string38, sp_dotimes, 0317, doc38 }, - { string39, sp_trace, 0301, doc39 }, - { string40, sp_untrace, 0301, doc40 }, - { string41, sp_formillis, 0317, doc41 }, - { string42, sp_time, 0311, doc42 }, - { string43, sp_withoutputtostring, 0317, doc43 }, - { string44, sp_withserial, 0317, doc44 }, - { string45, sp_withi2c, 0317, doc45 }, - { string46, sp_withspi, 0317, doc46 }, - { string47, sp_withsdcard, 0327, doc47 }, - { string48, tf_progn, 0107, doc48 }, - { string49, tf_if, 0123, doc49 }, - { string50, tf_cond, 0107, doc50 }, - { string51, tf_when, 0117, doc51 }, - { string52, tf_unless, 0117, doc52 }, - { string53, tf_case, 0117, doc53 }, - { string54, tf_and, 0107, doc54 }, - { string55, fn_not, 0211, doc55 }, - { string56, fn_not, 0211, NULL }, - { string57, fn_cons, 0222, doc57 }, - { string58, fn_atom, 0211, doc58 }, - { string59, fn_listp, 0211, doc59 }, - { string60, fn_consp, 0211, doc60 }, - { string61, fn_symbolp, 0211, doc61 }, - { string62, fn_arrayp, 0211, doc62 }, - { string63, fn_boundp, 0211, doc63 }, - { string64, fn_keywordp, 0211, doc64 }, - { string65, fn_setfn, 0227, doc65 }, - { string66, fn_streamp, 0211, doc66 }, - { string67, fn_eq, 0222, doc67 }, - { string68, fn_equal, 0222, doc68 }, - { string69, fn_caar, 0211, doc69 }, - { string70, fn_cadr, 0211, doc70 }, - { string71, fn_cadr, 0211, NULL }, - { string72, fn_cdar, 0211, doc72 }, - { string73, fn_cddr, 0211, doc73 }, - { string74, fn_caaar, 0211, doc74 }, - { string75, fn_caadr, 0211, doc75 }, - { string76, fn_cadar, 0211, doc76 }, - { string77, fn_caddr, 0211, doc77 }, - { string78, fn_caddr, 0211, NULL }, - { string79, fn_cdaar, 0211, doc79 }, - { string80, fn_cdadr, 0211, doc80 }, - { string81, fn_cddar, 0211, doc81 }, - { string82, fn_cdddr, 0211, doc82 }, - { string83, fn_length, 0211, doc83 }, - { string84, fn_arraydimensions, 0211, doc84 }, - { string85, fn_list, 0207, doc85 }, - { string86, fn_makearray, 0215, doc86 }, - { string87, fn_reverse, 0211, doc87 }, - { string88, fn_assoc, 0222, doc88 }, - { string89, fn_member, 0222, doc89 }, - { string90, fn_apply, 0227, doc90 }, - { string91, fn_funcall, 0217, doc91 }, - { string92, fn_append, 0207, doc92 }, - { string93, fn_mapc, 0227, doc93 }, - { string94, fn_mapcar, 0227, doc94 }, - { string95, fn_mapcan, 0227, doc95 }, - { string96, fn_add, 0207, doc96 }, - { string97, fn_subtract, 0217, doc97 }, - { string98, fn_multiply, 0207, doc98 }, - { string99, fn_divide, 0217, doc99 }, - { string100, fn_mod, 0222, doc100 }, - { string101, fn_oneplus, 0211, doc101 }, - { string102, fn_oneminus, 0211, doc102 }, - { string103, fn_abs, 0211, doc103 }, - { string104, fn_random, 0211, doc104 }, - { string105, fn_maxfn, 0217, doc105 }, - { string106, fn_minfn, 0217, doc106 }, - { string107, fn_noteq, 0217, doc107 }, - { string108, fn_numeq, 0217, doc108 }, - { string109, fn_less, 0217, doc109 }, - { string110, fn_lesseq, 0217, doc110 }, - { string111, fn_greater, 0217, doc111 }, - { string112, fn_greatereq, 0217, doc112 }, - { string113, fn_plusp, 0211, doc113 }, - { string114, fn_minusp, 0211, doc114 }, - { string115, fn_zerop, 0211, doc115 }, - { string116, fn_oddp, 0211, doc116 }, - { string117, fn_evenp, 0211, doc117 }, - { string118, fn_integerp, 0211, doc118 }, - { string119, fn_numberp, 0211, doc119 }, - { string120, fn_floatfn, 0211, doc120 }, - { string121, fn_floatp, 0211, doc121 }, - { string122, fn_sin, 0211, doc122 }, - { string123, fn_cos, 0211, doc123 }, - { string124, fn_tan, 0211, doc124 }, - { string125, fn_asin, 0211, doc125 }, - { string126, fn_acos, 0211, doc126 }, - { string127, fn_atan, 0212, doc127 }, - { string128, fn_sinh, 0211, doc128 }, - { string129, fn_cosh, 0211, doc129 }, - { string130, fn_tanh, 0211, doc130 }, - { string131, fn_exp, 0211, doc131 }, - { string132, fn_sqrt, 0211, doc132 }, - { string133, fn_log, 0212, doc133 }, - { string134, fn_expt, 0222, doc134 }, - { string135, fn_ceiling, 0212, doc135 }, - { string136, fn_floor, 0212, doc136 }, - { string137, fn_truncate, 0212, doc137 }, - { string138, fn_round, 0212, doc138 }, - { string139, fn_char, 0222, doc139 }, - { string140, fn_charcode, 0211, doc140 }, - { string141, fn_codechar, 0211, doc141 }, - { string142, fn_characterp, 0211, doc142 }, - { string143, fn_stringp, 0211, doc143 }, - { string144, fn_stringeq, 0222, doc144 }, - { string145, fn_stringless, 0222, doc145 }, - { string146, fn_stringgreater, 0222, doc146 }, - { string147, fn_sort, 0222, doc147 }, - { string148, fn_concatenate, 0217, doc148 }, - { string149, fn_subseq, 0223, doc149 }, - { string150, fn_search, 0222, doc150 }, - { string151, fn_readfromstring, 0211, doc151 }, - { string152, fn_princtostring, 0211, doc152 }, - { string153, fn_prin1tostring, 0211, doc153 }, - { string154, fn_logand, 0207, doc154 }, - { string155, fn_logior, 0207, doc155 }, - { string156, fn_logxor, 0207, doc156 }, - { string157, fn_lognot, 0211, doc157 }, - { string158, fn_ash, 0222, doc158 }, - { string159, fn_logbitp, 0222, doc159 }, - { string160, fn_eval, 0211, doc160 }, - { string161, fn_globals, 0200, doc161 }, - { string162, fn_locals, 0200, doc162 }, - { string163, fn_makunbound, 0211, doc163 }, - { string164, fn_break, 0200, doc164 }, - { string165, fn_read, 0201, doc165 }, - { string166, fn_prin1, 0212, doc166 }, - { string167, fn_print, 0212, doc167 }, - { string168, fn_princ, 0212, doc168 }, - { string169, fn_terpri, 0201, doc169 }, - { string170, fn_readbyte, 0202, doc170 }, - { string171, fn_readline, 0201, doc171 }, - { string172, fn_writebyte, 0212, doc172 }, - { string173, fn_writestring, 0212, doc173 }, - { string174, fn_writeline, 0212, doc174 }, - { string175, fn_restarti2c, 0212, doc175 }, - { string176, fn_gc, 0200, doc176 }, - { string177, fn_room, 0200, doc177 }, - { string180, fn_cls, 0200, doc180 }, - { string181, fn_digitalread, 0211, doc181 }, - { string182, fn_analogreadresolution, 0211, doc182 }, - { string183, fn_analogwrite, 0222, doc183 }, - { string184, fn_delay, 0211, doc184 }, - { string185, fn_millis, 0200, doc185 }, - { string186, fn_sleep, 0201, doc186 }, - { string187, fn_note, 0203, doc187 }, - { string188, fn_edit, 0211, doc188 }, - { string189, fn_pprint, 0212, doc189 }, - { string190, fn_pprintall, 0201, doc190 }, - { string191, fn_require, 0211, doc191 }, - { string192, fn_listlibrary, 0200, doc192 }, - { string193, sp_help, 0311, doc193 }, - { string194, fn_documentation, 0212, doc194 }, - { string195, fn_apropos, 0211, doc195 }, - { string196, fn_aproposlist, 0211, doc196 }, - { string197, sp_unwindprotect, 0307, doc197 }, - { string198, sp_ignoreerrors, 0307, doc198 }, - { string199, sp_error, 0317, doc199 }, - { string200, sp_withclient, 0312, doc200 }, - { string201, fn_available, 0211, doc201 }, - { string202, fn_wifiserver, 0200, doc202 }, - { string203, fn_wifisoftap, 0204, doc203 }, - { string204, fn_connected, 0211, doc204 }, - { string205, fn_wifilocalip, 0200, doc205 }, - { string206, fn_wificonnect, 0203, doc206 }, - { string207, sp_withgfx, 0317, doc207 }, - { string208, fn_drawpixel, 0223, doc208 }, - { string209, fn_drawline, 0245, doc209 }, - { string210, fn_drawrect, 0245, doc210 }, - { string211, fn_fillrect, 0245, doc211 }, - { string212, fn_drawcircle, 0234, doc212 }, - { string213, fn_fillcircle, 0234, doc213 }, - { string214, fn_drawroundrect, 0256, doc214 }, - { string215, fn_fillroundrect, 0256, doc215 }, - { string216, fn_drawtriangle, 0267, doc216 }, - { string217, fn_filltriangle, 0267, doc217 }, - { string218, fn_drawchar, 0236, doc218 }, - { string219, fn_setcursor, 0222, doc219 }, - { string220, fn_settextcolor, 0212, doc220 }, - { string221, fn_settextsize, 0211, doc221 }, - { string222, fn_settextwrap, 0211, doc222 }, - { string223, fn_fillscreen, 0201, doc223 }, - { string224, fn_setrotation, 0211, doc224 }, - { string225, fn_invertdisplay, 0211, doc225 }, - { string226, (fn_ptr_type)LED_BUILTIN, 0, NULL }, - { string227, (fn_ptr_type)HIGH, DIGITALWRITE, NULL }, - { string228, (fn_ptr_type)LOW, DIGITALWRITE, NULL }, - { string229, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string230, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string231, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, - { string232, (fn_ptr_type)OUTPUT, PINMODE, NULL }, -}; - -#if !defined(extensions) -// Table cross-reference functions - -tbl_entry_t *tables[] = {lookup_table, NULL}; -const unsigned int tablesizes[] = { arraysize(lookup_table), 0 }; - -const tbl_entry_t *table (int n) { - return tables[n]; -} - -unsigned int tablesize (int n) { - return tablesizes[n]; -} -#endif - -// Table lookup functions - -/* - lookupbuiltin - looks up a string in lookup_table[], and returns the index of its entry, - or ENDFUNCTIONS if no match is found -*/ -builtin_t lookupbuiltin (char* c) { - unsigned int end = 0, start; - for (int n=0; n<2; n++) { - start = end; - int entries = tablesize(n); - end = end + entries; - for (int i=0; i> 3) & 0x07)) error2(toofewargs); - if ((minmax & 0x07) != 0x07 && nargs>(minmax & 0x07)) error2(toomanyargs); -} - -/* - lookupdoc - looks up the documentation string for the built-in function name -*/ -char *lookupdoc (builtin_t name) { - int n = namename))) return false; - builtin_t name = builtin(obj->name); - int n = name>4) gc(form, env); - // Escape - if (tstflag(ESCAPE)) { clrflag(ESCAPE); error2(PSTR("escape!"));} - if (!tstflag(NOESC)) testescape(); - - if (form == NULL) return nil; - - if (form->type >= NUMBER && form->type <= STRING) return form; - - if (symbolp(form)) { - symbol_t name = form->name; - object *pair = value(name, env); - if (pair != NULL) return cdr(pair); - pair = value(name, GlobalEnv); - if (pair != NULL) return cdr(pair); - else if (builtinp(name)) return form; - error(PSTR("undefined"), form); - } - - // It's a list - object *function = car(form); - object *args = cdr(form); - - if (function == NULL) error(PSTR("illegal function"), nil); - if (!listp(args)) error(PSTR("can't evaluate a dotted pair"), args); - - // List starts with a builtin symbol? - if (symbolp(function) && builtinp(function->name)) { - builtin_t name = builtin(function->name); - - if ((name == LET) || (name == LETSTAR)) { - int TCstart = TC; - if (args == NULL) error2(noargument); - object *assigns = first(args); - if (!listp(assigns)) error(notalist, assigns); - object *forms = cdr(args); - object *newenv = env; - push(newenv, GCStack); - while (assigns != NULL) { - object *assign = car(assigns); - if (!consp(assign)) push(cons(assign,nil), newenv); - else if (cdr(assign) == NULL) push(cons(first(assign),nil), newenv); - else push(cons(first(assign),eval(second(assign),env)), newenv); - car(GCStack) = newenv; - if (name == LETSTAR) env = newenv; - assigns = cdr(assigns); - } - env = newenv; - pop(GCStack); - form = tf_progn(forms,env); - TC = TCstart; - goto EVAL; - } - - if (name == LAMBDA) { - if (env == NULL) return form; - object *envcopy = NULL; - while (env != NULL) { - object *pair = first(env); - if (pair != NULL) push(pair, envcopy); - env = cdr(env); - } - return cons(bsymbol(CLOSURE), cons(envcopy,args)); - } - uint8_t fntype = getminmax(name)>>6; - - if (fntype == SPECIAL_FORMS) { - Context = name; - return ((fn_ptr_type)lookupfn(name))(args, env); - } - - if (fntype == TAIL_FORMS) { - Context = name; - form = ((fn_ptr_type)lookupfn(name))(args, env); - TC = 1; - goto EVAL; - } - if (fntype == OTHER_FORMS) error(PSTR("can't be used as a function"), function); - } - - // Evaluate the parameters - result in head - object *fname = car(form); - int TCstart = TC; - object *head = cons(eval(fname, 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 (symbolp(function)) { - builtin_t bname = builtin(function->name); - if (!builtinp(function->name)) error(PSTR("not valid here"), fname); - Context = bname; - checkminmax(bname, nargs); - object *result = ((fn_ptr_type)lookupfn(bname))(args, env); - pop(GCStack); - return result; - } - - if (consp(function)) { - symbol_t name = sym(NIL); - if (!listp(fname)) name = fname->name; - - if (isbuiltin(car(function), LAMBDA)) { - form = closure(TCstart, name, function, args, &env); - pop(GCStack); - int trace = tracing(fname->name); - if (trace) { - object *result = eval(form, env); - indent((--(TraceDepth[trace-1]))<<1, ' ', pserial); - pint(TraceDepth[trace-1], pserial); - pserial(':'); pserial(' '); - printobject(fname, pserial); pfstring(PSTR(" returned "), pserial); - printobject(result, pserial); pln(pserial); - return result; - } else { - TC = 1; - goto EVAL; - } - } - - if (isbuiltin(car(function), CLOSURE)) { - function = cdr(function); - form = closure(TCstart, name, function, args, &env); - pop(GCStack); - TC = 1; - goto EVAL; - } - - } - error(PSTR("illegal function"), fname); return nil; -} - -// Print functions - -/* - pserial - prints a character to the serial port -*/ -void pserial (char c) { - LastPrint = c; - if (c == '\n') Serial.write('\r'); - Serial.write(c); -} - -const char ControlCodes[] PROGMEM = "Null\0SOH\0STX\0ETX\0EOT\0ENQ\0ACK\0Bell\0Backspace\0Tab\0Newline\0VT\0" -"Page\0Return\0SO\0SI\0DLE\0DC1\0DC2\0DC3\0DC4\0NAK\0SYN\0ETB\0CAN\0EM\0SUB\0Escape\0FS\0GS\0RS\0US\0Space\0"; - -/* - pcharacter - prints a character to a stream, escaping special characters if PRINTREADABLY is false - If <= 32 prints character name; eg #\Space - If < 127 prints ASCII; eg #\A - Otherwise prints decimal; eg #\234 -*/ -void pcharacter (uint8_t c, pfun_t pfun) { - if (!tstflag(PRINTREADABLY)) pfun(c); - else { - pfun('#'); pfun('\\'); - if (c <= 32) { - PGM_P p = ControlCodes; - while (c > 0) {p = p + strlen_P(p) + 1; c--; } - pfstring(p, pfun); - } else if (c < 127) pfun(c); - else pint(c, pfun); - } -} - -/* - pstring - prints a C string to the specified stream -*/ -void pstring (char *s, pfun_t pfun) { - while (*s) pfun(*s++); -} - -/* - plispstring - prints a Lisp string object to the specified stream -*/ -void plispstring (object *form, pfun_t pfun) { - plispstr(form->name, pfun); -} - -/* - plispstr - prints a Lisp string name to the specified stream -*/ -void plispstr (symbol_t name, pfun_t pfun) { - object *form = (object *)name; - while (form != NULL) { - int chars = form->chars; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; - if (tstflag(PRINTREADABLY) && (ch == '"' || ch == '\\')) pfun('\\'); - if (ch) pfun(ch); - } - form = car(form); - } -} - -/* - printstring - prints a Lisp string object to the specified stream - taking account of the PRINTREADABLY flag -*/ -void printstring (object *form, pfun_t pfun) { - if (tstflag(PRINTREADABLY)) pfun('"'); - plispstr(form->name, pfun); - if (tstflag(PRINTREADABLY)) pfun('"'); -} - -/* - pbuiltin - prints a built-in symbol to the specified stream -*/ -void pbuiltin (builtin_t name, pfun_t pfun) { - int p = 0; - int n = name0; d = d/40) { - uint32_t j = x/d; - char c = fromradix40(j); - if (c == 0) return; - pfun(c); x = x - j*d; - } -} - -/* - printsymbol - prints any symbol from a symbol object to the specified stream -*/ -void printsymbol (object *form, pfun_t pfun) { - psymbol(form->name, pfun); -} - -/* - psymbol - prints any symbol from a symbol name to the specified stream -*/ -void psymbol (symbol_t name, pfun_t pfun) { - if ((name & 0x03) == 0) plispstr(name, pfun); - else { - uint32_t value = untwist(name); - if (value < PACKEDS) error2(PSTR("invalid symbol")); - else if (value >= BUILTINS) pbuiltin((builtin_t)(value-BUILTINS), pfun); - else pradix40(name, pfun); - } -} - -/* - pfstring - prints a string from flash memory to the specified stream -*/ -void pfstring (PGM_P s, pfun_t pfun) { - int p = 0; - while (1) { - char c = pgm_read_byte(&s[p++]); - if (c == 0) return; - pfun(c); - } -} - -/* - pint - prints an integer in decimal to the specified stream -*/ -void pint (int i, pfun_t pfun) { - uint32_t j = i; - if (i<0) { pfun('-'); j=-i; } - pintbase(j, 10, pfun); -} - -/* - pintbase - prints an integer in base 'base' to the specified stream -*/ -void pintbase (uint32_t i, uint8_t base, pfun_t pfun) { - int lead = 0; uint32_t p = 1000000000; - if (base == 2) p = 0x80000000; else if (base == 16) p = 0x10000000; - for (uint32_t d=p; d>0; d=d/base) { - uint32_t j = i/d; - if (j!=0 || lead || d==1) { pfun((j<10) ? j+'0' : j+'W'); lead=1;} - i = i - j*d; - } -} - -/* - pmantissa - prints the mantissa of a floating-point number to the specified stream -*/ -void pmantissa (float f, pfun_t pfun) { - int sig = floor(log10(f)); - int mul = pow(10, 5 - sig); - int i = round(f * mul); - bool point = false; - if (i == 1000000) { i = 100000; sig++; } - if (sig < 0) { - pfun('0'); pfun('.'); point = true; - for (int j=0; j < - sig - 1; j++) pfun('0'); - } - mul = 100000; - for (int j=0; j<7; j++) { - int d = (int)(i / mul); - pfun(d + '0'); - i = i - d * mul; - if (i == 0) { - if (!point) { - for (int k=j; k= 0) { pfun('.'); point = true; } - mul = mul / 10; - } -} - -/* - pfloat - prints a floating-point number to the specified stream -*/ -void pfloat (float f, pfun_t pfun) { - if (isnan(f)) { pfstring(PSTR("NaN"), pfun); return; } - if (f == 0.0) { pfun('0'); return; } - if (isinf(f)) { pfstring(PSTR("Inf"), pfun); return; } - if (f < 0) { pfun('-'); f = -f; } - // Calculate exponent - int e = 0; - if (f < 1e-3 || f >= 1e5) { - e = floor(log(f) / 2.302585); // log10 gives wrong result - f = f / pow(10, e); - } - - pmantissa (f, pfun); - - // Exponent - if (e != 0) { - pfun('e'); - pint(e, pfun); - } -} - -/* - pln - prints a newline to the specified stream -*/ -inline void pln (pfun_t pfun) { - pfun('\n'); -} - -/* - pfl - prints a newline to the specified stream if a newline has not just been printed -*/ -void pfl (pfun_t pfun) { - if (LastPrint != '\n') pfun('\n'); -} - -/* - plist - prints a list to the specified stream -*/ -void plist (object *form, pfun_t pfun) { - pfun('('); - printobject(car(form), pfun); - form = cdr(form); - while (form != NULL && listp(form)) { - pfun(' '); - printobject(car(form), pfun); - form = cdr(form); - } - if (form != NULL) { - pfstring(PSTR(" . "), pfun); - printobject(form, pfun); - } - pfun(')'); -} - -/* - pstream - prints a stream name to the specified stream -*/ -void pstream (object *form, pfun_t pfun) { - pfun('<'); - PGM_P s = (char*)pgm_read_ptr(&streamname[(form->integer)>>8]); - pfstring(s, pfun); - pfstring(PSTR("-stream "), pfun); - pint(form->integer & 0xFF, pfun); - pfun('>'); -} - -/* - printobject - prints any Lisp object to the specified stream -*/ -void printobject (object *form, pfun_t pfun) { - if (form == NULL) pfstring(PSTR("nil"), pfun); - else if (listp(form) && isbuiltin(car(form), CLOSURE)) pfstring(PSTR(""), pfun); - else if (listp(form)) plist(form, pfun); - else if (integerp(form)) pint(form->integer, pfun); - else if (floatp(form)) pfloat(form->single_float, pfun); - else if (symbolp(form)) { if (form->name != sym(NOTHING)) printsymbol(form, pfun); } - else if (characterp(form)) pcharacter(form->chars, pfun); - else if (stringp(form)) printstring(form, pfun); - else if (arrayp(form)) printarray(form, pfun); - else if (streamp(form)) pstream(form, pfun); - else error2(PSTR("error in print")); -} - -/* - prin1object - prints any Lisp object to the specified stream escaping special characters -*/ -void prin1object (object *form, pfun_t pfun) { - char temp = Flags; - clrflag(PRINTREADABLY); - printobject(form, pfun); - Flags = temp; -} - -// Read functions - -/* - glibrary - reads a character from the Lisp Library -*/ -int glibrary () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - char c = pgm_read_byte(&LispLibrary[GlobalStringIndex++]); - return (c != 0) ? c : -1; // -1? -} - -/* - loadfromlibrary - reads and evaluates a form from the Lisp Library -*/ -void loadfromlibrary (object *env) { - GlobalStringIndex = 0; - object *line = read(glibrary); - while (line != NULL) { - push(line, GCStack); - eval(line, env); - pop(GCStack); - line = read(glibrary); - } -} - -/* - gserial - gets a character from the serial port -*/ -int gserial () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - unsigned long start = millis(); - while (!Serial.available()) { delay(1); if (millis() - start > 1000) clrflag(NOECHO); } - char temp = Serial.read(); - if (temp != '\n' && !tstflag(NOECHO)) pserial(temp); - return temp; -#endif -} - -/* - nextitem - reads the next token from the specified stream -*/ -object *nextitem (gfun_t gfun) { - int ch = gfun(); - while(issp(ch)) ch = gfun(); - - if (ch == ';') { - do { ch = gfun(); if (ch == ';' || ch == '(') setflag(NOECHO); } - while(ch != '('); - } - if (ch == '\n') ch = gfun(); - if (ch == -1) return nil; - if (ch == ')') return (object *)KET; - if (ch == '(') return (object *)BRA; - if (ch == '\'') return (object *)QUO; - - // Parse string - if (ch == '"') return readstring('"', gfun); - - // Parse symbol, character, or number - int index = 0, base = 10, sign = 1; - char buffer[BUFFERSIZE]; - int bufmax = BUFFERSIZE-3; // Max index - unsigned int result = 0; - bool isfloat = false; - float fresult = 0.0; - - if (ch == '+') { - buffer[index++] = ch; - ch = gfun(); - } else if (ch == '-') { - sign = -1; - buffer[index++] = ch; - ch = gfun(); - } else if (ch == '.') { - buffer[index++] = ch; - ch = gfun(); - if (ch == ' ') return (object *)DOT; - isfloat = true; - } - - // Parse reader macros - else if (ch == '#') { - ch = gfun(); - char ch2 = ch & ~0x20; // force to upper case - if (ch == '\\') { // Character - base = 0; ch = gfun(); - if (issp(ch) || isbr(ch)) return character(ch); - else LastChar = ch; - } else if (ch == '|') { - do { while (gfun() != '|'); } - while (gfun() != '#'); - return nextitem(gfun); - } else if (ch2 == 'B') base = 2; - else if (ch2 == 'O') base = 8; - else if (ch2 == 'X') base = 16; - else if (ch == '\'') return nextitem(gfun); - else if (ch == '.') { - setflag(NOESC); - object *result = eval(read(gfun), NULL); - clrflag(NOESC); - return result; - } - else if (ch == '(') { LastChar = ch; return readarray(1, read(gfun)); } - else if (ch == '*') return readbitarray(gfun); - else if (ch >= '1' && ch <= '9' && (gfun() & ~0x20) == 'A') return readarray(ch - '0', read(gfun)); - else error2(PSTR("illegal character after #")); - ch = gfun(); - } - int valid; // 0=undecided, -1=invalid, +1=valid - if (ch == '.') valid = 0; else if (digitvalue(ch) ((unsigned int)INT_MAX+(1-sign)/2)) - return makefloat((float)result*sign); - return number(result*sign); - } else if (base == 0) { - if (index == 1) return character(buffer[0]); - PGM_P p = ControlCodes; char c = 0; - while (c < 33) { - if (strcasecmp_P(buffer, p) == 0) return character(c); - p = p + strlen_P(p) + 1; c++; - } - if (index == 3) return character((buffer[0]*10+buffer[1])*10+buffer[2]-5328); - error2(PSTR("unknown character")); - } - - builtin_t x = lookupbuiltin(buffer); - if (x == NIL) return nil; - if (x != ENDFUNCTIONS) return bsymbol(x); - else if ((index <= 6) && valid40(buffer)) return intern(twist(pack40(buffer))); - buffer[index+1] = '\0'; buffer[index+2] = '\0'; buffer[index+3] = '\0'; // For internlong - return internlong(buffer); -} - -/* - readrest - reads the remaining tokens from the specified stream -*/ -object *readrest (gfun_t gfun) { - object *item = nextitem(gfun); - object *head = NULL; - object *tail = NULL; - - while (item != (object *)KET) { - if (item == (object *)BRA) { - item = readrest(gfun); - } else if (item == (object *)QUO) { - item = cons(bsymbol(QUOTE), cons(read(gfun), NULL)); - } else if (item == (object *)DOT) { - tail->cdr = read(gfun); - if (readrest(gfun) != NULL) error2(PSTR("malformed list")); - return head; - } else { - object *cell = cons(item, NULL); - if (head == NULL) head = cell; - else tail->cdr = cell; - tail = cell; - item = nextitem(gfun); - } - } - return head; -} - -/* - read - recursively reads a Lisp object from the stream gfun and returns it -*/ -object *read (gfun_t gfun) { - object *item = nextitem(gfun); - if (item == (object *)KET) error2(PSTR("incomplete list")); - if (item == (object *)BRA) return readrest(gfun); - if (item == (object *)DOT) return read(gfun); - if (item == (object *)QUO) return cons(bsymbol(QUOTE), cons(read(gfun), NULL)); - return item; -} - -// Setup - -/* - initenv - initialises the uLisp environment -*/ -void initenv () { - GlobalEnv = NULL; - tee = bsymbol(TEE); -} - -/* - initgfx - initialises the graphics -*/ -void initgfx () { - #if defined(gfxsupport) - tft.init(135, 240); - #if defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) - pinMode(TFT_I2C_POWER, OUTPUT); - digitalWrite(TFT_I2C_POWER, HIGH); - tft.setRotation(3); - #else - tft.setRotation(1); - #endif - tft.fillScreen(ST77XX_BLACK); - pinMode(TFT_BACKLITE, OUTPUT); - digitalWrite(TFT_BACKLITE, HIGH); - #endif -} +#include "ulisp.h" /* setup - entry point from the Arduino IDE @@ -7050,38 +33,6 @@ void setup () { pfstring(PSTR("uLisp 4.4 "), pserial); pln(pserial); } -// Read/Evaluate/Print loop - -/* - repl - the Lisp Read/Evaluate/Print loop -*/ -void repl (object *env) { - for (;;) { - randomSeed(micros()); - gc(NULL, env); - #if defined(printfreespace) - pint(Freespace, pserial); - #endif - if (BreakLevel) { - pfstring(PSTR(" : "), pserial); - pint(BreakLevel, pserial); - } - pserial('>'); pserial(' '); - Context = 0; - object *line = read(gserial); - if (BreakLevel && line == nil) { pln(pserial); return; } - if (line == (object *)KET) error2(PSTR("unmatched right bracket")); - push(line, GCStack); - pfl(pserial); - line = eval(line, env); - pfl(pserial); - printobject(line, pserial); - pop(GCStack); - pfl(pserial); - pln(pserial); - } -} - /* loop - the Arduino IDE main execution loop */ @@ -7092,17 +43,3 @@ void loop () { ulispreset(); repl(NULL); } - -void ulispreset () { - // Come here after error - delay(100); while (Serial.available()) Serial.read(); - clrflag(NOESC); BreakLevel = 0; - for (int i=0; i +#include +#include +#include +#include +#include + +#if defined(gfxsupport) +#include // Core graphics library +#include // Hardware-specific library for ST7789 +Adafruit_ST7789 tft = Adafruit_ST7789(5, 16, 19, 18); +#endif + +#include +#define SDSIZE 172 + +// Constants + +const int TRACEMAX = 3; // Number of traced functions + +// Stream names used by printobject +const char serialstream[] PROGMEM = "serial"; +const char i2cstream[] PROGMEM = "i2c"; +const char spistream[] PROGMEM = "spi"; +const char sdstream[] PROGMEM = "sd"; +const char wifistream[] PROGMEM = "wifi"; +const char stringstream[] PROGMEM = "string"; +const char gfxstream[] PROGMEM = "gfx"; +PGM_P const streamname[] PROGMEM = {serialstream, i2cstream, spistream, sdstream, wifistream, stringstream, gfxstream}; + +// Global variables + +object Workspace[WORKSPACESIZE] WORDALIGNED; + +jmp_buf toplevel_handler; +jmp_buf *handler = &toplevel_handler; +unsigned int Freespace = 0; +object *Freelist; +unsigned int I2Ccount; +unsigned int TraceFn[TRACEMAX]; +unsigned int TraceDepth[TRACEMAX]; +builtin_t Context; + +object *GlobalEnv; +object *GCStack = NULL; +object *GlobalString; +object *GlobalStringTail; +int GlobalStringIndex = 0; +uint8_t PrintCount = 0; +uint8_t BreakLevel = 0; +char LastChar = 0; +char LastPrint = 0; + +// Flags +volatile uint8_t Flags = 0b00001; // PRINTREADABLY set by default + +// Error handling + +/* + errorsub - used by all the error routines. + Prints: "Error: 'fname' string", where fname is the name of the Lisp function in which the error occurred. +*/ +void errorsub (symbol_t fname, PGM_P string) { + pfl(pserial); pfstring(PSTR("Error: "), pserial); + if (fname != sym(NIL)) { + pserial('\''); + psymbol(fname, pserial); + pserial('\''); pserial(' '); + } + pfstring(string, pserial); +} + +void errorend () { GCStack = NULL; longjmp(*handler, 1); } + +/* + errorsym - prints an error message and reenters the REPL. + Prints: "Error: 'fname' string: symbol", where fname is the name of the user Lisp function in which the error occurred, + and symbol is the object generating the error. +*/ +void errorsym (symbol_t fname, PGM_P string, object *symbol) { + if (!tstflag(MUFFLEERRORS)) { + errorsub(fname, string); + pserial(':'); pserial(' '); + printobject(symbol, pserial); + pln(pserial); + } + errorend(); +} + +/* + errorsym2 - prints an error message and reenters the REPL. + Prints: "Error: 'fname' string", where fname is the name of the user Lisp function in which the error occurred. +*/ +void errorsym2 (symbol_t fname, PGM_P string) { + if (!tstflag(MUFFLEERRORS)) { + errorsub(fname, string); + pln(pserial); + } + errorend(); +} + +/* + error - prints an error message and reenters the REPL. + Prints: "Error: 'Context' string: symbol", where Context is the name of the built-in Lisp function in which the error occurred, + and symbol is the object generating the error. +*/ +void error (PGM_P string, object *symbol) { + errorsym(sym(Context), string, symbol); +} + +/* + error2 - prints an error message and reenters the REPL. + Prints: "Error: 'Context' string", where Context is the name of the built-in Lisp function in which the error occurred. +*/ +void error2 (PGM_P string) { + errorsym2(sym(Context), string); +} + +/* + formaterr - displays a format error with a ^ pointing to the error +*/ +void formaterr (object *formatstr, PGM_P string, uint8_t p) { + pln(pserial); indent(4, ' ', pserial); printstring(formatstr, pserial); pln(pserial); + indent(p+5, ' ', pserial); pserial('^'); + error2(string); + pln(pserial); + GCStack = NULL; + longjmp(*handler, 1); +} + +// Save space as these are used multiple times +const char notanumber[] PROGMEM = "argument is not a number"; +const char notaninteger[] PROGMEM = "argument is not an integer"; +const char notastring[] PROGMEM = "argument is not a string"; +const char notalist[] PROGMEM = "argument is not a list"; +const char notasymbol[] PROGMEM = "argument is not a symbol"; +const char notproper[] PROGMEM = "argument is not a proper list"; +const char toomanyargs[] PROGMEM = "too many arguments"; +const char toofewargs[] PROGMEM = "too few arguments"; +const char noargument[] PROGMEM = "missing argument"; +const char nostream[] PROGMEM = "missing stream argument"; +const char overflow[] PROGMEM = "arithmetic overflow"; +const char divisionbyzero[] PROGMEM = "division by zero"; +const char indexnegative[] PROGMEM = "index can't be negative"; +const char invalidarg[] PROGMEM = "invalid argument"; +const char invalidkey[] PROGMEM = "invalid keyword"; +const char illegalclause[] PROGMEM = "illegal clause"; +const char invalidpin[] PROGMEM = "invalid pin"; +const char oddargs[] PROGMEM = "odd number of arguments"; +const char indexrange[] PROGMEM = "index out of range"; +const char canttakecar[] PROGMEM = "can't take car"; +const char canttakecdr[] PROGMEM = "can't take cdr"; +const char unknownstreamtype[] PROGMEM = "unknown stream type"; + +// Set up workspace + +/* + initworkspace - initialises the workspace into a linked list of free objects +*/ +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++; + } +} + +/* + myalloc - returns the first object from the linked list of free objects +*/ +object *myalloc () { + if (Freespace == 0) error2(PSTR("no room")); + object *temp = Freelist; + Freelist = cdr(Freelist); + Freespace--; + return temp; +} + +/* + myfree - adds obj to the linked list of free objects. + inline makes gc significantly faster +*/ +inline void myfree (object *obj) { + car(obj) = NULL; + cdr(obj) = Freelist; + Freelist = obj; + Freespace++; +} + +// Make each type of object + +/* + number - make an integer object with value n and return it +*/ +object *number (int n) { + object *ptr = myalloc(); + ptr->type = NUMBER; + ptr->integer = n; + return ptr; +} + +/* + makefloat - make a floating point object with value f and return it +*/ +object *makefloat (float f) { + object *ptr = myalloc(); + ptr->type = FLOAT; + ptr->single_float = f; + return ptr; +} + +/* + character - make a character object with value c and return it +*/ +object *character (uint8_t c) { + object *ptr = myalloc(); + ptr->type = CHARACTER; + ptr->chars = c; + return ptr; +} + +/* + cons - make a cons with arg1 and arg2 return it +*/ +object *cons (object *arg1, object *arg2) { + object *ptr = myalloc(); + ptr->car = arg1; + ptr->cdr = arg2; + return ptr; +} + +/* + symbol - make a symbol object with value name and return it +*/ +object *symbol (symbol_t name) { + object *ptr = myalloc(); + ptr->type = SYMBOL; + ptr->name = name; + return ptr; +} + +/* + bsymbol - make a built-in symbol +*/ +inline object *bsymbol (builtin_t name) { + return intern(twist(name+BUILTINS)); +} + +/* + intern - looks through the workspace for an existing occurrence of symbol name and returns it, + otherwise calls symbol(name) to create a new symbol. +*/ +object *intern (symbol_t name) { + for (int i=0; itype == SYMBOL && obj->name == name) return obj; + } + return symbol(name); +} + +/* + eqsymbols - compares the long string/symbol obj with the string in buffer. +*/ +bool eqsymbols (object *obj, char *buffer) { + object *arg = cdr(obj); + int i = 0; + while (!(arg == NULL && buffer[i] == 0)) { + if (arg == NULL || buffer[i] == 0 || + arg->chars != (buffer[i]<<24 | buffer[i+1]<<16 | buffer[i+2]<<8 | buffer[i+3])) return false; + arg = car(arg); + i = i + 4; + } + return true; +} + +/* + internlong - looks through the workspace for an existing occurrence of the long symbol in buffer and returns it, + otherwise calls lispstring(buffer) to create a new symbol. +*/ +object *internlong (char *buffer) { + for (int i=0; itype == SYMBOL && longsymbolp(obj) && eqsymbols(obj, buffer)) return obj; + } + object *obj = lispstring(buffer); + obj->type = SYMBOL; + return obj; +} + +/* + stream - makes a stream object defined by streamtype and address, and returns it +*/ +object *stream (uint8_t streamtype, uint8_t address) { + object *ptr = myalloc(); + ptr->type = STREAM; + ptr->integer = streamtype<<8 | address; + return ptr; +} + +/* + newstring - makes an empty string object and returns it +*/ +object *newstring () { + object *ptr = myalloc(); + ptr->type = STRING; + ptr->chars = 0; + return ptr; +} + +// Garbage collection + +/* + markobject - recursively marks reachable objects, starting from obj +*/ +void markobject (object *obj) { + MARK: + if (obj == NULL) return; + if (marked(obj)) return; + + object* arg = car(obj); + unsigned int type = obj->type; + mark(obj); + + if (type >= PAIR || type == ZZERO) { // cons + markobject(arg); + obj = cdr(obj); + goto MARK; + } + + if (type == ARRAY) { + obj = cdr(obj); + goto MARK; + } + + if ((type == STRING) || (type == SYMBOL && longsymbolp(obj))) { + obj = cdr(obj); + while (obj != NULL) { + arg = car(obj); + mark(obj); + obj = arg; + } + } +} + +/* + sweep - goes through the workspace freeing objects that have not been marked, + and unmarks marked objects +*/ +void sweep () { + Freelist = NULL; + Freespace = 0; + for (int i=WORKSPACESIZE-1; i>=0; i--) { + object *obj = &Workspace[i]; + if (!marked(obj)) myfree(obj); else unmark(obj); + } +} + +/* + gc - performs garbage collection by calling markobject() on each of the pointers to objects in use, + followed by sweep() to free unused objects. +*/ +void gc (object *form, object *env) { + #if defined(printgcs) + int start = Freespace; + static int GC_Count = 0; + #endif + markobject(tee); + markobject(GlobalEnv); + markobject(GCStack); + markobject(form); + markobject(env); + sweep(); + #if defined(printgcs) + GC_Count++; + pfl(pserial); + pfstring(PSTR("{GC #"), pserial); + pint(GC_Count, pserial); + pfstring(PSTR(": "), pserial); + pint(Freespace - start, pserial); + pfstring(PSTR(" freed}"), pserial); + #endif +} + +// Tracing + +/* + tracing - returns a number between 1 and TRACEMAX if name is being traced, or 0 otherwise +*/ +int tracing (symbol_t name) { + int i = 0; + while (i < TRACEMAX) { + if (TraceFn[i] == name) return i+1; + i++; + } + return 0; +} + +/* + trace - enables tracing of symbol name and adds it to the array TraceFn[]. +*/ +void trace (symbol_t name) { + if (tracing(name)) error(PSTR("already being traced"), symbol(name)); + int i = 0; + while (i < TRACEMAX) { + if (TraceFn[i] == 0) { TraceFn[i] = name; TraceDepth[i] = 0; return; } + i++; + } + error2(PSTR("already tracing 3 functions")); +} + +/* + untrace - disables tracing of symbol name and removes it from the array TraceFn[]. +*/ +void untrace (symbol_t name) { + int i = 0; + while (i < TRACEMAX) { + if (TraceFn[i] == name) { TraceFn[i] = 0; return; } + i++; + } + error(PSTR("not tracing"), symbol(name)); +} + +// Helper functions + +/* + consp - implements Lisp consp +*/ +bool consp (object *x) { + if (x == NULL) return false; + unsigned int type = x->type; + return type >= PAIR || type == ZZERO; +} + +/* + atom - implements Lisp atom +*/ +#define atom(x) (!consp(x)) + +/* + listp - implements Lisp listp +*/ +bool listp (object *x) { + if (x == NULL) return true; + unsigned int type = x->type; + return type >= PAIR || type == ZZERO; +} + +/* + improperp - tests whether x is an improper list +*/ +#define improperp(x) (!listp(x)) + +object *quote (object *arg) { + return cons(bsymbol(QUOTE), cons(arg,NULL)); +} + +// Radix 40 encoding + +/* + builtin - converts a symbol name to builtin +*/ +builtin_t builtin (symbol_t name) { + return (builtin_t)(untwist(name) - BUILTINS); +} + +/* + sym - converts a builtin to a symbol name +*/ +symbol_t sym (builtin_t x) { + return twist(x + BUILTINS); +} + +/* + toradix40 - returns a number from 0 to 39 if the character can be encoded, or -1 otherwise. +*/ +int8_t toradix40 (char ch) { + if (ch == 0) return 0; + if (ch >= '0' && ch <= '9') return ch-'0'+1; + if (ch == '-') return 37; if (ch == '*') return 38; if (ch == '$') return 39; + ch = ch | 0x20; + if (ch >= 'a' && ch <= 'z') return ch-'a'+11; + return -1; // Invalid +} + +/* + fromradix40 - returns the character encoded by the number n. +*/ +char fromradix40 (char n) { + if (n >= 1 && n <= 9) return '0'+n-1; + if (n >= 11 && n <= 36) return 'a'+n-11; + if (n == 37) return '-'; if (n == 38) return '*'; if (n == 39) return '$'; + return 0; +} + +/* + pack40 - packs six radix40-encoded characters from buffer into a 32-bit number and returns it. +*/ +uint32_t pack40 (char *buffer) { + int x = 0; + for (int i=0; i<6; i++) x = x * 40 + toradix40(buffer[i]); + return x; +} + +/* + valid40 - returns true if the symbol in buffer can be encoded as six radix40-encoded characters. +*/ +bool valid40 (char *buffer) { + if (toradix40(buffer[0]) < 11) return false; + for (int i=1; i<6; i++) if (toradix40(buffer[i]) < 0) return false; + return true; +} + +/* + digitvalue - returns the numerical value of a hexadecimal digit, or 16 if invalid. +*/ +int8_t 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; +} + +/* + checkinteger - check that obj is an integer and return it +*/ +int checkinteger (object *obj) { + if (!integerp(obj)) error(notaninteger, obj); + return obj->integer; +} + +/* + checkbitvalue - check that obj is an integer equal to 0 or 1 and return it +*/ +int checkbitvalue (object *obj) { + if (!integerp(obj)) error(notaninteger, obj); + int n = obj->integer; + if (n & ~1) error(PSTR("argument is not a bit value"), obj); + return n; +} + +/* + checkintfloat - check that obj is an integer or floating-point number and return the number +*/ +float checkintfloat (object *obj){ + if (integerp(obj)) return obj->integer; + if (!floatp(obj)) error(notanumber, obj); + return obj->single_float; +} + +/* + checkchar - check that obj is a character and return the character +*/ +int checkchar (object *obj) { + if (!characterp(obj)) error(PSTR("argument is not a character"), obj); + return obj->chars; +} + +/* + checkstring - check that obj is a string +*/ +object *checkstring (object *obj) { + if (!stringp(obj)) error(notastring, obj); + return obj; +} + +int isstream (object *obj){ + if (!streamp(obj)) error(PSTR("not a stream"), obj); + return obj->integer; +} + +int isbuiltin (object *obj, builtin_t n) { + return symbolp(obj) && obj->name == sym(n); +} + +bool builtinp (symbol_t name) { + return (untwist(name) >= BUILTINS); +} + +int checkkeyword (object *obj) { + if (!keywordp(obj)) error(PSTR("argument is not a keyword"), obj); + builtin_t kname = builtin(obj->name); + uint8_t context = getminmax(kname); + if (context != 0 && context != Context) error(invalidkey, obj); + return ((int)lookupfn(kname)); +} + +/* + checkargs - checks that the number of objects in the list args + is within the range specified in the symbol lookup table +*/ +void checkargs (object *args) { + int nargs = listlength(args); + checkminmax(Context, nargs); +} + +/* + eq - implements Lisp eq +*/ +boolean eq (object *arg1, object *arg2) { + if (arg1 == arg2) return true; // Same object + if ((arg1 == nil) || (arg2 == nil)) return false; // Not both values + if (arg1->cdr != arg2->cdr) return false; // Different values + if (symbolp(arg1) && symbolp(arg2)) return true; // Same symbol + if (integerp(arg1) && integerp(arg2)) return true; // Same integer + if (floatp(arg1) && floatp(arg2)) return true; // Same float + if (characterp(arg1) && characterp(arg2)) return true; // Same character + return false; +} + +/* + equal - implements Lisp equal +*/ +boolean equal (object *arg1, object *arg2) { + if (stringp(arg1) && stringp(arg2)) return stringcompare(cons(arg1, cons(arg2, nil)), false, false, true); + if (consp(arg1) && consp(arg2)) return (equal(car(arg1), car(arg2)) && equal(cdr(arg1), cdr(arg2))); + return eq(arg1, arg2); +} + +/* + listlength - returns the length of a list +*/ +int listlength (object *list) { + int length = 0; + while (list != NULL) { + if (improperp(list)) error2(notproper); + list = cdr(list); + length++; + } + return length; +} + +// Mathematical helper functions + +/* + add_floats - used by fn_add + Converts the numbers in args to floats, adds them to fresult, and returns the sum as a Lisp float. +*/ +object *add_floats (object *args, float fresult) { + while (args != NULL) { + object *arg = car(args); + fresult = fresult + checkintfloat(arg); + args = cdr(args); + } + return makefloat(fresult); +} + +/* + subtract_floats - used by fn_subtract with more than one argument + Converts the numbers in args to floats, subtracts them from fresult, and returns the result as a Lisp float. +*/ +object *subtract_floats (object *args, float fresult) { + while (args != NULL) { + object *arg = car(args); + fresult = fresult - checkintfloat(arg); + args = cdr(args); + } + return makefloat(fresult); +} + +/* + negate - used by fn_subtract with one argument + If the result is an integer, and negating it doesn't overflow, keep the result as an integer. + Otherwise convert the result to a float, negate it, and return the result as a Lisp float. +*/ +object *negate (object *arg) { + if (integerp(arg)) { + int result = arg->integer; + if (result == INT_MIN) return makefloat(-result); + else return number(-result); + } else if (floatp(arg)) return makefloat(-(arg->single_float)); + else error(notanumber, arg); + return nil; +} + +/* + multiply_floats - used by fn_multiply + Converts the numbers in args to floats, adds them to fresult, and returns the result as a Lisp float. +*/ +object *multiply_floats (object *args, float fresult) { + while (args != NULL) { + object *arg = car(args); + fresult = fresult * checkintfloat(arg); + args = cdr(args); + } + return makefloat(fresult); +} + +/* + divide_floats - used by fn_divide + Converts the numbers in args to floats, divides fresult by them, and returns the result as a Lisp float. +*/ +object *divide_floats (object *args, float fresult) { + while (args != NULL) { + object *arg = car(args); + float f = checkintfloat(arg); + if (f == 0.0) error2(divisionbyzero); + fresult = fresult / f; + args = cdr(args); + } + return makefloat(fresult); +} + +/* + myround - rounds + Returns t if the argument is a floating-point number. +*/ +int myround (float number) { + return (number >= 0) ? (int)(number + 0.5) : (int)(number - 0.5); +} + +/* + compare - a generic compare function + Used to implement the other comparison functions. + If lt is true the result is true if each argument is less than the next argument. + If gt is true the result is true if each argument is greater than the next argument. + If eq is true the result is true if each argument is equal to the next argument. +*/ +object *compare (object *args, bool lt, bool gt, bool eq) { + object *arg1 = first(args); + args = cdr(args); + while (args != NULL) { + object *arg2 = first(args); + if (integerp(arg1) && integerp(arg2)) { + if (!lt && ((arg1->integer) < (arg2->integer))) return nil; + if (!eq && ((arg1->integer) == (arg2->integer))) return nil; + if (!gt && ((arg1->integer) > (arg2->integer))) return nil; + } else { + if (!lt && (checkintfloat(arg1) < checkintfloat(arg2))) return nil; + if (!eq && (checkintfloat(arg1) == checkintfloat(arg2))) return nil; + if (!gt && (checkintfloat(arg1) > checkintfloat(arg2))) return nil; + } + arg1 = arg2; + args = cdr(args); + } + return tee; +} + +/* + intpower - calculates base to the power exp as an integer +*/ +int intpower (int base, int exp) { + int result = 1; + while (exp) { + if (exp & 1) result = result * base; + exp = exp / 2; + base = base * base; + } + return result; +} + +// Association lists + +/* + assoc - looks for key in an association list and returns the matching pair, or nil if not found +*/ +object *assoc (object *key, object *list) { + while (list != NULL) { + if (improperp(list)) error(notproper, list); + object *pair = first(list); + if (!listp(pair)) error(PSTR("element is not a list"), pair); + if (pair != NULL && eq(key,car(pair))) return pair; + list = cdr(list); + } + return nil; +} + +/* + delassoc - deletes the pair matching key from an association list and returns the key, or nil if not found +*/ +object *delassoc (object *key, object **alist) { + object *list = *alist; + object *prev = NULL; + while (list != NULL) { + object *pair = first(list); + if (eq(key,car(pair))) { + if (prev == NULL) *alist = cdr(list); + else cdr(prev) = cdr(list); + return key; + } + prev = list; + list = cdr(list); + } + return nil; +} + +// Array utilities + +/* + nextpower2 - returns the smallest power of 2 that is equal to or greater than n +*/ +int nextpower2 (int n) { + n--; n |= n >> 1; n |= n >> 2; n |= n >> 4; + n |= n >> 8; n |= n >> 16; n++; + return n<2 ? 2 : n; +} + +/* + buildarray - builds an array with n elements using a tree of size s which must be a power of 2 + The elements are initialised to the default def +*/ +object *buildarray (int n, int s, object *def) { + int s2 = s>>1; + if (s2 == 1) { + if (n == 2) return cons(def, def); + else if (n == 1) return cons(def, NULL); + else return NULL; + } else if (n >= s2) return cons(buildarray(s2, s2, def), buildarray(n - s2, s2, def)); + else return cons(buildarray(n, s2, def), nil); +} + +object *makearray (object *dims, object *def, bool bitp) { + int size = 1; + object *dimensions = dims; + while (dims != NULL) { + int d = car(dims)->integer; + if (d < 0) error2(PSTR("dimension can't be negative")); + size = size * d; + dims = cdr(dims); + } + // Bit array identified by making first dimension negative + if (bitp) { + size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); + car(dimensions) = number(-(car(dimensions)->integer)); + } + object *ptr = myalloc(); + ptr->type = ARRAY; + object *tree = nil; + if (size != 0) tree = buildarray(size, nextpower2(size), def); + ptr->cdr = cons(tree, dimensions); + return ptr; +} + +/* + arrayref - returns a pointer to the element specified by index in the array of size s +*/ +object **arrayref (object *array, int index, int size) { + int mask = nextpower2(size)>>1; + object **p = &car(cdr(array)); + while (mask) { + if ((index & mask) == 0) p = &(car(*p)); else p = &(cdr(*p)); + mask = mask>>1; + } + return p; +} + +/* + getarray - gets a pointer to an element in a multi-dimensional array, given a list of the subscripts subs + If the first subscript is negative it's a bit array and bit is set to the bit number +*/ +object **getarray (object *array, object *subs, object *env, int *bit) { + int index = 0, size = 1, s; + *bit = -1; + bool bitp = false; + object *dims = cddr(array); + while (dims != NULL && subs != NULL) { + int d = car(dims)->integer; + if (d < 0) { d = -d; bitp = true; } + if (env) s = checkinteger(eval(car(subs), env)); else s = checkinteger(car(subs)); + if (s < 0 || s >= d) error(PSTR("subscript out of range"), car(subs)); + size = size * d; + index = index * d + s; + dims = cdr(dims); subs = cdr(subs); + } + if (dims != NULL) error2(PSTR("too few subscripts")); + if (subs != NULL) error2(PSTR("too many subscripts")); + if (bitp) { + size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); + *bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); + index = index>>(sizeof(int)==4 ? 5 : 4); + } + return arrayref(array, index, size); +} + +/* + rslice - reads a slice of an array recursively +*/ +void rslice (object *array, int size, int slice, object *dims, object *args) { + int d = first(dims)->integer; + for (int i = 0; i < d; i++) { + int index = slice * d + i; + if (!consp(args)) error2(PSTR("initial contents don't match array type")); + if (cdr(dims) == NULL) { + object **p = arrayref(array, index, size); + *p = car(args); + } else rslice(array, size, index, cdr(dims), car(args)); + args = cdr(args); + } +} + +/* + readarray - reads a list structure from args and converts it to a d-dimensional array. + Uses rslice for each of the slices of the array. +*/ +object *readarray (int d, object *args) { + object *list = args; + object *dims = NULL; object *head = NULL; + int size = 1; + for (int i = 0; i < d; i++) { + if (!listp(list)) error2(PSTR("initial contents don't match array type")); + int l = listlength(list); + if (dims == NULL) { dims = cons(number(l), NULL); head = dims; } + else { cdr(dims) = cons(number(l), NULL); dims = cdr(dims); } + size = size * l; + if (list != NULL) list = car(list); + } + object *array = makearray(head, NULL, false); + rslice(array, size, 0, head, args); + return array; +} + +/* + readbitarray - reads an item in the format #*1010101000110 by reading it and returning a list of integers, + and then converting that to a bit array +*/ +object *readbitarray (gfun_t gfun) { + char ch = gfun(); + object *head = NULL; + object *tail = NULL; + while (!issp(ch) && !isbr(ch)) { + if (ch != '0' && ch != '1') error2(PSTR("illegal character in bit array")); + object *cell = cons(number(ch - '0'), NULL); + if (head == NULL) head = cell; + else tail->cdr = cell; + tail = cell; + ch = gfun(); + } + LastChar = ch; + int size = listlength(head); + object *array = makearray(cons(number(size), NULL), number(0), true); + size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); + int index = 0; + while (head != NULL) { + object **loc = arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size); + int bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); + *loc = number((((*loc)->integer) & ~(1<integer)<integer; + if (d < 0) d = -d; + for (int i = 0; i < d; i++) { + if (i && spaces) pfun(' '); + int index = slice * d + i; + if (cdr(dims) == NULL) { + if (bitp) pint(((*arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size))->integer)>> + (index & (sizeof(int)==4 ? 0x1F : 0x0F)) & 1, pfun); + else printobject(*arrayref(array, index, size), pfun); + } else { pfun('('); pslice(array, size, index, cdr(dims), pfun, bitp); pfun(')'); } + } +} + +/* + printarray - prints an array in the appropriate Lisp format +*/ +void printarray (object *array, pfun_t pfun) { + object *dimensions = cddr(array); + object *dims = dimensions; + bool bitp = false; + int size = 1, n = 0; + while (dims != NULL) { + int d = car(dims)->integer; + if (d < 0) { bitp = true; d = -d; } + size = size * d; + dims = cdr(dims); n++; + } + if (bitp) size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); + pfun('#'); + if (n == 1 && bitp) { pfun('*'); pslice(array, size, -1, dimensions, pfun, bitp); } + else { + if (n > 1) { pint(n, pfun); pfun('A'); } + pfun('('); pslice(array, size, 0, dimensions, pfun, bitp); pfun(')'); + } +} + +// String utilities + +void indent (uint8_t spaces, char ch, pfun_t pfun) { + for (uint8_t i=0; ichars & 0xFFFFFF) == 0) { + (*tail)->chars = (*tail)->chars | ch<<16; return; + } else if (((*tail)->chars & 0xFFFF) == 0) { + (*tail)->chars = (*tail)->chars | ch<<8; return; + } else if (((*tail)->chars & 0xFF) == 0) { + (*tail)->chars = (*tail)->chars | ch; return; + } else { + cell = myalloc(); car(*tail) = cell; + } + car(cell) = NULL; cell->chars = ch<<24; *tail = cell; +} + +/* + copystring - returns a copy of a Lisp string +*/ +object *copystring (object *arg) { + object *obj = newstring(); + object *ptr = obj; + arg = cdr(arg); + while (arg != NULL) { + object *cell = myalloc(); car(cell) = NULL; + if (cdr(obj) == NULL) cdr(obj) = cell; else car(ptr) = cell; + ptr = cell; + ptr->chars = arg->chars; + arg = car(arg); + } + return obj; +} + +/* + readstring - reads characters from an input stream up to delimiter delim + and returns a Lisp string +*/ +object *readstring (uint8_t delim, gfun_t gfun) { + object *obj = newstring(); + object *tail = obj; + int ch = gfun(); + if (ch == -1) return nil; + while ((ch != delim) && (ch != -1)) { + if (ch == '\\') ch = gfun(); + buildstring(ch, &tail); + ch = gfun(); + } + return obj; +} + +/* + stringlength - returns the length of a Lisp string + Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word +*/ +int stringlength (object *form) { + int length = 0; + form = cdr(form); + while (form != NULL) { + int chars = form->chars; + for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { + if (chars>>i & 0xFF) length++; + } + form = car(form); + } + return length; +} + +/* + nthchar - returns the nth character from a Lisp string + Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word +*/ +uint8_t nthchar (object *string, int n) { + object *arg = cdr(string); + int top; + if (sizeof(int) == 4) { top = n>>2; n = 3 - (n&3); } + else { top = n>>1; n = 1 - (n&1); } + for (int i=0; ichars)>>(n*8) & 0xFF; +} + +/* + gstr - reads a character from a string stream +*/ +int gstr () { + if (LastChar) { + char temp = LastChar; + LastChar = 0; + return temp; + } + char c = nthchar(GlobalString, GlobalStringIndex++); + if (c != 0) return c; + return '\n'; // -1? +} + +/* + pstr - prints a character to a string stream +*/ +void pstr (char c) { + buildstring(c, &GlobalStringTail); +} + +/* + lispstring - converts a C string to a Lisp string +*/ +object *lispstring (char *s) { + object *obj = newstring(); + object *tail = obj; + while(1) { + char ch = *s++; + if (ch == 0) break; + if (ch == '\\') ch = *s++; + buildstring(ch, &tail); + } + return obj; +} + +/* + stringcompare - a generic string compare function + Used to implement the other string comparison functions. + If lt is true the result is true if each argument is less than the next argument. + If gt is true the result is true if each argument is greater than the next argument. + If eq is true the result is true if each argument is equal to the next argument. +*/ +bool stringcompare (object *args, bool lt, bool gt, bool eq) { + object *arg1 = checkstring(first(args)); + object *arg2 = checkstring(second(args)); + arg1 = cdr(arg1); + arg2 = cdr(arg2); + while ((arg1 != NULL) || (arg2 != NULL)) { + if (arg1 == NULL) return lt; + if (arg2 == NULL) return gt; + if (arg1->chars < arg2->chars) return lt; + if (arg1->chars > arg2->chars) return gt; + arg1 = car(arg1); + arg2 = car(arg2); + } + return eq; +} + +/* + documentation - returns the documentation string of a built-in or user-defined function. +*/ +object *documentation (object *arg, object *env) { + if (arg == NULL) return nil; + if (!symbolp(arg)) error(notasymbol, arg); + object *pair = findpair(arg, env); + if (pair != NULL) { + object *val = cdr(pair); + if (listp(val) && first(val)->name == sym(LAMBDA) && cdr(val) != NULL && cddr(val) != NULL) { + if (stringp(third(val))) return third(val); + } + } + symbol_t docname = arg->name; + if (!builtinp(docname)) return nil; + char *docstring = lookupdoc(builtin(docname)); + if (docstring == NULL) return nil; + object *obj = startstring(); + pfstring(docstring, pstr); + return obj; +} + +/* + apropos - finds the user-defined and built-in functions whose names contain the specified string or symbol, + and prints them if print is true, or returns them in a list. +*/ +object *apropos (object *arg, bool print) { + char buf[17], buf2[33]; + char *part = cstring(princtostring(arg), buf, 17); + object *result = cons(NULL, NULL); + object *ptr = result; + // User-defined? + object *globals = GlobalEnv; + while (globals != NULL) { + object *pair = first(globals); + object *var = car(pair); + object *val = cdr(pair); + char *full = cstring(princtostring(var), buf2, 33); + if (strstr(full, part) != NULL) { + if (print) { + printsymbol(var, pserial); pserial(' '); pserial('('); + if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) pfstring(PSTR("user function"), pserial); + else if (consp(val) && car(val)->type == CODE) pfstring(PSTR("code"), pserial); + else pfstring(PSTR("user symbol"), pserial); + pserial(')'); pln(pserial); + } else { + cdr(ptr) = cons(var, NULL); ptr = cdr(ptr); + } + } + globals = cdr(globals); + } + // Built-in? + int entries = tablesize(0) + tablesize(1); + for (int i = 0; i < entries; i++) { + if (findsubstring(part, (builtin_t)i)) { + if (print) { + uint8_t fntype = getminmax(i)>>6; + pbuiltin((builtin_t)i, pserial); pserial(' '); pserial('('); + if (fntype == FUNCTIONS) pfstring(PSTR("function"), pserial); + else if (fntype == SPECIAL_FORMS) pfstring(PSTR("special form"), pserial); + else pfstring(PSTR("symbol/keyword"), pserial); + pserial(')'); pln(pserial); + } else { + cdr(ptr) = cons(bsymbol(i), NULL); ptr = cdr(ptr); + } + } + } + return cdr(result); +} + +/* + cstring - converts a Lisp string to a C string in buffer and returns buffer + Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word +*/ +char *cstring (object *form, char *buffer, int buflen) { + form = cdr(checkstring(form)); + int index = 0; + while (form != NULL) { + int chars = form->integer; + for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { + char ch = chars>>i & 0xFF; + if (ch) { + if (index >= buflen-1) error2(PSTR("no room for string")); + buffer[index++] = ch; + } + } + form = car(form); + } + buffer[index] = '\0'; + return buffer; +} + +/* + ipstring - parses an IP address from a Lisp string and returns it as an IPAddress type (uint32_t) + Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word +*/ +uint32_t ipstring (object *form) { + form = cdr(checkstring(form)); + int p = 0; + union { uint32_t ipaddress; uint8_t ipbytes[4]; } ; + ipaddress = 0; + while (form != NULL) { + int chars = form->integer; + for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { + char ch = chars>>i & 0xFF; + if (ch) { + if (ch == '.') { p++; if (p > 3) error2(PSTR("illegal IP address")); } + else ipbytes[p] = (ipbytes[p] * 10) + ch - '0'; + } + } + form = car(form); + } + return ipaddress; +} + +// Lookup variable in environment + +object *value (symbol_t n, object *env) { + while (env != NULL) { + object *pair = car(env); + if (pair != NULL && car(pair)->name == n) return pair; + env = cdr(env); + } + return nil; +} + +/* + findpair - returns the (var . value) pair bound to variable var in the local or global environment +*/ +object *findpair (object *var, object *env) { + symbol_t name = var->name; + object *pair = value(name, env); + if (pair == NULL) pair = value(name, GlobalEnv); + return pair; +} + +/* + boundp - tests whether var is bound to a value +*/ +bool boundp (object *var, object *env) { + if (!symbolp(var)) error(notasymbol, var); + return (findpair(var, env) != NULL); +} + +/* + findvalue - returns the value bound to variable var, or gives an error if unbound +*/ +object *findvalue (object *var, object *env) { + object *pair = findpair(var, env); + if (pair == NULL) error(PSTR("unknown variable"), var); + return pair; +} + +// Handling closures + +object *closure (int tc, symbol_t name, object *function, object *args, object **env) { + object *state = car(function); + function = cdr(function); + int trace = 0; + if (name) trace = tracing(name); + if (trace) { + indent(TraceDepth[trace-1]<<1, ' ', pserial); + pint(TraceDepth[trace-1]++, pserial); + pserial(':'); pserial(' '); pserial('('); printsymbol(symbol(name), pserial); + } + object *params = first(function); + if (!listp(params)) errorsym(name, notalist, params); + function = cdr(function); + // Dropframe + if (tc) { + if (*env != NULL && car(*env) == NULL) { + pop(*env); + while (*env != NULL && car(*env) != NULL) pop(*env); + } else push(nil, *env); + } + // Push state + while (consp(state)) { + object *pair = first(state); + push(pair, *env); + state = cdr(state); + } + // Add arguments to environment + bool optional = false; + while (params != NULL) { + object *value; + object *var = first(params); + if (isbuiltin(var, OPTIONAL)) optional = true; + else { + if (consp(var)) { + if (!optional) errorsym(name, PSTR("invalid default value"), var); + if (args == NULL) value = eval(second(var), *env); + else { value = first(args); args = cdr(args); } + var = first(var); + if (!symbolp(var)) errorsym(name, PSTR("illegal optional parameter"), var); + } else if (!symbolp(var)) { + errorsym(name, PSTR("illegal function parameter"), var); + } else if (isbuiltin(var, AMPREST)) { + params = cdr(params); + var = first(params); + value = args; + args = NULL; + } else { + if (args == NULL) { + if (optional) value = nil; + else errorsym2(name, toofewargs); + } else { value = first(args); args = cdr(args); } + } + push(cons(var,value), *env); + if (trace) { pserial(' '); printobject(value, pserial); } + } + params = cdr(params); + } + if (args != NULL) errorsym2(name, toomanyargs); + if (trace) { pserial(')'); pln(pserial); } + // Do an implicit progn + if (tc) push(nil, *env); + return tf_progn(function, *env); +} + +object *apply (object *function, object *args, object *env) { + if (symbolp(function)) { + builtin_t fname = builtin(function->name); + if ((fname < ENDFUNCTIONS) && ((getminmax(fname)>>6) == FUNCTIONS)) { + Context = fname; + checkargs(args); + return ((fn_ptr_type)lookupfn(fname))(args, env); + } else function = eval(function, env); + } + if (consp(function) && isbuiltin(car(function), LAMBDA)) { + object *result = closure(0, sym(NIL), function, args, &env); + return eval(result, env); + } + if (consp(function) && isbuiltin(car(function), CLOSURE)) { + function = cdr(function); + object *result = closure(0, sym(NIL), function, args, &env); + return eval(result, env); + } + error(PSTR("illegal function"), function); + return NULL; +} + +// In-place operations + +/* + place - returns a pointer to an object referenced in the second argument of an + in-place operation such as setf. bit is used to indicate the bit position in a bit array +*/ +object **place (object *args, object *env, int *bit) { + *bit = -1; + if (atom(args)) return &cdr(findvalue(args, env)); + object* function = first(args); + if (symbolp(function)) { + symbol_t sname = function->name; + if (sname == sym(CAR) || sname == sym(FIRST)) { + object *value = eval(second(args), env); + if (!listp(value)) error(canttakecar, value); + return &car(value); + } + if (sname == sym(CDR) || sname == sym(REST)) { + object *value = eval(second(args), env); + if (!listp(value)) error(canttakecdr, value); + return &cdr(value); + } + if (sname == sym(NTH)) { + int index = checkinteger(eval(second(args), env)); + object *list = eval(third(args), env); + if (atom(list)) error(PSTR("second argument to nth is not a list"), list); + while (index > 0) { + list = cdr(list); + if (list == NULL) error2(PSTR("index to nth is out of range")); + index--; + } + return &car(list); + } + if (sname == sym(AREF)) { + object *array = eval(second(args), env); + if (!arrayp(array)) error(PSTR("first argument is not an array"), array); + return getarray(array, cddr(args), env, bit); + } + } + error2(PSTR("illegal place")); + return nil; +} + +// Checked car and cdr + +/* + carx - car with error checking +*/ +object *carx (object *arg) { + if (!listp(arg)) error(canttakecar, arg); + if (arg == nil) return nil; + return car(arg); +} + +/* + cdrx - cdr with error checking +*/ +object *cdrx (object *arg) { + if (!listp(arg)) error(canttakecdr, arg); + if (arg == nil) return nil; + return cdr(arg); +} + +/* + cxxxr - implements a general cxxxr function, + pattern is a sequence of bits 0b1xxx where x is 0 for a and 1 for d. +*/ +object *cxxxr (object *args, uint8_t pattern) { + object *arg = first(args); + while (pattern != 1) { + if ((pattern & 1) == 0) arg = carx(arg); else arg = cdrx(arg); + pattern = pattern>>1; + } + return arg; +} + +// Mapping helper functions + +/* + mapcarfun - function specifying how to combine the results in mapcar +*/ +void mapcarfun (object *result, object **tail) { + object *obj = cons(result,NULL); + cdr(*tail) = obj; *tail = obj; +} + +/* + mapcanfun - function specifying how to combine the results in mapcan +*/ +void mapcanfun (object *result, object **tail) { + if (cdr(*tail) != NULL) error(notproper, *tail); + while (consp(result)) { + cdr(*tail) = result; *tail = result; + result = cdr(result); + } +} + +/* + mapcarcan - function used by marcar and mapcan + It takes the arguments, the env, and a function specifying how the results are combined. +*/ +object *mapcarcan (object *args, object *env, mapfun_t fun) { + object *function = first(args); + args = cdr(args); + object *params = cons(NULL, NULL); + push(params,GCStack); + object *head = cons(NULL, NULL); + push(head,GCStack); + object *tail = head; + // Make parameters + while (true) { + object *tailp = params; + object *lists = args; + while (lists != NULL) { + object *list = car(lists); + if (list == NULL) { + pop(GCStack); pop(GCStack); + return cdr(head); + } + if (improperp(list)) error(notproper, list); + object *obj = cons(first(list),NULL); + car(lists) = cdr(list); + cdr(tailp) = obj; tailp = obj; + lists = cdr(lists); + } + object *result = apply(function, cdr(params), env); + fun(result, &tail); + } +} + +// I2C interface for one port, using Arduino Wire + +void I2Cinit (bool enablePullup) { + (void) enablePullup; + Wire.begin(); +} + +int I2Cread () { + return Wire.read(); +} + +void I2Cwrite (uint8_t data) { + Wire.write(data); +} + +bool I2Cstart (uint8_t address, uint8_t read) { + int ok = true; + if (read == 0) { + Wire.beginTransmission(address); + ok = (Wire.endTransmission(true) == 0); + Wire.beginTransmission(address); + } + else Wire.requestFrom(address, I2Ccount); + return ok; +} + +bool I2Crestart (uint8_t address, uint8_t read) { + int error = (Wire.endTransmission(false) != 0); + if (read == 0) Wire.beginTransmission(address); + else Wire.requestFrom(address, I2Ccount); + return error ? false : true; +} + +void I2Cstop (uint8_t read) { + if (read == 0) Wire.endTransmission(); // Check for error? +} + +// Streams + +inline int spiread () { return SPI.transfer(0); } +inline int serial1read () { while (!Serial1.available()) testescape(); return Serial1.read(); } +#if defined(sdcardsupport) +File SDpfile, SDgfile; +inline int SDread () { + if (LastChar) { + char temp = LastChar; + LastChar = 0; + return temp; + } + return SDgfile.read(); +} +#endif + +WiFiClient client; +WiFiServer server(80); + +inline int WiFiread () { + if (LastChar) { + char temp = LastChar; + LastChar = 0; + return temp; + } + return client.read(); +} + +void serialbegin (int address, int baud) { + if (address == 1) Serial1.begin((long)baud*100); + else error(PSTR("port not supported"), number(address)); +} + +void serialend (int address) { + if (address == 1) {Serial1.flush(); Serial1.end(); } +} + +gfun_t gstreamfun (object *args) { + int streamtype = SERIALSTREAM; + int address = 0; + gfun_t gfun = gserial; + if (args != NULL) { + int stream = isstream(first(args)); + streamtype = stream>>8; address = stream & 0xFF; + } + if (streamtype == I2CSTREAM) gfun = (gfun_t)I2Cread; + else if (streamtype == SPISTREAM) gfun = spiread; + else if (streamtype == SERIALSTREAM) { + if (address == 0) gfun = gserial; + else if (address == 1) gfun = serial1read; + } + #if defined(sdcardsupport) + else if (streamtype == SDSTREAM) gfun = (gfun_t)SDread; + #endif + else if (streamtype == WIFISTREAM) gfun = (gfun_t)WiFiread; + else error2(PSTR("unknown stream type")); + return gfun; +} + +inline void spiwrite (char c) { SPI.transfer(c); } +inline void serial1write (char c) { Serial1.write(c); } +inline void WiFiwrite (char c) { client.write(c); } +#if defined(sdcardsupport) +inline void SDwrite (char c) { SDpfile.write(c); } +#endif +#if defined(gfxsupport) +inline void gfxwrite (char c) { tft.write(c); } +#endif + +pfun_t pstreamfun (object *args) { + int streamtype = SERIALSTREAM; + int address = 0; + pfun_t pfun = pserial; + if (args != NULL && first(args) != NULL) { + int stream = isstream(first(args)); + streamtype = stream>>8; address = stream & 0xFF; + } + if (streamtype == I2CSTREAM) pfun = (pfun_t)I2Cwrite; + else if (streamtype == SPISTREAM) pfun = spiwrite; + else if (streamtype == SERIALSTREAM) { + if (address == 0) pfun = pserial; + else if (address == 1) pfun = serial1write; + } + else if (streamtype == STRINGSTREAM) { + pfun = pstr; + } + #if defined(sdcardsupport) + else if (streamtype == SDSTREAM) pfun = (pfun_t)SDwrite; + #endif + #if defined(gfxsupport) + else if (streamtype == GFXSTREAM) pfun = (pfun_t)gfxwrite; + #endif + else if (streamtype == WIFISTREAM) pfun = (pfun_t)WiFiwrite; + else error2(PSTR("unknown stream type")); + return pfun; +} + +// Check pins + +void checkanalogread (int pin) { +#if defined(ESP8266) + if (pin!=17) error(PSTR("invalid pin"), number(pin)); +#elif defined(ESP32) || defined(ARDUINO_ESP32_DEV) + if (!(pin==0 || pin==2 || pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) + error(PSTR("invalid pin"), number(pin)); +#elif defined(ARDUINO_FEATHER_ESP32) + if (!(pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) + error(PSTR("invalid pin"), number(pin)); +#elif defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2) || defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) + if (!(pin==8 || (pin>=14 && pin<=18))) error(PSTR("invalid pin"), number(pin)); +#elif defined(ARDUINO_ADAFRUIT_QTPY_ESP32S2) + if (!((pin>=5 && pin<=9) || (pin>=16 && pin<=18))) error(PSTR("invalid pin"), number(pin)); +#elif defined(ARDUINO_ADAFRUIT_QTPY_ESP32C3) + if (!((pin>=0 && pin<=1) || (pin>=3 && pin<=5))) error(PSTR("invalid pin"), number(pin)); +#elif defined(ARDUINO_FEATHERS2) | defined(ARDUINO_ESP32S2_DEV) + if (!((pin>=1 && pin<=20))) error(PSTR("invalid pin"), number(pin)); +#elif defined(ARDUINO_ESP32C3_DEV) + if (!((pin>=0 && pin<=5))) error(PSTR("invalid pin"), number(pin)); +#elif defined(ARDUINO_ESP32S3_DEV) + if (!((pin>=1 && pin<=20))) error(PSTR("invalid pin"), number(pin)); +#endif +} + +void checkanalogwrite (int pin) { +#if defined(ESP8266) + if (!(pin>=0 && pin<=16)) error(PSTR("invalid pin"), number(pin)); +#elif defined(ESP32) || defined(ARDUINO_FEATHER_ESP32) || defined(ARDUINO_ESP32_DEV) + if (!(pin>=25 && pin<=26)) error(PSTR("invalid pin"), number(pin)); +#elif defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2) || defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) || defined(ARDUINO_ADAFRUIT_QTPY_ESP32S2) || defined(ARDUINO_FEATHERS2) || defined(ARDUINO_ESP32S2_DEV) + if (!(pin>=17 && pin<=18)) error(PSTR("invalid pin"), number(pin)); +#elif defined(ARDUINO_ESP32C3_DEV) | defined(ARDUINO_ESP32S3_DEV) | defined(ARDUINO_ADAFRUIT_QTPY_ESP32C3) + error2(ANALOGWRITE, PSTR("not supported")); +#endif +} + +// Note + +void tone (int pin, int note) { + (void) pin, (void) note; +} + +void noTone (int pin) { + (void) pin; +} + +const int scale[] PROGMEM = {4186,4435,4699,4978,5274,5588,5920,6272,6645,7040,7459,7902}; + +void playnote (int pin, int note, int octave) { + int prescaler = 8 - octave - note/12; + if (prescaler<0 || prescaler>8) error(PSTR("octave out of range"), number(prescaler)); + tone(pin, pgm_read_word(&scale[note%12])>>prescaler); +} + +void nonote (int pin) { + noTone(pin); +} + +// Sleep + +void initsleep () { } + +void doze (int secs) { + delay(1000 * secs); +} + +// Prettyprint + +const int PPINDENT = 2; +const int PPWIDTH = 80; +const int GFXPPWIDTH = 52; // 320 pixel wide screen +int ppwidth = PPWIDTH; + +void pcount (char c) { + if (c == '\n') PrintCount++; + PrintCount++; +} + +/* + atomwidth - calculates the character width of an atom +*/ +uint8_t atomwidth (object *obj) { + PrintCount = 0; + printobject(obj, pcount); + return PrintCount; +} + +uint8_t basewidth (object *obj, uint8_t base) { + PrintCount = 0; + pintbase(obj->integer, base, pcount); + return PrintCount; +} + +bool quoted (object *obj) { + return (consp(obj) && car(obj) != NULL && car(obj)->name == sym(QUOTE) && consp(cdr(obj)) && cddr(obj) == NULL); +} + +int subwidth (object *obj, int w) { + if (atom(obj)) return w - atomwidth(obj); + if (quoted(obj)) obj = car(cdr(obj)); + return subwidthlist(obj, w - 1); +} + +int subwidthlist (object *form, int w) { + while (form != NULL && w >= 0) { + if (atom(form)) return w - (2 + atomwidth(form)); + w = subwidth(car(form), w - 1); + form = cdr(form); + } + return w; +} + +/* + superprint - the main pretty-print subroutine +*/ +void superprint (object *form, int lm, pfun_t pfun) { + if (atom(form)) { + if (symbolp(form) && form->name == sym(NOTHING)) printsymbol(form, pfun); + else printobject(form, pfun); + } + else if (quoted(form)) { pfun('\''); superprint(car(cdr(form)), lm + 1, pfun); } + else if (subwidth(form, ppwidth - lm) >= 0) supersub(form, lm + PPINDENT, 0, pfun); + else supersub(form, lm + PPINDENT, 1, pfun); +} + +/* + supersub - subroutine used by pprint +*/ +void supersub (object *form, int lm, int super, pfun_t pfun) { + int special = 0, separate = 1; + object *arg = car(form); + if (symbolp(arg) && builtinp(arg->name)) { + uint8_t minmax = getminmax(builtin(arg->name)); + if (minmax == 0327 || minmax == 0313) special = 2; // defun, setq, setf, defvar + else if (minmax == 0317 || minmax == 0017 || minmax == 0117 || minmax == 0123) special = 1; + } + while (form != NULL) { + if (atom(form)) { pfstring(PSTR(" . "), pfun); printobject(form, pfun); pfun(')'); return; } + else if (separate) { pfun('('); separate = 0; } + else if (special) { pfun(' '); special--; } + else if (!super) pfun(' '); + else { pln(pfun); indent(lm, ' ', pfun); } + superprint(car(form), lm, pfun); + form = cdr(form); + } + pfun(')'); return; +} + +/* + edit - the Lisp tree editor + Steps through a function definition, editing it a bit at a time, using single-key editing commands. +*/ +object *edit (object *fun) { + while (1) { + if (tstflag(EXITEDITOR)) return fun; + char c = gserial(); + if (c == 'q') setflag(EXITEDITOR); + else if (c == 'b') return fun; + else if (c == 'r') fun = read(gserial); + else if (c == '\n') { pfl(pserial); superprint(fun, 0, pserial); pln(pserial); } + else if (c == 'c') fun = cons(read(gserial), fun); + else if (atom(fun)) pserial('!'); + else if (c == 'd') fun = cons(car(fun), edit(cdr(fun))); + else if (c == 'a') fun = cons(edit(car(fun)), cdr(fun)); + else if (c == 'x') fun = cdr(fun); + else pserial('?'); + } +} + +// Special forms + +object *sp_quote (object *args, object *env) { + (void) env; + checkargs(args); + return first(args); +} + +/* + (or item*) + Evaluates its arguments until one returns non-nil, and returns its value. +*/ +object *sp_or (object *args, object *env) { + while (args != NULL) { + object *val = eval(car(args), env); + if (val != NULL) return val; + args = cdr(args); + } + return nil; +} + +/* + (defun name (parameters) form*) + Defines a function. +*/ +object *sp_defun (object *args, object *env) { + (void) env; + checkargs(args); + object *var = first(args); + if (!symbolp(var)) error(notasymbol, var); + object *val = cons(bsymbol(LAMBDA), cdr(args)); + object *pair = value(var->name, GlobalEnv); + if (pair != NULL) cdr(pair) = val; + else push(cons(var, val), GlobalEnv); + return var; +} + +/* + (defvar variable form) + Defines a global variable. +*/ +object *sp_defvar (object *args, object *env) { + checkargs(args); + object *var = first(args); + if (!symbolp(var)) error(notasymbol, var); + object *val = NULL; + args = cdr(args); + if (args != NULL) { setflag(NOESC); val = eval(first(args), env); clrflag(NOESC); } + object *pair = value(var->name, GlobalEnv); + if (pair != NULL) cdr(pair) = val; + else push(cons(var, val), GlobalEnv); + return var; +} + +/* + (setq symbol value [symbol value]*) + For each pair of arguments assigns the value of the second argument + to the variable specified in the first argument. +*/ +object *sp_setq (object *args, object *env) { + object *arg = nil; + while (args != NULL) { + if (cdr(args) == NULL) error2(oddargs); + object *pair = findvalue(first(args), env); + arg = eval(second(args), env); + cdr(pair) = arg; + args = cddr(args); + } + return arg; +} + +/* + (loop forms*) + Executes its arguments repeatedly until one of the arguments calls (return), + which then causes an exit from the loop. +*/ +object *sp_loop (object *args, object *env) { + object *start = args; + for (;;) { + yield(); + args = start; + while (args != NULL) { + object *result = eval(car(args),env); + if (tstflag(RETURNFLAG)) { + clrflag(RETURNFLAG); + return result; + } + args = cdr(args); + } + } +} + +/* + (return [value]) + Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value. +*/ +object *sp_return (object *args, object *env) { + object *result = eval(tf_progn(args,env), env); + setflag(RETURNFLAG); + return result; +} + +/* + (push item place) + Modifies the value of place, which should be a list, to add item onto the front of the list, + and returns the new list. +*/ +object *sp_push (object *args, object *env) { + int bit; + checkargs(args); + object *item = eval(first(args), env); + object **loc = place(second(args), env, &bit); + push(item, *loc); + return *loc; +} + +/* + (pop place) + Modifies the value of place, which should be a list, to remove its first item, and returns that item. +*/ +object *sp_pop (object *args, object *env) { + int bit; + checkargs(args); + object **loc = place(first(args), env, &bit); + object *result = car(*loc); + pop(*loc); + return result; +} + +// Accessors + +/* + (incf place [number]) + Increments a place, which should have an numeric value, and returns the result. + The third argument is an optional increment which defaults to 1. +*/ +object *sp_incf (object *args, object *env) { + int bit; + checkargs(args); + object **loc = place(first(args), env, &bit); + args = cdr(args); + + object *x = *loc; + object *inc = (args != NULL) ? eval(first(args), env) : NULL; + + if (bit != -1) { + int increment; + if (inc == NULL) increment = 1; else increment = checkbitvalue(inc); + int newvalue = (((*loc)->integer)>>bit & 1) + increment; + + if (newvalue & ~1) error2(PSTR("result is not a bit value")); + *loc = number((((*loc)->integer) & ~(1<integer; + + if (inc == NULL) increment = 1; else increment = inc->integer; + + if (increment < 1) { + if (INT_MIN - increment > value) *loc = makefloat((float)value + (float)increment); + else *loc = number(value + increment); + } else { + if (INT_MAX - increment < value) *loc = makefloat((float)value + (float)increment); + else *loc = number(value + increment); + } + } else error2(notanumber); + return *loc; +} + +/* + (decf place [number]) + Decrements a place, which should have an numeric value, and returns the result. + The third argument is an optional decrement which defaults to 1. +*/ +object *sp_decf (object *args, object *env) { + int bit; + checkargs(args); + object **loc = place(first(args), env, &bit); + args = cdr(args); + + object *x = *loc; + object *dec = (args != NULL) ? eval(first(args), env) : NULL; + + if (bit != -1) { + int decrement; + if (dec == NULL) decrement = 1; else decrement = checkbitvalue(dec); + int newvalue = (((*loc)->integer)>>bit & 1) - decrement; + + if (newvalue & ~1) error2(PSTR("result is not a bit value")); + *loc = number((((*loc)->integer) & ~(1<integer; + + if (dec == NULL) decrement = 1; else decrement = dec->integer; + + if (decrement < 1) { + if (INT_MAX + decrement < value) *loc = makefloat((float)value - (float)decrement); + else *loc = number(value - decrement); + } else { + if (INT_MIN + decrement > value) *loc = makefloat((float)value - (float)decrement); + else *loc = number(value - decrement); + } + } else error2(notanumber); + return *loc; +} + +/* + (setf place value [place value]*) + For each pair of arguments modifies a place to the result of evaluating value. +*/ +object *sp_setf (object *args, object *env) { + int bit; + object *arg = nil; + while (args != NULL) { + if (cdr(args) == NULL) error2(oddargs); + object **loc = place(first(args), env, &bit); + arg = eval(second(args), env); + if (bit == -1) *loc = arg; + else *loc = number((checkinteger(*loc) & ~(1<name); + args = cdr(args); + } + int i = 0; + while (i < TRACEMAX) { + if (TraceFn[i] != 0) args = cons(symbol(TraceFn[i]), args); + i++; + } + return args; +} + +/* + (untrace [function]*) + Turns off tracing of up to TRACEMAX user-defined functions, and returns a list of the functions untraced. + If no functions are specified it untraces all functions. +*/ +object *sp_untrace (object *args, object *env) { + (void) env; + if (args == NULL) { + int i = 0; + while (i < TRACEMAX) { + if (TraceFn[i] != 0) args = cons(symbol(TraceFn[i]), args); + TraceFn[i] = 0; + i++; + } + } else { + while (args != NULL) { + object *var = first(args); + if (!symbolp(var)) error(notasymbol, var); + untrace(var->name); + args = cdr(args); + } + } + return args; +} + +/* + (for-millis ([number]) form*) + Executes the forms and then waits until a total of number milliseconds have elapsed. + Returns the total number of milliseconds taken. +*/ +object *sp_formillis (object *args, object *env) { + if (args == NULL) error2(noargument); + object *param = first(args); + unsigned long start = millis(); + unsigned long now, total = 0; + if (param != NULL) total = checkinteger(eval(first(param), env)); + eval(tf_progn(cdr(args),env), env); + do { + now = millis() - start; + testescape(); + } while (now < total); + if (now <= INT_MAX) return number(now); + return nil; +} + +/* + (time form) + Prints the value returned by the form, and the time taken to evaluate the form + in milliseconds or seconds. +*/ +object *sp_time (object *args, object *env) { + unsigned long start = millis(); + object *result = eval(first(args), env); + unsigned long elapsed = millis() - start; + printobject(result, pserial); + pfstring(PSTR("\nTime: "), pserial); + if (elapsed < 1000) { + pint(elapsed, pserial); + pfstring(PSTR(" ms\n"), pserial); + } else { + elapsed = elapsed+50; + pint(elapsed/1000, pserial); + pserial('.'); pint((elapsed/100)%10, pserial); + pfstring(PSTR(" s\n"), pserial); + } + return bsymbol(NOTHING); +} + +/* + (with-output-to-string (str) form*) + Returns a string containing the output to the stream variable str. +*/ +object *sp_withoutputtostring (object *args, object *env) { + if (args == NULL) error2(noargument); + object *params = first(args); + if (params == NULL) error2(nostream); + object *var = first(params); + object *pair = cons(var, stream(STRINGSTREAM, 0)); + push(pair,env); + object *string = startstring(); + push(string, GCStack); + object *forms = cdr(args); + eval(tf_progn(forms,env), env); + pop(GCStack); + return string; +} + +/* + (with-serial (str port [baud]) form*) + Evaluates the forms with str bound to a serial-stream using port. + The optional baud gives the baud rate divided by 100, default 96. +*/ +object *sp_withserial (object *args, object *env) { + object *params = first(args); + if (params == NULL) error2(nostream); + object *var = first(params); + int address = checkinteger(eval(second(params), env)); + params = cddr(params); + int baud = 96; + if (params != NULL) baud = checkinteger(eval(first(params), env)); + object *pair = cons(var, stream(SERIALSTREAM, address)); + push(pair,env); + serialbegin(address, baud); + object *forms = cdr(args); + object *result = eval(tf_progn(forms,env), env); + serialend(address); + return result; +} + +/* + (with-i2c (str [port] address [read-p]) form*) + Evaluates the forms with str bound to an i2c-stream defined by address. + If read-p is nil or omitted the stream is written to, otherwise it specifies the number of bytes + to be read from the stream. The port if specified is ignored. +*/ +object *sp_withi2c (object *args, object *env) { + object *params = first(args); + if (params == NULL) error2(nostream); + object *var = first(params); + int address = checkinteger(eval(second(params), env)); + params = cddr(params); + if (address == 0 && params != NULL) params = cdr(params); // Ignore port + int read = 0; // Write + I2Ccount = 0; + if (params != NULL) { + object *rw = eval(first(params), env); + if (integerp(rw)) I2Ccount = rw->integer; + read = (rw != NULL); + } + I2Cinit(1); // Pullups + object *pair = cons(var, (I2Cstart(address, read)) ? stream(I2CSTREAM, address) : nil); + push(pair,env); + object *forms = cdr(args); + object *result = eval(tf_progn(forms,env), env); + I2Cstop(read); + return result; +} + +/* + (with-spi (str pin [clock] [bitorder] [mode]) form*) + Evaluates the forms with str bound to an spi-stream. + The parameters specify the enable pin, clock in kHz (default 4000), + bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0). +*/ +object *sp_withspi (object *args, object *env) { + object *params = first(args); + if (params == NULL) error2(nostream); + object *var = first(params); + params = cdr(params); + if (params == NULL) error2(nostream); + int pin = checkinteger(eval(car(params), env)); + pinMode(pin, OUTPUT); + digitalWrite(pin, HIGH); + params = cdr(params); + int clock = 4000, mode = SPI_MODE0; // Defaults + int bitorder = MSBFIRST; + if (params != NULL) { + clock = checkinteger(eval(car(params), env)); + params = cdr(params); + if (params != NULL) { + bitorder = (checkinteger(eval(car(params), env)) == 0) ? LSBFIRST : MSBFIRST; + params = cdr(params); + if (params != NULL) { + int modeval = checkinteger(eval(car(params), env)); + mode = (modeval == 3) ? SPI_MODE3 : (modeval == 2) ? SPI_MODE2 : (modeval == 1) ? SPI_MODE1 : SPI_MODE0; + } + } + } + object *pair = cons(var, stream(SPISTREAM, pin)); + push(pair,env); + SPI.begin(); + SPI.beginTransaction(SPISettings(((unsigned long)clock * 1000), bitorder, mode)); + digitalWrite(pin, LOW); + object *forms = cdr(args); + object *result = eval(tf_progn(forms,env), env); + digitalWrite(pin, HIGH); + SPI.endTransaction(); + return result; +} + +/* + (with-sd-card (str filename [mode]) form*) + Evaluates the forms with str bound to an sd-stream reading from or writing to the file filename. + If mode is omitted the file is read, otherwise 0 means read, 1 write-append, or 2 write-overwrite. +*/ +object *sp_withsdcard (object *args, object *env) { +#if defined(sdcardsupport) + object *params = first(args); + if (params == NULL) error2(nostream); + object *var = first(params); + params = cdr(params); + if (params == NULL) error2(PSTR("no filename specified")); + object *filename = eval(first(params), env); + params = cdr(params); + SD.begin(); + int mode = 0; + if (params != NULL && first(params) != NULL) mode = checkinteger(first(params)); + const char *oflag = FILE_READ; + if (mode == 1) oflag = FILE_APPEND; else if (mode == 2) oflag = FILE_WRITE; + if (mode >= 1) { + char buffer[BUFFERSIZE]; + SDpfile = SD.open(MakeFilename(filename, buffer), oflag); + if (!SDpfile) error2(PSTR("problem writing to SD card or invalid filename")); + } else { + char buffer[BUFFERSIZE]; + SDgfile = SD.open(MakeFilename(filename, buffer), oflag); + if (!SDgfile) error2(PSTR("problem reading from SD card or invalid filename")); + } + object *pair = cons(var, stream(SDSTREAM, 1)); + push(pair,env); + object *forms = cdr(args); + object *result = eval(tf_progn(forms,env), env); + if (mode >= 1) SDpfile.close(); else SDgfile.close(); + return result; +#else + (void) args, (void) env; + error2(PSTR("not supported")); + return nil; +#endif +} + +// Tail-recursive forms + +/* + (progn form*) + Evaluates several forms grouped together into a block, and returns the result of evaluating the last form. +*/ +object *tf_progn (object *args, object *env) { + if (args == NULL) return nil; + object *more = cdr(args); + while (more != NULL) { + object *result = eval(car(args),env); + if (tstflag(RETURNFLAG)) return result; + args = more; + more = cdr(args); + } + return car(args); +} + +/* + (if test then [else]) + Evaluates test. If it's non-nil the form then is evaluated and returned; + otherwise the form else is evaluated and returned. +*/ +object *tf_if (object *args, object *env) { + if (args == NULL || cdr(args) == NULL) error2(toofewargs); + if (eval(first(args), env) != nil) return second(args); + args = cddr(args); + return (args != NULL) ? first(args) : nil; +} + +/* + (cond ((test form*) (test form*) ... )) + Each argument is a list consisting of a test optionally followed by one or more forms. + If the test evaluates to non-nil the forms are evaluated, and the last value is returned as the result of the cond. + If the test evaluates to nil, none of the forms are evaluated, and the next argument is processed in the same way. +*/ +object *tf_cond (object *args, object *env) { + while (args != NULL) { + object *clause = first(args); + if (!consp(clause)) error(illegalclause, clause); + object *test = eval(first(clause), env); + object *forms = cdr(clause); + if (test != nil) { + if (forms == NULL) return quote(test); else return tf_progn(forms, env); + } + args = cdr(args); + } + return nil; +} + +/* + (when test form*) + Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned. +*/ +object *tf_when (object *args, object *env) { + if (args == NULL) error2(noargument); + if (eval(first(args), env) != nil) return tf_progn(cdr(args),env); + else return nil; +} + +/* + (unless test form*) + Evaluates the test. If it's nil the forms are evaluated and the last value is returned. +*/ +object *tf_unless (object *args, object *env) { + if (args == NULL) error2(noargument); + if (eval(first(args), env) != nil) return nil; + else return tf_progn(cdr(args),env); +} + +/* + (case keyform ((key form*) (key form*) ... )) + Evaluates a keyform to produce a test key, and then tests this against a series of arguments, + each of which is a list containing a key optionally followed by one or more forms. +*/ +object *tf_case (object *args, object *env) { + object *test = eval(first(args), env); + args = cdr(args); + while (args != NULL) { + object *clause = first(args); + if (!consp(clause)) error(illegalclause, clause); + object *key = car(clause); + object *forms = cdr(clause); + if (consp(key)) { + while (key != NULL) { + if (eq(test,car(key))) return tf_progn(forms, env); + key = cdr(key); + } + } else if (eq(test,key) || eq(key,tee)) return tf_progn(forms, env); + args = cdr(args); + } + return nil; +} + +/* + (and item*) + Evaluates its arguments until one returns nil, and returns the last value. +*/ +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); +} + +// Core functions + +/* + (not item) + Returns t if its argument is nil, or nil otherwise. Equivalent to null. +*/ +object *fn_not (object *args, object *env) { + (void) env; + return (first(args) == nil) ? tee : nil; +} + +/* + (cons item item) + If the second argument is a list, cons returns a new list with item added to the front of the list. + If the second argument isn't a list cons returns a dotted pair. +*/ +object *fn_cons (object *args, object *env) { + (void) env; + return cons(first(args), second(args)); +} + +/* + (atom item) + Returns t if its argument is a single number, symbol, or nil. +*/ +object *fn_atom (object *args, object *env) { + (void) env; + return atom(first(args)) ? tee : nil; +} + +/* + (listp item) + Returns t if its argument is a list. +*/ +object *fn_listp (object *args, object *env) { + (void) env; + return listp(first(args)) ? tee : nil; +} + +/* + (consp item) + Returns t if its argument is a non-null list. +*/ +object *fn_consp (object *args, object *env) { + (void) env; + return consp(first(args)) ? tee : nil; +} + +/* + (symbolp item) + Returns t if its argument is a symbol. +*/ +object *fn_symbolp (object *args, object *env) { + (void) env; + object *arg = first(args); + return (arg == NULL || symbolp(arg)) ? tee : nil; +} + +/* + (arrayp item) + Returns t if its argument is an array. +*/ +object *fn_arrayp (object *args, object *env) { + (void) env; + return arrayp(first(args)) ? tee : nil; +} + +/* + (boundp item) + Returns t if its argument is a symbol with a value. +*/ +object *fn_boundp (object *args, object *env) { + return boundp(first(args), env) ? tee : nil; +} + +/* + (keywordp item) + Returns t if its argument is a keyword. +*/ +object *fn_keywordp (object *args, object *env) { + (void) env; + return keywordp(first(args)) ? tee : nil; +} + +/* + (set symbol value [symbol value]*) + For each pair of arguments, assigns the value of the second argument to the value of the first argument. +*/ +object *fn_setfn (object *args, object *env) { + object *arg = nil; + while (args != NULL) { + if (cdr(args) == NULL) error2(oddargs); + object *pair = findvalue(first(args), env); + arg = second(args); + cdr(pair) = arg; + args = cddr(args); + } + return arg; +} + +/* + (streamp item) + Returns t if its argument is a stream. +*/ +object *fn_streamp (object *args, object *env) { + (void) env; + object *arg = first(args); + return streamp(arg) ? tee : nil; +} + +/* + (eq item item) + Tests whether the two arguments are the same symbol, same character, equal numbers, + or point to the same cons, and returns t or nil as appropriate. +*/ +object *fn_eq (object *args, object *env) { + (void) env; + return eq(first(args), second(args)) ? tee : nil; +} + +/* + (equal item item) + Tests whether the two arguments are the same symbol, same character, equal numbers, + or point to the same cons, and returns t or nil as appropriate. +*/ +object *fn_equal (object *args, object *env) { + (void) env; + return equal(first(args), second(args)) ? tee : nil; +} + +// List functions + +/* + (car list) + Returns the first item in a list. +*/ +object *fn_car (object *args, object *env) { + (void) env; + return carx(first(args)); +} + +/* + (cdr list) + Returns a list with the first item removed. +*/ +object *fn_cdr (object *args, object *env) { + (void) env; + return cdrx(first(args)); +} + +/* + (caar list) +*/ +object *fn_caar (object *args, object *env) { + (void) env; + return cxxxr(args, 0b100); +} + +/* + (cadr list) +*/ +object *fn_cadr (object *args, object *env) { + (void) env; + return cxxxr(args, 0b101); +} + +/* + (cdar list) + Equivalent to (cdr (car list)). +*/ +object *fn_cdar (object *args, object *env) { + (void) env; + return cxxxr(args, 0b110); +} + +/* + (cddr list) + Equivalent to (cdr (cdr list)). +*/ +object *fn_cddr (object *args, object *env) { + (void) env; + return cxxxr(args, 0b111); +} + +/* + (caaar list) + Equivalent to (car (car (car list))). +*/ +object *fn_caaar (object *args, object *env) { + (void) env; + return cxxxr(args, 0b1000); +} + +/* + (caadr list) + Equivalent to (car (car (cdar list))). +*/ +object *fn_caadr (object *args, object *env) { + (void) env; + return cxxxr(args, 0b1001);; +} + +/* + (cadar list) + Equivalent to (car (cdr (car list))). +*/ +object *fn_cadar (object *args, object *env) { + (void) env; + return cxxxr(args, 0b1010); +} + +/* + (caddr list) + Equivalent to (car (cdr (cdr list))). +*/ +object *fn_caddr (object *args, object *env) { + (void) env; + return cxxxr(args, 0b1011); +} + +/* + (cdaar list) + Equivalent to (cdar (car (car list))). +*/ +object *fn_cdaar (object *args, object *env) { + (void) env; + return cxxxr(args, 0b1100); +} + +/* + (cdadr list) + Equivalent to (cdr (car (cdr list))). +*/ +object *fn_cdadr (object *args, object *env) { + (void) env; + return cxxxr(args, 0b1101); +} + +/* + (cddar list) + Equivalent to (cdr (cdr (car list))). +*/ +object *fn_cddar (object *args, object *env) { + (void) env; + return cxxxr(args, 0b1110); +} + +/* + (cdddr list) + Equivalent to (cdr (cdr (cdr list))). +*/ +object *fn_cdddr (object *args, object *env) { + (void) env; + return cxxxr(args, 0b1111); +} + +/* + (length item) + Returns the number of items in a list, the length of a string, or the length of a one-dimensional array. +*/ +object *fn_length (object *args, object *env) { + (void) env; + object *arg = first(args); + if (listp(arg)) return number(listlength(arg)); + if (stringp(arg)) return number(stringlength(arg)); + if (!(arrayp(arg) && cdr(cddr(arg)) == NULL)) error(PSTR("argument is not a list, 1d array, or string"), arg); + return number(abs(first(cddr(arg))->integer)); +} + +/* + (array-dimensions item) + Returns a list of the dimensions of an array. +*/ +object *fn_arraydimensions (object *args, object *env) { + (void) env; + object *array = first(args); + if (!arrayp(array)) error(PSTR("argument is not an array"), array); + object *dimensions = cddr(array); + return (first(dimensions)->integer < 0) ? cons(number(-(first(dimensions)->integer)), cdr(dimensions)) : dimensions; +} + +/* + (list item*) + Returns a list of the values of its arguments. +*/ +object *fn_list (object *args, object *env) { + (void) env; + return args; +} + +/* + (make-array size [:initial-element element] [:element-type 'bit]) + If size is an integer it creates a one-dimensional array with elements from 0 to size-1. + If size is a list of n integers it creates an n-dimensional array with those dimensions. + If :element-type 'bit is specified the array is a bit array. +*/ +object *fn_makearray (object *args, object *env) { + (void) env; + object *def = nil; + bool bitp = false; + object *dims = first(args); + if (dims == NULL) error2(PSTR("dimensions can't be nil")); + else if (atom(dims)) dims = cons(dims, NULL); + args = cdr(args); + while (args != NULL && cdr(args) != NULL) { + object *var = first(args); + if (isbuiltin(first(args), INITIALELEMENT)) def = second(args); + else if (isbuiltin(first(args), ELEMENTTYPE) && isbuiltin(second(args), BIT)) bitp = true; + else error(PSTR("argument not recognised"), var); + args = cddr(args); + } + if (bitp) { + if (def == nil) def = number(0); + else def = number(-checkbitvalue(def)); // 1 becomes all ones + } + return makearray(dims, def, bitp); +} + +/* + (reverse list) + Returns a list with the elements of list in reverse order. +*/ +object *fn_reverse (object *args, object *env) { + (void) env; + object *list = first(args); + object *result = NULL; + while (list != NULL) { + if (improperp(list)) error(notproper, list); + push(first(list),result); + list = cdr(list); + } + return result; +} + +/* + (nth number list) + Returns the nth item in list, counting from zero. +*/ +object *fn_nth (object *args, object *env) { + (void) env; + int n = checkinteger(first(args)); + if (n < 0) error(indexnegative, first(args)); + object *list = second(args); + while (list != NULL) { + if (improperp(list)) error(notproper, list); + if (n == 0) return car(list); + list = cdr(list); + n--; + } + return nil; +} + +/* + (aref array index [index*]) + Returns an element from the specified array. +*/ +object *fn_aref (object *args, object *env) { + (void) env; + int bit; + object *array = first(args); + if (!arrayp(array)) error(PSTR("first argument is not an array"), array); + object *loc = *getarray(array, cdr(args), 0, &bit); + if (bit == -1) return loc; + else return number((loc->integer)>>bit & 1); +} + +/* + (assoc key list) + Looks up a key in an association list of (key . value) pairs, + and returns the matching pair, or nil if no pair is found. +*/ +object *fn_assoc (object *args, object *env) { + (void) env; + object *key = first(args); + object *list = second(args); + return assoc(key,list); +} + +/* + (member item list) + Searches for an item in a list, using eq, and returns the list starting from the first occurrence of the item, + or nil if it is not found. +*/ +object *fn_member (object *args, object *env) { + (void) env; + object *item = first(args); + object *list = second(args); + while (list != NULL) { + if (improperp(list)) error(notproper, list); + if (eq(item,car(list))) return list; + list = cdr(list); + } + return nil; +} + +/* + (apply function list) + Returns the result of evaluating function, with the list of arguments specified by the second parameter. +*/ +object *fn_apply (object *args, object *env) { + object *previous = NULL; + object *last = args; + while (cdr(last) != NULL) { + previous = last; + last = cdr(last); + } + object *arg = car(last); + if (!listp(arg)) error(notalist, arg); + cdr(previous) = arg; + return apply(first(args), cdr(args), env); +} + +/* + (funcall function argument*) + Evaluates function with the specified arguments. +*/ +object *fn_funcall (object *args, object *env) { + return apply(first(args), cdr(args), env); +} + +/* + (append list*) + Joins its arguments, which should be lists, into a single list. +*/ +object *fn_append (object *args, object *env) { + (void) env; + object *head = NULL; + object *tail; + while (args != NULL) { + object *list = first(args); + if (!listp(list)) error(notalist, list); + while (consp(list)) { + object *obj = cons(car(list), cdr(list)); + if (head == NULL) head = obj; + else cdr(tail) = obj; + tail = obj; + list = cdr(list); + if (cdr(args) != NULL && improperp(list)) error(notproper, first(args)); + } + args = cdr(args); + } + return head; +} + +/* + (mapc function list1 [list]*) + Applies the function to each element in one or more lists, ignoring the results. + It returns the first list argument. +*/ +object *fn_mapc (object *args, object *env) { + object *function = first(args); + args = cdr(args); + object *result = first(args); + push(result,GCStack); + object *params = cons(NULL, NULL); + push(params,GCStack); + // Make parameters + while (true) { + object *tailp = params; + object *lists = args; + while (lists != NULL) { + object *list = car(lists); + if (list == NULL) { + pop(GCStack); pop(GCStack); + return result; + } + if (improperp(list)) error(notproper, list); + object *obj = cons(first(list),NULL); + car(lists) = cdr(list); + cdr(tailp) = obj; tailp = obj; + lists = cdr(lists); + } + apply(function, cdr(params), env); + } +} + +/* + (mapcar function list1 [list]*) + Applies the function to each element in one or more lists, and returns the resulting list. +*/ +object *fn_mapcar (object *args, object *env) { + return mapcarcan(args, env, mapcarfun); +} + +/* + (mapcan function list1 [list]*) + Applies the function to each element in one or more lists. The results should be lists, + and these are appended together to give the value returned. +*/ +object *fn_mapcan (object *args, object *env) { + return mapcarcan(args, env, mapcanfun); +} + +// Arithmetic functions + +/* + (+ number*) + Adds its arguments together. + If each argument is an integer, and the running total doesn't overflow, the result is an integer, + otherwise a floating-point number. +*/ +object *fn_add (object *args, object *env) { + (void) env; + int result = 0; + while (args != NULL) { + object *arg = car(args); + if (floatp(arg)) return add_floats(args, (float)result); + else if (integerp(arg)) { + int val = arg->integer; + if (val < 1) { if (INT_MIN - val > result) return add_floats(args, (float)result); } + else { if (INT_MAX - val < result) return add_floats(args, (float)result); } + result = result + val; + } else error(notanumber, arg); + args = cdr(args); + } + return number(result); +} + +/* + (- number*) + If there is one argument, negates the argument. + If there are two or more arguments, subtracts the second and subsequent arguments from the first argument. + If each argument is an integer, and the running total doesn't overflow, returns the result as an integer, + otherwise a floating-point number. +*/ +object *fn_subtract (object *args, object *env) { + (void) env; + object *arg = car(args); + args = cdr(args); + if (args == NULL) return negate(arg); + else if (floatp(arg)) return subtract_floats(args, arg->single_float); + else if (integerp(arg)) { + int result = arg->integer; + while (args != NULL) { + arg = car(args); + if (floatp(arg)) return subtract_floats(args, result); + else if (integerp(arg)) { + int val = (car(args))->integer; + if (val < 1) { if (INT_MAX + val < result) return subtract_floats(args, result); } + else { if (INT_MIN + val > result) return subtract_floats(args, result); } + result = result - val; + } else error(notanumber, arg); + args = cdr(args); + } + return number(result); + } else error(notanumber, arg); + return nil; +} + +/* + (* number*) + Multiplies its arguments together. + If each argument is an integer, and the running total doesn't overflow, the result is an integer, + otherwise it's a floating-point number. +*/ +object *fn_multiply (object *args, object *env) { + (void) env; + int result = 1; + while (args != NULL){ + object *arg = car(args); + if (floatp(arg)) return multiply_floats(args, result); + else if (integerp(arg)) { + int64_t val = result * (int64_t)(arg->integer); + if ((val > INT_MAX) || (val < INT_MIN)) return multiply_floats(args, result); + result = val; + } else error(notanumber, arg); + args = cdr(args); + } + return number(result); +} + +/* + (/ number*) + Divides the first argument by the second and subsequent arguments. + If each argument is an integer, and each division produces an exact result, the result is an integer; + otherwise it's a floating-point number. +*/ +object *fn_divide (object *args, object *env) { + (void) env; + object* arg = first(args); + args = cdr(args); + // One argument + if (args == NULL) { + if (floatp(arg)) { + float f = arg->single_float; + if (f == 0.0) error2(PSTR("division by zero")); + return makefloat(1.0 / f); + } else if (integerp(arg)) { + int i = arg->integer; + if (i == 0) error2(PSTR("division by zero")); + else if (i == 1) return number(1); + else return makefloat(1.0 / i); + } else error(notanumber, arg); + } + // Multiple arguments + if (floatp(arg)) return divide_floats(args, arg->single_float); + else if (integerp(arg)) { + int result = arg->integer; + while (args != NULL) { + arg = car(args); + if (floatp(arg)) { + return divide_floats(args, result); + } else if (integerp(arg)) { + int i = arg->integer; + if (i == 0) error2(PSTR("division by zero")); + if ((result % i) != 0) return divide_floats(args, result); + if ((result == INT_MIN) && (i == -1)) return divide_floats(args, result); + result = result / i; + args = cdr(args); + } else error(notanumber, arg); + } + return number(result); + } else error(notanumber, arg); + return nil; +} + +/* + (mod number number) + Returns its first argument modulo the second argument. + If both arguments are integers the result is an integer; otherwise it's a floating-point number. +*/ +object *fn_mod (object *args, object *env) { + (void) env; + object *arg1 = first(args); + object *arg2 = second(args); + if (integerp(arg1) && integerp(arg2)) { + int divisor = arg2->integer; + if (divisor == 0) error2(PSTR("division by zero")); + int dividend = arg1->integer; + int remainder = dividend % divisor; + if ((dividend<0) != (divisor<0)) remainder = remainder + divisor; + return number(remainder); + } else { + float fdivisor = checkintfloat(arg2); + if (fdivisor == 0.0) error2(PSTR("division by zero")); + float fdividend = checkintfloat(arg1); + float fremainder = fmod(fdividend , fdivisor); + if ((fdividend<0) != (fdivisor<0)) fremainder = fremainder + fdivisor; + return makefloat(fremainder); + } +} + +/* + (1+ number) + Adds one to its argument and returns it. + If the argument is an integer the result is an integer if possible; + otherwise it's a floating-point number. +*/ +object *fn_oneplus (object *args, object *env) { + (void) env; + object* arg = first(args); + if (floatp(arg)) return makefloat((arg->single_float) + 1.0); + else if (integerp(arg)) { + int result = arg->integer; + if (result == INT_MAX) return makefloat((arg->integer) + 1.0); + else return number(result + 1); + } else error(notanumber, arg); + return nil; +} + +/* + (1- number) + Subtracts one from its argument and returns it. + If the argument is an integer the result is an integer if possible; + otherwise it's a floating-point number. +*/ +object *fn_oneminus (object *args, object *env) { + (void) env; + object* arg = first(args); + if (floatp(arg)) return makefloat((arg->single_float) - 1.0); + else if (integerp(arg)) { + int result = arg->integer; + if (result == INT_MIN) return makefloat((arg->integer) - 1.0); + else return number(result - 1); + } else error(notanumber, arg); + return nil; +} + +/* + (abs number) + Returns the absolute, positive value of its argument. + If the argument is an integer the result will be returned as an integer if possible, + otherwise a floating-point number. +*/ +object *fn_abs (object *args, object *env) { + (void) env; + object *arg = first(args); + if (floatp(arg)) return makefloat(abs(arg->single_float)); + else if (integerp(arg)) { + int result = arg->integer; + if (result == INT_MIN) return makefloat(abs((float)result)); + else return number(abs(result)); + } else error(notanumber, arg); + return nil; +} + +/* + (random number) + If number is an integer returns a random number between 0 and one less than its argument. + Otherwise returns a floating-point number between zero and number. +*/ +object *fn_random (object *args, object *env) { + (void) env; + object *arg = first(args); + if (integerp(arg)) return number(random(arg->integer)); + else if (floatp(arg)) return makefloat((float)rand()/(float)(RAND_MAX/(arg->single_float))); + else error(notanumber, arg); + return nil; +} + +/* + (max number*) + Returns the maximum of one or more arguments. +*/ +object *fn_maxfn (object *args, object *env) { + (void) env; + object* result = first(args); + args = cdr(args); + while (args != NULL) { + object *arg = car(args); + if (integerp(result) && integerp(arg)) { + if ((arg->integer) > (result->integer)) result = arg; + } else if ((checkintfloat(arg) > checkintfloat(result))) result = arg; + args = cdr(args); + } + return result; +} + +/* + (min number*) + Returns the minimum of one or more arguments. +*/ +object *fn_minfn (object *args, object *env) { + (void) env; + object* result = first(args); + args = cdr(args); + while (args != NULL) { + object *arg = car(args); + if (integerp(result) && integerp(arg)) { + if ((arg->integer) < (result->integer)) result = arg; + } else if ((checkintfloat(arg) < checkintfloat(result))) result = arg; + args = cdr(args); + } + return result; +} + +// Arithmetic comparisons + +/* + (/= number*) + Returns t if none of the arguments are equal, or nil if two or more arguments are equal. +*/ +object *fn_noteq (object *args, object *env) { + (void) env; + while (args != NULL) { + object *nargs = args; + object *arg1 = first(nargs); + nargs = cdr(nargs); + while (nargs != NULL) { + object *arg2 = first(nargs); + if (integerp(arg1) && integerp(arg2)) { + if ((arg1->integer) == (arg2->integer)) return nil; + } else if ((checkintfloat(arg1) == checkintfloat(arg2))) return nil; + nargs = cdr(nargs); + } + args = cdr(args); + } + return tee; +} + +/* + (= number*) + Returns t if all the arguments, which must be numbers, are numerically equal, and nil otherwise. +*/ +object *fn_numeq (object *args, object *env) { + (void) env; + return compare(args, false, false, true); +} + +/* + (< number*) + Returns t if each argument is less than the next argument, and nil otherwise. +*/ +object *fn_less (object *args, object *env) { + (void) env; + return compare(args, true, false, false); +} + +/* + (<= number*) + Returns t if each argument is less than or equal to the next argument, and nil otherwise. +*/ +object *fn_lesseq (object *args, object *env) { + (void) env; + return compare(args, true, false, true); +} + +/* + (> number*) + Returns t if each argument is greater than the next argument, and nil otherwise. +*/ +object *fn_greater (object *args, object *env) { + (void) env; + return compare(args, false, true, false); +} + +/* + (>= number*) + Returns t if each argument is greater than or equal to the next argument, and nil otherwise. +*/ +object *fn_greatereq (object *args, object *env) { + (void) env; + return compare(args, false, true, true); +} + +/* + (plusp number) + Returns t if the argument is greater than zero, or nil otherwise. +*/ +object *fn_plusp (object *args, object *env) { + (void) env; + object *arg = first(args); + if (floatp(arg)) return ((arg->single_float) > 0.0) ? tee : nil; + else if (integerp(arg)) return ((arg->integer) > 0) ? tee : nil; + else error(notanumber, arg); + return nil; +} + +/* + (minusp number) + Returns t if the argument is less than zero, or nil otherwise. +*/ +object *fn_minusp (object *args, object *env) { + (void) env; + object *arg = first(args); + if (floatp(arg)) return ((arg->single_float) < 0.0) ? tee : nil; + else if (integerp(arg)) return ((arg->integer) < 0) ? tee : nil; + else error(notanumber, arg); + return nil; +} + +/* + (zerop number) + Returns t if the argument is zero. +*/ +object *fn_zerop (object *args, object *env) { + (void) env; + object *arg = first(args); + if (floatp(arg)) return ((arg->single_float) == 0.0) ? tee : nil; + else if (integerp(arg)) return ((arg->integer) == 0) ? tee : nil; + else error(notanumber, arg); + return nil; +} + +/* + (oddp number) + Returns t if the integer argument is odd. +*/ +object *fn_oddp (object *args, object *env) { + (void) env; + int arg = checkinteger(first(args)); + return ((arg & 1) == 1) ? tee : nil; +} + +/* + (evenp number) + Returns t if the integer argument is even. +*/ +object *fn_evenp (object *args, object *env) { + (void) env; + int arg = checkinteger(first(args)); + return ((arg & 1) == 0) ? tee : nil; +} + +// Number functions + +/* + (integerp number) + Returns t if the argument is an integer. +*/ +object *fn_integerp (object *args, object *env) { + (void) env; + return integerp(first(args)) ? tee : nil; +} + +/* + (numberp number) + Returns t if the argument is a number. +*/ +object *fn_numberp (object *args, object *env) { + (void) env; + object *arg = first(args); + return (integerp(arg) || floatp(arg)) ? tee : nil; +} + +// Floating-point functions + +/* + (float number) + Returns its argument converted to a floating-point number. +*/ +object *fn_floatfn (object *args, object *env) { + (void) env; + object *arg = first(args); + return (floatp(arg)) ? arg : makefloat((float)(arg->integer)); +} + +/* + (floatp number) + Returns t if the argument is a floating-point number. +*/ +object *fn_floatp (object *args, object *env) { + (void) env; + return floatp(first(args)) ? tee : nil; +} + +/* + (sin number) + Returns sin(number). +*/ +object *fn_sin (object *args, object *env) { + (void) env; + return makefloat(sin(checkintfloat(first(args)))); +} + +/* + (cos number) + Returns cos(number). +*/ +object *fn_cos (object *args, object *env) { + (void) env; + return makefloat(cos(checkintfloat(first(args)))); +} + +/* + (tan number) + Returns tan(number). +*/ +object *fn_tan (object *args, object *env) { + (void) env; + return makefloat(tan(checkintfloat(first(args)))); +} + +/* + (asin number) + Returns asin(number). +*/ +object *fn_asin (object *args, object *env) { + (void) env; + return makefloat(asin(checkintfloat(first(args)))); +} + +/* + (acos number) + Returns acos(number). +*/ +object *fn_acos (object *args, object *env) { + (void) env; + return makefloat(acos(checkintfloat(first(args)))); +} + +/* + (atan number1 [number2]) + Returns the arc tangent of number1/number2, in radians. If number2 is omitted it defaults to 1. +*/ +object *fn_atan (object *args, object *env) { + (void) env; + object *arg = first(args); + float div = 1.0; + args = cdr(args); + if (args != NULL) div = checkintfloat(first(args)); + return makefloat(atan2(checkintfloat(arg), div)); +} + +/* + (sinh number) + Returns sinh(number). +*/ +object *fn_sinh (object *args, object *env) { + (void) env; + return makefloat(sinh(checkintfloat(first(args)))); +} + +/* + (cosh number) + Returns cosh(number). +*/ +object *fn_cosh (object *args, object *env) { + (void) env; + return makefloat(cosh(checkintfloat(first(args)))); +} + +/* + (tanh number) + Returns tanh(number). +*/ +object *fn_tanh (object *args, object *env) { + (void) env; + return makefloat(tanh(checkintfloat(first(args)))); +} + +/* + (exp number) + Returns exp(number). +*/ +object *fn_exp (object *args, object *env) { + (void) env; + return makefloat(exp(checkintfloat(first(args)))); +} + +/* + (sqrt number) + Returns sqrt(number). +*/ +object *fn_sqrt (object *args, object *env) { + (void) env; + return makefloat(sqrt(checkintfloat(first(args)))); +} + +/* + (number [base]) + Returns the logarithm of number to the specified base. If base is omitted it defaults to e. +*/ +object *fn_log (object *args, object *env) { + (void) env; + object *arg = first(args); + float fresult = log(checkintfloat(arg)); + args = cdr(args); + if (args == NULL) return makefloat(fresult); + else return makefloat(fresult / log(checkintfloat(first(args)))); +} + +/* + (expt number power) + Returns number raised to the specified power. + Returns the result as an integer if the arguments are integers and the result will be within range, + otherwise a floating-point number. +*/ +object *fn_expt (object *args, object *env) { + (void) env; + object *arg1 = first(args); object *arg2 = second(args); + float float1 = checkintfloat(arg1); + float value = log(abs(float1)) * checkintfloat(arg2); + if (integerp(arg1) && integerp(arg2) && ((arg2->integer) >= 0) && (abs(value) < 21.4875)) + return number(intpower(arg1->integer, arg2->integer)); + if (float1 < 0) { + if (integerp(arg2)) return makefloat((arg2->integer & 1) ? -exp(value) : exp(value)); + else error2(PSTR("invalid result")); + } + return makefloat(exp(value)); +} + +/* + (ceiling number [divisor]) + Returns ceil(number/divisor). If omitted, divisor is 1. +*/ +object *fn_ceiling (object *args, object *env) { + (void) env; + object *arg = first(args); + args = cdr(args); + if (args != NULL) return number(ceil(checkintfloat(arg) / checkintfloat(first(args)))); + else return number(ceil(checkintfloat(arg))); +} + +/* + (floor number [divisor]) + Returns floor(number/divisor). If omitted, divisor is 1. +*/ +object *fn_floor (object *args, object *env) { + (void) env; + object *arg = first(args); + args = cdr(args); + if (args != NULL) return number(floor(checkintfloat(arg) / checkintfloat(first(args)))); + else return number(floor(checkintfloat(arg))); +} + +/* + (truncate number) + Returns t if the argument is a floating-point number. +*/ +object *fn_truncate (object *args, object *env) { + (void) env; + object *arg = first(args); + args = cdr(args); + if (args != NULL) return number((int)(checkintfloat(arg) / checkintfloat(first(args)))); + else return number((int)(checkintfloat(arg))); +} + +/* + (round number) + Returns t if the argument is a floating-point number. +*/ +object *fn_round (object *args, object *env) { + (void) env; + object *arg = first(args); + args = cdr(args); + if (args != NULL) return number(myround(checkintfloat(arg) / checkintfloat(first(args)))); + else return number(myround(checkintfloat(arg))); +} + +// Characters + +/* + (char string n) + Returns the nth character in a string, counting from zero. +*/ +object *fn_char (object *args, object *env) { + (void) env; + object *arg = first(args); + if (!stringp(arg)) error(notastring, arg); + object *n = second(args); + char c = nthchar(arg, checkinteger(n)); + if (c == 0) error(indexrange, n); + return character(c); +} + +/* + (char-code character) + Returns the ASCII code for a character, as an integer. +*/ +object *fn_charcode (object *args, object *env) { + (void) env; + return number(checkchar(first(args))); +} + +/* + (code-char integer) + Returns the character for the specified ASCII code. +*/ +object *fn_codechar (object *args, object *env) { + (void) env; + return character(checkinteger(first(args))); +} + +/* + (characterp item) + Returns t if the argument is a character and nil otherwise. +*/ +object *fn_characterp (object *args, object *env) { + (void) env; + return characterp(first(args)) ? tee : nil; +} + +// Strings + +/* + (stringp item) + Returns t if the argument is a string and nil otherwise. +*/ +object *fn_stringp (object *args, object *env) { + (void) env; + return stringp(first(args)) ? tee : nil; +} + +/* + (string= string string) + Tests whether two strings are the same. +*/ +object *fn_stringeq (object *args, object *env) { + (void) env; + return stringcompare(args, false, false, true) ? tee : nil; +} + +/* + (string< string string) + Returns t if the first string is alphabetically less than the second string, and nil otherwise. +*/ +object *fn_stringless (object *args, object *env) { + (void) env; + return stringcompare(args, true, false, false) ? tee : nil; +} + +/* + (string> string string) + Returns t if the first string is alphabetically greater than the second string, and nil otherwise. +*/ +object *fn_stringgreater (object *args, object *env) { + (void) env; + return stringcompare(args, false, true, false) ? tee : nil; +} + +/* + (sort list test) + Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list. +*/ +object *fn_sort (object *args, object *env) { + if (first(args) == NULL) return nil; + object *list = cons(nil,first(args)); + push(list,GCStack); + object *predicate = second(args); + object *compare = cons(NULL, cons(NULL, NULL)); + push(compare,GCStack); + object *ptr = cdr(list); + while (cdr(ptr) != NULL) { + object *go = list; + while (go != ptr) { + car(compare) = car(cdr(ptr)); + car(cdr(compare)) = car(cdr(go)); + if (apply(predicate, compare, env)) break; + go = cdr(go); + } + if (go != ptr) { + object *obj = cdr(ptr); + cdr(ptr) = cdr(obj); + cdr(obj) = cdr(go); + cdr(go) = obj; + } else ptr = cdr(ptr); + } + pop(GCStack); pop(GCStack); + return cdr(list); +} + +/* + (string item) + Converts its argument to a string. +*/ +object *fn_stringfn (object *args, object *env) { + return fn_princtostring(args, env); +} + +/* + (concatenate 'string string*) + Joins together the strings given in the second and subsequent arguments, and returns a single string. +*/ +object *fn_concatenate (object *args, object *env) { + (void) env; + object *arg = first(args); + if (builtin(arg->name) != STRINGFN) error2(PSTR("only supports strings")); + args = cdr(args); + object *result = newstring(); + object *tail = result; + while (args != NULL) { + object *obj = checkstring(first(args)); + obj = cdr(obj); + while (obj != NULL) { + int quad = obj->chars; + while (quad != 0) { + char ch = quad>>((sizeof(int)-1)*8) & 0xFF; + buildstring(ch, &tail); + quad = quad<<8; + } + obj = car(obj); + } + args = cdr(args); + } + return result; +} + +/* + (subseq seq start [end]) + Returns a subsequence of a list or string from item start to item end-1. +*/ +object *fn_subseq (object *args, object *env) { + (void) env; + object *arg = first(args); + int start = checkinteger(second(args)), end; + if (start < 0) error(indexnegative, second(args)); + args = cddr(args); + if (listp(arg)) { + int length = listlength(arg); + if (args != NULL) end = checkinteger(car(args)); else end = length; + if (start > end || end > length) error2(indexrange); + object *result = cons(NULL, NULL); + object *ptr = result; + for (int x = 0; x < end; x++) { + if (x >= start) { cdr(ptr) = cons(car(arg), NULL); ptr = cdr(ptr); } + arg = cdr(arg); + } + return cdr(result); + } else if (stringp(arg)) { + int length = stringlength(arg); + if (args != NULL) end = checkinteger(car(args)); else end = length; + if (start > end || end > length) error2(indexrange); + object *result = newstring(); + object *tail = result; + for (int i=start; i= 0) return number(value << count); + else return number(value >> abs(count)); +} + +/* + (logbitp bit value) + Returns t if bit number bit in value is a '1', and nil if it is a '0'. +*/ +object *fn_logbitp (object *args, object *env) { + (void) env; + int index = checkinteger(first(args)); + int value = checkinteger(second(args)); + return (bitRead(value, index) == 1) ? tee : nil; +} + +// System functions + +/* + (eval form*) + Evaluates its argument an extra time. +*/ +object *fn_eval (object *args, object *env) { + return eval(first(args), env); +} + +/* + (globals) + Returns a list of global variables. +*/ +object *fn_globals (object *args, object *env) { + (void) args, (void) env; + object *result = cons(NULL, NULL); + object *ptr = result; + object *arg = GlobalEnv; + while (arg != NULL) { + cdr(ptr) = cons(car(car(arg)), NULL); ptr = cdr(ptr); + arg = cdr(arg); + } + return cdr(result); +} + +/* + (locals) + Returns an association list of local variables and their values. +*/ +object *fn_locals (object *args, object *env) { + (void) args; + return env; +} + +/* + (makunbound symbol) + Removes the value of the symbol from GlobalEnv and returns the symbol. +*/ +object *fn_makunbound (object *args, object *env) { + (void) env; + object *var = first(args); + if (!symbolp(var)) error(notasymbol, var); + delassoc(var, &GlobalEnv); + return var; +} + +/* + (break) + Inserts a breakpoint in the program. When evaluated prints Break! and reenters the REPL. +*/ +object *fn_break (object *args, object *env) { + (void) args; + pfstring(PSTR("\nBreak!\n"), pserial); + BreakLevel++; + repl(env); + BreakLevel--; + return nil; +} + +/* + (read [stream]) + Reads an atom or list from the serial input and returns it. + If stream is specified the item is read from the specified stream. +*/ +object *fn_read (object *args, object *env) { + (void) env; + gfun_t gfun = gstreamfun(args); + return read(gfun); +} + +/* + (prin1 item [stream]) + Prints its argument, and returns its value. + Strings are printed with quotation marks and escape characters. +*/ +object *fn_prin1 (object *args, object *env) { + (void) env; + object *obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); + printobject(obj, pfun); + return obj; +} + +/* + (print item [stream]) + Prints its argument with quotation marks and escape characters, on a new line, and followed by a space. + If stream is specified the argument is printed to the specified stream. +*/ +object *fn_print (object *args, object *env) { + (void) env; + object *obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); + pln(pfun); + printobject(obj, pfun); + pfun(' '); + return obj; +} + +/* + (princ item [stream]) + Prints its argument, and returns its value. + Characters and strings are printed without quotation marks or escape characters. +*/ +object *fn_princ (object *args, object *env) { + (void) env; + object *obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); + prin1object(obj, pfun); + return obj; +} + +/* + (terpri [stream]) + Prints a new line, and returns nil. + If stream is specified the new line is written to the specified stream. +*/ +object *fn_terpri (object *args, object *env) { + (void) env; + pfun_t pfun = pstreamfun(args); + pln(pfun); + return nil; +} + +/* + (read-byte stream) + Reads a byte from a stream and returns it. +*/ +object *fn_readbyte (object *args, object *env) { + (void) env; + gfun_t gfun = gstreamfun(args); + int c = gfun(); + return (c == -1) ? nil : number(c); +} + +/* + (read-line [stream]) + Reads characters from the serial input up to a newline character, and returns them as a string, excluding the newline. + If stream is specified the line is read from the specified stream. +*/ +object *fn_readline (object *args, object *env) { + (void) env; + gfun_t gfun = gstreamfun(args); + return readstring('\n', gfun); +} + +/* + (write-byte number [stream]) + Writes a byte to a stream. +*/ +object *fn_writebyte (object *args, object *env) { + (void) env; + int value = checkinteger(first(args)); + pfun_t pfun = pstreamfun(cdr(args)); + (pfun)(value); + return nil; +} + +/* + (write-string string [stream]) + Writes a string. If stream is specified the string is written to the stream. +*/ +object *fn_writestring (object *args, object *env) { + (void) env; + object *obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); + char temp = Flags; + clrflag(PRINTREADABLY); + printstring(obj, pfun); + Flags = temp; + return nil; +} + +/* + (write-line string [stream]) + Writes a string terminated by a newline character. If stream is specified the string is written to the stream. +*/ +object *fn_writeline (object *args, object *env) { + (void) env; + object *obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); + char temp = Flags; + clrflag(PRINTREADABLY); + printstring(obj, pfun); + pln(pfun); + Flags = temp; + return nil; +} + +/* + (restart-i2c stream [read-p]) + Restarts an i2c-stream. + If read-p is nil or omitted the stream is written to. + If read-p is an integer it specifies the number of bytes to be read from the stream. +*/ +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 (integerp(rw)) I2Ccount = rw->integer; + read = (rw != NULL); + } + int address = stream & 0xFF; + if (stream>>8 != I2CSTREAM) error2(PSTR("not an i2c stream")); + return I2Crestart(address, read) ? tee : nil; +} + +/* + (gc) + Forces a garbage collection and prints the number of objects collected, and the time taken. +*/ +object *fn_gc (object *obj, object *env) { + int initial = Freespace; + unsigned long start = micros(); + gc(obj, env); + unsigned long elapsed = micros() - start; + pfstring(PSTR("Space: "), pserial); + pint(Freespace - initial, pserial); + pfstring(PSTR(" bytes, Time: "), pserial); + pint(elapsed, pserial); + pfstring(PSTR(" us\n"), pserial); + return nil; +} + +/* + (room) + Returns the number of free Lisp cells remaining. +*/ +object *fn_room (object *args, object *env) { + (void) args, (void) env; + return number(Freespace); +} + +/* + (cls) + Prints a clear-screen character. +*/ +object *fn_cls (object *args, object *env) { + (void) args, (void) env; + pserial(12); + return nil; +} + +// Arduino procedures + +/* + (pinmode pin mode) + Sets the input/output mode of an Arduino pin number, and returns nil. + The mode parameter can be an integer, a keyword, or t or nil. +*/ +object *fn_pinmode (object *args, object *env) { + (void) env; int pin; + object *arg = first(args); + if (keywordp(arg)) pin = checkkeyword(arg); + else pin = checkinteger(first(args)); + int pm = INPUT; + arg = second(args); + if (keywordp(arg)) pm = checkkeyword(arg); + else if (integerp(arg)) { + int mode = arg->integer; + if (mode == 1) pm = OUTPUT; else if (mode == 2) pm = INPUT_PULLUP; + #if defined(INPUT_PULLDOWN) + else if (mode == 4) pm = INPUT_PULLDOWN; + #endif + } else if (arg != nil) pm = OUTPUT; + pinMode(pin, pm); + return nil; +} + +/* + (digitalread pin) + Reads the state of the specified Arduino pin number and returns t (high) or nil (low). +*/ +object *fn_digitalread (object *args, object *env) { + (void) env; + int pin; + object *arg = first(args); + if (keywordp(arg)) pin = checkkeyword(arg); + else pin = checkinteger(arg); + if (digitalRead(pin) != 0) return tee; else return nil; +} + +/* + (digitalwrite pin state) + Sets the state of the specified Arduino pin number. +*/ +object *fn_digitalwrite (object *args, object *env) { + (void) env; + int pin; + object *arg = first(args); + if (keywordp(arg)) pin = checkkeyword(arg); + else pin = checkinteger(arg); + arg = second(args); + int mode; + if (keywordp(arg)) mode = checkkeyword(arg); + else if (integerp(arg)) mode = arg->integer ? HIGH : LOW; + else mode = (arg != nil) ? HIGH : LOW; + digitalWrite(pin, mode); + return arg; +} + +/* + (analogread pin) + Reads the specified Arduino analogue pin number and returns the value. +*/ +object *fn_analogread (object *args, object *env) { + (void) env; + int pin; + object *arg = first(args); + if (keywordp(arg)) pin = checkkeyword(arg); + else { + pin = checkinteger(arg); + checkanalogread(pin); + } + return number(analogRead(pin)); +} + +/* + (analogreadresolution bits) + Specifies the resolution for the analogue inputs on platforms that support it. + The default resolution on all platforms is 10 bits. +*/ +object *fn_analogreadresolution (object *args, object *env) { + (void) env; + object *arg = first(args); + #if defined(ESP32) + analogReadResolution(checkinteger(arg)); + #else + error2(PSTR("not supported")); + #endif + return arg; +} + +/* + (analogwrite pin value) + Writes the value to the specified Arduino pin number. +*/ +object *fn_analogwrite (object *args, object *env) { + (void) env; + int pin; + object *arg = first(args); + if (keywordp(arg)) pin = checkkeyword(arg); + else pin = checkinteger(arg); + checkanalogwrite(pin); + object *value = second(args); + analogWrite(pin, checkinteger(value)); + return value; +} + +/* + (delay number) + Delays for a specified number of milliseconds. +*/ +object *fn_delay (object *args, object *env) { + (void) env; + object *arg1 = first(args); + delay(checkinteger(arg1)); + return arg1; +} + +/* + (millis) + Returns the time in milliseconds that uLisp has been running. +*/ +object *fn_millis (object *args, object *env) { + (void) args, (void) env; + return number(millis()); +} + +/* + (sleep secs) + Puts the processor into a low-power sleep mode for secs. + Only supported on some platforms. On other platforms it does delay(1000*secs). +*/ +object *fn_sleep (object *args, object *env) { + (void) env; + object *arg1 = first(args); + doze(checkinteger(arg1)); + return arg1; +} + +/* + (note [pin] [note] [octave]) + Generates a square wave on pin. + The argument note represents the note in the well-tempered scale, from 0 to 11, + where 0 represents C, 1 represents C#, and so on. + The argument octave can be from 3 to 6. If omitted it defaults to 0. +*/ +object *fn_note (object *args, object *env) { + (void) env; + static int pin = 255; + if (args != NULL) { + pin = checkinteger(first(args)); + int note = 0; + if (cddr(args) != NULL) note = checkinteger(second(args)); + int octave = 0; + if (cddr(args) != NULL) octave = checkinteger(third(args)); + playnote(pin, note, octave); + } else nonote(pin); + return nil; +} + +/* + (register address [value]) + Reads or writes the value of a peripheral register. + If value is not specified the function returns the value of the register at address. + If value is specified the value is written to the register at address and the function returns value. +*/ +object *fn_register (object *args, object *env) { + (void) env; + object *arg = first(args); + int addr; + if (keywordp(arg)) addr = checkkeyword(arg); + else addr = checkinteger(first(args)); + if (cdr(args) == NULL) return number(*(uint32_t *)addr); + (*(uint32_t *)addr) = checkinteger(second(args)); + return second(args); +} + +// Tree Editor + +/* + (edit 'function) + Calls the Lisp tree editor to allow you to edit a function definition. +*/ +object *fn_edit (object *args, object *env) { + object *fun = first(args); + object *pair = findvalue(fun, env); + clrflag(EXITEDITOR); + object *arg = edit(eval(fun, env)); + cdr(pair) = arg; + return arg; +} + +// Pretty printer + +/* + (pprint item [str]) + Prints its argument, using the pretty printer, to display it formatted in a structured way. + If str is specified it prints to the specified stream. It returns no value. +*/ +object *fn_pprint (object *args, object *env) { + (void) env; + object *obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); + #if defined(gfxsupport) + if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; + #endif + pln(pfun); + superprint(obj, 0, pfun); + ppwidth = PPWIDTH; + return bsymbol(NOTHING); +} + +/* + (pprintall [str]) + Pretty-prints the definition of every function and variable defined in the uLisp workspace. + If str is specified it prints to the specified stream. It returns no value. +*/ +object *fn_pprintall (object *args, object *env) { + (void) env; + pfun_t pfun = pstreamfun(args); + #if defined(gfxsupport) + if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; + #endif + object *globals = GlobalEnv; + while (globals != NULL) { + object *pair = first(globals); + object *var = car(pair); + object *val = cdr(pair); + pln(pfun); + if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) { + superprint(cons(bsymbol(DEFUN), cons(var, cdr(val))), 0, pfun); + } else { + superprint(cons(bsymbol(DEFVAR), cons(var, cons(quote(val), NULL))), 0, pfun); + } + pln(pfun); + testescape(); + globals = cdr(globals); + } + ppwidth = PPWIDTH; + return bsymbol(NOTHING); +} + +// Format + +/* + (format output controlstring [arguments]*) + Outputs its arguments formatted according to the format directives in controlstring. +*/ +object *fn_format (object *args, object *env) { + (void) env; + pfun_t pfun = pserial; + object *output = first(args); + object *obj; + if (output == nil) { obj = startstring(); pfun = pstr; } + else if (output != tee) pfun = pstreamfun(args); + object *formatstr = checkstring(second(args)); + object *save = NULL; + args = cddr(args); + int len = stringlength(formatstr); + uint8_t n = 0, width = 0, w, bra = 0; + char pad = ' '; + bool tilde = false, mute = false, comma = false, quote = false; + while (n < len) { + char ch = nthchar(formatstr, n); + char ch2 = ch & ~0x20; // force to upper case + if (tilde) { + if (ch == '}') { + if (save == NULL) formaterr(formatstr, PSTR("no matching ~{"), n); + if (args == NULL) { args = cdr(save); save = NULL; } else n = bra; + mute = false; tilde = false; + } + else if (!mute) { + if (comma && quote) { pad = ch; comma = false, quote = false; } + else if (ch == '\'') { + if (comma) quote = true; + else formaterr(formatstr, PSTR("quote not valid"), n); + } + else if (ch == '~') { pfun('~'); tilde = false; } + else if (ch >= '0' && ch <= '9') width = width*10 + ch - '0'; + else if (ch == ',') comma = true; + else if (ch == '%') { pln(pfun); tilde = false; } + else if (ch == '&') { pfl(pfun); tilde = false; } + else if (ch == '^') { + if (save != NULL && args == NULL) mute = true; + tilde = false; + } + else if (ch == '{') { + if (save != NULL) formaterr(formatstr, PSTR("can't nest ~{"), n); + if (args == NULL) formaterr(formatstr, noargument, n); + if (!listp(first(args))) formaterr(formatstr, notalist, n); + save = args; args = first(args); bra = n; tilde = false; + if (args == NULL) mute = true; + } + else if (ch2 == 'A' || ch2 == 'S' || ch2 == 'D' || ch2 == 'G' || ch2 == 'X' || ch2 == 'B') { + if (args == NULL) formaterr(formatstr, noargument, n); + object *arg = first(args); args = cdr(args); + uint8_t aw = atomwidth(arg); + if (width < aw) w = 0; else w = width-aw; + tilde = false; + if (ch2 == 'A') { prin1object(arg, pfun); indent(w, pad, pfun); } + else if (ch2 == 'S') { printobject(arg, pfun); indent(w, pad, pfun); } + else if (ch2 == 'D' || ch2 == 'G') { indent(w, pad, pfun); prin1object(arg, pfun); } + else if (ch2 == 'X' || ch2 == 'B') { + if (integerp(arg)) { + uint8_t base = (ch2 == 'B') ? 2 : 16; + uint8_t hw = basewidth(arg, base); if (width < hw) w = 0; else w = width-hw; + indent(w, pad, pfun); pintbase(arg->integer, base, pfun); + } else { + indent(w, pad, pfun); prin1object(arg, pfun); + } + } + tilde = false; + } else formaterr(formatstr, PSTR("invalid directive"), n); + } + } else { + if (ch == '~') { tilde = true; pad = ' '; width = 0; comma = false; quote = false; } + else if (!mute) pfun(ch); + } + n++; + } + if (output == nil) return obj; + else return nil; +} + +// LispLibrary + +/* + (require 'symbol) + Loads the definition of a function defined with defun, or a variable defined with defvar, from the Lisp Library. + It returns t if it was loaded, or nil if the symbol is already defined or isn't defined in the Lisp Library. +*/ +object *fn_require (object *args, object *env) { + object *arg = first(args); + object *globals = GlobalEnv; + if (!symbolp(arg)) error(notasymbol, arg); + while (globals != NULL) { + object *pair = first(globals); + object *var = car(pair); + if (symbolp(var) && var == arg) return nil; + globals = cdr(globals); + } + GlobalStringIndex = 0; + object *line = read(glibrary); + while (line != NULL) { + // Is this the definition we want + symbol_t fname = first(line)->name; + if ((fname == sym(DEFUN) || fname == sym(DEFVAR)) && symbolp(second(line)) && second(line)->name == arg->name) { + eval(line, env); + return tee; + } + line = read(glibrary); + } + return nil; +} + +/* + (list-library) + Prints a list of the functions defined in the List Library. +*/ +object *fn_listlibrary (object *args, object *env) { + (void) args, (void) env; + GlobalStringIndex = 0; + object *line = read(glibrary); + while (line != NULL) { + builtin_t bname = builtin(first(line)->name); + if (bname == DEFUN || bname == DEFVAR) { + printsymbol(second(line), pserial); pserial(' '); + } + line = read(glibrary); + } + return bsymbol(NOTHING); +} + +// Documentation + +/* + (? item) + Prints the documentation string of a built-in or user-defined function. +*/ +object *sp_help (object *args, object *env) { + if (args == NULL) error2(noargument); + object *docstring = documentation(first(args), env); + if (docstring) { + char temp = Flags; + clrflag(PRINTREADABLY); + printstring(docstring, pserial); + Flags = temp; + } + return bsymbol(NOTHING); +} + +/* + (documentation 'symbol [type]) + Returns the documentation string of a built-in or user-defined function. The type argument is ignored. +*/ +object *fn_documentation (object *args, object *env) { + return documentation(first(args), env); +} + +/* + (apropos item) + Prints the user-defined and built-in functions whose names contain the specified string or symbol. +*/ +object *fn_apropos (object *args, object *env) { + (void) env; + apropos(first(args), true); + return bsymbol(NOTHING); +} + +/* + (apropos-list item) + Returns a list of user-defined and built-in functions whose names contain the specified string or symbol. +*/ +object *fn_aproposlist (object *args, object *env) { + (void) env; + return apropos(first(args), false); +} + +// Error handling + +/* + (unwind-protect form1 [forms]*) + Evaluates form1 and forms in order and returns the value of form1, + but guarantees to evaluate forms even if an error occurs in form1. +*/ +object *sp_unwindprotect (object *args, object *env) { + if (args == NULL) error2(toofewargs); + object *current_GCStack = GCStack; + jmp_buf dynamic_handler; + jmp_buf *previous_handler = handler; + handler = &dynamic_handler; + object *protected_form = first(args); + object *result; + + bool signaled = false; + if (!setjmp(dynamic_handler)) { + result = eval(protected_form, env); + } else { + GCStack = current_GCStack; + signaled = true; + } + handler = previous_handler; + + object *protective_forms = cdr(args); + while (protective_forms != NULL) { + eval(car(protective_forms), env); + if (tstflag(RETURNFLAG)) break; + protective_forms = cdr(protective_forms); + } + + if (!signaled) return result; + GCStack = NULL; + longjmp(*handler, 1); +} + +/* + (ignore-errors [forms]*) + Evaluates forms ignoring errors. +*/ +object *sp_ignoreerrors (object *args, object *env) { + object *current_GCStack = GCStack; + jmp_buf dynamic_handler; + jmp_buf *previous_handler = handler; + handler = &dynamic_handler; + object *result = nil; + + bool muffled = tstflag(MUFFLEERRORS); + setflag(MUFFLEERRORS); + bool signaled = false; + if (!setjmp(dynamic_handler)) { + while (args != NULL) { + result = eval(car(args), env); + if (tstflag(RETURNFLAG)) break; + args = cdr(args); + } + } else { + GCStack = current_GCStack; + signaled = true; + } + handler = previous_handler; + if (!muffled) clrflag(MUFFLEERRORS); + + if (signaled) return bsymbol(NOTHING); + else return result; +} + +/* + (error controlstring [arguments]*) + Signals an error. The message is printed by format using the controlstring and arguments. +*/ +object *sp_error (object *args, object *env) { + object *message = eval(cons(bsymbol(FORMAT), cons(nil, args)), env); + if (!tstflag(MUFFLEERRORS)) { + char temp = Flags; + clrflag(PRINTREADABLY); + pfstring(PSTR("Error: "), pserial); printstring(message, pserial); + Flags = temp; + pln(pserial); + } + GCStack = NULL; + longjmp(*handler, 1); +} + +// Wi-Fi + +/* + (with-client (str [address port]) form*) + Evaluates the forms with str bound to a wifi-stream. +*/ +object *sp_withclient (object *args, object *env) { + object *params = first(args); + object *var = first(params); + char buffer[BUFFERSIZE]; + params = cdr(params); + int n; + if (params == NULL) { + client = server.available(); + if (!client) return nil; + n = 2; + } else { + object *address = eval(first(params), env); + object *port = eval(second(params), env); + int success; + if (stringp(address)) success = client.connect(cstring(address, buffer, BUFFERSIZE), checkinteger(port)); + else if (integerp(address)) success = client.connect(address->integer, checkinteger(port)); + else error2(PSTR("invalid address")); + if (!success) return nil; + n = 1; + } + object *pair = cons(var, stream(WIFISTREAM, n)); + push(pair,env); + object *forms = cdr(args); + object *result = eval(tf_progn(forms,env), env); + client.stop(); + return result; +} + +/* + (available stream) + Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available. +*/ +object *fn_available (object *args, object *env) { + (void) env; + if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); + return number(client.available()); +} + +/* + (wifi-server) + Starts a Wi-Fi server running. It returns nil. +*/ +object *fn_wifiserver (object *args, object *env) { + (void) args, (void) env; + server.begin(); + return nil; +} + +/* + (wifi-softap ssid [password channel hidden]) + Set up a soft access point to establish a Wi-Fi network. + Returns the IP address as a string or nil if unsuccessful. +*/ +object *fn_wifisoftap (object *args, object *env) { + (void) env; + char ssid[33], pass[65]; + if (args == NULL) return WiFi.softAPdisconnect(true) ? tee : nil; + object *first = first(args); args = cdr(args); + if (args == NULL) WiFi.softAP(cstring(first, ssid, 33)); + else { + object *second = first(args); + args = cdr(args); + int channel = 1; + bool hidden = false; + if (args != NULL) { + channel = checkinteger(first(args)); + args = cdr(args); + if (args != NULL) hidden = (first(args) != nil); + } + WiFi.softAP(cstring(first, ssid, 33), cstring(second, pass, 65), channel, hidden); + } + return lispstring((char*)WiFi.softAPIP().toString().c_str()); +} + +/* + (connected stream) + Returns t or nil to indicate if the client on stream is connected. +*/ +object *fn_connected (object *args, object *env) { + (void) env; + if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); + return client.connected() ? tee : nil; +} + +/* + (wifi-localip) + Returns the IP address of the local network as a string. +*/ +object *fn_wifilocalip (object *args, object *env) { + (void) args, (void) env; + return lispstring((char*)WiFi.localIP().toString().c_str()); +} + +/* + (wifi-connect [ssid pass]) + Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string. +*/ +object *fn_wificonnect (object *args, object *env) { + (void) env; + char ssid[33], pass[65]; + if (args == NULL) { WiFi.disconnect(true); return nil; } + if (cdr(args) == NULL) WiFi.begin(cstring(first(args), ssid, 33)); + else WiFi.begin(cstring(first(args), ssid, 33), cstring(second(args), pass, 65)); + int result = WiFi.waitForConnectResult(); + if (result == WL_CONNECTED) return lispstring((char*)WiFi.localIP().toString().c_str()); + else if (result == WL_NO_SSID_AVAIL) error2(PSTR("network not found")); + else if (result == WL_CONNECT_FAILED) error2(PSTR("connection failed")); + else error2(PSTR("unable to connect")); + return nil; +} + +// Graphics functions + +/* + (with-gfx (str) form*) + Evaluates the forms with str bound to an gfx-stream so you can print text + to the graphics display using the standard uLisp print commands. +*/ +object *sp_withgfx (object *args, object *env) { +#if defined(gfxsupport) + object *params = first(args); + object *var = first(params); + object *pair = cons(var, stream(GFXSTREAM, 1)); + push(pair,env); + object *forms = cdr(args); + object *result = eval(tf_progn(forms,env), env); + return result; +#else + (void) args, (void) env; + error2(PSTR("not supported")); + return nil; +#endif +} + +/* + (draw-pixel x y [colour]) + Draws a pixel at coordinates (x,y) in colour, or white if omitted. +*/ +object *fn_drawpixel (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + uint16_t colour = COLOR_WHITE; + if (cddr(args) != NULL) colour = checkinteger(third(args)); + tft.drawPixel(checkinteger(first(args)), checkinteger(second(args)), colour); + #else + (void) args; + #endif + return nil; +} + +/* + (draw-line x0 y0 x1 y1 [colour]) + Draws a line from (x0,y0) to (x1,y1) in colour, or white if omitted. +*/ +object *fn_drawline (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + uint16_t params[4], colour = COLOR_WHITE; + for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.drawLine(params[0], params[1], params[2], params[3], colour); + #else + (void) args; + #endif + return nil; +} + +/* + (draw-rect x y w h [colour]) + Draws an outline rectangle with its top left corner at (x,y), with width w, + and with height h. The outline is drawn in colour, or white if omitted. +*/ +object *fn_drawrect (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + uint16_t params[4], colour = COLOR_WHITE; + for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.drawRect(params[0], params[1], params[2], params[3], colour); + #else + (void) args; + #endif + return nil; +} + +/* + (fill-rect x y w h [colour]) + Draws a filled rectangle with its top left corner at (x,y), with width w, + and with height h. The outline is drawn in colour, or white if omitted. +*/ +object *fn_fillrect (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + uint16_t params[4], colour = COLOR_WHITE; + for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.fillRect(params[0], params[1], params[2], params[3], colour); + #else + (void) args; + #endif + return nil; +} + +/* + (draw-circle x y r [colour]) + Draws an outline circle with its centre at (x, y) and with radius r. + The circle is drawn in colour, or white if omitted. +*/ +object *fn_drawcircle (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + uint16_t params[3], colour = COLOR_WHITE; + for (int i=0; i<3; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.drawCircle(params[0], params[1], params[2], colour); + #else + (void) args; + #endif + return nil; +} + +/* + (fill-circle x y r [colour]) + Draws a filled circle with its centre at (x, y) and with radius r. + The circle is drawn in colour, or white if omitted. +*/ +object *fn_fillcircle (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + uint16_t params[3], colour = COLOR_WHITE; + for (int i=0; i<3; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.fillCircle(params[0], params[1], params[2], colour); + #else + (void) args; + #endif + return nil; +} + +/* + (draw-round-rect x y w h radius [colour]) + Draws an outline rounded rectangle with its top left corner at (x,y), with width w, + height h, and corner radius radius. The outline is drawn in colour, or white if omitted. +*/ +object *fn_drawroundrect (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + uint16_t params[5], colour = COLOR_WHITE; + for (int i=0; i<5; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.drawRoundRect(params[0], params[1], params[2], params[3], params[4], colour); + #else + (void) args; + #endif + return nil; +} + +/* + (fill-round-rect x y w h radius [colour]) + Draws a filled rounded rectangle with its top left corner at (x,y), with width w, + height h, and corner radius radius. The outline is drawn in colour, or white if omitted. +*/ +object *fn_fillroundrect (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + uint16_t params[5], colour = COLOR_WHITE; + for (int i=0; i<5; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.fillRoundRect(params[0], params[1], params[2], params[3], params[4], colour); + #else + (void) args; + #endif + return nil; +} + +/* + (draw-triangle x0 y0 x1 y1 x2 y2 [colour]) + Draws an outline triangle between (x1,y1), (x2,y2), and (x3,y3). + The outline is drawn in colour, or white if omitted. +*/ +object *fn_drawtriangle (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + uint16_t params[6], colour = COLOR_WHITE; + for (int i=0; i<6; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.drawTriangle(params[0], params[1], params[2], params[3], params[4], params[5], colour); + #else + (void) args; + #endif + return nil; +} + +/* + (fill-triangle x0 y0 x1 y1 x2 y2 [colour]) + Draws a filled triangle between (x1,y1), (x2,y2), and (x3,y3). + The outline is drawn in colour, or white if omitted. +*/ +object *fn_filltriangle (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + uint16_t params[6], colour = COLOR_WHITE; + for (int i=0; i<6; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.fillTriangle(params[0], params[1], params[2], params[3], params[4], params[5], colour); + #else + (void) args; + #endif + return nil; +} + +/* + (draw-char x y char [colour background size]) + Draws the character char with its top left corner at (x,y). + The character is drawn in a 5 x 7 pixel font in colour against background, + which default to white and black respectively. + The character can optionally be scaled by size. +*/ +object *fn_drawchar (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + uint16_t colour = COLOR_WHITE, bg = COLOR_BLACK, size = 1; + object *more = cdr(cddr(args)); + if (more != NULL) { + colour = checkinteger(car(more)); + more = cdr(more); + if (more != NULL) { + bg = checkinteger(car(more)); + more = cdr(more); + if (more != NULL) size = checkinteger(car(more)); + } + } + tft.drawChar(checkinteger(first(args)), checkinteger(second(args)), checkchar(third(args)), + colour, bg, size); + #else + (void) args; + #endif + return nil; +} + +/* + (set-cursor x y) + Sets the start point for text plotting to (x, y). +*/ +object *fn_setcursor (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + tft.setCursor(checkinteger(first(args)), checkinteger(second(args))); + #else + (void) args; + #endif + return nil; +} + +/* + (set-text-color colour [background]) + Sets the text colour for text plotted using (with-gfx ...). +*/ +object *fn_settextcolor (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + if (cdr(args) != NULL) tft.setTextColor(checkinteger(first(args)), checkinteger(second(args))); + else tft.setTextColor(checkinteger(first(args))); + #else + (void) args; + #endif + return nil; +} + +/* + (set-text-size scale) + Scales text by the specified size, default 1. +*/ +object *fn_settextsize (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + tft.setTextSize(checkinteger(first(args))); + #else + (void) args; + #endif + return nil; +} + +/* + (set-text-wrap boolean) + Specified whether text wraps at the right-hand edge of the display; the default is t. +*/ +object *fn_settextwrap (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + tft.setTextWrap(first(args) != NULL); + #else + (void) args; + #endif + return nil; +} + +/* + (fill-screen [colour]) + Fills or clears the screen with colour, default black. +*/ +object *fn_fillscreen (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + uint16_t colour = COLOR_BLACK; + if (args != NULL) colour = checkinteger(first(args)); + tft.fillScreen(colour); + #else + (void) args; + #endif + return nil; +} + +/* + (set-rotation option) + Sets the display orientation for subsequent graphics commands; values are 0, 1, 2, or 3. +*/ +object *fn_setrotation (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + tft.setRotation(checkinteger(first(args))); + #else + (void) args; + #endif + return nil; +} + +/* + (invert-display boolean) + Mirror-images the display. +*/ +object *fn_invertdisplay (object *args, object *env) { + (void) env; + #if defined(gfxsupport) + tft.invertDisplay(first(args) != NULL); + #else + (void) args; + #endif + return nil; +} + +// Built-in symbol names +const char string0[] PROGMEM = "nil"; +const char string1[] PROGMEM = "t"; +const char string2[] PROGMEM = "nothing"; +const char string3[] PROGMEM = "&optional"; +const char string4[] PROGMEM = ":initial-element"; +const char string5[] PROGMEM = ":element-type"; +const char string6[] PROGMEM = "bit"; +const char string7[] PROGMEM = "&rest"; +const char string8[] PROGMEM = "lambda"; +const char string9[] PROGMEM = "let"; +const char string10[] PROGMEM = "let*"; +const char string11[] PROGMEM = "closure"; +const char string12[] PROGMEM = "*pc*"; +const char string13[] PROGMEM = "quote"; +const char string14[] PROGMEM = "defun"; +const char string15[] PROGMEM = "defvar"; +const char string16[] PROGMEM = "car"; +const char string17[] PROGMEM = "first"; +const char string18[] PROGMEM = "cdr"; +const char string19[] PROGMEM = "rest"; +const char string20[] PROGMEM = "nth"; +const char string21[] PROGMEM = "aref"; +const char string22[] PROGMEM = "string"; +const char string23[] PROGMEM = "pinmode"; +const char string24[] PROGMEM = "digitalwrite"; +const char string25[] PROGMEM = "analogread"; +const char string26[] PROGMEM = "register"; +const char string27[] PROGMEM = "format"; +const char string28[] PROGMEM = "or"; +const char string29[] PROGMEM = "setq"; +const char string30[] PROGMEM = "loop"; +const char string31[] PROGMEM = "return"; +const char string32[] PROGMEM = "push"; +const char string33[] PROGMEM = "pop"; +const char string34[] PROGMEM = "incf"; +const char string35[] PROGMEM = "decf"; +const char string36[] PROGMEM = "setf"; +const char string37[] PROGMEM = "dolist"; +const char string38[] PROGMEM = "dotimes"; +const char string39[] PROGMEM = "trace"; +const char string40[] PROGMEM = "untrace"; +const char string41[] PROGMEM = "for-millis"; +const char string42[] PROGMEM = "time"; +const char string43[] PROGMEM = "with-output-to-string"; +const char string44[] PROGMEM = "with-serial"; +const char string45[] PROGMEM = "with-i2c"; +const char string46[] PROGMEM = "with-spi"; +const char string47[] PROGMEM = "with-sd-card"; +const char string48[] PROGMEM = "progn"; +const char string49[] PROGMEM = "if"; +const char string50[] PROGMEM = "cond"; +const char string51[] PROGMEM = "when"; +const char string52[] PROGMEM = "unless"; +const char string53[] PROGMEM = "case"; +const char string54[] PROGMEM = "and"; +const char string55[] PROGMEM = "not"; +const char string56[] PROGMEM = "null"; +const char string57[] PROGMEM = "cons"; +const char string58[] PROGMEM = "atom"; +const char string59[] PROGMEM = "listp"; +const char string60[] PROGMEM = "consp"; +const char string61[] PROGMEM = "symbolp"; +const char string62[] PROGMEM = "arrayp"; +const char string63[] PROGMEM = "boundp"; +const char string64[] PROGMEM = "keywordp"; +const char string65[] PROGMEM = "set"; +const char string66[] PROGMEM = "streamp"; +const char string67[] PROGMEM = "eq"; +const char string68[] PROGMEM = "equal"; +const char string69[] PROGMEM = "caar"; +const char string70[] PROGMEM = "cadr"; +const char string71[] PROGMEM = "second"; +const char string72[] PROGMEM = "cdar"; +const char string73[] PROGMEM = "cddr"; +const char string74[] PROGMEM = "caaar"; +const char string75[] PROGMEM = "caadr"; +const char string76[] PROGMEM = "cadar"; +const char string77[] PROGMEM = "caddr"; +const char string78[] PROGMEM = "third"; +const char string79[] PROGMEM = "cdaar"; +const char string80[] PROGMEM = "cdadr"; +const char string81[] PROGMEM = "cddar"; +const char string82[] PROGMEM = "cdddr"; +const char string83[] PROGMEM = "length"; +const char string84[] PROGMEM = "array-dimensions"; +const char string85[] PROGMEM = "list"; +const char string86[] PROGMEM = "make-array"; +const char string87[] PROGMEM = "reverse"; +const char string88[] PROGMEM = "assoc"; +const char string89[] PROGMEM = "member"; +const char string90[] PROGMEM = "apply"; +const char string91[] PROGMEM = "funcall"; +const char string92[] PROGMEM = "append"; +const char string93[] PROGMEM = "mapc"; +const char string94[] PROGMEM = "mapcar"; +const char string95[] PROGMEM = "mapcan"; +const char string96[] PROGMEM = "+"; +const char string97[] PROGMEM = "-"; +const char string98[] PROGMEM = "*"; +const char string99[] PROGMEM = "/"; +const char string100[] PROGMEM = "mod"; +const char string101[] PROGMEM = "1+"; +const char string102[] PROGMEM = "1-"; +const char string103[] PROGMEM = "abs"; +const char string104[] PROGMEM = "random"; +const char string105[] PROGMEM = "max"; +const char string106[] PROGMEM = "min"; +const char string107[] PROGMEM = "/="; +const char string108[] PROGMEM = "="; +const char string109[] PROGMEM = "<"; +const char string110[] PROGMEM = "<="; +const char string111[] PROGMEM = ">"; +const char string112[] PROGMEM = ">="; +const char string113[] PROGMEM = "plusp"; +const char string114[] PROGMEM = "minusp"; +const char string115[] PROGMEM = "zerop"; +const char string116[] PROGMEM = "oddp"; +const char string117[] PROGMEM = "evenp"; +const char string118[] PROGMEM = "integerp"; +const char string119[] PROGMEM = "numberp"; +const char string120[] PROGMEM = "float"; +const char string121[] PROGMEM = "floatp"; +const char string122[] PROGMEM = "sin"; +const char string123[] PROGMEM = "cos"; +const char string124[] PROGMEM = "tan"; +const char string125[] PROGMEM = "asin"; +const char string126[] PROGMEM = "acos"; +const char string127[] PROGMEM = "atan"; +const char string128[] PROGMEM = "sinh"; +const char string129[] PROGMEM = "cosh"; +const char string130[] PROGMEM = "tanh"; +const char string131[] PROGMEM = "exp"; +const char string132[] PROGMEM = "sqrt"; +const char string133[] PROGMEM = "log"; +const char string134[] PROGMEM = "expt"; +const char string135[] PROGMEM = "ceiling"; +const char string136[] PROGMEM = "floor"; +const char string137[] PROGMEM = "truncate"; +const char string138[] PROGMEM = "round"; +const char string139[] PROGMEM = "char"; +const char string140[] PROGMEM = "char-code"; +const char string141[] PROGMEM = "code-char"; +const char string142[] PROGMEM = "characterp"; +const char string143[] PROGMEM = "stringp"; +const char string144[] PROGMEM = "string="; +const char string145[] PROGMEM = "string<"; +const char string146[] PROGMEM = "string>"; +const char string147[] PROGMEM = "sort"; +const char string148[] PROGMEM = "concatenate"; +const char string149[] PROGMEM = "subseq"; +const char string150[] PROGMEM = "search"; +const char string151[] PROGMEM = "read-from-string"; +const char string152[] PROGMEM = "princ-to-string"; +const char string153[] PROGMEM = "prin1-to-string"; +const char string154[] PROGMEM = "logand"; +const char string155[] PROGMEM = "logior"; +const char string156[] PROGMEM = "logxor"; +const char string157[] PROGMEM = "lognot"; +const char string158[] PROGMEM = "ash"; +const char string159[] PROGMEM = "logbitp"; +const char string160[] PROGMEM = "eval"; +const char string161[] PROGMEM = "globals"; +const char string162[] PROGMEM = "locals"; +const char string163[] PROGMEM = "makunbound"; +const char string164[] PROGMEM = "break"; +const char string165[] PROGMEM = "read"; +const char string166[] PROGMEM = "prin1"; +const char string167[] PROGMEM = "print"; +const char string168[] PROGMEM = "princ"; +const char string169[] PROGMEM = "terpri"; +const char string170[] PROGMEM = "read-byte"; +const char string171[] PROGMEM = "read-line"; +const char string172[] PROGMEM = "write-byte"; +const char string173[] PROGMEM = "write-string"; +const char string174[] PROGMEM = "write-line"; +const char string175[] PROGMEM = "restart-i2c"; +const char string176[] PROGMEM = "gc"; +const char string177[] PROGMEM = "room"; +const char string180[] PROGMEM = "cls"; +const char string181[] PROGMEM = "digitalread"; +const char string182[] PROGMEM = "analogreadresolution"; +const char string183[] PROGMEM = "analogwrite"; +const char string184[] PROGMEM = "delay"; +const char string185[] PROGMEM = "millis"; +const char string186[] PROGMEM = "sleep"; +const char string187[] PROGMEM = "note"; +const char string188[] PROGMEM = "edit"; +const char string189[] PROGMEM = "pprint"; +const char string190[] PROGMEM = "pprintall"; +const char string191[] PROGMEM = "require"; +const char string192[] PROGMEM = "list-library"; +const char string193[] PROGMEM = "?"; +const char string194[] PROGMEM = "documentation"; +const char string195[] PROGMEM = "apropos"; +const char string196[] PROGMEM = "apropos-list"; +const char string197[] PROGMEM = "unwind-protect"; +const char string198[] PROGMEM = "ignore-errors"; +const char string199[] PROGMEM = "error"; +const char string200[] PROGMEM = "with-client"; +const char string201[] PROGMEM = "available"; +const char string202[] PROGMEM = "wifi-server"; +const char string203[] PROGMEM = "wifi-softap"; +const char string204[] PROGMEM = "connected"; +const char string205[] PROGMEM = "wifi-localip"; +const char string206[] PROGMEM = "wifi-connect"; +const char string207[] PROGMEM = "with-gfx"; +const char string208[] PROGMEM = "draw-pixel"; +const char string209[] PROGMEM = "draw-line"; +const char string210[] PROGMEM = "draw-rect"; +const char string211[] PROGMEM = "fill-rect"; +const char string212[] PROGMEM = "draw-circle"; +const char string213[] PROGMEM = "fill-circle"; +const char string214[] PROGMEM = "draw-round-rect"; +const char string215[] PROGMEM = "fill-round-rect"; +const char string216[] PROGMEM = "draw-triangle"; +const char string217[] PROGMEM = "fill-triangle"; +const char string218[] PROGMEM = "draw-char"; +const char string219[] PROGMEM = "set-cursor"; +const char string220[] PROGMEM = "set-text-color"; +const char string221[] PROGMEM = "set-text-size"; +const char string222[] PROGMEM = "set-text-wrap"; +const char string223[] PROGMEM = "fill-screen"; +const char string224[] PROGMEM = "set-rotation"; +const char string225[] PROGMEM = "invert-display"; +const char string226[] PROGMEM = ":led-builtin"; +const char string227[] PROGMEM = ":high"; +const char string228[] PROGMEM = ":low"; +const char string229[] PROGMEM = ":input"; +const char string230[] PROGMEM = ":input-pullup"; +const char string231[] PROGMEM = ":input-pulldown"; +const char string232[] PROGMEM = ":output"; + +// Documentation strings +const char doc0[] PROGMEM = "nil\n" +"A symbol equivalent to the empty list (). Also represents false."; +const char doc1[] PROGMEM = "t\n" +"A symbol representing true."; +const char doc2[] PROGMEM = "nothing\n" +"A symbol with no value.\n" +"It is useful if you want to suppress printing the result of evaluating a function."; +const char doc3[] PROGMEM = "&optional\n" +"Can be followed by one or more optional parameters in a lambda or defun parameter list."; +const char doc7[] PROGMEM = "&rest\n" +"Can be followed by a parameter in a lambda or defun parameter list,\n" +"and is assigned a list of the corresponding arguments."; +const char doc8[] PROGMEM = "(lambda (parameter*) form*)\n" +"Creates an unnamed function with parameters. The body is evaluated with the parameters as local variables\n" +"whose initial values are defined by the values of the forms after the lambda form."; +const char doc9[] PROGMEM = "(let ((var value) ... ) forms*)\n" +"Declares local variables with values, and evaluates the forms with those local variables."; +const char doc10[] PROGMEM = "(let* ((var value) ... ) forms*)\n" +"Declares local variables with values, and evaluates the forms with those local variables.\n" +"Each declaration can refer to local variables that have been defined earlier in the let*."; +const char doc14[] PROGMEM = "(defun name (parameters) form*)\n" +"Defines a function."; +const char doc15[] PROGMEM = "(defvar variable form)\n" +"Defines a global variable."; +const char doc16[] PROGMEM = "(car list)\n" +"Returns the first item in a list."; +const char doc18[] PROGMEM = "(cdr list)\n" +"Returns a list with the first item removed."; +const char doc20[] PROGMEM = "(nth number list)\n" +"Returns the nth item in list, counting from zero."; +const char doc21[] PROGMEM = "(aref array index [index*])\n" +"Returns an element from the specified array."; +const char doc22[] PROGMEM = "(string item)\n" +"Converts its argument to a string."; +const char doc23[] PROGMEM = "(pinmode pin mode)\n" +"Sets the input/output mode of an Arduino pin number, and returns nil.\n" +"The mode parameter can be an integer, a keyword, or t or nil."; +const char doc24[] PROGMEM = "(digitalwrite pin state)\n" +"Sets the state of the specified Arduino pin number."; +const char doc25[] PROGMEM = "(analogread pin)\n" +"Reads the specified Arduino analogue pin number and returns the value."; +const char doc26[] PROGMEM = "(register address [value])\n" +"Reads or writes the value of a peripheral register.\n" +"If value is not specified the function returns the value of the register at address.\n" +"If value is specified the value is written to the register at address and the function returns value."; +const char doc27[] PROGMEM = "(format output controlstring [arguments]*)\n" +"Outputs its arguments formatted according to the format directives in controlstring."; +const char doc28[] PROGMEM = "(or item*)\n" +"Evaluates its arguments until one returns non-nil, and returns its value."; +const char doc29[] PROGMEM = "(setq symbol value [symbol value]*)\n" +"For each pair of arguments assigns the value of the second argument\n" +"to the variable specified in the first argument."; +const char doc30[] PROGMEM = "(loop forms*)\n" +"Executes its arguments repeatedly until one of the arguments calls (return),\n" +"which then causes an exit from the loop."; +const char doc31[] PROGMEM = "(return [value])\n" +"Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value."; +const char doc32[] PROGMEM = "(push item place)\n" +"Modifies the value of place, which should be a list, to add item onto the front of the list,\n" +"and returns the new list."; +const char doc33[] PROGMEM = "(pop place)\n" +"Modifies the value of place, which should be a list, to remove its first item, and returns that item."; +const char doc34[] PROGMEM = "(incf place [number])\n" +"Increments a place, which should have an numeric value, and returns the result.\n" +"The third argument is an optional increment which defaults to 1."; +const char doc35[] PROGMEM = "(decf place [number])\n" +"Decrements a place, which should have an numeric value, and returns the result.\n" +"The third argument is an optional decrement which defaults to 1."; +const char doc36[] PROGMEM = "(setf place value [place value]*)\n" +"For each pair of arguments modifies a place to the result of evaluating value."; +const char doc37[] PROGMEM = "(dolist (var list [result]) form*)\n" +"Sets the local variable var to each element of list in turn, and executes the forms.\n" +"It then returns result, or nil if result is omitted."; +const char doc38[] PROGMEM = "(dotimes (var number [result]) form*)\n" +"Executes the forms number times, with the local variable var set to each integer from 0 to number-1 in turn.\n" +"It then returns result, or nil if result is omitted."; +const char doc39[] PROGMEM = "(trace [function]*)\n" +"Turns on tracing of up to TRACEMAX user-defined functions,\n" +"and returns a list of the functions currently being traced."; +const char doc40[] PROGMEM = "(untrace [function]*)\n" +"Turns off tracing of up to TRACEMAX user-defined functions, and returns a list of the functions untraced.\n" +"If no functions are specified it untraces all functions."; +const char doc41[] PROGMEM = "(for-millis ([number]) form*)\n" +"Executes the forms and then waits until a total of number milliseconds have elapsed.\n" +"Returns the total number of milliseconds taken."; +const char doc42[] PROGMEM = "(time form)\n" +"Prints the value returned by the form, and the time taken to evaluate the form\n" +"in milliseconds or seconds."; +const char doc43[] PROGMEM = "(with-output-to-string (str) form*)\n" +"Returns a string containing the output to the stream variable str."; +const char doc44[] PROGMEM = "(with-serial (str port [baud]) form*)\n" +"Evaluates the forms with str bound to a serial-stream using port.\n" +"The optional baud gives the baud rate divided by 100, default 96."; +const char doc45[] PROGMEM = "(with-i2c (str [port] address [read-p]) form*)\n" +"Evaluates the forms with str bound to an i2c-stream defined by address.\n" +"If read-p is nil or omitted the stream is written to, otherwise it specifies the number of bytes\n" +"to be read from the stream. The port if specified is ignored."; +const char doc46[] PROGMEM = "(with-spi (str pin [clock] [bitorder] [mode]) form*)\n" +"Evaluates the forms with str bound to an spi-stream.\n" +"The parameters specify the enable pin, clock in kHz (default 4000),\n" +"bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0)."; +const char doc47[] PROGMEM = "(with-sd-card (str filename [mode]) form*)\n" +"Evaluates the forms with str bound to an sd-stream reading from or writing to the file filename.\n" +"If mode is omitted the file is read, otherwise 0 means read, 1 write-append, or 2 write-overwrite."; +const char doc48[] PROGMEM = "(progn form*)\n" +"Evaluates several forms grouped together into a block, and returns the result of evaluating the last form."; +const char doc49[] PROGMEM = "(if test then [else])\n" +"Evaluates test. If it's non-nil the form then is evaluated and returned;\n" +"otherwise the form else is evaluated and returned."; +const char doc50[] PROGMEM = "(cond ((test form*) (test form*) ... ))\n" +"Each argument is a list consisting of a test optionally followed by one or more forms.\n" +"If the test evaluates to non-nil the forms are evaluated, and the last value is returned as the result of the cond.\n" +"If the test evaluates to nil, none of the forms are evaluated, and the next argument is processed in the same way."; +const char doc51[] PROGMEM = "(when test form*)\n" +"Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned."; +const char doc52[] PROGMEM = "(unless test form*)\n" +"Evaluates the test. If it's nil the forms are evaluated and the last value is returned."; +const char doc53[] PROGMEM = "(case keyform ((key form*) (key form*) ... ))\n" +"Evaluates a keyform to produce a test key, and then tests this against a series of arguments,\n" +"each of which is a list containing a key optionally followed by one or more forms."; +const char doc54[] PROGMEM = "(and item*)\n" +"Evaluates its arguments until one returns nil, and returns the last value."; +const char doc55[] PROGMEM = "(not item)\n" +"Returns t if its argument is nil, or nil otherwise. Equivalent to null."; +const char doc57[] PROGMEM = "(cons item item)\n" +"If the second argument is a list, cons returns a new list with item added to the front of the list.\n" +"If the second argument isn't a list cons returns a dotted pair."; +const char doc58[] PROGMEM = "(atom item)\n" +"Returns t if its argument is a single number, symbol, or nil."; +const char doc59[] PROGMEM = "(listp item)\n" +"Returns t if its argument is a list."; +const char doc60[] PROGMEM = "(consp item)\n" +"Returns t if its argument is a non-null list."; +const char doc61[] PROGMEM = "(symbolp item)\n" +"Returns t if its argument is a symbol."; +const char doc62[] PROGMEM = "(arrayp item)\n" +"Returns t if its argument is an array."; +const char doc63[] PROGMEM = "(boundp item)\n" +"Returns t if its argument is a symbol with a value."; +const char doc64[] PROGMEM = "(keywordp item)\n" +"Returns t if its argument is a keyword."; +const char doc65[] PROGMEM = "(set symbol value [symbol value]*)\n" +"For each pair of arguments, assigns the value of the second argument to the value of the first argument."; +const char doc66[] PROGMEM = "(streamp item)\n" +"Returns t if its argument is a stream."; +const char doc67[] PROGMEM = "(eq item item)\n" +"Tests whether the two arguments are the same symbol, same character, equal numbers,\n" +"or point to the same cons, and returns t or nil as appropriate."; +const char doc68[] PROGMEM = "(equal item item)\n" +"Tests whether the two arguments are the same symbol, same character, equal numbers,\n" +"or point to the same cons, and returns t or nil as appropriate."; +const char doc69[] PROGMEM = "(caar list)"; +const char doc70[] PROGMEM = "(cadr list)"; +const char doc72[] PROGMEM = "(cdar list)\n" +"Equivalent to (cdr (car list))."; +const char doc73[] PROGMEM = "(cddr list)\n" +"Equivalent to (cdr (cdr list))."; +const char doc74[] PROGMEM = "(caaar list)\n" +"Equivalent to (car (car (car list)))."; +const char doc75[] PROGMEM = "(caadr list)\n" +"Equivalent to (car (car (cdar list)))."; +const char doc76[] PROGMEM = "(cadar list)\n" +"Equivalent to (car (cdr (car list)))."; +const char doc77[] PROGMEM = "(caddr list)\n" +"Equivalent to (car (cdr (cdr list)))."; +const char doc79[] PROGMEM = "(cdaar list)\n" +"Equivalent to (cdar (car (car list)))."; +const char doc80[] PROGMEM = "(cdadr list)\n" +"Equivalent to (cdr (car (cdr list)))."; +const char doc81[] PROGMEM = "(cddar list)\n" +"Equivalent to (cdr (cdr (car list)))."; +const char doc82[] PROGMEM = "(cdddr list)\n" +"Equivalent to (cdr (cdr (cdr list)))."; +const char doc83[] PROGMEM = "(length item)\n" +"Returns the number of items in a list, the length of a string, or the length of a one-dimensional array."; +const char doc84[] PROGMEM = "(array-dimensions item)\n" +"Returns a list of the dimensions of an array."; +const char doc85[] PROGMEM = "(list item*)\n" +"Returns a list of the values of its arguments."; +const char doc86[] PROGMEM = "(make-array size [:initial-element element] [:element-type 'bit])\n" +"If size is an integer it creates a one-dimensional array with elements from 0 to size-1.\n" +"If size is a list of n integers it creates an n-dimensional array with those dimensions.\n" +"If :element-type 'bit is specified the array is a bit array."; +const char doc87[] PROGMEM = "(reverse list)\n" +"Returns a list with the elements of list in reverse order."; +const char doc88[] PROGMEM = "(assoc key list)\n" +"Looks up a key in an association list of (key . value) pairs,\n" +"and returns the matching pair, or nil if no pair is found."; +const char doc89[] PROGMEM = "(member item list)\n" +"Searches for an item in a list, using eq, and returns the list starting from the first occurrence of the item,\n" +"or nil if it is not found."; +const char doc90[] PROGMEM = "(apply function list)\n" +"Returns the result of evaluating function, with the list of arguments specified by the second parameter."; +const char doc91[] PROGMEM = "(funcall function argument*)\n" +"Evaluates function with the specified arguments."; +const char doc92[] PROGMEM = "(append list*)\n" +"Joins its arguments, which should be lists, into a single list."; +const char doc93[] PROGMEM = "(mapc function list1 [list]*)\n" +"Applies the function to each element in one or more lists, ignoring the results.\n" +"It returns the first list argument."; +const char doc94[] PROGMEM = "(mapcar function list1 [list]*)\n" +"Applies the function to each element in one or more lists, and returns the resulting list."; +const char doc95[] PROGMEM = "(mapcan function list1 [list]*)\n" +"Applies the function to each element in one or more lists. The results should be lists,\n" +"and these are appended together to give the value returned."; +const char doc96[] PROGMEM = "(+ number*)\n" +"Adds its arguments together.\n" +"If each argument is an integer, and the running total doesn't overflow, the result is an integer,\n" +"otherwise a floating-point number."; +const char doc97[] PROGMEM = "(- number*)\n" +"If there is one argument, negates the argument.\n" +"If there are two or more arguments, subtracts the second and subsequent arguments from the first argument.\n" +"If each argument is an integer, and the running total doesn't overflow, returns the result as an integer,\n" +"otherwise a floating-point number."; +const char doc98[] PROGMEM = "(* number*)\n" +"Multiplies its arguments together.\n" +"If each argument is an integer, and the running total doesn't overflow, the result is an integer,\n" +"otherwise it's a floating-point number."; +const char doc99[] PROGMEM = "(/ number*)\n" +"Divides the first argument by the second and subsequent arguments.\n" +"If each argument is an integer, and each division produces an exact result, the result is an integer;\n" +"otherwise it's a floating-point number."; +const char doc100[] PROGMEM = "(mod number number)\n" +"Returns its first argument modulo the second argument.\n" +"If both arguments are integers the result is an integer; otherwise it's a floating-point number."; +const char doc101[] PROGMEM = "(1+ number)\n" +"Adds one to its argument and returns it.\n" +"If the argument is an integer the result is an integer if possible;\n" +"otherwise it's a floating-point number."; +const char doc102[] PROGMEM = "(1- number)\n" +"Subtracts one from its argument and returns it.\n" +"If the argument is an integer the result is an integer if possible;\n" +"otherwise it's a floating-point number."; +const char doc103[] PROGMEM = "(abs number)\n" +"Returns the absolute, positive value of its argument.\n" +"If the argument is an integer the result will be returned as an integer if possible,\n" +"otherwise a floating-point number."; +const char doc104[] PROGMEM = "(random number)\n" +"If number is an integer returns a random number between 0 and one less than its argument.\n" +"Otherwise returns a floating-point number between zero and number."; +const char doc105[] PROGMEM = "(max number*)\n" +"Returns the maximum of one or more arguments."; +const char doc106[] PROGMEM = "(min number*)\n" +"Returns the minimum of one or more arguments."; +const char doc107[] PROGMEM = "(/= number*)\n" +"Returns t if none of the arguments are equal, or nil if two or more arguments are equal."; +const char doc108[] PROGMEM = "(= number*)\n" +"Returns t if all the arguments, which must be numbers, are numerically equal, and nil otherwise."; +const char doc109[] PROGMEM = "(< number*)\n" +"Returns t if each argument is less than the next argument, and nil otherwise."; +const char doc110[] PROGMEM = "(<= number*)\n" +"Returns t if each argument is less than or equal to the next argument, and nil otherwise."; +const char doc111[] PROGMEM = "(> number*)\n" +"Returns t if each argument is greater than the next argument, and nil otherwise."; +const char doc112[] PROGMEM = "(>= number*)\n" +"Returns t if each argument is greater than or equal to the next argument, and nil otherwise."; +const char doc113[] PROGMEM = "(plusp number)\n" +"Returns t if the argument is greater than zero, or nil otherwise."; +const char doc114[] PROGMEM = "(minusp number)\n" +"Returns t if the argument is less than zero, or nil otherwise."; +const char doc115[] PROGMEM = "(zerop number)\n" +"Returns t if the argument is zero."; +const char doc116[] PROGMEM = "(oddp number)\n" +"Returns t if the integer argument is odd."; +const char doc117[] PROGMEM = "(evenp number)\n" +"Returns t if the integer argument is even."; +const char doc118[] PROGMEM = "(integerp number)\n" +"Returns t if the argument is an integer."; +const char doc119[] PROGMEM = "(numberp number)\n" +"Returns t if the argument is a number."; +const char doc120[] PROGMEM = "(float number)\n" +"Returns its argument converted to a floating-point number."; +const char doc121[] PROGMEM = "(floatp number)\n" +"Returns t if the argument is a floating-point number."; +const char doc122[] PROGMEM = "(sin number)\n" +"Returns sin(number)."; +const char doc123[] PROGMEM = "(cos number)\n" +"Returns cos(number)."; +const char doc124[] PROGMEM = "(tan number)\n" +"Returns tan(number)."; +const char doc125[] PROGMEM = "(asin number)\n" +"Returns asin(number)."; +const char doc126[] PROGMEM = "(acos number)\n" +"Returns acos(number)."; +const char doc127[] PROGMEM = "(atan number1 [number2])\n" +"Returns the arc tangent of number1/number2, in radians. If number2 is omitted it defaults to 1."; +const char doc128[] PROGMEM = "(sinh number)\n" +"Returns sinh(number)."; +const char doc129[] PROGMEM = "(cosh number)\n" +"Returns cosh(number)."; +const char doc130[] PROGMEM = "(tanh number)\n" +"Returns tanh(number)."; +const char doc131[] PROGMEM = "(exp number)\n" +"Returns exp(number)."; +const char doc132[] PROGMEM = "(sqrt number)\n" +"Returns sqrt(number)."; +const char doc133[] PROGMEM = "(number [base])\n" +"Returns the logarithm of number to the specified base. If base is omitted it defaults to e."; +const char doc134[] PROGMEM = "(expt number power)\n" +"Returns number raised to the specified power.\n" +"Returns the result as an integer if the arguments are integers and the result will be within range,\n" +"otherwise a floating-point number."; +const char doc135[] PROGMEM = "(ceiling number [divisor])\n" +"Returns ceil(number/divisor). If omitted, divisor is 1."; +const char doc136[] PROGMEM = "(floor number [divisor])\n" +"Returns floor(number/divisor). If omitted, divisor is 1."; +const char doc137[] PROGMEM = "(truncate number)\n" +"Returns t if the argument is a floating-point number."; +const char doc138[] PROGMEM = "(round number)\n" +"Returns t if the argument is a floating-point number."; +const char doc139[] PROGMEM = "(char string n)\n" +"Returns the nth character in a string, counting from zero."; +const char doc140[] PROGMEM = "(char-code character)\n" +"Returns the ASCII code for a character, as an integer."; +const char doc141[] PROGMEM = "(code-char integer)\n" +"Returns the character for the specified ASCII code."; +const char doc142[] PROGMEM = "(characterp item)\n" +"Returns t if the argument is a character and nil otherwise."; +const char doc143[] PROGMEM = "(stringp item)\n" +"Returns t if the argument is a string and nil otherwise."; +const char doc144[] PROGMEM = "(string= string string)\n" +"Tests whether two strings are the same."; +const char doc145[] PROGMEM = "(string< string string)\n" +"Returns t if the first string is alphabetically less than the second string, and nil otherwise."; +const char doc146[] PROGMEM = "(string> string string)\n" +"Returns t if the first string is alphabetically greater than the second string, and nil otherwise."; +const char doc147[] PROGMEM = "(sort list test)\n" +"Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list."; +const char doc148[] PROGMEM = "(concatenate 'string string*)\n" +"Joins together the strings given in the second and subsequent arguments, and returns a single string."; +const char doc149[] PROGMEM = "(subseq seq start [end])\n" +"Returns a subsequence of a list or string from item start to item end-1."; +const char doc150[] PROGMEM = "(search pattern target)\n" +"Returns the index of the first occurrence of pattern in target,\n" +"which can be lists or strings, or nil if it's not found."; +const char doc151[] PROGMEM = "(read-from-string string)\n" +"Reads an atom or list from the specified string and returns it."; +const char doc152[] PROGMEM = "(princ-to-string item)\n" +"Prints its argument to a string, and returns the string.\n" +"Characters and strings are printed without quotation marks or escape characters."; +const char doc153[] PROGMEM = "(prin1-to-string item [stream])\n" +"Prints its argument to a string, and returns the string.\n" +"Characters and strings are printed with quotation marks and escape characters,\n" +"in a format that will be suitable for read-from-string."; +const char doc154[] PROGMEM = "(logand [value*])\n" +"Returns the bitwise & of the values."; +const char doc155[] PROGMEM = "(logior [value*])\n" +"Returns the bitwise | of the values."; +const char doc156[] PROGMEM = "(logxor [value*])\n" +"Returns the bitwise ^ of the values."; +const char doc157[] PROGMEM = "(prin1-to-string item [stream])\n" +"Prints its argument to a string, and returns the string.\n" +"Characters and strings are printed with quotation marks and escape characters,\n" +"in a format that will be suitable for read-from-string."; +const char doc158[] PROGMEM = "(ash value shift)\n" +"Returns the result of bitwise shifting value by shift bits. If shift is positive, value is shifted to the left."; +const char doc159[] PROGMEM = "(logbitp bit value)\n" +"Returns t if bit number bit in value is a '1', and nil if it is a '0'."; +const char doc160[] PROGMEM = "(eval form*)\n" +"Evaluates its argument an extra time."; +const char doc161[] PROGMEM = "(globals)\n" +"Returns a list of global variables."; +const char doc162[] PROGMEM = "(locals)\n" +"Returns an association list of local variables and their values."; +const char doc163[] PROGMEM = "(makunbound symbol)\n" +"Removes the value of the symbol from GlobalEnv and returns the symbol."; +const char doc164[] PROGMEM = "(break)\n" +"Inserts a breakpoint in the program. When evaluated prints Break! and reenters the REPL."; +const char doc165[] PROGMEM = "(read [stream])\n" +"Reads an atom or list from the serial input and returns it.\n" +"If stream is specified the item is read from the specified stream."; +const char doc166[] PROGMEM = "(prin1 item [stream])\n" +"Prints its argument, and returns its value.\n" +"Strings are printed with quotation marks and escape characters."; +const char doc167[] PROGMEM = "(print item [stream])\n" +"Prints its argument with quotation marks and escape characters, on a new line, and followed by a space.\n" +"If stream is specified the argument is printed to the specified stream."; +const char doc168[] PROGMEM = "(princ item [stream])\n" +"Prints its argument, and returns its value.\n" +"Characters and strings are printed without quotation marks or escape characters."; +const char doc169[] PROGMEM = "(terpri [stream])\n" +"Prints a new line, and returns nil.\n" +"If stream is specified the new line is written to the specified stream."; +const char doc170[] PROGMEM = "(read-byte stream)\n" +"Reads a byte from a stream and returns it."; +const char doc171[] PROGMEM = "(read-line [stream])\n" +"Reads characters from the serial input up to a newline character, and returns them as a string, excluding the newline.\n" +"If stream is specified the line is read from the specified stream."; +const char doc172[] PROGMEM = "(write-byte number [stream])\n" +"Writes a byte to a stream."; +const char doc173[] PROGMEM = "(write-string string [stream])\n" +"Writes a string. If stream is specified the string is written to the stream."; +const char doc174[] PROGMEM = "(write-line string [stream])\n" +"Writes a string terminated by a newline character. If stream is specified the string is written to the stream."; +const char doc175[] PROGMEM = "(restart-i2c stream [read-p])\n" +"Restarts an i2c-stream.\n" +"If read-p is nil or omitted the stream is written to.\n" +"If read-p is an integer it specifies the number of bytes to be read from the stream."; +const char doc176[] PROGMEM = "(gc)\n" +"Forces a garbage collection and prints the number of objects collected, and the time taken."; +const char doc177[] PROGMEM = "(room)\n" +"Returns the number of free Lisp cells remaining."; +const char doc180[] PROGMEM = "(cls)\n" +"Prints a clear-screen character."; +const char doc181[] PROGMEM = "(digitalread pin)\n" +"Reads the state of the specified Arduino pin number and returns t (high) or nil (low)."; +const char doc182[] PROGMEM = "(analogreadresolution bits)\n" +"Specifies the resolution for the analogue inputs on platforms that support it.\n" +"The default resolution on all platforms is 10 bits."; +const char doc183[] PROGMEM = "(analogwrite pin value)\n" +"Writes the value to the specified Arduino pin number."; +const char doc184[] PROGMEM = "(delay number)\n" +"Delays for a specified number of milliseconds."; +const char doc185[] PROGMEM = "(millis)\n" +"Returns the time in milliseconds that uLisp has been running."; +const char doc186[] PROGMEM = "(sleep secs)\n" +"Puts the processor into a low-power sleep mode for secs.\n" +"Only supported on some platforms. On other platforms it does delay(1000*secs)."; +const char doc187[] PROGMEM = "(note [pin] [note] [octave])\n" +"Generates a square wave on pin.\n" +"The argument note represents the note in the well-tempered scale, from 0 to 11,\n" +"where 0 represents C, 1 represents C#, and so on.\n" +"The argument octave can be from 3 to 6. If omitted it defaults to 0."; +const char doc188[] PROGMEM = "(edit 'function)\n" +"Calls the Lisp tree editor to allow you to edit a function definition."; +const char doc189[] PROGMEM = "(pprint item [str])\n" +"Prints its argument, using the pretty printer, to display it formatted in a structured way.\n" +"If str is specified it prints to the specified stream. It returns no value."; +const char doc190[] PROGMEM = "(pprintall [str])\n" +"Pretty-prints the definition of every function and variable defined in the uLisp workspace.\n" +"If str is specified it prints to the specified stream. It returns no value."; +const char doc191[] PROGMEM = "(require 'symbol)\n" +"Loads the definition of a function defined with defun, or a variable defined with defvar, from the Lisp Library.\n" +"It returns t if it was loaded, or nil if the symbol is already defined or isn't defined in the Lisp Library."; +const char doc192[] PROGMEM = "(list-library)\n" +"Prints a list of the functions defined in the List Library."; +const char doc193[] PROGMEM = "(? item)\n" +"Prints the documentation string of a built-in or user-defined function."; +const char doc194[] PROGMEM = "(documentation 'symbol [type])\n" +"Returns the documentation string of a built-in or user-defined function. The type argument is ignored."; +const char doc195[] PROGMEM = "(apropos item)\n" +"Prints the user-defined and built-in functions whose names contain the specified string or symbol."; +const char doc196[] PROGMEM = "(apropos-list item)\n" +"Returns a list of user-defined and built-in functions whose names contain the specified string or symbol."; +const char doc197[] PROGMEM = "(unwind-protect form1 [forms]*)\n" +"Evaluates form1 and forms in order and returns the value of form1,\n" +"but guarantees to evaluate forms even if an error occurs in form1."; +const char doc198[] PROGMEM = "(ignore-errors [forms]*)\n" +"Evaluates forms ignoring errors."; +const char doc199[] PROGMEM = "(error controlstring [arguments]*)\n" +"Signals an error. The message is printed by format using the controlstring and arguments."; +const char doc200[] PROGMEM = "(with-client (str [address port]) form*)\n" +"Evaluates the forms with str bound to a wifi-stream."; +const char doc201[] PROGMEM = "(available stream)\n" +"Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available."; +const char doc202[] PROGMEM = "(wifi-server)\n" +"Starts a Wi-Fi server running. It returns nil."; +const char doc203[] PROGMEM = "(wifi-softap ssid [password channel hidden])\n" +"Set up a soft access point to establish a Wi-Fi network.\n" +"Returns the IP address as a string or nil if unsuccessful."; +const char doc204[] PROGMEM = "(connected stream)\n" +"Returns t or nil to indicate if the client on stream is connected."; +const char doc205[] PROGMEM = "(wifi-localip)\n" +"Returns the IP address of the local network as a string."; +const char doc206[] PROGMEM = "(wifi-connect [ssid pass])\n" +"Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string."; +const char doc207[] PROGMEM = "(with-gfx (str) form*)\n" +"Evaluates the forms with str bound to an gfx-stream so you can print text\n" +"to the graphics display using the standard uLisp print commands."; +const char doc208[] PROGMEM = "(draw-pixel x y [colour])\n" +"Draws a pixel at coordinates (x,y) in colour, or white if omitted."; +const char doc209[] PROGMEM = "(draw-line x0 y0 x1 y1 [colour])\n" +"Draws a line from (x0,y0) to (x1,y1) in colour, or white if omitted."; +const char doc210[] PROGMEM = "(draw-rect x y w h [colour])\n" +"Draws an outline rectangle with its top left corner at (x,y), with width w,\n" +"and with height h. The outline is drawn in colour, or white if omitted."; +const char doc211[] PROGMEM = "(fill-rect x y w h [colour])\n" +"Draws a filled rectangle with its top left corner at (x,y), with width w,\n" +"and with height h. The outline is drawn in colour, or white if omitted."; +const char doc212[] PROGMEM = "(draw-circle x y r [colour])\n" +"Draws an outline circle with its centre at (x, y) and with radius r.\n" +"The circle is drawn in colour, or white if omitted."; +const char doc213[] PROGMEM = "(fill-circle x y r [colour])\n" +"Draws a filled circle with its centre at (x, y) and with radius r.\n" +"The circle is drawn in colour, or white if omitted."; +const char doc214[] PROGMEM = "(draw-round-rect x y w h radius [colour])\n" +"Draws an outline rounded rectangle with its top left corner at (x,y), with width w,\n" +"height h, and corner radius radius. The outline is drawn in colour, or white if omitted."; +const char doc215[] PROGMEM = "(fill-round-rect x y w h radius [colour])\n" +"Draws a filled rounded rectangle with its top left corner at (x,y), with width w,\n" +"height h, and corner radius radius. The outline is drawn in colour, or white if omitted."; +const char doc216[] PROGMEM = "(draw-triangle x0 y0 x1 y1 x2 y2 [colour])\n" +"Draws an outline triangle between (x1,y1), (x2,y2), and (x3,y3).\n" +"The outline is drawn in colour, or white if omitted."; +const char doc217[] PROGMEM = "(fill-triangle x0 y0 x1 y1 x2 y2 [colour])\n" +"Draws a filled triangle between (x1,y1), (x2,y2), and (x3,y3).\n" +"The outline is drawn in colour, or white if omitted."; +const char doc218[] PROGMEM = "(draw-char x y char [colour background size])\n" +"Draws the character char with its top left corner at (x,y).\n" +"The character is drawn in a 5 x 7 pixel font in colour against background,\n" +"which default to white and black respectively.\n" +"The character can optionally be scaled by size."; +const char doc219[] PROGMEM = "(set-cursor x y)\n" +"Sets the start point for text plotting to (x, y)."; +const char doc220[] PROGMEM = "(set-text-color colour [background])\n" +"Sets the text colour for text plotted using (with-gfx ...)."; +const char doc221[] PROGMEM = "(set-text-size scale)\n" +"Scales text by the specified size, default 1."; +const char doc222[] PROGMEM = "(set-text-wrap boolean)\n" +"Specified whether text wraps at the right-hand edge of the display; the default is t."; +const char doc223[] PROGMEM = "(fill-screen [colour])\n" +"Fills or clears the screen with colour, default black."; +const char doc224[] PROGMEM = "(set-rotation option)\n" +"Sets the display orientation for subsequent graphics commands; values are 0, 1, 2, or 3."; +const char doc225[] PROGMEM = "(invert-display boolean)\n" +"Mirror-images the display."; + +// Built-in symbol lookup table +const tbl_entry_t lookup_table[] PROGMEM = { + { string0, NULL, 0000, doc0 }, + { string1, NULL, 0000, doc1 }, + { string2, NULL, 0000, doc2 }, + { string3, NULL, 0000, doc3 }, + { string4, NULL, 0000, NULL }, + { string5, NULL, 0000, NULL }, + { string6, NULL, 0000, NULL }, + { string7, NULL, 0000, doc7 }, + { string8, NULL, 0017, doc8 }, + { string9, NULL, 0017, doc9 }, + { string10, NULL, 0017, doc10 }, + { string11, NULL, 0017, NULL }, + { string12, NULL, 0007, NULL }, + { string13, sp_quote, 0311, NULL }, + { string14, sp_defun, 0327, doc14 }, + { string15, sp_defvar, 0313, doc15 }, + { string16, fn_car, 0211, doc16 }, + { string17, fn_car, 0211, NULL }, + { string18, fn_cdr, 0211, doc18 }, + { string19, fn_cdr, 0211, NULL }, + { string20, fn_nth, 0222, doc20 }, + { string21, fn_aref, 0227, doc21 }, + { string22, fn_stringfn, 0211, doc22 }, + { string23, fn_pinmode, 0222, doc23 }, + { string24, fn_digitalwrite, 0222, doc24 }, + { string25, fn_analogread, 0211, doc25 }, + { string26, fn_register, 0212, doc26 }, + { string27, fn_format, 0227, doc27 }, + { string28, sp_or, 0307, doc28 }, + { string29, sp_setq, 0327, doc29 }, + { string30, sp_loop, 0307, doc30 }, + { string31, sp_return, 0307, doc31 }, + { string32, sp_push, 0322, doc32 }, + { string33, sp_pop, 0311, doc33 }, + { string34, sp_incf, 0312, doc34 }, + { string35, sp_decf, 0312, doc35 }, + { string36, sp_setf, 0327, doc36 }, + { string37, sp_dolist, 0317, doc37 }, + { string38, sp_dotimes, 0317, doc38 }, + { string39, sp_trace, 0301, doc39 }, + { string40, sp_untrace, 0301, doc40 }, + { string41, sp_formillis, 0317, doc41 }, + { string42, sp_time, 0311, doc42 }, + { string43, sp_withoutputtostring, 0317, doc43 }, + { string44, sp_withserial, 0317, doc44 }, + { string45, sp_withi2c, 0317, doc45 }, + { string46, sp_withspi, 0317, doc46 }, + { string47, sp_withsdcard, 0327, doc47 }, + { string48, tf_progn, 0107, doc48 }, + { string49, tf_if, 0123, doc49 }, + { string50, tf_cond, 0107, doc50 }, + { string51, tf_when, 0117, doc51 }, + { string52, tf_unless, 0117, doc52 }, + { string53, tf_case, 0117, doc53 }, + { string54, tf_and, 0107, doc54 }, + { string55, fn_not, 0211, doc55 }, + { string56, fn_not, 0211, NULL }, + { string57, fn_cons, 0222, doc57 }, + { string58, fn_atom, 0211, doc58 }, + { string59, fn_listp, 0211, doc59 }, + { string60, fn_consp, 0211, doc60 }, + { string61, fn_symbolp, 0211, doc61 }, + { string62, fn_arrayp, 0211, doc62 }, + { string63, fn_boundp, 0211, doc63 }, + { string64, fn_keywordp, 0211, doc64 }, + { string65, fn_setfn, 0227, doc65 }, + { string66, fn_streamp, 0211, doc66 }, + { string67, fn_eq, 0222, doc67 }, + { string68, fn_equal, 0222, doc68 }, + { string69, fn_caar, 0211, doc69 }, + { string70, fn_cadr, 0211, doc70 }, + { string71, fn_cadr, 0211, NULL }, + { string72, fn_cdar, 0211, doc72 }, + { string73, fn_cddr, 0211, doc73 }, + { string74, fn_caaar, 0211, doc74 }, + { string75, fn_caadr, 0211, doc75 }, + { string76, fn_cadar, 0211, doc76 }, + { string77, fn_caddr, 0211, doc77 }, + { string78, fn_caddr, 0211, NULL }, + { string79, fn_cdaar, 0211, doc79 }, + { string80, fn_cdadr, 0211, doc80 }, + { string81, fn_cddar, 0211, doc81 }, + { string82, fn_cdddr, 0211, doc82 }, + { string83, fn_length, 0211, doc83 }, + { string84, fn_arraydimensions, 0211, doc84 }, + { string85, fn_list, 0207, doc85 }, + { string86, fn_makearray, 0215, doc86 }, + { string87, fn_reverse, 0211, doc87 }, + { string88, fn_assoc, 0222, doc88 }, + { string89, fn_member, 0222, doc89 }, + { string90, fn_apply, 0227, doc90 }, + { string91, fn_funcall, 0217, doc91 }, + { string92, fn_append, 0207, doc92 }, + { string93, fn_mapc, 0227, doc93 }, + { string94, fn_mapcar, 0227, doc94 }, + { string95, fn_mapcan, 0227, doc95 }, + { string96, fn_add, 0207, doc96 }, + { string97, fn_subtract, 0217, doc97 }, + { string98, fn_multiply, 0207, doc98 }, + { string99, fn_divide, 0217, doc99 }, + { string100, fn_mod, 0222, doc100 }, + { string101, fn_oneplus, 0211, doc101 }, + { string102, fn_oneminus, 0211, doc102 }, + { string103, fn_abs, 0211, doc103 }, + { string104, fn_random, 0211, doc104 }, + { string105, fn_maxfn, 0217, doc105 }, + { string106, fn_minfn, 0217, doc106 }, + { string107, fn_noteq, 0217, doc107 }, + { string108, fn_numeq, 0217, doc108 }, + { string109, fn_less, 0217, doc109 }, + { string110, fn_lesseq, 0217, doc110 }, + { string111, fn_greater, 0217, doc111 }, + { string112, fn_greatereq, 0217, doc112 }, + { string113, fn_plusp, 0211, doc113 }, + { string114, fn_minusp, 0211, doc114 }, + { string115, fn_zerop, 0211, doc115 }, + { string116, fn_oddp, 0211, doc116 }, + { string117, fn_evenp, 0211, doc117 }, + { string118, fn_integerp, 0211, doc118 }, + { string119, fn_numberp, 0211, doc119 }, + { string120, fn_floatfn, 0211, doc120 }, + { string121, fn_floatp, 0211, doc121 }, + { string122, fn_sin, 0211, doc122 }, + { string123, fn_cos, 0211, doc123 }, + { string124, fn_tan, 0211, doc124 }, + { string125, fn_asin, 0211, doc125 }, + { string126, fn_acos, 0211, doc126 }, + { string127, fn_atan, 0212, doc127 }, + { string128, fn_sinh, 0211, doc128 }, + { string129, fn_cosh, 0211, doc129 }, + { string130, fn_tanh, 0211, doc130 }, + { string131, fn_exp, 0211, doc131 }, + { string132, fn_sqrt, 0211, doc132 }, + { string133, fn_log, 0212, doc133 }, + { string134, fn_expt, 0222, doc134 }, + { string135, fn_ceiling, 0212, doc135 }, + { string136, fn_floor, 0212, doc136 }, + { string137, fn_truncate, 0212, doc137 }, + { string138, fn_round, 0212, doc138 }, + { string139, fn_char, 0222, doc139 }, + { string140, fn_charcode, 0211, doc140 }, + { string141, fn_codechar, 0211, doc141 }, + { string142, fn_characterp, 0211, doc142 }, + { string143, fn_stringp, 0211, doc143 }, + { string144, fn_stringeq, 0222, doc144 }, + { string145, fn_stringless, 0222, doc145 }, + { string146, fn_stringgreater, 0222, doc146 }, + { string147, fn_sort, 0222, doc147 }, + { string148, fn_concatenate, 0217, doc148 }, + { string149, fn_subseq, 0223, doc149 }, + { string150, fn_search, 0222, doc150 }, + { string151, fn_readfromstring, 0211, doc151 }, + { string152, fn_princtostring, 0211, doc152 }, + { string153, fn_prin1tostring, 0211, doc153 }, + { string154, fn_logand, 0207, doc154 }, + { string155, fn_logior, 0207, doc155 }, + { string156, fn_logxor, 0207, doc156 }, + { string157, fn_lognot, 0211, doc157 }, + { string158, fn_ash, 0222, doc158 }, + { string159, fn_logbitp, 0222, doc159 }, + { string160, fn_eval, 0211, doc160 }, + { string161, fn_globals, 0200, doc161 }, + { string162, fn_locals, 0200, doc162 }, + { string163, fn_makunbound, 0211, doc163 }, + { string164, fn_break, 0200, doc164 }, + { string165, fn_read, 0201, doc165 }, + { string166, fn_prin1, 0212, doc166 }, + { string167, fn_print, 0212, doc167 }, + { string168, fn_princ, 0212, doc168 }, + { string169, fn_terpri, 0201, doc169 }, + { string170, fn_readbyte, 0202, doc170 }, + { string171, fn_readline, 0201, doc171 }, + { string172, fn_writebyte, 0212, doc172 }, + { string173, fn_writestring, 0212, doc173 }, + { string174, fn_writeline, 0212, doc174 }, + { string175, fn_restarti2c, 0212, doc175 }, + { string176, fn_gc, 0200, doc176 }, + { string177, fn_room, 0200, doc177 }, + { string180, fn_cls, 0200, doc180 }, + { string181, fn_digitalread, 0211, doc181 }, + { string182, fn_analogreadresolution, 0211, doc182 }, + { string183, fn_analogwrite, 0222, doc183 }, + { string184, fn_delay, 0211, doc184 }, + { string185, fn_millis, 0200, doc185 }, + { string186, fn_sleep, 0201, doc186 }, + { string187, fn_note, 0203, doc187 }, + { string188, fn_edit, 0211, doc188 }, + { string189, fn_pprint, 0212, doc189 }, + { string190, fn_pprintall, 0201, doc190 }, + { string191, fn_require, 0211, doc191 }, + { string192, fn_listlibrary, 0200, doc192 }, + { string193, sp_help, 0311, doc193 }, + { string194, fn_documentation, 0212, doc194 }, + { string195, fn_apropos, 0211, doc195 }, + { string196, fn_aproposlist, 0211, doc196 }, + { string197, sp_unwindprotect, 0307, doc197 }, + { string198, sp_ignoreerrors, 0307, doc198 }, + { string199, sp_error, 0317, doc199 }, + { string200, sp_withclient, 0312, doc200 }, + { string201, fn_available, 0211, doc201 }, + { string202, fn_wifiserver, 0200, doc202 }, + { string203, fn_wifisoftap, 0204, doc203 }, + { string204, fn_connected, 0211, doc204 }, + { string205, fn_wifilocalip, 0200, doc205 }, + { string206, fn_wificonnect, 0203, doc206 }, + { string207, sp_withgfx, 0317, doc207 }, + { string208, fn_drawpixel, 0223, doc208 }, + { string209, fn_drawline, 0245, doc209 }, + { string210, fn_drawrect, 0245, doc210 }, + { string211, fn_fillrect, 0245, doc211 }, + { string212, fn_drawcircle, 0234, doc212 }, + { string213, fn_fillcircle, 0234, doc213 }, + { string214, fn_drawroundrect, 0256, doc214 }, + { string215, fn_fillroundrect, 0256, doc215 }, + { string216, fn_drawtriangle, 0267, doc216 }, + { string217, fn_filltriangle, 0267, doc217 }, + { string218, fn_drawchar, 0236, doc218 }, + { string219, fn_setcursor, 0222, doc219 }, + { string220, fn_settextcolor, 0212, doc220 }, + { string221, fn_settextsize, 0211, doc221 }, + { string222, fn_settextwrap, 0211, doc222 }, + { string223, fn_fillscreen, 0201, doc223 }, + { string224, fn_setrotation, 0211, doc224 }, + { string225, fn_invertdisplay, 0211, doc225 }, + { string226, (fn_ptr_type)LED_BUILTIN, 0, NULL }, + { string227, (fn_ptr_type)HIGH, DIGITALWRITE, NULL }, + { string228, (fn_ptr_type)LOW, DIGITALWRITE, NULL }, + { string229, (fn_ptr_type)INPUT, PINMODE, NULL }, + { string230, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, + { string231, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, + { string232, (fn_ptr_type)OUTPUT, PINMODE, NULL }, +}; + +#if !defined(extensions) +// Table cross-reference functions + +tbl_entry_t *tables[] = {lookup_table, NULL}; +const unsigned int tablesizes[] = { arraysize(lookup_table), 0 }; + +const tbl_entry_t *table (int n) { + return tables[n]; +} + +unsigned int tablesize (int n) { + return tablesizes[n]; +} +#endif + +// Table lookup functions + +/* + lookupbuiltin - looks up a string in lookup_table[], and returns the index of its entry, + or ENDFUNCTIONS if no match is found +*/ +builtin_t lookupbuiltin (char* c) { + unsigned int end = 0, start; + for (int n=0; n<2; n++) { + start = end; + int entries = tablesize(n); + end = end + entries; + for (int i=0; i> 3) & 0x07)) error2(toofewargs); + if ((minmax & 0x07) != 0x07 && nargs>(minmax & 0x07)) error2(toomanyargs); +} + +/* + lookupdoc - looks up the documentation string for the built-in function name +*/ +char *lookupdoc (builtin_t name) { + int n = namename))) return false; + builtin_t name = builtin(obj->name); + int n = name>4) gc(form, env); + // Escape + if (tstflag(ESCAPE)) { clrflag(ESCAPE); error2(PSTR("escape!"));} + if (!tstflag(NOESC)) testescape(); + + if (form == NULL) return nil; + + if (form->type >= NUMBER && form->type <= STRING) return form; + + if (symbolp(form)) { + symbol_t name = form->name; + object *pair = value(name, env); + if (pair != NULL) return cdr(pair); + pair = value(name, GlobalEnv); + if (pair != NULL) return cdr(pair); + else if (builtinp(name)) return form; + error(PSTR("undefined"), form); + } + + // It's a list + object *function = car(form); + object *args = cdr(form); + + if (function == NULL) error(PSTR("illegal function"), nil); + if (!listp(args)) error(PSTR("can't evaluate a dotted pair"), args); + + // List starts with a builtin symbol? + if (symbolp(function) && builtinp(function->name)) { + builtin_t name = builtin(function->name); + + if ((name == LET) || (name == LETSTAR)) { + int TCstart = TC; + if (args == NULL) error2(noargument); + object *assigns = first(args); + if (!listp(assigns)) error(notalist, assigns); + object *forms = cdr(args); + object *newenv = env; + push(newenv, GCStack); + while (assigns != NULL) { + object *assign = car(assigns); + if (!consp(assign)) push(cons(assign,nil), newenv); + else if (cdr(assign) == NULL) push(cons(first(assign),nil), newenv); + else push(cons(first(assign),eval(second(assign),env)), newenv); + car(GCStack) = newenv; + if (name == LETSTAR) env = newenv; + assigns = cdr(assigns); + } + env = newenv; + pop(GCStack); + form = tf_progn(forms,env); + TC = TCstart; + goto EVAL; + } + + if (name == LAMBDA) { + if (env == NULL) return form; + object *envcopy = NULL; + while (env != NULL) { + object *pair = first(env); + if (pair != NULL) push(pair, envcopy); + env = cdr(env); + } + return cons(bsymbol(CLOSURE), cons(envcopy,args)); + } + uint8_t fntype = getminmax(name)>>6; + + if (fntype == SPECIAL_FORMS) { + Context = name; + return ((fn_ptr_type)lookupfn(name))(args, env); + } + + if (fntype == TAIL_FORMS) { + Context = name; + form = ((fn_ptr_type)lookupfn(name))(args, env); + TC = 1; + goto EVAL; + } + if (fntype == OTHER_FORMS) error(PSTR("can't be used as a function"), function); + } + + // Evaluate the parameters - result in head + object *fname = car(form); + int TCstart = TC; + object *head = cons(eval(fname, 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 (symbolp(function)) { + builtin_t bname = builtin(function->name); + if (!builtinp(function->name)) error(PSTR("not valid here"), fname); + Context = bname; + checkminmax(bname, nargs); + object *result = ((fn_ptr_type)lookupfn(bname))(args, env); + pop(GCStack); + return result; + } + + if (consp(function)) { + symbol_t name = sym(NIL); + if (!listp(fname)) name = fname->name; + + if (isbuiltin(car(function), LAMBDA)) { + form = closure(TCstart, name, function, args, &env); + pop(GCStack); + int trace = tracing(fname->name); + if (trace) { + object *result = eval(form, env); + indent((--(TraceDepth[trace-1]))<<1, ' ', pserial); + pint(TraceDepth[trace-1], pserial); + pserial(':'); pserial(' '); + printobject(fname, pserial); pfstring(PSTR(" returned "), pserial); + printobject(result, pserial); pln(pserial); + return result; + } else { + TC = 1; + goto EVAL; + } + } + + if (isbuiltin(car(function), CLOSURE)) { + function = cdr(function); + form = closure(TCstart, name, function, args, &env); + pop(GCStack); + TC = 1; + goto EVAL; + } + + } + error(PSTR("illegal function"), fname); return nil; +} + +// Print functions + +/* + pserial - prints a character to the serial port +*/ +void pserial (char c) { + LastPrint = c; + if (c == '\n') Serial.write('\r'); + Serial.write(c); +} + +const char ControlCodes[] PROGMEM = "Null\0SOH\0STX\0ETX\0EOT\0ENQ\0ACK\0Bell\0Backspace\0Tab\0Newline\0VT\0" +"Page\0Return\0SO\0SI\0DLE\0DC1\0DC2\0DC3\0DC4\0NAK\0SYN\0ETB\0CAN\0EM\0SUB\0Escape\0FS\0GS\0RS\0US\0Space\0"; + +/* + pcharacter - prints a character to a stream, escaping special characters if PRINTREADABLY is false + If <= 32 prints character name; eg #\Space + If < 127 prints ASCII; eg #\A + Otherwise prints decimal; eg #\234 +*/ +void pcharacter (uint8_t c, pfun_t pfun) { + if (!tstflag(PRINTREADABLY)) pfun(c); + else { + pfun('#'); pfun('\\'); + if (c <= 32) { + PGM_P p = ControlCodes; + while (c > 0) {p = p + strlen_P(p) + 1; c--; } + pfstring(p, pfun); + } else if (c < 127) pfun(c); + else pint(c, pfun); + } +} + +/* + pstring - prints a C string to the specified stream +*/ +void pstring (char *s, pfun_t pfun) { + while (*s) pfun(*s++); +} + +/* + plispstring - prints a Lisp string object to the specified stream +*/ +void plispstring (object *form, pfun_t pfun) { + plispstr(form->name, pfun); +} + +/* + plispstr - prints a Lisp string name to the specified stream +*/ +void plispstr (symbol_t name, pfun_t pfun) { + object *form = (object *)name; + while (form != NULL) { + int chars = form->chars; + for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { + char ch = chars>>i & 0xFF; + if (tstflag(PRINTREADABLY) && (ch == '"' || ch == '\\')) pfun('\\'); + if (ch) pfun(ch); + } + form = car(form); + } +} + +/* + printstring - prints a Lisp string object to the specified stream + taking account of the PRINTREADABLY flag +*/ +void printstring (object *form, pfun_t pfun) { + if (tstflag(PRINTREADABLY)) pfun('"'); + plispstr(form->name, pfun); + if (tstflag(PRINTREADABLY)) pfun('"'); +} + +/* + pbuiltin - prints a built-in symbol to the specified stream +*/ +void pbuiltin (builtin_t name, pfun_t pfun) { + int p = 0; + int n = name0; d = d/40) { + uint32_t j = x/d; + char c = fromradix40(j); + if (c == 0) return; + pfun(c); x = x - j*d; + } +} + +/* + printsymbol - prints any symbol from a symbol object to the specified stream +*/ +void printsymbol (object *form, pfun_t pfun) { + psymbol(form->name, pfun); +} + +/* + psymbol - prints any symbol from a symbol name to the specified stream +*/ +void psymbol (symbol_t name, pfun_t pfun) { + if ((name & 0x03) == 0) plispstr(name, pfun); + else { + uint32_t value = untwist(name); + if (value < PACKEDS) error2(PSTR("invalid symbol")); + else if (value >= BUILTINS) pbuiltin((builtin_t)(value-BUILTINS), pfun); + else pradix40(name, pfun); + } +} + +/* + pfstring - prints a string from flash memory to the specified stream +*/ +void pfstring (PGM_P s, pfun_t pfun) { + int p = 0; + while (1) { + char c = pgm_read_byte(&s[p++]); + if (c == 0) return; + pfun(c); + } +} + +/* + pint - prints an integer in decimal to the specified stream +*/ +void pint (int i, pfun_t pfun) { + uint32_t j = i; + if (i<0) { pfun('-'); j=-i; } + pintbase(j, 10, pfun); +} + +/* + pintbase - prints an integer in base 'base' to the specified stream +*/ +void pintbase (uint32_t i, uint8_t base, pfun_t pfun) { + int lead = 0; uint32_t p = 1000000000; + if (base == 2) p = 0x80000000; else if (base == 16) p = 0x10000000; + for (uint32_t d=p; d>0; d=d/base) { + uint32_t j = i/d; + if (j!=0 || lead || d==1) { pfun((j<10) ? j+'0' : j+'W'); lead=1;} + i = i - j*d; + } +} + +/* + pmantissa - prints the mantissa of a floating-point number to the specified stream +*/ +void pmantissa (float f, pfun_t pfun) { + int sig = floor(log10(f)); + int mul = pow(10, 5 - sig); + int i = round(f * mul); + bool point = false; + if (i == 1000000) { i = 100000; sig++; } + if (sig < 0) { + pfun('0'); pfun('.'); point = true; + for (int j=0; j < - sig - 1; j++) pfun('0'); + } + mul = 100000; + for (int j=0; j<7; j++) { + int d = (int)(i / mul); + pfun(d + '0'); + i = i - d * mul; + if (i == 0) { + if (!point) { + for (int k=j; k= 0) { pfun('.'); point = true; } + mul = mul / 10; + } +} + +/* + pfloat - prints a floating-point number to the specified stream +*/ +void pfloat (float f, pfun_t pfun) { + if (isnan(f)) { pfstring(PSTR("NaN"), pfun); return; } + if (f == 0.0) { pfun('0'); return; } + if (isinf(f)) { pfstring(PSTR("Inf"), pfun); return; } + if (f < 0) { pfun('-'); f = -f; } + // Calculate exponent + int e = 0; + if (f < 1e-3 || f >= 1e5) { + e = floor(log(f) / 2.302585); // log10 gives wrong result + f = f / pow(10, e); + } + + pmantissa (f, pfun); + + // Exponent + if (e != 0) { + pfun('e'); + pint(e, pfun); + } +} + +/* + pln - prints a newline to the specified stream +*/ +inline void pln (pfun_t pfun) { + pfun('\n'); +} + +/* + pfl - prints a newline to the specified stream if a newline has not just been printed +*/ +void pfl (pfun_t pfun) { + if (LastPrint != '\n') pfun('\n'); +} + +/* + plist - prints a list to the specified stream +*/ +void plist (object *form, pfun_t pfun) { + pfun('('); + printobject(car(form), pfun); + form = cdr(form); + while (form != NULL && listp(form)) { + pfun(' '); + printobject(car(form), pfun); + form = cdr(form); + } + if (form != NULL) { + pfstring(PSTR(" . "), pfun); + printobject(form, pfun); + } + pfun(')'); +} + +/* + pstream - prints a stream name to the specified stream +*/ +void pstream (object *form, pfun_t pfun) { + pfun('<'); + PGM_P s = (char*)pgm_read_ptr(&streamname[(form->integer)>>8]); + pfstring(s, pfun); + pfstring(PSTR("-stream "), pfun); + pint(form->integer & 0xFF, pfun); + pfun('>'); +} + +/* + printobject - prints any Lisp object to the specified stream +*/ +void printobject (object *form, pfun_t pfun) { + if (form == NULL) pfstring(PSTR("nil"), pfun); + else if (listp(form) && isbuiltin(car(form), CLOSURE)) pfstring(PSTR(""), pfun); + else if (listp(form)) plist(form, pfun); + else if (integerp(form)) pint(form->integer, pfun); + else if (floatp(form)) pfloat(form->single_float, pfun); + else if (symbolp(form)) { if (form->name != sym(NOTHING)) printsymbol(form, pfun); } + else if (characterp(form)) pcharacter(form->chars, pfun); + else if (stringp(form)) printstring(form, pfun); + else if (arrayp(form)) printarray(form, pfun); + else if (streamp(form)) pstream(form, pfun); + else error2(PSTR("error in print")); +} + +/* + prin1object - prints any Lisp object to the specified stream escaping special characters +*/ +void prin1object (object *form, pfun_t pfun) { + char temp = Flags; + clrflag(PRINTREADABLY); + printobject(form, pfun); + Flags = temp; +} + +// Read functions + +/* + glibrary - reads a character from the Lisp Library +*/ +int glibrary () { + if (LastChar) { + char temp = LastChar; + LastChar = 0; + return temp; + } + char c = pgm_read_byte(&LispLibrary[GlobalStringIndex++]); + return (c != 0) ? c : -1; // -1? +} + +/* + loadfromlibrary - reads and evaluates a form from the Lisp Library +*/ +void loadfromlibrary (object *env) { + GlobalStringIndex = 0; + object *line = read(glibrary); + while (line != NULL) { + push(line, GCStack); + eval(line, env); + pop(GCStack); + line = read(glibrary); + } +} + +/* + gserial - gets a character from the serial port +*/ +int gserial () { + if (LastChar) { + char temp = LastChar; + LastChar = 0; + return temp; + } + unsigned long start = millis(); + while (!Serial.available()) { delay(1); if (millis() - start > 1000) clrflag(NOECHO); } + char temp = Serial.read(); + if (temp != '\n' && !tstflag(NOECHO)) pserial(temp); + return temp; +#endif +} + +/* + nextitem - reads the next token from the specified stream +*/ +object *nextitem (gfun_t gfun) { + int ch = gfun(); + while(issp(ch)) ch = gfun(); + + if (ch == ';') { + do { ch = gfun(); if (ch == ';' || ch == '(') setflag(NOECHO); } + while(ch != '('); + } + if (ch == '\n') ch = gfun(); + if (ch == -1) return nil; + if (ch == ')') return (object *)KET; + if (ch == '(') return (object *)BRA; + if (ch == '\'') return (object *)QUO; + + // Parse string + if (ch == '"') return readstring('"', gfun); + + // Parse symbol, character, or number + int index = 0, base = 10, sign = 1; + char buffer[BUFFERSIZE]; + int bufmax = BUFFERSIZE-3; // Max index + unsigned int result = 0; + bool isfloat = false; + float fresult = 0.0; + + if (ch == '+') { + buffer[index++] = ch; + ch = gfun(); + } else if (ch == '-') { + sign = -1; + buffer[index++] = ch; + ch = gfun(); + } else if (ch == '.') { + buffer[index++] = ch; + ch = gfun(); + if (ch == ' ') return (object *)DOT; + isfloat = true; + } + + // Parse reader macros + else if (ch == '#') { + ch = gfun(); + char ch2 = ch & ~0x20; // force to upper case + if (ch == '\\') { // Character + base = 0; ch = gfun(); + if (issp(ch) || isbr(ch)) return character(ch); + else LastChar = ch; + } else if (ch == '|') { + do { while (gfun() != '|'); } + while (gfun() != '#'); + return nextitem(gfun); + } else if (ch2 == 'B') base = 2; + else if (ch2 == 'O') base = 8; + else if (ch2 == 'X') base = 16; + else if (ch == '\'') return nextitem(gfun); + else if (ch == '.') { + setflag(NOESC); + object *result = eval(read(gfun), NULL); + clrflag(NOESC); + return result; + } + else if (ch == '(') { LastChar = ch; return readarray(1, read(gfun)); } + else if (ch == '*') return readbitarray(gfun); + else if (ch >= '1' && ch <= '9' && (gfun() & ~0x20) == 'A') return readarray(ch - '0', read(gfun)); + else error2(PSTR("illegal character after #")); + ch = gfun(); + } + int valid; // 0=undecided, -1=invalid, +1=valid + if (ch == '.') valid = 0; else if (digitvalue(ch) ((unsigned int)INT_MAX+(1-sign)/2)) + return makefloat((float)result*sign); + return number(result*sign); + } else if (base == 0) { + if (index == 1) return character(buffer[0]); + PGM_P p = ControlCodes; char c = 0; + while (c < 33) { + if (strcasecmp_P(buffer, p) == 0) return character(c); + p = p + strlen_P(p) + 1; c++; + } + if (index == 3) return character((buffer[0]*10+buffer[1])*10+buffer[2]-5328); + error2(PSTR("unknown character")); + } + + builtin_t x = lookupbuiltin(buffer); + if (x == NIL) return nil; + if (x != ENDFUNCTIONS) return bsymbol(x); + else if ((index <= 6) && valid40(buffer)) return intern(twist(pack40(buffer))); + buffer[index+1] = '\0'; buffer[index+2] = '\0'; buffer[index+3] = '\0'; // For internlong + return internlong(buffer); +} + +/* + readrest - reads the remaining tokens from the specified stream +*/ +object *readrest (gfun_t gfun) { + object *item = nextitem(gfun); + object *head = NULL; + object *tail = NULL; + + while (item != (object *)KET) { + if (item == (object *)BRA) { + item = readrest(gfun); + } else if (item == (object *)QUO) { + item = cons(bsymbol(QUOTE), cons(read(gfun), NULL)); + } else if (item == (object *)DOT) { + tail->cdr = read(gfun); + if (readrest(gfun) != NULL) error2(PSTR("malformed list")); + return head; + } else { + object *cell = cons(item, NULL); + if (head == NULL) head = cell; + else tail->cdr = cell; + tail = cell; + item = nextitem(gfun); + } + } + return head; +} + +/* + read - recursively reads a Lisp object from the stream gfun and returns it +*/ +object *read (gfun_t gfun) { + object *item = nextitem(gfun); + if (item == (object *)KET) error2(PSTR("incomplete list")); + if (item == (object *)BRA) return readrest(gfun); + if (item == (object *)DOT) return read(gfun); + if (item == (object *)QUO) return cons(bsymbol(QUOTE), cons(read(gfun), NULL)); + return item; +} + +// Setup + +/* + initenv - initialises the uLisp environment +*/ +void initenv () { + GlobalEnv = NULL; + tee = bsymbol(TEE); +} + +/* + initgfx - initialises the graphics +*/ +void initgfx () { + #if defined(gfxsupport) + tft.init(135, 240); + #if defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) + pinMode(TFT_I2C_POWER, OUTPUT); + digitalWrite(TFT_I2C_POWER, HIGH); + tft.setRotation(3); + #else + tft.setRotation(1); + #endif + tft.fillScreen(ST77XX_BLACK); + pinMode(TFT_BACKLITE, OUTPUT); + digitalWrite(TFT_BACKLITE, HIGH); + #endif +} + +/* + setup - entry point from the Arduino IDE +*/ +void setup () { + Serial.begin(9600); + int start = millis(); + while ((millis() - start) < 5000) { if (Serial) break; } + initworkspace(); + initenv(); + initsleep(); + initgfx(); + pfstring(PSTR("uLisp 4.4 "), pserial); pln(pserial); +} + +// Read/Evaluate/Print loop + +/* + repl - the Lisp Read/Evaluate/Print loop +*/ +void repl (object *env) { + for (;;) { + randomSeed(micros()); + gc(NULL, env); + #if defined(printfreespace) + pint(Freespace, pserial); + #endif + if (BreakLevel) { + pfstring(PSTR(" : "), pserial); + pint(BreakLevel, pserial); + } + pserial('>'); pserial(' '); + Context = 0; + object *line = read(gserial); + if (BreakLevel && line == nil) { pln(pserial); return; } + if (line == (object *)KET) error2(PSTR("unmatched right bracket")); + push(line, GCStack); + pfl(pserial); + line = eval(line, env); + pfl(pserial); + printobject(line, pserial); + pop(GCStack); + pfl(pserial); + pln(pserial); + } +} + +/* + loop - the Arduino IDE main execution loop +*/ +void loop () { + if (!setjmp(toplevel_handler)) { + ; // noop + } + ulispreset(); + repl(NULL); +} + +void ulispreset () { + // Come here after error + delay(100); while (Serial.available()) Serial.read(); + clrflag(NOESC); BreakLevel = 0; + for (int i=0; i +#include +#include +#include +#include +#include +#if defined(gfxsupport) +#define COLOR_WHITE ST77XX_WHITE +#define COLOR_BLACK ST77XX_BLACK +#include +#include +Adafruit_ST7789 tft; +#define TFT_BACKLITE 4 +#endif +#include +#define SDSIZE 172 +#define WORDALIGNED __attribute__((aligned (4))) +#define BUFFERSIZE 36 +#define WORKSPACESIZE (9216-SDSIZE) +#define LITTLEFS +#include "FS.h" +#include +#ifndef analogWrite +#define analogWrite(x,y) dacWrite((x),(y)) +#endif +#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 push(x, y) ((y); +enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; +enum token { UNUSED, BRA, KET, QUO, DOT }; +enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM }; +enum fntypes_t { OTHER_FORMS, TAIL_FORMS, FUNCTIONS, SPECIAL_FORMS }; +extern const char serialstream[] PROGMEM; +extern const char i2cstream[] PROGMEM; +extern const char spistream[] PROGMEM; +extern const char sdstream[] PROGMEM; +extern const char wifistream[] PROGMEM; +extern const char stringstream[] PROGMEM; +extern const char gfxstream[] PROGMEM; +extern PGM_P const streamname[] PROGMEM; +typedef uint32_t symbol_t; +typedef struct sobject { + union { + struct { + sobject *car; + sobject *cdr; + }; + struct { + unsigned int type; + union { + symbol_t name; + int integer; + int chars; + float single_float; + }; + }; + }; +} object; +typedef object *(*fn_ptr_type)(object *, object *); +typedef void (*mapfun_t)(object *, object **); +typedef const struct { + PGM_P string; + fn_ptr_type fptr; + uint8_t minmax; + const char *doc; +} tbl_entry_t; +typedef int (*gfun_t)(); +typedef void (*pfun_t)(char); +typedef uint16_t builtin_t; +enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, LET, LETSTAR, +CLOSURE, PSTAR, QUOTE, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, +ANALOGREAD, REGISTER, FORMAT, + }; +extern object Workspace[WORKSPACESIZE] WORDALIGNED; +extern jmp_buf toplevel_handler; +extern jmp_buf *handler; +extern unsigned int Freespace; +extern object *Freelist; +extern unsigned int I2Ccount; +extern unsigned int TraceFn[TRACEMAX]; +extern unsigned int TraceDepth[TRACEMAX]; +extern builtin_t Context; +extern object *GlobalEnv; +extern object *GCStack; +extern object *GlobalString; +extern object *GlobalStringTail; +extern int GlobalStringIndex; +extern uint8_t PrintCount; +extern uint8_t BreakLevel; +extern char LastChar; +extern char LastPrint; +enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, NOECHO, MUFFLEERRORS }; +extern volatile uint8_t Flags; +void errorsub (symbol_t fname, PGM_P string); +void errorend (); +void errorsym (symbol_t fname, PGM_P string, object *symbol); +void errorsym2 (symbol_t fname, PGM_P string); +void error (PGM_P string, object *symbol); +void error2 (PGM_P string); +void formaterr (object *formatstr, PGM_P string, uint8_t p); +extern const char notanumber[] PROGMEM; +extern const char notaninteger[] PROGMEM; +extern const char notastring[] PROGMEM; +extern const char notalist[] PROGMEM; +extern const char notasymbol[] PROGMEM; +extern const char notproper[] PROGMEM; +extern const char toomanyargs[] PROGMEM; +extern const char toofewargs[] PROGMEM; +extern const char noargument[] PROGMEM; +extern const char nostream[] PROGMEM; +extern const char overflow[] PROGMEM; +extern const char divisionbyzero[] PROGMEM; +extern const char indexnegative[] PROGMEM; +extern const char invalidarg[] PROGMEM; +extern const char invalidkey[] PROGMEM; +extern const char illegalclause[] PROGMEM; +extern const char invalidpin[] PROGMEM; +extern const char oddargs[] PROGMEM; +extern const char indexrange[] PROGMEM; +extern const char canttakecar[] PROGMEM; +extern const char canttakecdr[] PROGMEM; +extern const char unknownstreamtype[] PROGMEM; +void initworkspace (); +object *myalloc (); +inline void myfree (object *obj); +object *number (int n); +object *makefloat (float f); +object *character (uint8_t c); +object *cons (object *arg1, object *arg2); +object *symbol (symbol_t name); +inline object *bsymbol (builtin_t name); +object *intern (symbol_t name); +bool eqsymbols (object *obj, char *buffer); +object *internlong (char *buffer); +object *stream (uint8_t streamtype, uint8_t address); +object *newstring (); +void markobject (object *obj); +void sweep (); +void gc (object *form, object *env); +int tracing (symbol_t name); +void trace (symbol_t name); +void untrace (symbol_t name); +bool consp (object *x); +#define atom(x) (!consp(x)) +bool listp (object *x); +#define improperp(x) (!listp(x)) +object *quote (object *arg); +builtin_t builtin (symbol_t name); +symbol_t sym (builtin_t x); +int8_t toradix40 (char ch); +char fromradix40 (char n); +uint32_t pack40 (char *buffer); +bool valid40 (char *buffer); +int8_t digitvalue (char d); +int checkinteger (object *obj); +int checkbitvalue (object *obj); +float checkintfloat (object *obj); +int checkchar (object *obj); +object *checkstring (object *obj); +int isstream (object *obj); +int isbuiltin (object *obj, builtin_t n); +bool builtinp (symbol_t name); +int checkkeyword (object *obj); +void checkargs (object *args); +boolean eq (object *arg1, object *arg2); +boolean equal (object *arg1, object *arg2); +int listlength (object *list); +object *add_floats (object *args, float fresult); +object *subtract_floats (object *args, float fresult); +object *negate (object *arg); +object *multiply_floats (object *args, float fresult); +object *divide_floats (object *args, float fresult); +int myround (float number); +object *compare (object *args, bool lt, bool gt, bool eq); +int intpower (int base, int exp); +object *assoc (object *key, object *list); +object *delassoc (object *key, object **alist); +int nextpower2 (int n); +object *buildarray (int n, int s, object *def); +object *makearray (object *dims, object *def, bool bitp); +object **arrayref (object *array, int index, int size); +object **getarray (object *array, object *subs, object *env, int *bit); +void rslice (object *array, int size, int slice, object *dims, object *args); +object *readarray (int d, object *args); +object *readbitarray (gfun_t gfun); +void pslice (object *array, int size, int slice, object *dims, pfun_t pfun, bool bitp); +void printarray (object *array, pfun_t pfun); +void indent (uint8_t spaces, char ch, pfun_t pfun); +object *startstring (); +object *princtostring (object *arg); +void buildstring (char ch, object **tail); +object *copystring (object *arg); +object *readstring (uint8_t delim, gfun_t gfun); +int stringlength (object *form); +uint8_t nthchar (object *string, int n); +int gstr (); +void pstr (char c); +object *lispstring (char *s); +bool stringcompare (object *args, bool lt, bool gt, bool eq); +object *documentation (object *arg, object *env); +object *apropos (object *arg, bool print); +char *cstring (object *form, char *buffer, int buflen); +uint32_t ipstring (object *form); +object *value (symbol_t n, object *env); +object *findpair (object *var, object *env); +bool boundp (object *var, object *env); +object *findvalue (object *var, object *env); +object *closure (int tc, symbol_t name, object *function, object *args, object **env); +object *apply (object *function, object *args, object *env); +object **place (object *args, object *env, int *bit); +object *carx (object *arg); +object *cdrx (object *arg); +object *cxxxr (object *args, uint8_t pattern); +void mapcarfun (object *result, object **tail); +void mapcanfun (object *result, object **tail); +object *mapcarcan (object *args, object *env, mapfun_t fun); +void I2Cinit (bool enablePullup); +int I2Cread (); +void I2Cwrite (uint8_t data); +bool I2Cstart (uint8_t address, uint8_t read); +bool I2Crestart (uint8_t address, uint8_t read); +void I2Cstop (uint8_t read); +inline int spiread (); +void serialbegin (int address, int baud); +void serialend (int address); +gfun_t gstreamfun (object *args); +inline void spiwrite (char c); +void checkanalogread (int pin); +void checkanalogwrite (int pin); +void tone (int pin, int note); +void noTone (int pin); +const int scale[] PROGMEM; +void playnote (int pin, int note, int octave); +void nonote (int pin); +void initsleep (); +void doze (int secs); +const int PPINDENT; +const int PPWIDTH; +const int GFXPPWIDTH; +int ppwidth; +void pcount (char c); +uint8_t atomwidth (object *obj); +uint8_t basewidth (object *obj, uint8_t base); +bool quoted (object *obj); +int subwidth (object *obj, int w); +int subwidthlist (object *form, int w); +void superprint (object *form, int lm, pfun_t pfun); +void supersub (object *form, int lm, int super, pfun_t pfun); +object *edit (object *fun); +object *sp_quote (object *args, object *env); +object *sp_or (object *args, object *env); +object *sp_defun (object *args, object *env); +object *sp_defvar (object *args, object *env); +object *sp_setq (object *args, object *env); +object *sp_loop (object *args, object *env); +object *sp_return (object *args, object *env); +object *sp_push (object *args, object *env); +object *sp_pop (object *args, object *env); +object *sp_incf (object *args, object *env); +object *sp_decf (object *args, object *env); +object *sp_setf (object *args, object *env); +object *sp_dolist (object *args, object *env); +object *sp_dotimes (object *args, object *env); +object *sp_trace (object *args, object *env); +object *sp_untrace (object *args, object *env); +object *sp_formillis (object *args, object *env); +object *sp_time (object *args, object *env); +object *sp_withoutputtostring (object *args, object *env); +object *sp_withserial (object *args, object *env); +object *sp_withi2c (object *args, object *env); +object *sp_withspi (object *args, object *env); +object *sp_withsdcard (object *args, object *env); +object *tf_progn (object *args, object *env); +object *tf_if (object *args, object *env); +object *tf_cond (object *args, object *env); +object *tf_when (object *args, object *env); +object *tf_unless (object *args, object *env); +object *tf_case (object *args, object *env); +object *tf_and (object *args, object *env); +object *fn_not (object *args, object *env); +object *fn_cons (object *args, object *env); +object *fn_atom (object *args, object *env); +object *fn_listp (object *args, object *env); +object *fn_consp (object *args, object *env); +object *fn_symbolp (object *args, object *env); +object *fn_arrayp (object *args, object *env); +object *fn_boundp (object *args, object *env); +object *fn_keywordp (object *args, object *env); +object *fn_setfn (object *args, object *env); +object *fn_streamp (object *args, object *env); +object *fn_eq (object *args, object *env); +object *fn_equal (object *args, object *env); +object *fn_car (object *args, object *env); +object *fn_cdr (object *args, object *env); +object *fn_caar (object *args, object *env); +object *fn_cadr (object *args, object *env); +object *fn_cdar (object *args, object *env); +object *fn_cddr (object *args, object *env); +object *fn_caaar (object *args, object *env); +object *fn_caadr (object *args, object *env); +object *fn_cadar (object *args, object *env); +object *fn_caddr (object *args, object *env); +object *fn_cdaar (object *args, object *env); +object *fn_cdadr (object *args, object *env); +object *fn_cddar (object *args, object *env); +object *fn_cdddr (object *args, object *env); +object *fn_length (object *args, object *env); +object *fn_arraydimensions (object *args, object *env); +object *fn_list (object *args, object *env); +object *fn_makearray (object *args, object *env); +object *fn_reverse (object *args, object *env); +object *fn_nth (object *args, object *env); +object *fn_aref (object *args, object *env); +object *fn_assoc (object *args, object *env); +object *fn_member (object *args, object *env); +object *fn_apply (object *args, object *env); +object *fn_funcall (object *args, object *env); +object *fn_append (object *args, object *env); +object *fn_mapc (object *args, object *env); +object *fn_mapcar (object *args, object *env); +object *fn_mapcan (object *args, object *env); +object *fn_add (object *args, object *env); +object *fn_subtract (object *args, object *env); +object *fn_multiply (object *args, object *env); +object *fn_divide (object *args, object *env); +object *fn_mod (object *args, object *env); +object *fn_oneplus (object *args, object *env); +object *fn_oneminus (object *args, object *env); +object *fn_abs (object *args, object *env); +object *fn_random (object *args, object *env); +object *fn_maxfn (object *args, object *env); +object *fn_minfn (object *args, object *env); +object *fn_noteq (object *args, object *env); +object *fn_numeq (object *args, object *env); +object *fn_less (object *args, object *env); +object *fn_lesseq (object *args, object *env); +object *fn_greater (object *args, object *env); +object *fn_greatereq (object *args, object *env); +object *fn_plusp (object *args, object *env); +object *fn_minusp (object *args, object *env); +object *fn_zerop (object *args, object *env); +object *fn_oddp (object *args, object *env); +object *fn_evenp (object *args, object *env); +object *fn_integerp (object *args, object *env); +object *fn_numberp (object *args, object *env); +object *fn_floatfn (object *args, object *env); +object *fn_floatp (object *args, object *env); +object *fn_sin (object *args, object *env); +object *fn_cos (object *args, object *env); +object *fn_tan (object *args, object *env); +object *fn_asin (object *args, object *env); +object *fn_acos (object *args, object *env); +object *fn_atan (object *args, object *env); +object *fn_sinh (object *args, object *env); +object *fn_cosh (object *args, object *env); +object *fn_tanh (object *args, object *env); +object *fn_exp (object *args, object *env); +object *fn_sqrt (object *args, object *env); +object *fn_log (object *args, object *env); +object *fn_expt (object *args, object *env); +object *fn_ceiling (object *args, object *env); +object *fn_floor (object *args, object *env); +object *fn_truncate (object *args, object *env); +object *fn_round (object *args, object *env); +object *fn_char (object *args, object *env); +object *fn_charcode (object *args, object *env); +object *fn_codechar (object *args, object *env); +object *fn_characterp (object *args, object *env); +object *fn_stringp (object *args, object *env); +object *fn_stringeq (object *args, object *env); +object *fn_stringless (object *args, object *env); +object *fn_stringgreater (object *args, object *env); +object *fn_sort (object *args, object *env); +object *fn_stringfn (object *args, object *env); +object *fn_concatenate (object *args, object *env); +object *fn_subseq (object *args, object *env); +object *fn_search (object *args, object *env); +object *fn_readfromstring (object *args, object *env); +object *fn_princtostring (object *args, object *env); +object *fn_prin1tostring (object *args, object *env); +object *fn_logand (object *args, object *env); +object *fn_logior (object *args, object *env); +object *fn_logxor (object *args, object *env); +object *fn_lognot (object *args, object *env); +object *fn_ash (object *args, object *env); +object *fn_logbitp (object *args, object *env); +object *fn_eval (object *args, object *env); +object *fn_globals (object *args, object *env); +object *fn_locals (object *args, object *env); +object *fn_makunbound (object *args, object *env); +object *fn_break (object *args, object *env); +object *fn_read (object *args, object *env); +object *fn_prin1 (object *args, object *env); +object *fn_print (object *args, object *env); +object *fn_princ (object *args, object *env); +object *fn_terpri (object *args, object *env); +object *fn_readbyte (object *args, object *env); +object *fn_readline (object *args, object *env); +object *fn_writebyte (object *args, object *env); +object *fn_writestring (object *args, object *env); +object *fn_writeline (object *args, object *env); +object *fn_restarti2c (object *args, object *env); +object *fn_gc (object *obj, object *env); +object *fn_room (object *args, object *env); +object *fn_cls (object *args, object *env); +object *fn_pinmode (object *args, object *env); +object *fn_digitalread (object *args, object *env); +object *fn_digitalwrite (object *args, object *env); +object *fn_analogread (object *args, object *env); +object *fn_analogreadresolution (object *args, object *env); +object *fn_analogwrite (object *args, object *env); +object *fn_delay (object *args, object *env); +object *fn_millis (object *args, object *env); +object *fn_sleep (object *args, object *env); +object *fn_note (object *args, object *env); +object *fn_register (object *args, object *env); +object *fn_edit (object *args, object *env); +object *fn_pprint (object *args, object *env); +object *fn_pprintall (object *args, object *env); +object *fn_format (object *args, object *env); +object *fn_require (object *args, object *env); +object *fn_listlibrary (object *args, object *env); +object *sp_help (object *args, object *env); +object *fn_documentation (object *args, object *env); +object *fn_apropos (object *args, object *env); +object *fn_aproposlist (object *args, object *env); +object *sp_unwindprotect (object *args, object *env); +object *sp_ignoreerrors (object *args, object *env); +object *sp_error (object *args, object *env); +object *sp_withclient (object *args, object *env); +object *fn_available (object *args, object *env); +object *fn_wifiserver (object *args, object *env); +object *fn_wifisoftap (object *args, object *env); +object *fn_connected (object *args, object *env); +object *fn_wifilocalip (object *args, object *env); +object *fn_wificonnect (object *args, object *env); +object *sp_withgfx (object *args, object *env); +object *fn_drawpixel (object *args, object *env); +object *fn_drawline (object *args, object *env); +object *fn_drawrect (object *args, object *env); +object *fn_fillrect (object *args, object *env); +object *fn_drawcircle (object *args, object *env); +object *fn_fillcircle (object *args, object *env); +object *fn_drawroundrect (object *args, object *env); +object *fn_fillroundrect (object *args, object *env); +object *fn_drawtriangle (object *args, object *env); +object *fn_filltriangle (object *args, object *env); +object *fn_drawchar (object *args, object *env); +object *fn_setcursor (object *args, object *env); +object *fn_settextcolor (object *args, object *env); +object *fn_settextsize (object *args, object *env); +object *fn_settextwrap (object *args, object *env); +object *fn_fillscreen (object *args, object *env); +object *fn_setrotation (object *args, object *env); +object *fn_invertdisplay (object *args, object *env); +extern const char string0[] PROGMEM; +extern const char string1[] PROGMEM; +extern const char string2[] PROGMEM; +extern const char string3[] PROGMEM; +extern const char string4[] PROGMEM; +extern const char string5[] PROGMEM; +extern const char string6[] PROGMEM; +extern const char string7[] PROGMEM; +extern const char string8[] PROGMEM; +extern const char string9[] PROGMEM; +extern const char string10[] PROGMEM; +extern const char string11[] PROGMEM; +extern const char string12[] PROGMEM; +extern const char string13[] PROGMEM; +extern const char string14[] PROGMEM; +extern const char string15[] PROGMEM; +extern const char string16[] PROGMEM; +extern const char string17[] PROGMEM; +extern const char string18[] PROGMEM; +extern const char string19[] PROGMEM; +extern const char string20[] PROGMEM; +extern const char string21[] PROGMEM; +extern const char string22[] PROGMEM; +extern const char string23[] PROGMEM; +extern const char string24[] PROGMEM; +extern const char string25[] PROGMEM; +extern const char string26[] PROGMEM; +extern const char string27[] PROGMEM; +extern const char string28[] PROGMEM; +extern const char string29[] PROGMEM; +extern const char string30[] PROGMEM; +extern const char string31[] PROGMEM; +extern const char string32[] PROGMEM; +extern const char string33[] PROGMEM; +extern const char string34[] PROGMEM; +extern const char string35[] PROGMEM; +extern const char string36[] PROGMEM; +extern const char string37[] PROGMEM; +extern const char string38[] PROGMEM; +extern const char string39[] PROGMEM; +extern const char string40[] PROGMEM; +extern const char string41[] PROGMEM; +extern const char string42[] PROGMEM; +extern const char string43[] PROGMEM; +extern const char string44[] PROGMEM; +extern const char string45[] PROGMEM; +extern const char string46[] PROGMEM; +extern const char string47[] PROGMEM; +extern const char string48[] PROGMEM; +extern const char string49[] PROGMEM; +extern const char string50[] PROGMEM; +extern const char string51[] PROGMEM; +extern const char string52[] PROGMEM; +extern const char string53[] PROGMEM; +extern const char string54[] PROGMEM; +extern const char string55[] PROGMEM; +extern const char string56[] PROGMEM; +extern const char string57[] PROGMEM; +extern const char string58[] PROGMEM; +extern const char string59[] PROGMEM; +extern const char string60[] PROGMEM; +extern const char string61[] PROGMEM; +extern const char string62[] PROGMEM; +extern const char string63[] PROGMEM; +extern const char string64[] PROGMEM; +extern const char string65[] PROGMEM; +extern const char string66[] PROGMEM; +extern const char string67[] PROGMEM; +extern const char string68[] PROGMEM; +extern const char string69[] PROGMEM; +extern const char string70[] PROGMEM; +extern const char string71[] PROGMEM; +extern const char string72[] PROGMEM; +extern const char string73[] PROGMEM; +extern const char string74[] PROGMEM; +extern const char string75[] PROGMEM; +extern const char string76[] PROGMEM; +extern const char string77[] PROGMEM; +extern const char string78[] PROGMEM; +extern const char string79[] PROGMEM; +extern const char string80[] PROGMEM; +extern const char string81[] PROGMEM; +extern const char string82[] PROGMEM; +extern const char string83[] PROGMEM; +extern const char string84[] PROGMEM; +extern const char string85[] PROGMEM; +extern const char string86[] PROGMEM; +extern const char string87[] PROGMEM; +extern const char string88[] PROGMEM; +extern const char string89[] PROGMEM; +extern const char string90[] PROGMEM; +extern const char string91[] PROGMEM; +extern const char string92[] PROGMEM; +extern const char string93[] PROGMEM; +extern const char string94[] PROGMEM; +extern const char string95[] PROGMEM; +extern const char string96[] PROGMEM; +extern const char string97[] PROGMEM; +extern const char string98[] PROGMEM; +extern const char string99[] PROGMEM; +extern const char string100[] PROGMEM; +extern const char string101[] PROGMEM; +extern const char string102[] PROGMEM; +extern const char string103[] PROGMEM; +extern const char string104[] PROGMEM; +extern const char string105[] PROGMEM; +extern const char string106[] PROGMEM; +extern const char string107[] PROGMEM; +extern const char string108[] PROGMEM; +extern const char string109[] PROGMEM; +extern const char string110[] PROGMEM; +extern const char string111[] PROGMEM; +extern const char string112[] PROGMEM; +extern const char string113[] PROGMEM; +extern const char string114[] PROGMEM; +extern const char string115[] PROGMEM; +extern const char string116[] PROGMEM; +extern const char string117[] PROGMEM; +extern const char string118[] PROGMEM; +extern const char string119[] PROGMEM; +extern const char string120[] PROGMEM; +extern const char string121[] PROGMEM; +extern const char string122[] PROGMEM; +extern const char string123[] PROGMEM; +extern const char string124[] PROGMEM; +extern const char string125[] PROGMEM; +extern const char string126[] PROGMEM; +extern const char string127[] PROGMEM; +extern const char string128[] PROGMEM; +extern const char string129[] PROGMEM; +extern const char string130[] PROGMEM; +extern const char string131[] PROGMEM; +extern const char string132[] PROGMEM; +extern const char string133[] PROGMEM; +extern const char string134[] PROGMEM; +extern const char string135[] PROGMEM; +extern const char string136[] PROGMEM; +extern const char string137[] PROGMEM; +extern const char string138[] PROGMEM; +extern const char string139[] PROGMEM; +extern const char string140[] PROGMEM; +extern const char string141[] PROGMEM; +extern const char string142[] PROGMEM; +extern const char string143[] PROGMEM; +extern const char string144[] PROGMEM; +extern const char string145[] PROGMEM; +extern const char string146[] PROGMEM; +extern const char string147[] PROGMEM; +extern const char string148[] PROGMEM; +extern const char string149[] PROGMEM; +extern const char string150[] PROGMEM; +extern const char string151[] PROGMEM; +extern const char string152[] PROGMEM; +extern const char string153[] PROGMEM; +extern const char string154[] PROGMEM; +extern const char string155[] PROGMEM; +extern const char string156[] PROGMEM; +extern const char string157[] PROGMEM; +extern const char string158[] PROGMEM; +extern const char string159[] PROGMEM; +extern const char string160[] PROGMEM; +extern const char string161[] PROGMEM; +extern const char string162[] PROGMEM; +extern const char string163[] PROGMEM; +extern const char string164[] PROGMEM; +extern const char string165[] PROGMEM; +extern const char string166[] PROGMEM; +extern const char string167[] PROGMEM; +extern const char string168[] PROGMEM; +extern const char string169[] PROGMEM; +extern const char string170[] PROGMEM; +extern const char string171[] PROGMEM; +extern const char string172[] PROGMEM; +extern const char string173[] PROGMEM; +extern const char string174[] PROGMEM; +extern const char string175[] PROGMEM; +extern const char string176[] PROGMEM; +extern const char string177[] PROGMEM; +extern const char string180[] PROGMEM; +extern const char string181[] PROGMEM; +extern const char string182[] PROGMEM; +extern const char string183[] PROGMEM; +extern const char string184[] PROGMEM; +extern const char string185[] PROGMEM; +extern const char string186[] PROGMEM; +extern const char string187[] PROGMEM; +extern const char string188[] PROGMEM; +extern const char string189[] PROGMEM; +extern const char string190[] PROGMEM; +extern const char string191[] PROGMEM; +extern const char string192[] PROGMEM; +extern const char string193[] PROGMEM; +extern const char string194[] PROGMEM; +extern const char string195[] PROGMEM; +extern const char string196[] PROGMEM; +extern const char string197[] PROGMEM; +extern const char string198[] PROGMEM; +extern const char string199[] PROGMEM; +extern const char string200[] PROGMEM; +extern const char string201[] PROGMEM; +extern const char string202[] PROGMEM; +extern const char string203[] PROGMEM; +extern const char string204[] PROGMEM; +extern const char string205[] PROGMEM; +extern const char string206[] PROGMEM; +extern const char string207[] PROGMEM; +extern const char string208[] PROGMEM; +extern const char string209[] PROGMEM; +extern const char string210[] PROGMEM; +extern const char string211[] PROGMEM; +extern const char string212[] PROGMEM; +extern const char string213[] PROGMEM; +extern const char string214[] PROGMEM; +extern const char string215[] PROGMEM; +extern const char string216[] PROGMEM; +extern const char string217[] PROGMEM; +extern const char string218[] PROGMEM; +extern const char string219[] PROGMEM; +extern const char string220[] PROGMEM; +extern const char string221[] PROGMEM; +extern const char string222[] PROGMEM; +extern const char string223[] PROGMEM; +extern const char string224[] PROGMEM; +extern const char string225[] PROGMEM; +extern const char string226[] PROGMEM; +extern const char string227[] PROGMEM; +extern const char string228[] PROGMEM; +extern const char string229[] PROGMEM; +extern const char string230[] PROGMEM; +extern const char string231[] PROGMEM; +extern const char string232[] PROGMEM; +extern const char doc0[] PROGMEM; +extern const char doc1[] PROGMEM; +extern const char doc2[] PROGMEM; +extern const char doc3[] PROGMEM; +extern const char doc7[] PROGMEM; +extern const char doc8[] PROGMEM; +extern const char doc9[] PROGMEM; +extern const char doc10[] PROGMEM; +extern const char doc14[] PROGMEM; +extern const char doc15[] PROGMEM; +extern const char doc16[] PROGMEM; +extern const char doc18[] PROGMEM; +extern const char doc20[] PROGMEM; +extern const char doc21[] PROGMEM; +extern const char doc22[] PROGMEM; +extern const char doc23[] PROGMEM; +extern const char doc24[] PROGMEM; +extern const char doc25[] PROGMEM; +extern const char doc26[] PROGMEM; +extern const char doc27[] PROGMEM; +extern const char doc28[] PROGMEM; +extern const char doc29[] PROGMEM; +extern const char doc30[] PROGMEM; +extern const char doc31[] PROGMEM; +extern const char doc32[] PROGMEM; +extern const char doc33[] PROGMEM; +extern const char doc34[] PROGMEM; +extern const char doc35[] PROGMEM; +extern const char doc36[] PROGMEM; +extern const char doc37[] PROGMEM; +extern const char doc38[] PROGMEM; +extern const char doc39[] PROGMEM; +extern const char doc40[] PROGMEM; +extern const char doc41[] PROGMEM; +extern const char doc42[] PROGMEM; +extern const char doc43[] PROGMEM; +extern const char doc44[] PROGMEM; +extern const char doc45[] PROGMEM; +extern const char doc46[] PROGMEM; +extern const char doc47[] PROGMEM; +extern const char doc48[] PROGMEM; +extern const char doc49[] PROGMEM; +extern const char doc50[] PROGMEM; +extern const char doc51[] PROGMEM; +extern const char doc52[] PROGMEM; +extern const char doc53[] PROGMEM; +extern const char doc54[] PROGMEM; +extern const char doc55[] PROGMEM; +extern const char doc57[] PROGMEM; +extern const char doc58[] PROGMEM; +extern const char doc59[] PROGMEM; +extern const char doc60[] PROGMEM; +extern const char doc61[] PROGMEM; +extern const char doc62[] PROGMEM; +extern const char doc63[] PROGMEM; +extern const char doc64[] PROGMEM; +extern const char doc65[] PROGMEM; +extern const char doc66[] PROGMEM; +extern const char doc67[] PROGMEM; +extern const char doc68[] PROGMEM; +extern const char doc69[] PROGMEM; +extern const char doc70[] PROGMEM; +extern const char doc72[] PROGMEM; +extern const char doc73[] PROGMEM; +extern const char doc74[] PROGMEM; +extern const char doc75[] PROGMEM; +extern const char doc76[] PROGMEM; +extern const char doc77[] PROGMEM; +extern const char doc79[] PROGMEM; +extern const char doc80[] PROGMEM; +extern const char doc81[] PROGMEM; +extern const char doc82[] PROGMEM; +extern const char doc83[] PROGMEM; +extern const char doc84[] PROGMEM; +extern const char doc85[] PROGMEM; +extern const char doc86[] PROGMEM; +extern const char doc87[] PROGMEM; +extern const char doc88[] PROGMEM; +extern const char doc89[] PROGMEM; +extern const char doc90[] PROGMEM; +extern const char doc91[] PROGMEM; +extern const char doc92[] PROGMEM; +extern const char doc93[] PROGMEM; +extern const char doc94[] PROGMEM; +extern const char doc95[] PROGMEM; +extern const char doc96[] PROGMEM; +extern const char doc97[] PROGMEM; +extern const char doc98[] PROGMEM; +extern const char doc99[] PROGMEM; +extern const char doc100[] PROGMEM; +extern const char doc101[] PROGMEM; +extern const char doc102[] PROGMEM; +extern const char doc103[] PROGMEM; +extern const char doc104[] PROGMEM; +extern const char doc105[] PROGMEM; +extern const char doc106[] PROGMEM; +extern const char doc107[] PROGMEM; +extern const char doc108[] PROGMEM; +extern const char doc109[] PROGMEM; +extern const char doc110[] PROGMEM; +extern const char doc111[] PROGMEM; +extern const char doc112[] PROGMEM; +extern const char doc113[] PROGMEM; +extern const char doc114[] PROGMEM; +extern const char doc115[] PROGMEM; +extern const char doc116[] PROGMEM; +extern const char doc117[] PROGMEM; +extern const char doc118[] PROGMEM; +extern const char doc119[] PROGMEM; +extern const char doc120[] PROGMEM; +extern const char doc121[] PROGMEM; +extern const char doc122[] PROGMEM; +extern const char doc123[] PROGMEM; +extern const char doc124[] PROGMEM; +extern const char doc125[] PROGMEM; +extern const char doc126[] PROGMEM; +extern const char doc127[] PROGMEM; +extern const char doc128[] PROGMEM; +extern const char doc129[] PROGMEM; +extern const char doc130[] PROGMEM; +extern const char doc131[] PROGMEM; +extern const char doc132[] PROGMEM; +extern const char doc133[] PROGMEM; +extern const char doc134[] PROGMEM; +extern const char doc135[] PROGMEM; +extern const char doc136[] PROGMEM; +extern const char doc137[] PROGMEM; +extern const char doc138[] PROGMEM; +extern const char doc139[] PROGMEM; +extern const char doc140[] PROGMEM; +extern const char doc141[] PROGMEM; +extern const char doc142[] PROGMEM; +extern const char doc143[] PROGMEM; +extern const char doc144[] PROGMEM; +extern const char doc145[] PROGMEM; +extern const char doc146[] PROGMEM; +extern const char doc147[] PROGMEM; +extern const char doc148[] PROGMEM; +extern const char doc149[] PROGMEM; +extern const char doc150[] PROGMEM; +extern const char doc151[] PROGMEM; +extern const char doc152[] PROGMEM; +extern const char doc153[] PROGMEM; +extern const char doc154[] PROGMEM; +extern const char doc155[] PROGMEM; +extern const char doc156[] PROGMEM; +extern const char doc157[] PROGMEM; +extern const char doc158[] PROGMEM; +extern const char doc159[] PROGMEM; +extern const char doc160[] PROGMEM; +extern const char doc161[] PROGMEM; +extern const char doc162[] PROGMEM; +extern const char doc163[] PROGMEM; +extern const char doc164[] PROGMEM; +extern const char doc165[] PROGMEM; +extern const char doc166[] PROGMEM; +extern const char doc167[] PROGMEM; +extern const char doc168[] PROGMEM; +extern const char doc169[] PROGMEM; +extern const char doc170[] PROGMEM; +extern const char doc171[] PROGMEM; +extern const char doc172[] PROGMEM; +extern const char doc173[] PROGMEM; +extern const char doc174[] PROGMEM; +extern const char doc175[] PROGMEM; +extern const char doc176[] PROGMEM; +extern const char doc177[] PROGMEM; +extern const char doc180[] PROGMEM; +extern const char doc181[] PROGMEM; +extern const char doc182[] PROGMEM; +extern const char doc183[] PROGMEM; +extern const char doc184[] PROGMEM; +extern const char doc185[] PROGMEM; +extern const char doc186[] PROGMEM; +extern const char doc187[] PROGMEM; +extern const char doc188[] PROGMEM; +extern const char doc189[] PROGMEM; +extern const char doc190[] PROGMEM; +extern const char doc191[] PROGMEM; +extern const char doc192[] PROGMEM; +extern const char doc193[] PROGMEM; +extern const char doc194[] PROGMEM; +extern const char doc195[] PROGMEM; +extern const char doc196[] PROGMEM; +extern const char doc197[] PROGMEM; +extern const char doc198[] PROGMEM; +extern const char doc199[] PROGMEM; +extern const char doc200[] PROGMEM; +extern const char doc201[] PROGMEM; +extern const char doc202[] PROGMEM; +extern const char doc203[] PROGMEM; +extern const char doc204[] PROGMEM; +extern const char doc205[] PROGMEM; +extern const char doc206[] PROGMEM; +extern const char doc207[] PROGMEM; +extern const char doc208[] PROGMEM; +extern const char doc209[] PROGMEM; +extern const char doc210[] PROGMEM; +extern const char doc211[] PROGMEM; +extern const char doc212[] PROGMEM; +extern const char doc213[] PROGMEM; +extern const char doc214[] PROGMEM; +extern const char doc215[] PROGMEM; +extern const char doc216[] PROGMEM; +extern const char doc217[] PROGMEM; +extern const char doc218[] PROGMEM; +extern const char doc219[] PROGMEM; +extern const char doc220[] PROGMEM; +extern const char doc221[] PROGMEM; +extern const char doc222[] PROGMEM; +extern const char doc223[] PROGMEM; +extern const char doc224[] PROGMEM; +extern const char doc225[] PROGMEM; +const tbl_entry_t lookup_table[] PROGMEM; +#if !defined(extensions) +tbl_entry_t *tables[]; +const unsigned int tablesizes[]; +const tbl_entry_t *table (int n); +unsigned int tablesize (int n); +#endif +intptr_t lookupfn (builtin_t name); +uint8_t getminmax (builtin_t name); +void checkminmax (builtin_t name, int nargs); +char *lookupdoc (builtin_t name); +bool findsubstring (char *part, builtin_t name); +void testescape (); +bool keywordp (object *obj); +object *eval (object *form, object *env); +void pserial (char c); +extern const char ControlCodes[] PROGMEM; +void pcharacter (uint8_t c, pfun_t pfun); +void pstring (char *s, pfun_t pfun); +void plispstring (object *form, pfun_t pfun); +void plispstr (symbol_t name, pfun_t pfun); +void printstring (object *form, pfun_t pfun); +void pbuiltin (builtin_t name, pfun_t pfun); +void pradix40 (symbol_t name, pfun_t pfun); +void printsymbol (object *form, pfun_t pfun); +void psymbol (symbol_t name, pfun_t pfun); +void pfstring (PGM_P s, pfun_t pfun); +void pint (int i, pfun_t pfun); +void pintbase (uint32_t i, uint8_t base, pfun_t pfun); +void pmantissa (float f, pfun_t pfun); +void pfloat (float f, pfun_t pfun); +inline void pln (pfun_t pfun); +void pfl (pfun_t pfun); +void plist (object *form, pfun_t pfun); +void pstream (object *form, pfun_t pfun); +void printobject (object *form, pfun_t pfun); +void prin1object (object *form, pfun_t pfun); +int glibrary (); +void loadfromlibrary (object *env); +int gserial (); +object *nextitem (gfun_t gfun); +object *readrest (gfun_t gfun); +object *read (gfun_t gfun); +void initenv (); +void initgfx (); +void repl (object *env); +void ulispreset (); +#include "ulisp.c" +#ifdef __cplusplus +} +#endif +#endif \ No newline at end of file From 2849549ee4061f53c70302c24fcc117bb7acbec9 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 25 Mar 2023 11:55:49 -0400 Subject: [PATCH 003/109] note changes --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index 90f06df..591a052 100644 --- a/README.md +++ b/README.md @@ -11,3 +11,4 @@ Patches: * Deleted load/save/autorunimage support * different garbage collect message +* no line-editor support (you can just use `rlwrap` if you have it) From c34ee2d892cce488cf86924d23658503c596472b Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 25 Mar 2023 11:56:53 -0400 Subject: [PATCH 004/109] mine --- mine | 2 ++ 1 file changed, 2 insertions(+) create mode 100755 mine diff --git a/mine b/mine new file mode 100755 index 0000000..33aef86 --- /dev/null +++ b/mine @@ -0,0 +1,2 @@ +#! /bin/bash +sudo chown --recursive $USER . From dc3f9d078370b6042167c519913e42d37be6ac62 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 25 Mar 2023 14:17:10 -0400 Subject: [PATCH 005/109] whoops stray #endif --- ulisp.c | 1 - 1 file changed, 1 deletion(-) diff --git a/ulisp.c b/ulisp.c index d3b2c73..81f12e2 100644 --- a/ulisp.c +++ b/ulisp.c @@ -6710,7 +6710,6 @@ int gserial () { char temp = Serial.read(); if (temp != '\n' && !tstflag(NOECHO)) pserial(temp); return temp; -#endif } /* From b535d64cd790bcec242b25097045dc6184c2f51a Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 25 Mar 2023 14:40:02 -0400 Subject: [PATCH 006/109] fix a few things --- ulisp-extensions.ino => extensions.cpp | 2 ++ ulisp.c => ulisp.cpp | 1 + ulisp.h | 12 ++++-------- 3 files changed, 7 insertions(+), 8 deletions(-) rename ulisp-extensions.ino => extensions.cpp (97%) rename ulisp.c => ulisp.cpp (99%) diff --git a/ulisp-extensions.ino b/extensions.cpp similarity index 97% rename from ulisp-extensions.ino rename to extensions.cpp index 7c5599e..a895c66 100644 --- a/ulisp-extensions.ino +++ b/extensions.cpp @@ -1,6 +1,8 @@ /* User Extensions */ +#include +#include "ulisp.h" // Definitions object *fn_now (object *args, object *env) { diff --git a/ulisp.c b/ulisp.cpp similarity index 99% rename from ulisp.c rename to ulisp.cpp index 81f12e2..e6e12b7 100644 --- a/ulisp.c +++ b/ulisp.cpp @@ -4,6 +4,7 @@ Licensed under the MIT license: https://opensource.org/licenses/MIT */ #include "ulisp.h" +#pragma once // Includes diff --git a/ulisp.h b/ulisp.h index 6a9436b..ce76732 100644 --- a/ulisp.h +++ b/ulisp.h @@ -4,9 +4,7 @@ */ #ifndef ULISP_H #define ULISP_H -#ifdef __cplusplus -extern "C" { -#endif +#include #include #include #include @@ -39,7 +37,8 @@ Adafruit_ST7789 tft; #define second(x) (car(cdr(x))) #define cddr(x) (cdr(cdr(x))) #define third(x) (car(cdr(cdr(x)))) -#define push(x, y) ((y); +#define push(x, y) ((y) = cons((x), (y))); +extern const int TRACEMAX; enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; enum token { UNUSED, BRA, KET, QUO, DOT }; enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM }; @@ -958,8 +957,5 @@ void initenv (); void initgfx (); void repl (object *env); void ulispreset (); -#include "ulisp.c" -#ifdef __cplusplus -} +#include "ulisp.cpp" #endif -#endif \ No newline at end of file From 2e0f39af927dc2b450fcc18c551c2cd08b552355 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sun, 26 Mar 2023 20:20:35 -0400 Subject: [PATCH 007/109] it now compiles --- extensions.cpp => extensions.hpp | 11 +- ulisp-esp32.ino | 6 +- ulisp.h | 961 ------------------ ulisp.cpp => ulisp.hpp | 1621 ++++++++++++++++-------------- 4 files changed, 886 insertions(+), 1713 deletions(-) rename extensions.cpp => extensions.hpp (85%) delete mode 100644 ulisp.h rename ulisp.cpp => ulisp.hpp (84%) diff --git a/extensions.cpp b/extensions.hpp similarity index 85% rename from extensions.cpp rename to extensions.hpp index a895c66..89db803 100644 --- a/extensions.cpp +++ b/extensions.hpp @@ -2,10 +2,11 @@ User Extensions */ #include -#include "ulisp.h" +#define extensions +#include "ulisp.hpp" // Definitions -object *fn_now (object *args, object *env) { +object* fn_now (object* args, object* env) { (void) env; static unsigned long Offset; unsigned long now = millis()/1000; @@ -19,9 +20,9 @@ object *fn_now (object *args, object *env) { // Return time unsigned long secs = Offset + now; - object *seconds = number(secs%60); - object *minutes = number((secs/60)%60); - object *hours = number((secs/3600)%24); + object* seconds = number(secs%60); + object* minutes = number((secs/60)%60); + object* hours = number((secs/3600)%24); return cons(hours, cons(minutes, cons(seconds, NULL))); } diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index e444924..e7cea87 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -3,10 +3,6 @@ Licensed under the MIT license: https://opensource.org/licenses/MIT */ - -// Lisp Library -const char LispLibrary[] PROGMEM = ""; - // Compile options #define printfreespace @@ -17,7 +13,7 @@ const char LispLibrary[] PROGMEM = ""; // #define extensions // Includes -#include "ulisp.h" +#include "ulisp.hpp" /* setup - entry point from the Arduino IDE diff --git a/ulisp.h b/ulisp.h deleted file mode 100644 index ce76732..0000000 --- a/ulisp.h +++ /dev/null @@ -1,961 +0,0 @@ -/* uLisp ESP Release 4.4 - www.ulisp.com - David Johnson-Davies - www.technoblogy.com - 21st March 2023 - Licensed under the MIT license: https://opensource.org/licenses/MIT -*/ -#ifndef ULISP_H -#define ULISP_H -#include -#include -#include -#include -#include -#include -#include -#if defined(gfxsupport) -#define COLOR_WHITE ST77XX_WHITE -#define COLOR_BLACK ST77XX_BLACK -#include -#include -Adafruit_ST7789 tft; -#define TFT_BACKLITE 4 -#endif -#include -#define SDSIZE 172 -#define WORDALIGNED __attribute__((aligned (4))) -#define BUFFERSIZE 36 -#define WORKSPACESIZE (9216-SDSIZE) -#define LITTLEFS -#include "FS.h" -#include -#ifndef analogWrite -#define analogWrite(x,y) dacWrite((x),(y)) -#endif -#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 push(x, y) ((y) = cons((x), (y))); -extern const int TRACEMAX; -enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; -enum token { UNUSED, BRA, KET, QUO, DOT }; -enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM }; -enum fntypes_t { OTHER_FORMS, TAIL_FORMS, FUNCTIONS, SPECIAL_FORMS }; -extern const char serialstream[] PROGMEM; -extern const char i2cstream[] PROGMEM; -extern const char spistream[] PROGMEM; -extern const char sdstream[] PROGMEM; -extern const char wifistream[] PROGMEM; -extern const char stringstream[] PROGMEM; -extern const char gfxstream[] PROGMEM; -extern PGM_P const streamname[] PROGMEM; -typedef uint32_t symbol_t; -typedef struct sobject { - union { - struct { - sobject *car; - sobject *cdr; - }; - struct { - unsigned int type; - union { - symbol_t name; - int integer; - int chars; - float single_float; - }; - }; - }; -} object; -typedef object *(*fn_ptr_type)(object *, object *); -typedef void (*mapfun_t)(object *, object **); -typedef const struct { - PGM_P string; - fn_ptr_type fptr; - uint8_t minmax; - const char *doc; -} tbl_entry_t; -typedef int (*gfun_t)(); -typedef void (*pfun_t)(char); -typedef uint16_t builtin_t; -enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, LET, LETSTAR, -CLOSURE, PSTAR, QUOTE, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, -ANALOGREAD, REGISTER, FORMAT, - }; -extern object Workspace[WORKSPACESIZE] WORDALIGNED; -extern jmp_buf toplevel_handler; -extern jmp_buf *handler; -extern unsigned int Freespace; -extern object *Freelist; -extern unsigned int I2Ccount; -extern unsigned int TraceFn[TRACEMAX]; -extern unsigned int TraceDepth[TRACEMAX]; -extern builtin_t Context; -extern object *GlobalEnv; -extern object *GCStack; -extern object *GlobalString; -extern object *GlobalStringTail; -extern int GlobalStringIndex; -extern uint8_t PrintCount; -extern uint8_t BreakLevel; -extern char LastChar; -extern char LastPrint; -enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, NOECHO, MUFFLEERRORS }; -extern volatile uint8_t Flags; -void errorsub (symbol_t fname, PGM_P string); -void errorend (); -void errorsym (symbol_t fname, PGM_P string, object *symbol); -void errorsym2 (symbol_t fname, PGM_P string); -void error (PGM_P string, object *symbol); -void error2 (PGM_P string); -void formaterr (object *formatstr, PGM_P string, uint8_t p); -extern const char notanumber[] PROGMEM; -extern const char notaninteger[] PROGMEM; -extern const char notastring[] PROGMEM; -extern const char notalist[] PROGMEM; -extern const char notasymbol[] PROGMEM; -extern const char notproper[] PROGMEM; -extern const char toomanyargs[] PROGMEM; -extern const char toofewargs[] PROGMEM; -extern const char noargument[] PROGMEM; -extern const char nostream[] PROGMEM; -extern const char overflow[] PROGMEM; -extern const char divisionbyzero[] PROGMEM; -extern const char indexnegative[] PROGMEM; -extern const char invalidarg[] PROGMEM; -extern const char invalidkey[] PROGMEM; -extern const char illegalclause[] PROGMEM; -extern const char invalidpin[] PROGMEM; -extern const char oddargs[] PROGMEM; -extern const char indexrange[] PROGMEM; -extern const char canttakecar[] PROGMEM; -extern const char canttakecdr[] PROGMEM; -extern const char unknownstreamtype[] PROGMEM; -void initworkspace (); -object *myalloc (); -inline void myfree (object *obj); -object *number (int n); -object *makefloat (float f); -object *character (uint8_t c); -object *cons (object *arg1, object *arg2); -object *symbol (symbol_t name); -inline object *bsymbol (builtin_t name); -object *intern (symbol_t name); -bool eqsymbols (object *obj, char *buffer); -object *internlong (char *buffer); -object *stream (uint8_t streamtype, uint8_t address); -object *newstring (); -void markobject (object *obj); -void sweep (); -void gc (object *form, object *env); -int tracing (symbol_t name); -void trace (symbol_t name); -void untrace (symbol_t name); -bool consp (object *x); -#define atom(x) (!consp(x)) -bool listp (object *x); -#define improperp(x) (!listp(x)) -object *quote (object *arg); -builtin_t builtin (symbol_t name); -symbol_t sym (builtin_t x); -int8_t toradix40 (char ch); -char fromradix40 (char n); -uint32_t pack40 (char *buffer); -bool valid40 (char *buffer); -int8_t digitvalue (char d); -int checkinteger (object *obj); -int checkbitvalue (object *obj); -float checkintfloat (object *obj); -int checkchar (object *obj); -object *checkstring (object *obj); -int isstream (object *obj); -int isbuiltin (object *obj, builtin_t n); -bool builtinp (symbol_t name); -int checkkeyword (object *obj); -void checkargs (object *args); -boolean eq (object *arg1, object *arg2); -boolean equal (object *arg1, object *arg2); -int listlength (object *list); -object *add_floats (object *args, float fresult); -object *subtract_floats (object *args, float fresult); -object *negate (object *arg); -object *multiply_floats (object *args, float fresult); -object *divide_floats (object *args, float fresult); -int myround (float number); -object *compare (object *args, bool lt, bool gt, bool eq); -int intpower (int base, int exp); -object *assoc (object *key, object *list); -object *delassoc (object *key, object **alist); -int nextpower2 (int n); -object *buildarray (int n, int s, object *def); -object *makearray (object *dims, object *def, bool bitp); -object **arrayref (object *array, int index, int size); -object **getarray (object *array, object *subs, object *env, int *bit); -void rslice (object *array, int size, int slice, object *dims, object *args); -object *readarray (int d, object *args); -object *readbitarray (gfun_t gfun); -void pslice (object *array, int size, int slice, object *dims, pfun_t pfun, bool bitp); -void printarray (object *array, pfun_t pfun); -void indent (uint8_t spaces, char ch, pfun_t pfun); -object *startstring (); -object *princtostring (object *arg); -void buildstring (char ch, object **tail); -object *copystring (object *arg); -object *readstring (uint8_t delim, gfun_t gfun); -int stringlength (object *form); -uint8_t nthchar (object *string, int n); -int gstr (); -void pstr (char c); -object *lispstring (char *s); -bool stringcompare (object *args, bool lt, bool gt, bool eq); -object *documentation (object *arg, object *env); -object *apropos (object *arg, bool print); -char *cstring (object *form, char *buffer, int buflen); -uint32_t ipstring (object *form); -object *value (symbol_t n, object *env); -object *findpair (object *var, object *env); -bool boundp (object *var, object *env); -object *findvalue (object *var, object *env); -object *closure (int tc, symbol_t name, object *function, object *args, object **env); -object *apply (object *function, object *args, object *env); -object **place (object *args, object *env, int *bit); -object *carx (object *arg); -object *cdrx (object *arg); -object *cxxxr (object *args, uint8_t pattern); -void mapcarfun (object *result, object **tail); -void mapcanfun (object *result, object **tail); -object *mapcarcan (object *args, object *env, mapfun_t fun); -void I2Cinit (bool enablePullup); -int I2Cread (); -void I2Cwrite (uint8_t data); -bool I2Cstart (uint8_t address, uint8_t read); -bool I2Crestart (uint8_t address, uint8_t read); -void I2Cstop (uint8_t read); -inline int spiread (); -void serialbegin (int address, int baud); -void serialend (int address); -gfun_t gstreamfun (object *args); -inline void spiwrite (char c); -void checkanalogread (int pin); -void checkanalogwrite (int pin); -void tone (int pin, int note); -void noTone (int pin); -const int scale[] PROGMEM; -void playnote (int pin, int note, int octave); -void nonote (int pin); -void initsleep (); -void doze (int secs); -const int PPINDENT; -const int PPWIDTH; -const int GFXPPWIDTH; -int ppwidth; -void pcount (char c); -uint8_t atomwidth (object *obj); -uint8_t basewidth (object *obj, uint8_t base); -bool quoted (object *obj); -int subwidth (object *obj, int w); -int subwidthlist (object *form, int w); -void superprint (object *form, int lm, pfun_t pfun); -void supersub (object *form, int lm, int super, pfun_t pfun); -object *edit (object *fun); -object *sp_quote (object *args, object *env); -object *sp_or (object *args, object *env); -object *sp_defun (object *args, object *env); -object *sp_defvar (object *args, object *env); -object *sp_setq (object *args, object *env); -object *sp_loop (object *args, object *env); -object *sp_return (object *args, object *env); -object *sp_push (object *args, object *env); -object *sp_pop (object *args, object *env); -object *sp_incf (object *args, object *env); -object *sp_decf (object *args, object *env); -object *sp_setf (object *args, object *env); -object *sp_dolist (object *args, object *env); -object *sp_dotimes (object *args, object *env); -object *sp_trace (object *args, object *env); -object *sp_untrace (object *args, object *env); -object *sp_formillis (object *args, object *env); -object *sp_time (object *args, object *env); -object *sp_withoutputtostring (object *args, object *env); -object *sp_withserial (object *args, object *env); -object *sp_withi2c (object *args, object *env); -object *sp_withspi (object *args, object *env); -object *sp_withsdcard (object *args, object *env); -object *tf_progn (object *args, object *env); -object *tf_if (object *args, object *env); -object *tf_cond (object *args, object *env); -object *tf_when (object *args, object *env); -object *tf_unless (object *args, object *env); -object *tf_case (object *args, object *env); -object *tf_and (object *args, object *env); -object *fn_not (object *args, object *env); -object *fn_cons (object *args, object *env); -object *fn_atom (object *args, object *env); -object *fn_listp (object *args, object *env); -object *fn_consp (object *args, object *env); -object *fn_symbolp (object *args, object *env); -object *fn_arrayp (object *args, object *env); -object *fn_boundp (object *args, object *env); -object *fn_keywordp (object *args, object *env); -object *fn_setfn (object *args, object *env); -object *fn_streamp (object *args, object *env); -object *fn_eq (object *args, object *env); -object *fn_equal (object *args, object *env); -object *fn_car (object *args, object *env); -object *fn_cdr (object *args, object *env); -object *fn_caar (object *args, object *env); -object *fn_cadr (object *args, object *env); -object *fn_cdar (object *args, object *env); -object *fn_cddr (object *args, object *env); -object *fn_caaar (object *args, object *env); -object *fn_caadr (object *args, object *env); -object *fn_cadar (object *args, object *env); -object *fn_caddr (object *args, object *env); -object *fn_cdaar (object *args, object *env); -object *fn_cdadr (object *args, object *env); -object *fn_cddar (object *args, object *env); -object *fn_cdddr (object *args, object *env); -object *fn_length (object *args, object *env); -object *fn_arraydimensions (object *args, object *env); -object *fn_list (object *args, object *env); -object *fn_makearray (object *args, object *env); -object *fn_reverse (object *args, object *env); -object *fn_nth (object *args, object *env); -object *fn_aref (object *args, object *env); -object *fn_assoc (object *args, object *env); -object *fn_member (object *args, object *env); -object *fn_apply (object *args, object *env); -object *fn_funcall (object *args, object *env); -object *fn_append (object *args, object *env); -object *fn_mapc (object *args, object *env); -object *fn_mapcar (object *args, object *env); -object *fn_mapcan (object *args, object *env); -object *fn_add (object *args, object *env); -object *fn_subtract (object *args, object *env); -object *fn_multiply (object *args, object *env); -object *fn_divide (object *args, object *env); -object *fn_mod (object *args, object *env); -object *fn_oneplus (object *args, object *env); -object *fn_oneminus (object *args, object *env); -object *fn_abs (object *args, object *env); -object *fn_random (object *args, object *env); -object *fn_maxfn (object *args, object *env); -object *fn_minfn (object *args, object *env); -object *fn_noteq (object *args, object *env); -object *fn_numeq (object *args, object *env); -object *fn_less (object *args, object *env); -object *fn_lesseq (object *args, object *env); -object *fn_greater (object *args, object *env); -object *fn_greatereq (object *args, object *env); -object *fn_plusp (object *args, object *env); -object *fn_minusp (object *args, object *env); -object *fn_zerop (object *args, object *env); -object *fn_oddp (object *args, object *env); -object *fn_evenp (object *args, object *env); -object *fn_integerp (object *args, object *env); -object *fn_numberp (object *args, object *env); -object *fn_floatfn (object *args, object *env); -object *fn_floatp (object *args, object *env); -object *fn_sin (object *args, object *env); -object *fn_cos (object *args, object *env); -object *fn_tan (object *args, object *env); -object *fn_asin (object *args, object *env); -object *fn_acos (object *args, object *env); -object *fn_atan (object *args, object *env); -object *fn_sinh (object *args, object *env); -object *fn_cosh (object *args, object *env); -object *fn_tanh (object *args, object *env); -object *fn_exp (object *args, object *env); -object *fn_sqrt (object *args, object *env); -object *fn_log (object *args, object *env); -object *fn_expt (object *args, object *env); -object *fn_ceiling (object *args, object *env); -object *fn_floor (object *args, object *env); -object *fn_truncate (object *args, object *env); -object *fn_round (object *args, object *env); -object *fn_char (object *args, object *env); -object *fn_charcode (object *args, object *env); -object *fn_codechar (object *args, object *env); -object *fn_characterp (object *args, object *env); -object *fn_stringp (object *args, object *env); -object *fn_stringeq (object *args, object *env); -object *fn_stringless (object *args, object *env); -object *fn_stringgreater (object *args, object *env); -object *fn_sort (object *args, object *env); -object *fn_stringfn (object *args, object *env); -object *fn_concatenate (object *args, object *env); -object *fn_subseq (object *args, object *env); -object *fn_search (object *args, object *env); -object *fn_readfromstring (object *args, object *env); -object *fn_princtostring (object *args, object *env); -object *fn_prin1tostring (object *args, object *env); -object *fn_logand (object *args, object *env); -object *fn_logior (object *args, object *env); -object *fn_logxor (object *args, object *env); -object *fn_lognot (object *args, object *env); -object *fn_ash (object *args, object *env); -object *fn_logbitp (object *args, object *env); -object *fn_eval (object *args, object *env); -object *fn_globals (object *args, object *env); -object *fn_locals (object *args, object *env); -object *fn_makunbound (object *args, object *env); -object *fn_break (object *args, object *env); -object *fn_read (object *args, object *env); -object *fn_prin1 (object *args, object *env); -object *fn_print (object *args, object *env); -object *fn_princ (object *args, object *env); -object *fn_terpri (object *args, object *env); -object *fn_readbyte (object *args, object *env); -object *fn_readline (object *args, object *env); -object *fn_writebyte (object *args, object *env); -object *fn_writestring (object *args, object *env); -object *fn_writeline (object *args, object *env); -object *fn_restarti2c (object *args, object *env); -object *fn_gc (object *obj, object *env); -object *fn_room (object *args, object *env); -object *fn_cls (object *args, object *env); -object *fn_pinmode (object *args, object *env); -object *fn_digitalread (object *args, object *env); -object *fn_digitalwrite (object *args, object *env); -object *fn_analogread (object *args, object *env); -object *fn_analogreadresolution (object *args, object *env); -object *fn_analogwrite (object *args, object *env); -object *fn_delay (object *args, object *env); -object *fn_millis (object *args, object *env); -object *fn_sleep (object *args, object *env); -object *fn_note (object *args, object *env); -object *fn_register (object *args, object *env); -object *fn_edit (object *args, object *env); -object *fn_pprint (object *args, object *env); -object *fn_pprintall (object *args, object *env); -object *fn_format (object *args, object *env); -object *fn_require (object *args, object *env); -object *fn_listlibrary (object *args, object *env); -object *sp_help (object *args, object *env); -object *fn_documentation (object *args, object *env); -object *fn_apropos (object *args, object *env); -object *fn_aproposlist (object *args, object *env); -object *sp_unwindprotect (object *args, object *env); -object *sp_ignoreerrors (object *args, object *env); -object *sp_error (object *args, object *env); -object *sp_withclient (object *args, object *env); -object *fn_available (object *args, object *env); -object *fn_wifiserver (object *args, object *env); -object *fn_wifisoftap (object *args, object *env); -object *fn_connected (object *args, object *env); -object *fn_wifilocalip (object *args, object *env); -object *fn_wificonnect (object *args, object *env); -object *sp_withgfx (object *args, object *env); -object *fn_drawpixel (object *args, object *env); -object *fn_drawline (object *args, object *env); -object *fn_drawrect (object *args, object *env); -object *fn_fillrect (object *args, object *env); -object *fn_drawcircle (object *args, object *env); -object *fn_fillcircle (object *args, object *env); -object *fn_drawroundrect (object *args, object *env); -object *fn_fillroundrect (object *args, object *env); -object *fn_drawtriangle (object *args, object *env); -object *fn_filltriangle (object *args, object *env); -object *fn_drawchar (object *args, object *env); -object *fn_setcursor (object *args, object *env); -object *fn_settextcolor (object *args, object *env); -object *fn_settextsize (object *args, object *env); -object *fn_settextwrap (object *args, object *env); -object *fn_fillscreen (object *args, object *env); -object *fn_setrotation (object *args, object *env); -object *fn_invertdisplay (object *args, object *env); -extern const char string0[] PROGMEM; -extern const char string1[] PROGMEM; -extern const char string2[] PROGMEM; -extern const char string3[] PROGMEM; -extern const char string4[] PROGMEM; -extern const char string5[] PROGMEM; -extern const char string6[] PROGMEM; -extern const char string7[] PROGMEM; -extern const char string8[] PROGMEM; -extern const char string9[] PROGMEM; -extern const char string10[] PROGMEM; -extern const char string11[] PROGMEM; -extern const char string12[] PROGMEM; -extern const char string13[] PROGMEM; -extern const char string14[] PROGMEM; -extern const char string15[] PROGMEM; -extern const char string16[] PROGMEM; -extern const char string17[] PROGMEM; -extern const char string18[] PROGMEM; -extern const char string19[] PROGMEM; -extern const char string20[] PROGMEM; -extern const char string21[] PROGMEM; -extern const char string22[] PROGMEM; -extern const char string23[] PROGMEM; -extern const char string24[] PROGMEM; -extern const char string25[] PROGMEM; -extern const char string26[] PROGMEM; -extern const char string27[] PROGMEM; -extern const char string28[] PROGMEM; -extern const char string29[] PROGMEM; -extern const char string30[] PROGMEM; -extern const char string31[] PROGMEM; -extern const char string32[] PROGMEM; -extern const char string33[] PROGMEM; -extern const char string34[] PROGMEM; -extern const char string35[] PROGMEM; -extern const char string36[] PROGMEM; -extern const char string37[] PROGMEM; -extern const char string38[] PROGMEM; -extern const char string39[] PROGMEM; -extern const char string40[] PROGMEM; -extern const char string41[] PROGMEM; -extern const char string42[] PROGMEM; -extern const char string43[] PROGMEM; -extern const char string44[] PROGMEM; -extern const char string45[] PROGMEM; -extern const char string46[] PROGMEM; -extern const char string47[] PROGMEM; -extern const char string48[] PROGMEM; -extern const char string49[] PROGMEM; -extern const char string50[] PROGMEM; -extern const char string51[] PROGMEM; -extern const char string52[] PROGMEM; -extern const char string53[] PROGMEM; -extern const char string54[] PROGMEM; -extern const char string55[] PROGMEM; -extern const char string56[] PROGMEM; -extern const char string57[] PROGMEM; -extern const char string58[] PROGMEM; -extern const char string59[] PROGMEM; -extern const char string60[] PROGMEM; -extern const char string61[] PROGMEM; -extern const char string62[] PROGMEM; -extern const char string63[] PROGMEM; -extern const char string64[] PROGMEM; -extern const char string65[] PROGMEM; -extern const char string66[] PROGMEM; -extern const char string67[] PROGMEM; -extern const char string68[] PROGMEM; -extern const char string69[] PROGMEM; -extern const char string70[] PROGMEM; -extern const char string71[] PROGMEM; -extern const char string72[] PROGMEM; -extern const char string73[] PROGMEM; -extern const char string74[] PROGMEM; -extern const char string75[] PROGMEM; -extern const char string76[] PROGMEM; -extern const char string77[] PROGMEM; -extern const char string78[] PROGMEM; -extern const char string79[] PROGMEM; -extern const char string80[] PROGMEM; -extern const char string81[] PROGMEM; -extern const char string82[] PROGMEM; -extern const char string83[] PROGMEM; -extern const char string84[] PROGMEM; -extern const char string85[] PROGMEM; -extern const char string86[] PROGMEM; -extern const char string87[] PROGMEM; -extern const char string88[] PROGMEM; -extern const char string89[] PROGMEM; -extern const char string90[] PROGMEM; -extern const char string91[] PROGMEM; -extern const char string92[] PROGMEM; -extern const char string93[] PROGMEM; -extern const char string94[] PROGMEM; -extern const char string95[] PROGMEM; -extern const char string96[] PROGMEM; -extern const char string97[] PROGMEM; -extern const char string98[] PROGMEM; -extern const char string99[] PROGMEM; -extern const char string100[] PROGMEM; -extern const char string101[] PROGMEM; -extern const char string102[] PROGMEM; -extern const char string103[] PROGMEM; -extern const char string104[] PROGMEM; -extern const char string105[] PROGMEM; -extern const char string106[] PROGMEM; -extern const char string107[] PROGMEM; -extern const char string108[] PROGMEM; -extern const char string109[] PROGMEM; -extern const char string110[] PROGMEM; -extern const char string111[] PROGMEM; -extern const char string112[] PROGMEM; -extern const char string113[] PROGMEM; -extern const char string114[] PROGMEM; -extern const char string115[] PROGMEM; -extern const char string116[] PROGMEM; -extern const char string117[] PROGMEM; -extern const char string118[] PROGMEM; -extern const char string119[] PROGMEM; -extern const char string120[] PROGMEM; -extern const char string121[] PROGMEM; -extern const char string122[] PROGMEM; -extern const char string123[] PROGMEM; -extern const char string124[] PROGMEM; -extern const char string125[] PROGMEM; -extern const char string126[] PROGMEM; -extern const char string127[] PROGMEM; -extern const char string128[] PROGMEM; -extern const char string129[] PROGMEM; -extern const char string130[] PROGMEM; -extern const char string131[] PROGMEM; -extern const char string132[] PROGMEM; -extern const char string133[] PROGMEM; -extern const char string134[] PROGMEM; -extern const char string135[] PROGMEM; -extern const char string136[] PROGMEM; -extern const char string137[] PROGMEM; -extern const char string138[] PROGMEM; -extern const char string139[] PROGMEM; -extern const char string140[] PROGMEM; -extern const char string141[] PROGMEM; -extern const char string142[] PROGMEM; -extern const char string143[] PROGMEM; -extern const char string144[] PROGMEM; -extern const char string145[] PROGMEM; -extern const char string146[] PROGMEM; -extern const char string147[] PROGMEM; -extern const char string148[] PROGMEM; -extern const char string149[] PROGMEM; -extern const char string150[] PROGMEM; -extern const char string151[] PROGMEM; -extern const char string152[] PROGMEM; -extern const char string153[] PROGMEM; -extern const char string154[] PROGMEM; -extern const char string155[] PROGMEM; -extern const char string156[] PROGMEM; -extern const char string157[] PROGMEM; -extern const char string158[] PROGMEM; -extern const char string159[] PROGMEM; -extern const char string160[] PROGMEM; -extern const char string161[] PROGMEM; -extern const char string162[] PROGMEM; -extern const char string163[] PROGMEM; -extern const char string164[] PROGMEM; -extern const char string165[] PROGMEM; -extern const char string166[] PROGMEM; -extern const char string167[] PROGMEM; -extern const char string168[] PROGMEM; -extern const char string169[] PROGMEM; -extern const char string170[] PROGMEM; -extern const char string171[] PROGMEM; -extern const char string172[] PROGMEM; -extern const char string173[] PROGMEM; -extern const char string174[] PROGMEM; -extern const char string175[] PROGMEM; -extern const char string176[] PROGMEM; -extern const char string177[] PROGMEM; -extern const char string180[] PROGMEM; -extern const char string181[] PROGMEM; -extern const char string182[] PROGMEM; -extern const char string183[] PROGMEM; -extern const char string184[] PROGMEM; -extern const char string185[] PROGMEM; -extern const char string186[] PROGMEM; -extern const char string187[] PROGMEM; -extern const char string188[] PROGMEM; -extern const char string189[] PROGMEM; -extern const char string190[] PROGMEM; -extern const char string191[] PROGMEM; -extern const char string192[] PROGMEM; -extern const char string193[] PROGMEM; -extern const char string194[] PROGMEM; -extern const char string195[] PROGMEM; -extern const char string196[] PROGMEM; -extern const char string197[] PROGMEM; -extern const char string198[] PROGMEM; -extern const char string199[] PROGMEM; -extern const char string200[] PROGMEM; -extern const char string201[] PROGMEM; -extern const char string202[] PROGMEM; -extern const char string203[] PROGMEM; -extern const char string204[] PROGMEM; -extern const char string205[] PROGMEM; -extern const char string206[] PROGMEM; -extern const char string207[] PROGMEM; -extern const char string208[] PROGMEM; -extern const char string209[] PROGMEM; -extern const char string210[] PROGMEM; -extern const char string211[] PROGMEM; -extern const char string212[] PROGMEM; -extern const char string213[] PROGMEM; -extern const char string214[] PROGMEM; -extern const char string215[] PROGMEM; -extern const char string216[] PROGMEM; -extern const char string217[] PROGMEM; -extern const char string218[] PROGMEM; -extern const char string219[] PROGMEM; -extern const char string220[] PROGMEM; -extern const char string221[] PROGMEM; -extern const char string222[] PROGMEM; -extern const char string223[] PROGMEM; -extern const char string224[] PROGMEM; -extern const char string225[] PROGMEM; -extern const char string226[] PROGMEM; -extern const char string227[] PROGMEM; -extern const char string228[] PROGMEM; -extern const char string229[] PROGMEM; -extern const char string230[] PROGMEM; -extern const char string231[] PROGMEM; -extern const char string232[] PROGMEM; -extern const char doc0[] PROGMEM; -extern const char doc1[] PROGMEM; -extern const char doc2[] PROGMEM; -extern const char doc3[] PROGMEM; -extern const char doc7[] PROGMEM; -extern const char doc8[] PROGMEM; -extern const char doc9[] PROGMEM; -extern const char doc10[] PROGMEM; -extern const char doc14[] PROGMEM; -extern const char doc15[] PROGMEM; -extern const char doc16[] PROGMEM; -extern const char doc18[] PROGMEM; -extern const char doc20[] PROGMEM; -extern const char doc21[] PROGMEM; -extern const char doc22[] PROGMEM; -extern const char doc23[] PROGMEM; -extern const char doc24[] PROGMEM; -extern const char doc25[] PROGMEM; -extern const char doc26[] PROGMEM; -extern const char doc27[] PROGMEM; -extern const char doc28[] PROGMEM; -extern const char doc29[] PROGMEM; -extern const char doc30[] PROGMEM; -extern const char doc31[] PROGMEM; -extern const char doc32[] PROGMEM; -extern const char doc33[] PROGMEM; -extern const char doc34[] PROGMEM; -extern const char doc35[] PROGMEM; -extern const char doc36[] PROGMEM; -extern const char doc37[] PROGMEM; -extern const char doc38[] PROGMEM; -extern const char doc39[] PROGMEM; -extern const char doc40[] PROGMEM; -extern const char doc41[] PROGMEM; -extern const char doc42[] PROGMEM; -extern const char doc43[] PROGMEM; -extern const char doc44[] PROGMEM; -extern const char doc45[] PROGMEM; -extern const char doc46[] PROGMEM; -extern const char doc47[] PROGMEM; -extern const char doc48[] PROGMEM; -extern const char doc49[] PROGMEM; -extern const char doc50[] PROGMEM; -extern const char doc51[] PROGMEM; -extern const char doc52[] PROGMEM; -extern const char doc53[] PROGMEM; -extern const char doc54[] PROGMEM; -extern const char doc55[] PROGMEM; -extern const char doc57[] PROGMEM; -extern const char doc58[] PROGMEM; -extern const char doc59[] PROGMEM; -extern const char doc60[] PROGMEM; -extern const char doc61[] PROGMEM; -extern const char doc62[] PROGMEM; -extern const char doc63[] PROGMEM; -extern const char doc64[] PROGMEM; -extern const char doc65[] PROGMEM; -extern const char doc66[] PROGMEM; -extern const char doc67[] PROGMEM; -extern const char doc68[] PROGMEM; -extern const char doc69[] PROGMEM; -extern const char doc70[] PROGMEM; -extern const char doc72[] PROGMEM; -extern const char doc73[] PROGMEM; -extern const char doc74[] PROGMEM; -extern const char doc75[] PROGMEM; -extern const char doc76[] PROGMEM; -extern const char doc77[] PROGMEM; -extern const char doc79[] PROGMEM; -extern const char doc80[] PROGMEM; -extern const char doc81[] PROGMEM; -extern const char doc82[] PROGMEM; -extern const char doc83[] PROGMEM; -extern const char doc84[] PROGMEM; -extern const char doc85[] PROGMEM; -extern const char doc86[] PROGMEM; -extern const char doc87[] PROGMEM; -extern const char doc88[] PROGMEM; -extern const char doc89[] PROGMEM; -extern const char doc90[] PROGMEM; -extern const char doc91[] PROGMEM; -extern const char doc92[] PROGMEM; -extern const char doc93[] PROGMEM; -extern const char doc94[] PROGMEM; -extern const char doc95[] PROGMEM; -extern const char doc96[] PROGMEM; -extern const char doc97[] PROGMEM; -extern const char doc98[] PROGMEM; -extern const char doc99[] PROGMEM; -extern const char doc100[] PROGMEM; -extern const char doc101[] PROGMEM; -extern const char doc102[] PROGMEM; -extern const char doc103[] PROGMEM; -extern const char doc104[] PROGMEM; -extern const char doc105[] PROGMEM; -extern const char doc106[] PROGMEM; -extern const char doc107[] PROGMEM; -extern const char doc108[] PROGMEM; -extern const char doc109[] PROGMEM; -extern const char doc110[] PROGMEM; -extern const char doc111[] PROGMEM; -extern const char doc112[] PROGMEM; -extern const char doc113[] PROGMEM; -extern const char doc114[] PROGMEM; -extern const char doc115[] PROGMEM; -extern const char doc116[] PROGMEM; -extern const char doc117[] PROGMEM; -extern const char doc118[] PROGMEM; -extern const char doc119[] PROGMEM; -extern const char doc120[] PROGMEM; -extern const char doc121[] PROGMEM; -extern const char doc122[] PROGMEM; -extern const char doc123[] PROGMEM; -extern const char doc124[] PROGMEM; -extern const char doc125[] PROGMEM; -extern const char doc126[] PROGMEM; -extern const char doc127[] PROGMEM; -extern const char doc128[] PROGMEM; -extern const char doc129[] PROGMEM; -extern const char doc130[] PROGMEM; -extern const char doc131[] PROGMEM; -extern const char doc132[] PROGMEM; -extern const char doc133[] PROGMEM; -extern const char doc134[] PROGMEM; -extern const char doc135[] PROGMEM; -extern const char doc136[] PROGMEM; -extern const char doc137[] PROGMEM; -extern const char doc138[] PROGMEM; -extern const char doc139[] PROGMEM; -extern const char doc140[] PROGMEM; -extern const char doc141[] PROGMEM; -extern const char doc142[] PROGMEM; -extern const char doc143[] PROGMEM; -extern const char doc144[] PROGMEM; -extern const char doc145[] PROGMEM; -extern const char doc146[] PROGMEM; -extern const char doc147[] PROGMEM; -extern const char doc148[] PROGMEM; -extern const char doc149[] PROGMEM; -extern const char doc150[] PROGMEM; -extern const char doc151[] PROGMEM; -extern const char doc152[] PROGMEM; -extern const char doc153[] PROGMEM; -extern const char doc154[] PROGMEM; -extern const char doc155[] PROGMEM; -extern const char doc156[] PROGMEM; -extern const char doc157[] PROGMEM; -extern const char doc158[] PROGMEM; -extern const char doc159[] PROGMEM; -extern const char doc160[] PROGMEM; -extern const char doc161[] PROGMEM; -extern const char doc162[] PROGMEM; -extern const char doc163[] PROGMEM; -extern const char doc164[] PROGMEM; -extern const char doc165[] PROGMEM; -extern const char doc166[] PROGMEM; -extern const char doc167[] PROGMEM; -extern const char doc168[] PROGMEM; -extern const char doc169[] PROGMEM; -extern const char doc170[] PROGMEM; -extern const char doc171[] PROGMEM; -extern const char doc172[] PROGMEM; -extern const char doc173[] PROGMEM; -extern const char doc174[] PROGMEM; -extern const char doc175[] PROGMEM; -extern const char doc176[] PROGMEM; -extern const char doc177[] PROGMEM; -extern const char doc180[] PROGMEM; -extern const char doc181[] PROGMEM; -extern const char doc182[] PROGMEM; -extern const char doc183[] PROGMEM; -extern const char doc184[] PROGMEM; -extern const char doc185[] PROGMEM; -extern const char doc186[] PROGMEM; -extern const char doc187[] PROGMEM; -extern const char doc188[] PROGMEM; -extern const char doc189[] PROGMEM; -extern const char doc190[] PROGMEM; -extern const char doc191[] PROGMEM; -extern const char doc192[] PROGMEM; -extern const char doc193[] PROGMEM; -extern const char doc194[] PROGMEM; -extern const char doc195[] PROGMEM; -extern const char doc196[] PROGMEM; -extern const char doc197[] PROGMEM; -extern const char doc198[] PROGMEM; -extern const char doc199[] PROGMEM; -extern const char doc200[] PROGMEM; -extern const char doc201[] PROGMEM; -extern const char doc202[] PROGMEM; -extern const char doc203[] PROGMEM; -extern const char doc204[] PROGMEM; -extern const char doc205[] PROGMEM; -extern const char doc206[] PROGMEM; -extern const char doc207[] PROGMEM; -extern const char doc208[] PROGMEM; -extern const char doc209[] PROGMEM; -extern const char doc210[] PROGMEM; -extern const char doc211[] PROGMEM; -extern const char doc212[] PROGMEM; -extern const char doc213[] PROGMEM; -extern const char doc214[] PROGMEM; -extern const char doc215[] PROGMEM; -extern const char doc216[] PROGMEM; -extern const char doc217[] PROGMEM; -extern const char doc218[] PROGMEM; -extern const char doc219[] PROGMEM; -extern const char doc220[] PROGMEM; -extern const char doc221[] PROGMEM; -extern const char doc222[] PROGMEM; -extern const char doc223[] PROGMEM; -extern const char doc224[] PROGMEM; -extern const char doc225[] PROGMEM; -const tbl_entry_t lookup_table[] PROGMEM; -#if !defined(extensions) -tbl_entry_t *tables[]; -const unsigned int tablesizes[]; -const tbl_entry_t *table (int n); -unsigned int tablesize (int n); -#endif -intptr_t lookupfn (builtin_t name); -uint8_t getminmax (builtin_t name); -void checkminmax (builtin_t name, int nargs); -char *lookupdoc (builtin_t name); -bool findsubstring (char *part, builtin_t name); -void testescape (); -bool keywordp (object *obj); -object *eval (object *form, object *env); -void pserial (char c); -extern const char ControlCodes[] PROGMEM; -void pcharacter (uint8_t c, pfun_t pfun); -void pstring (char *s, pfun_t pfun); -void plispstring (object *form, pfun_t pfun); -void plispstr (symbol_t name, pfun_t pfun); -void printstring (object *form, pfun_t pfun); -void pbuiltin (builtin_t name, pfun_t pfun); -void pradix40 (symbol_t name, pfun_t pfun); -void printsymbol (object *form, pfun_t pfun); -void psymbol (symbol_t name, pfun_t pfun); -void pfstring (PGM_P s, pfun_t pfun); -void pint (int i, pfun_t pfun); -void pintbase (uint32_t i, uint8_t base, pfun_t pfun); -void pmantissa (float f, pfun_t pfun); -void pfloat (float f, pfun_t pfun); -inline void pln (pfun_t pfun); -void pfl (pfun_t pfun); -void plist (object *form, pfun_t pfun); -void pstream (object *form, pfun_t pfun); -void printobject (object *form, pfun_t pfun); -void prin1object (object *form, pfun_t pfun); -int glibrary (); -void loadfromlibrary (object *env); -int gserial (); -object *nextitem (gfun_t gfun); -object *readrest (gfun_t gfun); -object *read (gfun_t gfun); -void initenv (); -void initgfx (); -void repl (object *env); -void ulispreset (); -#include "ulisp.cpp" -#endif diff --git a/ulisp.cpp b/ulisp.hpp similarity index 84% rename from ulisp.cpp rename to ulisp.hpp index e6e12b7..88851dd 100644 --- a/ulisp.cpp +++ b/ulisp.hpp @@ -3,8 +3,23 @@ Licensed under the MIT license: https://opensource.org/licenses/MIT */ -#include "ulisp.h" -#pragma once + +#ifndef ULISP_HPP +#define ULISP_HPP + +// Lisp Library +#ifndef LispLibrary +const char LispLibrary[] PROGMEM = ""; +#endif + +// Compile options + +#define printfreespace +#define printgcs +#define sdcardsupport +// #define gfxsupport +// #define lisplibrary +// #define extensions // Includes @@ -17,17 +32,88 @@ #include #if defined(gfxsupport) +#define COLOR_WHITE ST77XX_WHITE +#define COLOR_BLACK ST77XX_BLACK #include // Core graphics library #include // Hardware-specific library for ST7789 +#if defined(ARDUINO_ESP32_DEV) Adafruit_ST7789 tft = Adafruit_ST7789(5, 16, 19, 18); +#define TFT_BACKLITE 4 +#else +Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); +#endif #endif #include #define SDSIZE 172 +// Platform specific settings + +#define WORDALIGNED __attribute__((aligned (4))) +#define BUFFERSIZE 36 // Number of bits+4 + +#define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ +#define LITTLEFS +#include "FS.h" +#include + +#ifndef analogWrite +#define analogWrite(x,y) dacWrite((x),(y)) +#endif + +#ifndef LED_BUILTIN +#define LED_BUILTIN 13 +#endif + + +// 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 push(x, y) ((y) = cons((x),(y))) +#define pop(y) ((y) = cdr(y)) + +#define integerp(x) ((x) != NULL && (x)->type == NUMBER) +#define floatp(x) ((x) != NULL && (x)->type == FLOAT) +#define symbolp(x) ((x) != NULL && (x)->type == SYMBOL) +#define stringp(x) ((x) != NULL && (x)->type == STRING) +#define characterp(x) ((x) != NULL && (x)->type == CHARACTER) +#define arrayp(x) ((x) != NULL && (x)->type == ARRAY) +#define streamp(x) ((x) != NULL && (x)->type == STREAM) + +#define mark(x) (car(x) = (object*)(((uintptr_t)(car(x))) | MARKBIT)) +#define unmark(x) (car(x) = (object*)(((uintptr_t)(car(x))) & ~MARKBIT)) +#define marked(x) ((((uintptr_t)(car(x))) & MARKBIT) != 0) +#define MARKBIT 1 + +#define setflag(x) (Flags = Flags | 1<<(x)) +#define clrflag(x) (Flags = Flags & ~(1<<(x))) +#define tstflag(x) (Flags & 1<<(x)) + +#define issp(x) (x == ' ' || x == '\n' || x == '\r' || x == '\t') +#define isbr(x) (x == ')' || x == '(' || x == '"' || x == '#') +#define longsymbolp(x) (((x)->name & 0x03) == 0) +#define twist(x) ((uint32_t)((x)<<2) | (((x) & 0xC0000000)>>30)) +#define untwist(x) (((x)>>2 & 0x3FFFFFFF) | ((x) & 0x03)<<30) +#define arraysize(x) (sizeof(x) / sizeof(x[0])) +#define PACKEDS 0x43238000 +#define BUILTINS 0xF4240000 +#define ENDFUNCTIONS 1536 + // Constants const int TRACEMAX = 3; // Number of traced functions +enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; // ARRAY STRING and PAIR must be last +enum token { UNUSED, BRA, KET, QUO, DOT }; +enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM }; +enum fntypes_t { OTHER_FORMS, TAIL_FORMS, FUNCTIONS, SPECIAL_FORMS }; // Stream names used by printobject const char serialstream[] PROGMEM = "serial"; @@ -39,6 +125,48 @@ const char stringstream[] PROGMEM = "string"; const char gfxstream[] PROGMEM = "gfx"; PGM_P const streamname[] PROGMEM = {serialstream, i2cstream, spistream, sdstream, wifistream, stringstream, gfxstream}; +// Typedefs + +typedef uint32_t symbol_t; + +typedef struct sobject { + union { + struct { + sobject* car; + sobject* cdr; + }; + struct { + unsigned int type; + union { + symbol_t name; + int integer; + int chars; // For strings + float single_float; + }; + }; + }; +} object; + +typedef object* (*fn_ptr_type)(object* , object*); +typedef void (*mapfun_t)(object* , object**); + +typedef const struct { + PGM_P string; + fn_ptr_type fptr; + uint8_t minmax; + const char* doc; +} tbl_entry_t; + +typedef int (*gfun_t)(); +typedef void (*pfun_t)(char); + +typedef uint16_t builtin_t; + +enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, LET, LETSTAR, +CLOSURE, PSTAR, QUOTE, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, +ANALOGREAD, REGISTER, FORMAT, + }; + // Global variables object Workspace[WORKSPACESIZE] WORDALIGNED; @@ -46,16 +174,16 @@ object Workspace[WORKSPACESIZE] WORDALIGNED; jmp_buf toplevel_handler; jmp_buf *handler = &toplevel_handler; unsigned int Freespace = 0; -object *Freelist; +object* Freelist; unsigned int I2Ccount; unsigned int TraceFn[TRACEMAX]; unsigned int TraceDepth[TRACEMAX]; builtin_t Context; -object *GlobalEnv; -object *GCStack = NULL; -object *GlobalString; -object *GlobalStringTail; +object* GlobalEnv; +object* GCStack = NULL; +object* GlobalString; +object* GlobalStringTail; int GlobalStringIndex = 0; uint8_t PrintCount = 0; uint8_t BreakLevel = 0; @@ -63,8 +191,58 @@ char LastChar = 0; char LastPrint = 0; // Flags +enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, NOECHO, MUFFLEERRORS }; volatile uint8_t Flags = 0b00001; // PRINTREADABLY set by default +// Forward references +object* tee; +bool keywordp (object*); +void pfstring (PGM_P, pfun_t); +uint8_t nthchar (object*, int); +void pfl (pfun_t); +void pln (pfun_t); +void pserial (char); +int gserial (); +int glibrary (); +void pstr (char); +void psymbol (symbol_t, pfun_t); +void printobject (object*, pfun_t); +symbol_t sym (builtin_t); +void indent (uint8_t, char, pfun_t); +object* intern (symbol_t); +object* lispstring (char*); +char* cstring (object*, char*, int); +void pint (int, pfun_t); +void pintbase (uint32_t, uint8_t, pfun_t); +void printstring (object*, pfun_t); +int subwidthlist (object*, int); +uint8_t getminmax (builtin_t); +intptr_t lookupfn (builtin_t); +int listlength (object*); +void checkminmax (builtin_t, int); +object* findpair (object*, object*); +object* findvalue (object*, object*); +char* lookupdoc (builtin_t); +void printsymbol (object*, pfun_t); +void psymbol (symbol_t, pfun_t); +unsigned int tablesize (int); +bool findsubstring (char*, builtin_t); +bool stringcompare (object*, bool, bool, bool); +void pbuiltin (builtin_t, pfun_t); +object* value (symbol_t, object*); +void supersub (object*, int, int, pfun_t); +object* tf_progn (object*, object*); +object* fn_princtostring (object*, object*); +object* read (gfun_t); +object* eval (object*, object*); +void repl (object*); +void prin1object (object*, pfun_t); +void plispstr (symbol_t, pfun_t); +void printstring (object*, pfun_t); +void psymbol (symbol_t, pfun_t); +void testescape (); + + // Error handling /* @@ -88,7 +266,7 @@ void errorend () { GCStack = NULL; longjmp(*handler, 1); } Prints: "Error: 'fname' string: symbol", where fname is the name of the user Lisp function in which the error occurred, and symbol is the object generating the error. */ -void errorsym (symbol_t fname, PGM_P string, object *symbol) { +void errorsym (symbol_t fname, PGM_P string, object* symbol) { if (!tstflag(MUFFLEERRORS)) { errorsub(fname, string); pserial(':'); pserial(' '); @@ -115,7 +293,7 @@ void errorsym2 (symbol_t fname, PGM_P string) { Prints: "Error: 'Context' string: symbol", where Context is the name of the built-in Lisp function in which the error occurred, and symbol is the object generating the error. */ -void error (PGM_P string, object *symbol) { +void error (PGM_P string, object* symbol) { errorsym(sym(Context), string, symbol); } @@ -130,7 +308,7 @@ void error2 (PGM_P string) { /* formaterr - displays a format error with a ^ pointing to the error */ -void formaterr (object *formatstr, PGM_P string, uint8_t p) { +void formaterr (object* formatstr, PGM_P string, uint8_t p) { pln(pserial); indent(4, ' ', pserial); printstring(formatstr, pserial); pln(pserial); indent(p+5, ' ', pserial); pserial('^'); error2(string); @@ -171,7 +349,7 @@ const char unknownstreamtype[] PROGMEM = "unknown stream type"; void initworkspace () { Freelist = NULL; for (int i=WORKSPACESIZE-1; i>=0; i--) { - object *obj = &Workspace[i]; + object* obj = &Workspace[i]; car(obj) = NULL; cdr(obj) = Freelist; Freelist = obj; @@ -182,9 +360,9 @@ void initworkspace () { /* myalloc - returns the first object from the linked list of free objects */ -object *myalloc () { +object* myalloc () { if (Freespace == 0) error2(PSTR("no room")); - object *temp = Freelist; + object* temp = Freelist; Freelist = cdr(Freelist); Freespace--; return temp; @@ -194,7 +372,7 @@ object *myalloc () { myfree - adds obj to the linked list of free objects. inline makes gc significantly faster */ -inline void myfree (object *obj) { +inline void myfree (object* obj) { car(obj) = NULL; cdr(obj) = Freelist; Freelist = obj; @@ -206,8 +384,8 @@ inline void myfree (object *obj) { /* number - make an integer object with value n and return it */ -object *number (int n) { - object *ptr = myalloc(); +object* number (int n) { + object* ptr = myalloc(); ptr->type = NUMBER; ptr->integer = n; return ptr; @@ -216,8 +394,8 @@ object *number (int n) { /* makefloat - make a floating point object with value f and return it */ -object *makefloat (float f) { - object *ptr = myalloc(); +object* makefloat (float f) { + object* ptr = myalloc(); ptr->type = FLOAT; ptr->single_float = f; return ptr; @@ -226,8 +404,8 @@ object *makefloat (float f) { /* character - make a character object with value c and return it */ -object *character (uint8_t c) { - object *ptr = myalloc(); +object* character (uint8_t c) { + object* ptr = myalloc(); ptr->type = CHARACTER; ptr->chars = c; return ptr; @@ -236,8 +414,8 @@ object *character (uint8_t c) { /* cons - make a cons with arg1 and arg2 return it */ -object *cons (object *arg1, object *arg2) { - object *ptr = myalloc(); +object* cons (object* arg1, object* arg2) { + object* ptr = myalloc(); ptr->car = arg1; ptr->cdr = arg2; return ptr; @@ -246,8 +424,8 @@ object *cons (object *arg1, object *arg2) { /* symbol - make a symbol object with value name and return it */ -object *symbol (symbol_t name) { - object *ptr = myalloc(); +object* symbol (symbol_t name) { + object* ptr = myalloc(); ptr->type = SYMBOL; ptr->name = name; return ptr; @@ -256,7 +434,7 @@ object *symbol (symbol_t name) { /* bsymbol - make a built-in symbol */ -inline object *bsymbol (builtin_t name) { +inline object* bsymbol (builtin_t name) { return intern(twist(name+BUILTINS)); } @@ -264,9 +442,9 @@ inline object *bsymbol (builtin_t name) { intern - looks through the workspace for an existing occurrence of symbol name and returns it, otherwise calls symbol(name) to create a new symbol. */ -object *intern (symbol_t name) { +object* intern (symbol_t name) { for (int i=0; itype == SYMBOL && obj->name == name) return obj; } return symbol(name); @@ -275,8 +453,8 @@ object *intern (symbol_t name) { /* eqsymbols - compares the long string/symbol obj with the string in buffer. */ -bool eqsymbols (object *obj, char *buffer) { - object *arg = cdr(obj); +bool eqsymbols (object* obj, char* buffer) { + object* arg = cdr(obj); int i = 0; while (!(arg == NULL && buffer[i] == 0)) { if (arg == NULL || buffer[i] == 0 || @@ -291,12 +469,12 @@ bool eqsymbols (object *obj, char *buffer) { internlong - looks through the workspace for an existing occurrence of the long symbol in buffer and returns it, otherwise calls lispstring(buffer) to create a new symbol. */ -object *internlong (char *buffer) { +object* internlong (char* buffer) { for (int i=0; itype == SYMBOL && longsymbolp(obj) && eqsymbols(obj, buffer)) return obj; } - object *obj = lispstring(buffer); + object* obj = lispstring(buffer); obj->type = SYMBOL; return obj; } @@ -304,8 +482,8 @@ object *internlong (char *buffer) { /* stream - makes a stream object defined by streamtype and address, and returns it */ -object *stream (uint8_t streamtype, uint8_t address) { - object *ptr = myalloc(); +object* stream (uint8_t streamtype, uint8_t address) { + object* ptr = myalloc(); ptr->type = STREAM; ptr->integer = streamtype<<8 | address; return ptr; @@ -314,8 +492,8 @@ object *stream (uint8_t streamtype, uint8_t address) { /* newstring - makes an empty string object and returns it */ -object *newstring () { - object *ptr = myalloc(); +object* newstring () { + object* ptr = myalloc(); ptr->type = STRING; ptr->chars = 0; return ptr; @@ -326,7 +504,7 @@ object *newstring () { /* markobject - recursively marks reachable objects, starting from obj */ -void markobject (object *obj) { +void markobject (object* obj) { MARK: if (obj == NULL) return; if (marked(obj)) return; @@ -364,7 +542,7 @@ void sweep () { Freelist = NULL; Freespace = 0; for (int i=WORKSPACESIZE-1; i>=0; i--) { - object *obj = &Workspace[i]; + object* obj = &Workspace[i]; if (!marked(obj)) myfree(obj); else unmark(obj); } } @@ -373,7 +551,7 @@ void sweep () { gc - performs garbage collection by calling markobject() on each of the pointers to objects in use, followed by sweep() to free unused objects. */ -void gc (object *form, object *env) { +void gc (object* form, object* env) { #if defined(printgcs) int start = Freespace; static int GC_Count = 0; @@ -395,6 +573,19 @@ void gc (object *form, object *env) { #endif } +char *MakeFilename (object *arg, char *buffer) { + int max = BUFFERSIZE-1; + buffer[0]='/'; + int i = 1; + do { + char c = nthchar(arg, i-1); + if (c == '\0') break; + buffer[i++] = c; + } while (itype; return type >= PAIR || type == ZZERO; @@ -453,7 +644,7 @@ bool consp (object *x) { /* listp - implements Lisp listp */ -bool listp (object *x) { +bool listp (object* x) { if (x == NULL) return true; unsigned int type = x->type; return type >= PAIR || type == ZZERO; @@ -464,7 +655,7 @@ bool listp (object *x) { */ #define improperp(x) (!listp(x)) -object *quote (object *arg) { +object* quote (object* arg) { return cons(bsymbol(QUOTE), cons(arg,NULL)); } @@ -509,7 +700,7 @@ char fromradix40 (char n) { /* pack40 - packs six radix40-encoded characters from buffer into a 32-bit number and returns it. */ -uint32_t pack40 (char *buffer) { +uint32_t pack40 (char* buffer) { int x = 0; for (int i=0; i<6; i++) x = x * 40 + toradix40(buffer[i]); return x; @@ -518,7 +709,7 @@ uint32_t pack40 (char *buffer) { /* valid40 - returns true if the symbol in buffer can be encoded as six radix40-encoded characters. */ -bool valid40 (char *buffer) { +bool valid40 (char* buffer) { if (toradix40(buffer[0]) < 11) return false; for (int i=1; i<6; i++) if (toradix40(buffer[i]) < 0) return false; return true; @@ -537,7 +728,7 @@ int8_t digitvalue (char d) { /* checkinteger - check that obj is an integer and return it */ -int checkinteger (object *obj) { +int checkinteger (object* obj) { if (!integerp(obj)) error(notaninteger, obj); return obj->integer; } @@ -545,7 +736,7 @@ int checkinteger (object *obj) { /* checkbitvalue - check that obj is an integer equal to 0 or 1 and return it */ -int checkbitvalue (object *obj) { +int checkbitvalue (object* obj) { if (!integerp(obj)) error(notaninteger, obj); int n = obj->integer; if (n & ~1) error(PSTR("argument is not a bit value"), obj); @@ -555,7 +746,7 @@ int checkbitvalue (object *obj) { /* checkintfloat - check that obj is an integer or floating-point number and return the number */ -float checkintfloat (object *obj){ +float checkintfloat (object* obj){ if (integerp(obj)) return obj->integer; if (!floatp(obj)) error(notanumber, obj); return obj->single_float; @@ -564,7 +755,7 @@ float checkintfloat (object *obj){ /* checkchar - check that obj is a character and return the character */ -int checkchar (object *obj) { +int checkchar (object* obj) { if (!characterp(obj)) error(PSTR("argument is not a character"), obj); return obj->chars; } @@ -572,17 +763,17 @@ int checkchar (object *obj) { /* checkstring - check that obj is a string */ -object *checkstring (object *obj) { +object* checkstring (object* obj) { if (!stringp(obj)) error(notastring, obj); return obj; } -int isstream (object *obj){ +int isstream (object* obj){ if (!streamp(obj)) error(PSTR("not a stream"), obj); return obj->integer; } -int isbuiltin (object *obj, builtin_t n) { +int isbuiltin (object* obj, builtin_t n) { return symbolp(obj) && obj->name == sym(n); } @@ -590,7 +781,7 @@ bool builtinp (symbol_t name) { return (untwist(name) >= BUILTINS); } -int checkkeyword (object *obj) { +int checkkeyword (object* obj) { if (!keywordp(obj)) error(PSTR("argument is not a keyword"), obj); builtin_t kname = builtin(obj->name); uint8_t context = getminmax(kname); @@ -602,7 +793,7 @@ int checkkeyword (object *obj) { checkargs - checks that the number of objects in the list args is within the range specified in the symbol lookup table */ -void checkargs (object *args) { +void checkargs (object* args) { int nargs = listlength(args); checkminmax(Context, nargs); } @@ -610,7 +801,7 @@ void checkargs (object *args) { /* eq - implements Lisp eq */ -boolean eq (object *arg1, object *arg2) { +boolean eq (object* arg1, object* arg2) { if (arg1 == arg2) return true; // Same object if ((arg1 == nil) || (arg2 == nil)) return false; // Not both values if (arg1->cdr != arg2->cdr) return false; // Different values @@ -624,7 +815,7 @@ boolean eq (object *arg1, object *arg2) { /* equal - implements Lisp equal */ -boolean equal (object *arg1, object *arg2) { +boolean equal (object* arg1, object* arg2) { if (stringp(arg1) && stringp(arg2)) return stringcompare(cons(arg1, cons(arg2, nil)), false, false, true); if (consp(arg1) && consp(arg2)) return (equal(car(arg1), car(arg2)) && equal(cdr(arg1), cdr(arg2))); return eq(arg1, arg2); @@ -633,7 +824,7 @@ boolean equal (object *arg1, object *arg2) { /* listlength - returns the length of a list */ -int listlength (object *list) { +int listlength (object* list) { int length = 0; while (list != NULL) { if (improperp(list)) error2(notproper); @@ -649,9 +840,9 @@ int listlength (object *list) { add_floats - used by fn_add Converts the numbers in args to floats, adds them to fresult, and returns the sum as a Lisp float. */ -object *add_floats (object *args, float fresult) { +object* add_floats (object* args, float fresult) { while (args != NULL) { - object *arg = car(args); + object* arg = car(args); fresult = fresult + checkintfloat(arg); args = cdr(args); } @@ -662,9 +853,9 @@ object *add_floats (object *args, float fresult) { subtract_floats - used by fn_subtract with more than one argument Converts the numbers in args to floats, subtracts them from fresult, and returns the result as a Lisp float. */ -object *subtract_floats (object *args, float fresult) { +object* subtract_floats (object* args, float fresult) { while (args != NULL) { - object *arg = car(args); + object* arg = car(args); fresult = fresult - checkintfloat(arg); args = cdr(args); } @@ -676,7 +867,7 @@ object *subtract_floats (object *args, float fresult) { If the result is an integer, and negating it doesn't overflow, keep the result as an integer. Otherwise convert the result to a float, negate it, and return the result as a Lisp float. */ -object *negate (object *arg) { +object* negate (object* arg) { if (integerp(arg)) { int result = arg->integer; if (result == INT_MIN) return makefloat(-result); @@ -690,9 +881,9 @@ object *negate (object *arg) { multiply_floats - used by fn_multiply Converts the numbers in args to floats, adds them to fresult, and returns the result as a Lisp float. */ -object *multiply_floats (object *args, float fresult) { +object* multiply_floats (object* args, float fresult) { while (args != NULL) { - object *arg = car(args); + object* arg = car(args); fresult = fresult * checkintfloat(arg); args = cdr(args); } @@ -703,9 +894,9 @@ object *multiply_floats (object *args, float fresult) { divide_floats - used by fn_divide Converts the numbers in args to floats, divides fresult by them, and returns the result as a Lisp float. */ -object *divide_floats (object *args, float fresult) { +object* divide_floats (object* args, float fresult) { while (args != NULL) { - object *arg = car(args); + object* arg = car(args); float f = checkintfloat(arg); if (f == 0.0) error2(divisionbyzero); fresult = fresult / f; @@ -729,11 +920,11 @@ int myround (float number) { If gt is true the result is true if each argument is greater than the next argument. If eq is true the result is true if each argument is equal to the next argument. */ -object *compare (object *args, bool lt, bool gt, bool eq) { - object *arg1 = first(args); +object* compare (object* args, bool lt, bool gt, bool eq) { + object* arg1 = first(args); args = cdr(args); while (args != NULL) { - object *arg2 = first(args); + object* arg2 = first(args); if (integerp(arg1) && integerp(arg2)) { if (!lt && ((arg1->integer) < (arg2->integer))) return nil; if (!eq && ((arg1->integer) == (arg2->integer))) return nil; @@ -767,10 +958,10 @@ int intpower (int base, int exp) { /* assoc - looks for key in an association list and returns the matching pair, or nil if not found */ -object *assoc (object *key, object *list) { +object* assoc (object* key, object* list) { while (list != NULL) { if (improperp(list)) error(notproper, list); - object *pair = first(list); + object* pair = first(list); if (!listp(pair)) error(PSTR("element is not a list"), pair); if (pair != NULL && eq(key,car(pair))) return pair; list = cdr(list); @@ -781,11 +972,11 @@ object *assoc (object *key, object *list) { /* delassoc - deletes the pair matching key from an association list and returns the key, or nil if not found */ -object *delassoc (object *key, object **alist) { - object *list = *alist; - object *prev = NULL; +object* delassoc (object* key, object** alist) { + object* list = *alist; + object* prev = NULL; while (list != NULL) { - object *pair = first(list); + object* pair = first(list); if (eq(key,car(pair))) { if (prev == NULL) *alist = cdr(list); else cdr(prev) = cdr(list); @@ -812,7 +1003,7 @@ int nextpower2 (int n) { buildarray - builds an array with n elements using a tree of size s which must be a power of 2 The elements are initialised to the default def */ -object *buildarray (int n, int s, object *def) { +object* buildarray (int n, int s, object* def) { int s2 = s>>1; if (s2 == 1) { if (n == 2) return cons(def, def); @@ -822,9 +1013,9 @@ object *buildarray (int n, int s, object *def) { else return cons(buildarray(n, s2, def), nil); } -object *makearray (object *dims, object *def, bool bitp) { +object* makearray (object* dims, object* def, bool bitp) { int size = 1; - object *dimensions = dims; + object* dimensions = dims; while (dims != NULL) { int d = car(dims)->integer; if (d < 0) error2(PSTR("dimension can't be negative")); @@ -836,9 +1027,9 @@ object *makearray (object *dims, object *def, bool bitp) { size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); car(dimensions) = number(-(car(dimensions)->integer)); } - object *ptr = myalloc(); + object* ptr = myalloc(); ptr->type = ARRAY; - object *tree = nil; + object* tree = nil; if (size != 0) tree = buildarray(size, nextpower2(size), def); ptr->cdr = cons(tree, dimensions); return ptr; @@ -847,9 +1038,9 @@ object *makearray (object *dims, object *def, bool bitp) { /* arrayref - returns a pointer to the element specified by index in the array of size s */ -object **arrayref (object *array, int index, int size) { +object** arrayref (object* array, int index, int size) { int mask = nextpower2(size)>>1; - object **p = &car(cdr(array)); + object** p = &car(cdr(array)); while (mask) { if ((index & mask) == 0) p = &(car(*p)); else p = &(cdr(*p)); mask = mask>>1; @@ -861,11 +1052,11 @@ object **arrayref (object *array, int index, int size) { getarray - gets a pointer to an element in a multi-dimensional array, given a list of the subscripts subs If the first subscript is negative it's a bit array and bit is set to the bit number */ -object **getarray (object *array, object *subs, object *env, int *bit) { +object** getarray (object* array, object* subs, object* env, int *bit) { int index = 0, size = 1, s; *bit = -1; bool bitp = false; - object *dims = cddr(array); + object* dims = cddr(array); while (dims != NULL && subs != NULL) { int d = car(dims)->integer; if (d < 0) { d = -d; bitp = true; } @@ -888,13 +1079,13 @@ object **getarray (object *array, object *subs, object *env, int *bit) { /* rslice - reads a slice of an array recursively */ -void rslice (object *array, int size, int slice, object *dims, object *args) { +void rslice (object* array, int size, int slice, object* dims, object* args) { int d = first(dims)->integer; for (int i = 0; i < d; i++) { int index = slice * d + i; if (!consp(args)) error2(PSTR("initial contents don't match array type")); if (cdr(dims) == NULL) { - object **p = arrayref(array, index, size); + object** p = arrayref(array, index, size); *p = car(args); } else rslice(array, size, index, cdr(dims), car(args)); args = cdr(args); @@ -905,9 +1096,9 @@ void rslice (object *array, int size, int slice, object *dims, object *args) { readarray - reads a list structure from args and converts it to a d-dimensional array. Uses rslice for each of the slices of the array. */ -object *readarray (int d, object *args) { - object *list = args; - object *dims = NULL; object *head = NULL; +object* readarray (int d, object* args) { + object* list = args; + object* dims = NULL; object* head = NULL; int size = 1; for (int i = 0; i < d; i++) { if (!listp(list)) error2(PSTR("initial contents don't match array type")); @@ -917,7 +1108,7 @@ object *readarray (int d, object *args) { size = size * l; if (list != NULL) list = car(list); } - object *array = makearray(head, NULL, false); + object* array = makearray(head, NULL, false); rslice(array, size, 0, head, args); return array; } @@ -926,13 +1117,13 @@ object *readarray (int d, object *args) { readbitarray - reads an item in the format #*1010101000110 by reading it and returning a list of integers, and then converting that to a bit array */ -object *readbitarray (gfun_t gfun) { +object* readbitarray (gfun_t gfun) { char ch = gfun(); - object *head = NULL; - object *tail = NULL; + object* head = NULL; + object* tail = NULL; while (!issp(ch) && !isbr(ch)) { if (ch != '0' && ch != '1') error2(PSTR("illegal character in bit array")); - object *cell = cons(number(ch - '0'), NULL); + object* cell = cons(number(ch - '0'), NULL); if (head == NULL) head = cell; else tail->cdr = cell; tail = cell; @@ -940,11 +1131,11 @@ object *readbitarray (gfun_t gfun) { } LastChar = ch; int size = listlength(head); - object *array = makearray(cons(number(size), NULL), number(0), true); + object* array = makearray(cons(number(size), NULL), number(0), true); size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); int index = 0; while (head != NULL) { - object **loc = arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size); + object** loc = arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size); int bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); *loc = number((((*loc)->integer) & ~(1<integer)<integer; @@ -975,9 +1166,9 @@ void pslice (object *array, int size, int slice, object *dims, pfun_t pfun, bool /* printarray - prints an array in the appropriate Lisp format */ -void printarray (object *array, pfun_t pfun) { - object *dimensions = cddr(array); - object *dims = dimensions; +void printarray (object* array, pfun_t pfun) { + object* dimensions = cddr(array); + object* dims = dimensions; bool bitp = false; int size = 1, n = 0; while (dims != NULL) { @@ -1004,8 +1195,8 @@ void indent (uint8_t spaces, char ch, pfun_t pfun) { /* startstring - starts building a string */ -object *startstring () { - object *string = newstring(); +object* startstring () { + object* string = newstring(); GlobalString = string; GlobalStringTail = string; return string; @@ -1014,8 +1205,8 @@ object *startstring () { /* princtostring - implements Lisp princtostring function */ -object *princtostring (object *arg) { - object *obj = startstring(); +object* princtostring (object* arg) { + object* obj = startstring(); prin1object(arg, pstr); return obj; } @@ -1024,8 +1215,8 @@ object *princtostring (object *arg) { buildstring - adds a character on the end of a string Handles Lisp strings packed four characters per 32-bit word */ -void buildstring (char ch, object **tail) { - object *cell; +void buildstring (char ch, object** tail) { + object* cell; if (cdr(*tail) == NULL) { cell = myalloc(); cdr(*tail) = cell; } else if (((*tail)->chars & 0xFFFFFF) == 0) { @@ -1043,12 +1234,12 @@ void buildstring (char ch, object **tail) { /* copystring - returns a copy of a Lisp string */ -object *copystring (object *arg) { - object *obj = newstring(); - object *ptr = obj; +object* copystring (object* arg) { + object* obj = newstring(); + object* ptr = obj; arg = cdr(arg); while (arg != NULL) { - object *cell = myalloc(); car(cell) = NULL; + object* cell = myalloc(); car(cell) = NULL; if (cdr(obj) == NULL) cdr(obj) = cell; else car(ptr) = cell; ptr = cell; ptr->chars = arg->chars; @@ -1061,9 +1252,9 @@ object *copystring (object *arg) { readstring - reads characters from an input stream up to delimiter delim and returns a Lisp string */ -object *readstring (uint8_t delim, gfun_t gfun) { - object *obj = newstring(); - object *tail = obj; +object* readstring (uint8_t delim, gfun_t gfun) { + object* obj = newstring(); + object* tail = obj; int ch = gfun(); if (ch == -1) return nil; while ((ch != delim) && (ch != -1)) { @@ -1078,7 +1269,7 @@ object *readstring (uint8_t delim, gfun_t gfun) { stringlength - returns the length of a Lisp string Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word */ -int stringlength (object *form) { +int stringlength (object* form) { int length = 0; form = cdr(form); while (form != NULL) { @@ -1095,8 +1286,8 @@ int stringlength (object *form) { nthchar - returns the nth character from a Lisp string Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word */ -uint8_t nthchar (object *string, int n) { - object *arg = cdr(string); +uint8_t nthchar (object* string, int n) { + object* arg = cdr(string); int top; if (sizeof(int) == 4) { top = n>>2; n = 3 - (n&3); } else { top = n>>1; n = 1 - (n&1); } @@ -1132,9 +1323,9 @@ void pstr (char c) { /* lispstring - converts a C string to a Lisp string */ -object *lispstring (char *s) { - object *obj = newstring(); - object *tail = obj; +object* lispstring (char* s) { + object* obj = newstring(); + object* tail = obj; while(1) { char ch = *s++; if (ch == 0) break; @@ -1151,9 +1342,9 @@ object *lispstring (char *s) { If gt is true the result is true if each argument is greater than the next argument. If eq is true the result is true if each argument is equal to the next argument. */ -bool stringcompare (object *args, bool lt, bool gt, bool eq) { - object *arg1 = checkstring(first(args)); - object *arg2 = checkstring(second(args)); +bool stringcompare (object* args, bool lt, bool gt, bool eq) { + object* arg1 = checkstring(first(args)); + object* arg2 = checkstring(second(args)); arg1 = cdr(arg1); arg2 = cdr(arg2); while ((arg1 != NULL) || (arg2 != NULL)) { @@ -1170,21 +1361,21 @@ bool stringcompare (object *args, bool lt, bool gt, bool eq) { /* documentation - returns the documentation string of a built-in or user-defined function. */ -object *documentation (object *arg, object *env) { +object* documentation (object* arg, object* env) { if (arg == NULL) return nil; if (!symbolp(arg)) error(notasymbol, arg); - object *pair = findpair(arg, env); + object* pair = findpair(arg, env); if (pair != NULL) { - object *val = cdr(pair); + object* val = cdr(pair); if (listp(val) && first(val)->name == sym(LAMBDA) && cdr(val) != NULL && cddr(val) != NULL) { if (stringp(third(val))) return third(val); } } symbol_t docname = arg->name; if (!builtinp(docname)) return nil; - char *docstring = lookupdoc(builtin(docname)); + char* docstring = lookupdoc(builtin(docname)); if (docstring == NULL) return nil; - object *obj = startstring(); + object* obj = startstring(); pfstring(docstring, pstr); return obj; } @@ -1193,18 +1384,18 @@ object *documentation (object *arg, object *env) { apropos - finds the user-defined and built-in functions whose names contain the specified string or symbol, and prints them if print is true, or returns them in a list. */ -object *apropos (object *arg, bool print) { +object* apropos (object* arg, bool print) { char buf[17], buf2[33]; - char *part = cstring(princtostring(arg), buf, 17); - object *result = cons(NULL, NULL); - object *ptr = result; + char* part = cstring(princtostring(arg), buf, 17); + object* result = cons(NULL, NULL); + object* ptr = result; // User-defined? - object *globals = GlobalEnv; + object* globals = GlobalEnv; while (globals != NULL) { - object *pair = first(globals); - object *var = car(pair); - object *val = cdr(pair); - char *full = cstring(princtostring(var), buf2, 33); + object* pair = first(globals); + object* var = car(pair); + object* val = cdr(pair); + char* full = cstring(princtostring(var), buf2, 33); if (strstr(full, part) != NULL) { if (print) { printsymbol(var, pserial); pserial(' '); pserial('('); @@ -1241,7 +1432,7 @@ object *apropos (object *arg, bool print) { cstring - converts a Lisp string to a C string in buffer and returns buffer Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word */ -char *cstring (object *form, char *buffer, int buflen) { +char* cstring (object* form, char* buffer, int buflen) { form = cdr(checkstring(form)); int index = 0; while (form != NULL) { @@ -1263,7 +1454,7 @@ char *cstring (object *form, char *buffer, int buflen) { ipstring - parses an IP address from a Lisp string and returns it as an IPAddress type (uint32_t) Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word */ -uint32_t ipstring (object *form) { +uint32_t ipstring (object* form) { form = cdr(checkstring(form)); int p = 0; union { uint32_t ipaddress; uint8_t ipbytes[4]; } ; @@ -1284,9 +1475,9 @@ uint32_t ipstring (object *form) { // Lookup variable in environment -object *value (symbol_t n, object *env) { +object* value (symbol_t n, object* env) { while (env != NULL) { - object *pair = car(env); + object* pair = car(env); if (pair != NULL && car(pair)->name == n) return pair; env = cdr(env); } @@ -1296,9 +1487,9 @@ object *value (symbol_t n, object *env) { /* findpair - returns the (var . value) pair bound to variable var in the local or global environment */ -object *findpair (object *var, object *env) { +object* findpair (object* var, object* env) { symbol_t name = var->name; - object *pair = value(name, env); + object* pair = value(name, env); if (pair == NULL) pair = value(name, GlobalEnv); return pair; } @@ -1306,7 +1497,7 @@ object *findpair (object *var, object *env) { /* boundp - tests whether var is bound to a value */ -bool boundp (object *var, object *env) { +bool boundp (object* var, object* env) { if (!symbolp(var)) error(notasymbol, var); return (findpair(var, env) != NULL); } @@ -1314,16 +1505,16 @@ bool boundp (object *var, object *env) { /* findvalue - returns the value bound to variable var, or gives an error if unbound */ -object *findvalue (object *var, object *env) { - object *pair = findpair(var, env); +object* findvalue (object* var, object* env) { + object* pair = findpair(var, env); if (pair == NULL) error(PSTR("unknown variable"), var); return pair; } // Handling closures -object *closure (int tc, symbol_t name, object *function, object *args, object **env) { - object *state = car(function); +object* closure (int tc, symbol_t name, object* function, object* args, object** env) { + object* state = car(function); function = cdr(function); int trace = 0; if (name) trace = tracing(name); @@ -1332,7 +1523,7 @@ object *closure (int tc, symbol_t name, object *function, object *args, object * pint(TraceDepth[trace-1]++, pserial); pserial(':'); pserial(' '); pserial('('); printsymbol(symbol(name), pserial); } - object *params = first(function); + object* params = first(function); if (!listp(params)) errorsym(name, notalist, params); function = cdr(function); // Dropframe @@ -1344,15 +1535,15 @@ object *closure (int tc, symbol_t name, object *function, object *args, object * } // Push state while (consp(state)) { - object *pair = first(state); + object* pair = first(state); push(pair, *env); state = cdr(state); } // Add arguments to environment bool optional = false; while (params != NULL) { - object *value; - object *var = first(params); + object* value; + object* var = first(params); if (isbuiltin(var, OPTIONAL)) optional = true; else { if (consp(var)) { @@ -1386,7 +1577,7 @@ object *closure (int tc, symbol_t name, object *function, object *args, 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)) { builtin_t fname = builtin(function->name); if ((fname < ENDFUNCTIONS) && ((getminmax(fname)>>6) == FUNCTIONS)) { @@ -1396,12 +1587,12 @@ object *apply (object *function, object *args, object *env) { } else function = eval(function, env); } if (consp(function) && isbuiltin(car(function), LAMBDA)) { - object *result = closure(0, sym(NIL), function, args, &env); + object* result = closure(0, sym(NIL), function, args, &env); return eval(result, env); } if (consp(function) && isbuiltin(car(function), CLOSURE)) { function = cdr(function); - object *result = closure(0, sym(NIL), function, args, &env); + object* result = closure(0, sym(NIL), function, args, &env); return eval(result, env); } error(PSTR("illegal function"), function); @@ -1414,25 +1605,25 @@ object *apply (object *function, object *args, object *env) { place - returns a pointer to an object referenced in the second argument of an in-place operation such as setf. bit is used to indicate the bit position in a bit array */ -object **place (object *args, object *env, int *bit) { +object** place (object* args, object* env, int *bit) { *bit = -1; if (atom(args)) return &cdr(findvalue(args, env)); object* function = first(args); if (symbolp(function)) { symbol_t sname = function->name; if (sname == sym(CAR) || sname == sym(FIRST)) { - object *value = eval(second(args), env); + object* value = eval(second(args), env); if (!listp(value)) error(canttakecar, value); return &car(value); } if (sname == sym(CDR) || sname == sym(REST)) { - object *value = eval(second(args), env); + object* value = eval(second(args), env); if (!listp(value)) error(canttakecdr, value); return &cdr(value); } if (sname == sym(NTH)) { int index = checkinteger(eval(second(args), env)); - object *list = eval(third(args), env); + object* list = eval(third(args), env); if (atom(list)) error(PSTR("second argument to nth is not a list"), list); while (index > 0) { list = cdr(list); @@ -1442,7 +1633,7 @@ object **place (object *args, object *env, int *bit) { return &car(list); } if (sname == sym(AREF)) { - object *array = eval(second(args), env); + object* array = eval(second(args), env); if (!arrayp(array)) error(PSTR("first argument is not an array"), array); return getarray(array, cddr(args), env, bit); } @@ -1456,7 +1647,7 @@ object **place (object *args, object *env, int *bit) { /* carx - car with error checking */ -object *carx (object *arg) { +object* carx (object* arg) { if (!listp(arg)) error(canttakecar, arg); if (arg == nil) return nil; return car(arg); @@ -1465,7 +1656,7 @@ object *carx (object *arg) { /* cdrx - cdr with error checking */ -object *cdrx (object *arg) { +object* cdrx (object* arg) { if (!listp(arg)) error(canttakecdr, arg); if (arg == nil) return nil; return cdr(arg); @@ -1475,8 +1666,8 @@ object *cdrx (object *arg) { cxxxr - implements a general cxxxr function, pattern is a sequence of bits 0b1xxx where x is 0 for a and 1 for d. */ -object *cxxxr (object *args, uint8_t pattern) { - object *arg = first(args); +object* cxxxr (object* args, uint8_t pattern) { + object* arg = first(args); while (pattern != 1) { if ((pattern & 1) == 0) arg = carx(arg); else arg = cdrx(arg); pattern = pattern>>1; @@ -1489,15 +1680,15 @@ object *cxxxr (object *args, uint8_t pattern) { /* mapcarfun - function specifying how to combine the results in mapcar */ -void mapcarfun (object *result, object **tail) { - object *obj = cons(result,NULL); +void mapcarfun (object* result, object** tail) { + object* obj = cons(result,NULL); cdr(*tail) = obj; *tail = obj; } /* mapcanfun - function specifying how to combine the results in mapcan */ -void mapcanfun (object *result, object **tail) { +void mapcanfun (object* result, object** tail) { if (cdr(*tail) != NULL) error(notproper, *tail); while (consp(result)) { cdr(*tail) = result; *tail = result; @@ -1509,31 +1700,31 @@ void mapcanfun (object *result, object **tail) { mapcarcan - function used by marcar and mapcan It takes the arguments, the env, and a function specifying how the results are combined. */ -object *mapcarcan (object *args, object *env, mapfun_t fun) { - object *function = first(args); +object* mapcarcan (object* args, object* env, mapfun_t fun) { + object* function = first(args); args = cdr(args); - object *params = cons(NULL, NULL); + object* params = cons(NULL, NULL); push(params,GCStack); - object *head = cons(NULL, NULL); + object* head = cons(NULL, NULL); push(head,GCStack); - object *tail = head; + object* tail = head; // Make parameters while (true) { - object *tailp = params; - object *lists = args; + object* tailp = params; + object* lists = args; while (lists != NULL) { - object *list = car(lists); + object* list = car(lists); if (list == NULL) { pop(GCStack); pop(GCStack); return cdr(head); } if (improperp(list)) error(notproper, list); - object *obj = cons(first(list),NULL); + object* obj = cons(first(list),NULL); car(lists) = cdr(list); cdr(tailp) = obj; tailp = obj; lists = cdr(lists); } - object *result = apply(function, cdr(params), env); + object* result = apply(function, cdr(params), env); fun(result, &tail); } } @@ -1612,7 +1803,7 @@ void serialend (int address) { if (address == 1) {Serial1.flush(); Serial1.end(); } } -gfun_t gstreamfun (object *args) { +gfun_t gstreamfun (object* args) { int streamtype = SERIALSTREAM; int address = 0; gfun_t gfun = gserial; @@ -1644,7 +1835,7 @@ inline void SDwrite (char c) { SDpfile.write(c); } inline void gfxwrite (char c) { tft.write(c); } #endif -pfun_t pstreamfun (object *args) { +pfun_t pstreamfun (object* args) { int streamtype = SERIALSTREAM; int address = 0; pfun_t pfun = pserial; @@ -1675,39 +1866,14 @@ pfun_t pstreamfun (object *args) { // Check pins void checkanalogread (int pin) { -#if defined(ESP8266) - if (pin!=17) error(PSTR("invalid pin"), number(pin)); -#elif defined(ESP32) || defined(ARDUINO_ESP32_DEV) + if (!(pin==0 || pin==2 || pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_FEATHER_ESP32) - if (!(pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) - error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2) || defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) - if (!(pin==8 || (pin>=14 && pin<=18))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ADAFRUIT_QTPY_ESP32S2) - if (!((pin>=5 && pin<=9) || (pin>=16 && pin<=18))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ADAFRUIT_QTPY_ESP32C3) - if (!((pin>=0 && pin<=1) || (pin>=3 && pin<=5))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_FEATHERS2) | defined(ARDUINO_ESP32S2_DEV) - if (!((pin>=1 && pin<=20))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ESP32C3_DEV) - if (!((pin>=0 && pin<=5))) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ESP32S3_DEV) - if (!((pin>=1 && pin<=20))) error(PSTR("invalid pin"), number(pin)); -#endif + } void checkanalogwrite (int pin) { -#if defined(ESP8266) - if (!(pin>=0 && pin<=16)) error(PSTR("invalid pin"), number(pin)); -#elif defined(ESP32) || defined(ARDUINO_FEATHER_ESP32) || defined(ARDUINO_ESP32_DEV) if (!(pin>=25 && pin<=26)) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2) || defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) || defined(ARDUINO_ADAFRUIT_QTPY_ESP32S2) || defined(ARDUINO_FEATHERS2) || defined(ARDUINO_ESP32S2_DEV) - if (!(pin>=17 && pin<=18)) error(PSTR("invalid pin"), number(pin)); -#elif defined(ARDUINO_ESP32C3_DEV) | defined(ARDUINO_ESP32S3_DEV) | defined(ARDUINO_ADAFRUIT_QTPY_ESP32C3) - error2(ANALOGWRITE, PSTR("not supported")); -#endif } // Note @@ -1755,29 +1921,29 @@ void pcount (char c) { /* atomwidth - calculates the character width of an atom */ -uint8_t atomwidth (object *obj) { +uint8_t atomwidth (object* obj) { PrintCount = 0; printobject(obj, pcount); return PrintCount; } -uint8_t basewidth (object *obj, uint8_t base) { +uint8_t basewidth (object* obj, uint8_t base) { PrintCount = 0; pintbase(obj->integer, base, pcount); return PrintCount; } -bool quoted (object *obj) { +bool quoted (object* obj) { return (consp(obj) && car(obj) != NULL && car(obj)->name == sym(QUOTE) && consp(cdr(obj)) && cddr(obj) == NULL); } -int subwidth (object *obj, int w) { +int subwidth (object* obj, int w) { if (atom(obj)) return w - atomwidth(obj); if (quoted(obj)) obj = car(cdr(obj)); return subwidthlist(obj, w - 1); } -int subwidthlist (object *form, int w) { +int subwidthlist (object* form, int w) { while (form != NULL && w >= 0) { if (atom(form)) return w - (2 + atomwidth(form)); w = subwidth(car(form), w - 1); @@ -1789,7 +1955,7 @@ int subwidthlist (object *form, int w) { /* superprint - the main pretty-print subroutine */ -void superprint (object *form, int lm, pfun_t pfun) { +void superprint (object* form, int lm, pfun_t pfun) { if (atom(form)) { if (symbolp(form) && form->name == sym(NOTHING)) printsymbol(form, pfun); else printobject(form, pfun); @@ -1802,9 +1968,9 @@ void superprint (object *form, int lm, pfun_t pfun) { /* supersub - subroutine used by pprint */ -void supersub (object *form, int lm, int super, pfun_t pfun) { +void supersub (object* form, int lm, int super, pfun_t pfun) { int special = 0, separate = 1; - object *arg = car(form); + object* arg = car(form); if (symbolp(arg) && builtinp(arg->name)) { uint8_t minmax = getminmax(builtin(arg->name)); if (minmax == 0327 || minmax == 0313) special = 2; // defun, setq, setf, defvar @@ -1826,7 +1992,7 @@ void supersub (object *form, int lm, int super, pfun_t pfun) { edit - the Lisp tree editor Steps through a function definition, editing it a bit at a time, using single-key editing commands. */ -object *edit (object *fun) { +object* edit (object* fun) { while (1) { if (tstflag(EXITEDITOR)) return fun; char c = gserial(); @@ -1845,7 +2011,7 @@ object *edit (object *fun) { // Special forms -object *sp_quote (object *args, object *env) { +object* sp_quote (object* args, object* env) { (void) env; checkargs(args); return first(args); @@ -1855,9 +2021,9 @@ object *sp_quote (object *args, object *env) { (or item*) Evaluates its arguments until one returns non-nil, and returns its value. */ -object *sp_or (object *args, object *env) { +object* sp_or (object* args, object* env) { while (args != NULL) { - object *val = eval(car(args), env); + object* val = eval(car(args), env); if (val != NULL) return val; args = cdr(args); } @@ -1868,13 +2034,13 @@ object *sp_or (object *args, object *env) { (defun name (parameters) form*) Defines a function. */ -object *sp_defun (object *args, object *env) { +object* sp_defun (object* args, object* env) { (void) env; checkargs(args); - object *var = first(args); + object* var = first(args); if (!symbolp(var)) error(notasymbol, var); - object *val = cons(bsymbol(LAMBDA), cdr(args)); - object *pair = value(var->name, GlobalEnv); + object* val = cons(bsymbol(LAMBDA), cdr(args)); + object* pair = value(var->name, GlobalEnv); if (pair != NULL) cdr(pair) = val; else push(cons(var, val), GlobalEnv); return var; @@ -1884,14 +2050,14 @@ object *sp_defun (object *args, object *env) { (defvar variable form) Defines a global variable. */ -object *sp_defvar (object *args, object *env) { +object* sp_defvar (object* args, object* env) { checkargs(args); - object *var = first(args); + object* var = first(args); if (!symbolp(var)) error(notasymbol, var); - object *val = NULL; + object* val = NULL; args = cdr(args); if (args != NULL) { setflag(NOESC); val = eval(first(args), env); clrflag(NOESC); } - object *pair = value(var->name, GlobalEnv); + object* pair = value(var->name, GlobalEnv); if (pair != NULL) cdr(pair) = val; else push(cons(var, val), GlobalEnv); return var; @@ -1902,11 +2068,11 @@ object *sp_defvar (object *args, object *env) { For each pair of arguments assigns the value of the second argument to the variable specified in the first argument. */ -object *sp_setq (object *args, object *env) { - object *arg = nil; +object* sp_setq (object* args, object* env) { + object* arg = nil; while (args != NULL) { if (cdr(args) == NULL) error2(oddargs); - object *pair = findvalue(first(args), env); + object* pair = findvalue(first(args), env); arg = eval(second(args), env); cdr(pair) = arg; args = cddr(args); @@ -1919,13 +2085,13 @@ object *sp_setq (object *args, object *env) { Executes its arguments repeatedly until one of the arguments calls (return), which then causes an exit from the loop. */ -object *sp_loop (object *args, object *env) { - object *start = args; +object* sp_loop (object* args, object* env) { + object* start = args; for (;;) { yield(); args = start; while (args != NULL) { - object *result = eval(car(args),env); + object* result = eval(car(args),env); if (tstflag(RETURNFLAG)) { clrflag(RETURNFLAG); return result; @@ -1939,8 +2105,8 @@ object *sp_loop (object *args, object *env) { (return [value]) Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value. */ -object *sp_return (object *args, object *env) { - object *result = eval(tf_progn(args,env), env); +object* sp_return (object* args, object* env) { + object* result = eval(tf_progn(args,env), env); setflag(RETURNFLAG); return result; } @@ -1950,11 +2116,11 @@ object *sp_return (object *args, object *env) { Modifies the value of place, which should be a list, to add item onto the front of the list, and returns the new list. */ -object *sp_push (object *args, object *env) { +object* sp_push (object* args, object* env) { int bit; checkargs(args); - object *item = eval(first(args), env); - object **loc = place(second(args), env, &bit); + object* item = eval(first(args), env); + object** loc = place(second(args), env, &bit); push(item, *loc); return *loc; } @@ -1963,11 +2129,11 @@ object *sp_push (object *args, object *env) { (pop place) Modifies the value of place, which should be a list, to remove its first item, and returns that item. */ -object *sp_pop (object *args, object *env) { +object* sp_pop (object* args, object* env) { int bit; checkargs(args); - object **loc = place(first(args), env, &bit); - object *result = car(*loc); + object** loc = place(first(args), env, &bit); + object* result = car(*loc); pop(*loc); return result; } @@ -1979,14 +2145,14 @@ object *sp_pop (object *args, object *env) { Increments a place, which should have an numeric value, and returns the result. The third argument is an optional increment which defaults to 1. */ -object *sp_incf (object *args, object *env) { +object* sp_incf (object* args, object* env) { int bit; checkargs(args); - object **loc = place(first(args), env, &bit); + object** loc = place(first(args), env, &bit); args = cdr(args); - object *x = *loc; - object *inc = (args != NULL) ? eval(first(args), env) : NULL; + object* x = *loc; + object* inc = (args != NULL) ? eval(first(args), env) : NULL; if (bit != -1) { int increment; @@ -2027,14 +2193,14 @@ object *sp_incf (object *args, object *env) { Decrements a place, which should have an numeric value, and returns the result. The third argument is an optional decrement which defaults to 1. */ -object *sp_decf (object *args, object *env) { +object* sp_decf (object* args, object* env) { int bit; checkargs(args); - object **loc = place(first(args), env, &bit); + object** loc = place(first(args), env, &bit); args = cdr(args); - object *x = *loc; - object *dec = (args != NULL) ? eval(first(args), env) : NULL; + object* x = *loc; + object* dec = (args != NULL) ? eval(first(args), env) : NULL; if (bit != -1) { int decrement; @@ -2074,12 +2240,12 @@ object *sp_decf (object *args, object *env) { (setf place value [place value]*) For each pair of arguments modifies a place to the result of evaluating value. */ -object *sp_setf (object *args, object *env) { +object* sp_setf (object* args, object* env) { int bit; - object *arg = nil; + object* arg = nil; while (args != NULL) { if (cdr(args) == NULL) error2(oddargs); - object **loc = place(first(args), env, &bit); + object** loc = place(first(args), env, &bit); arg = eval(second(args), env); if (bit == -1) *loc = arg; else *loc = number((checkinteger(*loc) & ~(1<name); args = cdr(args); @@ -2185,7 +2351,7 @@ object *sp_trace (object *args, object *env) { Turns off tracing of up to TRACEMAX user-defined functions, and returns a list of the functions untraced. If no functions are specified it untraces all functions. */ -object *sp_untrace (object *args, object *env) { +object* sp_untrace (object* args, object* env) { (void) env; if (args == NULL) { int i = 0; @@ -2196,7 +2362,7 @@ object *sp_untrace (object *args, object *env) { } } else { while (args != NULL) { - object *var = first(args); + object* var = first(args); if (!symbolp(var)) error(notasymbol, var); untrace(var->name); args = cdr(args); @@ -2210,9 +2376,9 @@ object *sp_untrace (object *args, object *env) { Executes the forms and then waits until a total of number milliseconds have elapsed. Returns the total number of milliseconds taken. */ -object *sp_formillis (object *args, object *env) { +object* sp_formillis (object* args, object* env) { if (args == NULL) error2(noargument); - object *param = first(args); + object* param = first(args); unsigned long start = millis(); unsigned long now, total = 0; if (param != NULL) total = checkinteger(eval(first(param), env)); @@ -2230,9 +2396,9 @@ object *sp_formillis (object *args, object *env) { Prints the value returned by the form, and the time taken to evaluate the form in milliseconds or seconds. */ -object *sp_time (object *args, object *env) { +object* sp_time (object* args, object* env) { unsigned long start = millis(); - object *result = eval(first(args), env); + object* result = eval(first(args), env); unsigned long elapsed = millis() - start; printobject(result, pserial); pfstring(PSTR("\nTime: "), pserial); @@ -2252,16 +2418,16 @@ object *sp_time (object *args, object *env) { (with-output-to-string (str) form*) Returns a string containing the output to the stream variable str. */ -object *sp_withoutputtostring (object *args, object *env) { +object* sp_withoutputtostring (object* args, object* env) { if (args == NULL) error2(noargument); - object *params = first(args); + object* params = first(args); if (params == NULL) error2(nostream); - object *var = first(params); - object *pair = cons(var, stream(STRINGSTREAM, 0)); + object* var = first(params); + object* pair = cons(var, stream(STRINGSTREAM, 0)); push(pair,env); - object *string = startstring(); + object* string = startstring(); push(string, GCStack); - object *forms = cdr(args); + object* forms = cdr(args); eval(tf_progn(forms,env), env); pop(GCStack); return string; @@ -2272,19 +2438,19 @@ object *sp_withoutputtostring (object *args, object *env) { Evaluates the forms with str bound to a serial-stream using port. The optional baud gives the baud rate divided by 100, default 96. */ -object *sp_withserial (object *args, object *env) { - object *params = first(args); +object* sp_withserial (object* args, object* env) { + object* params = first(args); if (params == NULL) error2(nostream); - object *var = first(params); + object* var = first(params); int address = checkinteger(eval(second(params), env)); params = cddr(params); int baud = 96; if (params != NULL) baud = checkinteger(eval(first(params), env)); - object *pair = cons(var, stream(SERIALSTREAM, address)); + object* pair = cons(var, stream(SERIALSTREAM, address)); push(pair,env); serialbegin(address, baud); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); + object* forms = cdr(args); + object* result = eval(tf_progn(forms,env), env); serialend(address); return result; } @@ -2295,25 +2461,25 @@ object *sp_withserial (object *args, object *env) { If read-p is nil or omitted the stream is written to, otherwise it specifies the number of bytes to be read from the stream. The port if specified is ignored. */ -object *sp_withi2c (object *args, object *env) { - object *params = first(args); +object* sp_withi2c (object* args, object* env) { + object* params = first(args); if (params == NULL) error2(nostream); - object *var = first(params); + object* var = first(params); int address = checkinteger(eval(second(params), env)); params = cddr(params); if (address == 0 && params != NULL) params = cdr(params); // Ignore port int read = 0; // Write I2Ccount = 0; if (params != NULL) { - object *rw = eval(first(params), env); + object* rw = eval(first(params), env); if (integerp(rw)) I2Ccount = rw->integer; read = (rw != NULL); } I2Cinit(1); // Pullups - object *pair = cons(var, (I2Cstart(address, read)) ? stream(I2CSTREAM, address) : nil); + object* pair = cons(var, (I2Cstart(address, read)) ? stream(I2CSTREAM, address) : nil); push(pair,env); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); + object* forms = cdr(args); + object* result = eval(tf_progn(forms,env), env); I2Cstop(read); return result; } @@ -2324,10 +2490,10 @@ object *sp_withi2c (object *args, object *env) { The parameters specify the enable pin, clock in kHz (default 4000), bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0). */ -object *sp_withspi (object *args, object *env) { - object *params = first(args); +object* sp_withspi (object* args, object* env) { + object* params = first(args); if (params == NULL) error2(nostream); - object *var = first(params); + object* var = first(params); params = cdr(params); if (params == NULL) error2(nostream); int pin = checkinteger(eval(car(params), env)); @@ -2348,13 +2514,13 @@ object *sp_withspi (object *args, object *env) { } } } - object *pair = cons(var, stream(SPISTREAM, pin)); + object* pair = cons(var, stream(SPISTREAM, pin)); push(pair,env); SPI.begin(); SPI.beginTransaction(SPISettings(((unsigned long)clock * 1000), bitorder, mode)); digitalWrite(pin, LOW); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); + object* forms = cdr(args); + object* result = eval(tf_progn(forms,env), env); digitalWrite(pin, HIGH); SPI.endTransaction(); return result; @@ -2365,19 +2531,19 @@ object *sp_withspi (object *args, object *env) { Evaluates the forms with str bound to an sd-stream reading from or writing to the file filename. If mode is omitted the file is read, otherwise 0 means read, 1 write-append, or 2 write-overwrite. */ -object *sp_withsdcard (object *args, object *env) { +object* sp_withsdcard (object* args, object* env) { #if defined(sdcardsupport) - object *params = first(args); + object* params = first(args); if (params == NULL) error2(nostream); - object *var = first(params); + object* var = first(params); params = cdr(params); if (params == NULL) error2(PSTR("no filename specified")); - object *filename = eval(first(params), env); + object* filename = eval(first(params), env); params = cdr(params); SD.begin(); int mode = 0; if (params != NULL && first(params) != NULL) mode = checkinteger(first(params)); - const char *oflag = FILE_READ; + const char* oflag = FILE_READ; if (mode == 1) oflag = FILE_APPEND; else if (mode == 2) oflag = FILE_WRITE; if (mode >= 1) { char buffer[BUFFERSIZE]; @@ -2388,10 +2554,10 @@ object *sp_withsdcard (object *args, object *env) { SDgfile = SD.open(MakeFilename(filename, buffer), oflag); if (!SDgfile) error2(PSTR("problem reading from SD card or invalid filename")); } - object *pair = cons(var, stream(SDSTREAM, 1)); + object* pair = cons(var, stream(SDSTREAM, 1)); push(pair,env); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); + object* forms = cdr(args); + object* result = eval(tf_progn(forms,env), env); if (mode >= 1) SDpfile.close(); else SDgfile.close(); return result; #else @@ -2407,11 +2573,11 @@ object *sp_withsdcard (object *args, object *env) { (progn form*) Evaluates several forms grouped together into a block, and returns the result of evaluating the last form. */ -object *tf_progn (object *args, object *env) { +object* tf_progn (object* args, object* env) { if (args == NULL) return nil; - object *more = cdr(args); + object* more = cdr(args); while (more != NULL) { - object *result = eval(car(args),env); + object* result = eval(car(args),env); if (tstflag(RETURNFLAG)) return result; args = more; more = cdr(args); @@ -2424,7 +2590,7 @@ object *tf_progn (object *args, object *env) { Evaluates test. If it's non-nil the form then is evaluated and returned; otherwise the form else is evaluated and returned. */ -object *tf_if (object *args, object *env) { +object* tf_if (object* args, object* env) { if (args == NULL || cdr(args) == NULL) error2(toofewargs); if (eval(first(args), env) != nil) return second(args); args = cddr(args); @@ -2437,12 +2603,12 @@ object *tf_if (object *args, object *env) { If the test evaluates to non-nil the forms are evaluated, and the last value is returned as the result of the cond. If the test evaluates to nil, none of the forms are evaluated, and the next argument is processed in the same way. */ -object *tf_cond (object *args, object *env) { +object* tf_cond (object* args, object* env) { while (args != NULL) { - object *clause = first(args); + object* clause = first(args); if (!consp(clause)) error(illegalclause, clause); - object *test = eval(first(clause), env); - object *forms = cdr(clause); + object* test = eval(first(clause), env); + object* forms = cdr(clause); if (test != nil) { if (forms == NULL) return quote(test); else return tf_progn(forms, env); } @@ -2455,7 +2621,7 @@ object *tf_cond (object *args, object *env) { (when test form*) Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned. */ -object *tf_when (object *args, object *env) { +object* tf_when (object* args, object* env) { if (args == NULL) error2(noargument); if (eval(first(args), env) != nil) return tf_progn(cdr(args),env); else return nil; @@ -2465,7 +2631,7 @@ object *tf_when (object *args, object *env) { (unless test form*) Evaluates the test. If it's nil the forms are evaluated and the last value is returned. */ -object *tf_unless (object *args, object *env) { +object* tf_unless (object* args, object* env) { if (args == NULL) error2(noargument); if (eval(first(args), env) != nil) return nil; else return tf_progn(cdr(args),env); @@ -2476,14 +2642,14 @@ object *tf_unless (object *args, object *env) { Evaluates a keyform to produce a test key, and then tests this against a series of arguments, each of which is a list containing a key optionally followed by one or more forms. */ -object *tf_case (object *args, object *env) { - object *test = eval(first(args), env); +object* tf_case (object* args, object* env) { + object* test = eval(first(args), env); args = cdr(args); while (args != NULL) { - object *clause = first(args); + object* clause = first(args); if (!consp(clause)) error(illegalclause, clause); - object *key = car(clause); - object *forms = cdr(clause); + object* key = car(clause); + object* forms = cdr(clause); if (consp(key)) { while (key != NULL) { if (eq(test,car(key))) return tf_progn(forms, env); @@ -2499,9 +2665,9 @@ object *tf_case (object *args, object *env) { (and item*) Evaluates its arguments until one returns nil, and returns the last value. */ -object *tf_and (object *args, object *env) { +object* tf_and (object* args, object* env) { if (args == NULL) return tee; - object *more = cdr(args); + object* more = cdr(args); while (more != NULL) { if (eval(car(args), env) == NULL) return nil; args = more; @@ -2516,7 +2682,7 @@ object *tf_and (object *args, object *env) { (not item) Returns t if its argument is nil, or nil otherwise. Equivalent to null. */ -object *fn_not (object *args, object *env) { +object* fn_not (object* args, object* env) { (void) env; return (first(args) == nil) ? tee : nil; } @@ -2526,7 +2692,7 @@ object *fn_not (object *args, object *env) { If the second argument is a list, cons returns a new list with item added to the front of the list. If the second argument isn't a list cons returns a dotted pair. */ -object *fn_cons (object *args, object *env) { +object* fn_cons (object* args, object* env) { (void) env; return cons(first(args), second(args)); } @@ -2535,7 +2701,7 @@ object *fn_cons (object *args, object *env) { (atom item) Returns t if its argument is a single number, symbol, or nil. */ -object *fn_atom (object *args, object *env) { +object* fn_atom (object* args, object* env) { (void) env; return atom(first(args)) ? tee : nil; } @@ -2544,7 +2710,7 @@ object *fn_atom (object *args, object *env) { (listp item) Returns t if its argument is a list. */ -object *fn_listp (object *args, object *env) { +object* fn_listp (object* args, object* env) { (void) env; return listp(first(args)) ? tee : nil; } @@ -2553,7 +2719,7 @@ object *fn_listp (object *args, object *env) { (consp item) Returns t if its argument is a non-null list. */ -object *fn_consp (object *args, object *env) { +object* fn_consp (object* args, object* env) { (void) env; return consp(first(args)) ? tee : nil; } @@ -2562,9 +2728,9 @@ object *fn_consp (object *args, object *env) { (symbolp item) Returns t if its argument is a symbol. */ -object *fn_symbolp (object *args, object *env) { +object* fn_symbolp (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); return (arg == NULL || symbolp(arg)) ? tee : nil; } @@ -2572,7 +2738,7 @@ object *fn_symbolp (object *args, object *env) { (arrayp item) Returns t if its argument is an array. */ -object *fn_arrayp (object *args, object *env) { +object* fn_arrayp (object* args, object* env) { (void) env; return arrayp(first(args)) ? tee : nil; } @@ -2581,7 +2747,7 @@ object *fn_arrayp (object *args, object *env) { (boundp item) Returns t if its argument is a symbol with a value. */ -object *fn_boundp (object *args, object *env) { +object* fn_boundp (object* args, object* env) { return boundp(first(args), env) ? tee : nil; } @@ -2589,7 +2755,7 @@ object *fn_boundp (object *args, object *env) { (keywordp item) Returns t if its argument is a keyword. */ -object *fn_keywordp (object *args, object *env) { +object* fn_keywordp (object* args, object* env) { (void) env; return keywordp(first(args)) ? tee : nil; } @@ -2598,11 +2764,11 @@ object *fn_keywordp (object *args, object *env) { (set symbol value [symbol value]*) For each pair of arguments, assigns the value of the second argument to the value of the first argument. */ -object *fn_setfn (object *args, object *env) { - object *arg = nil; +object* fn_setfn (object* args, object* env) { + object* arg = nil; while (args != NULL) { if (cdr(args) == NULL) error2(oddargs); - object *pair = findvalue(first(args), env); + object* pair = findvalue(first(args), env); arg = second(args); cdr(pair) = arg; args = cddr(args); @@ -2614,9 +2780,9 @@ object *fn_setfn (object *args, object *env) { (streamp item) Returns t if its argument is a stream. */ -object *fn_streamp (object *args, object *env) { +object* fn_streamp (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); return streamp(arg) ? tee : nil; } @@ -2625,7 +2791,7 @@ object *fn_streamp (object *args, object *env) { Tests whether the two arguments are the same symbol, same character, equal numbers, or point to the same cons, and returns t or nil as appropriate. */ -object *fn_eq (object *args, object *env) { +object* fn_eq (object* args, object* env) { (void) env; return eq(first(args), second(args)) ? tee : nil; } @@ -2635,7 +2801,7 @@ object *fn_eq (object *args, object *env) { Tests whether the two arguments are the same symbol, same character, equal numbers, or point to the same cons, and returns t or nil as appropriate. */ -object *fn_equal (object *args, object *env) { +object* fn_equal (object* args, object* env) { (void) env; return equal(first(args), second(args)) ? tee : nil; } @@ -2646,7 +2812,7 @@ object *fn_equal (object *args, object *env) { (car list) Returns the first item in a list. */ -object *fn_car (object *args, object *env) { +object* fn_car (object* args, object* env) { (void) env; return carx(first(args)); } @@ -2655,7 +2821,7 @@ object *fn_car (object *args, object *env) { (cdr list) Returns a list with the first item removed. */ -object *fn_cdr (object *args, object *env) { +object* fn_cdr (object* args, object* env) { (void) env; return cdrx(first(args)); } @@ -2663,7 +2829,7 @@ object *fn_cdr (object *args, object *env) { /* (caar list) */ -object *fn_caar (object *args, object *env) { +object* fn_caar (object* args, object* env) { (void) env; return cxxxr(args, 0b100); } @@ -2671,7 +2837,7 @@ object *fn_caar (object *args, object *env) { /* (cadr list) */ -object *fn_cadr (object *args, object *env) { +object* fn_cadr (object* args, object* env) { (void) env; return cxxxr(args, 0b101); } @@ -2680,7 +2846,7 @@ object *fn_cadr (object *args, object *env) { (cdar list) Equivalent to (cdr (car list)). */ -object *fn_cdar (object *args, object *env) { +object* fn_cdar (object* args, object* env) { (void) env; return cxxxr(args, 0b110); } @@ -2689,7 +2855,7 @@ object *fn_cdar (object *args, object *env) { (cddr list) Equivalent to (cdr (cdr list)). */ -object *fn_cddr (object *args, object *env) { +object* fn_cddr (object* args, object* env) { (void) env; return cxxxr(args, 0b111); } @@ -2698,7 +2864,7 @@ object *fn_cddr (object *args, object *env) { (caaar list) Equivalent to (car (car (car list))). */ -object *fn_caaar (object *args, object *env) { +object* fn_caaar (object* args, object* env) { (void) env; return cxxxr(args, 0b1000); } @@ -2707,7 +2873,7 @@ object *fn_caaar (object *args, object *env) { (caadr list) Equivalent to (car (car (cdar list))). */ -object *fn_caadr (object *args, object *env) { +object* fn_caadr (object* args, object* env) { (void) env; return cxxxr(args, 0b1001);; } @@ -2716,7 +2882,7 @@ object *fn_caadr (object *args, object *env) { (cadar list) Equivalent to (car (cdr (car list))). */ -object *fn_cadar (object *args, object *env) { +object* fn_cadar (object* args, object* env) { (void) env; return cxxxr(args, 0b1010); } @@ -2725,7 +2891,7 @@ object *fn_cadar (object *args, object *env) { (caddr list) Equivalent to (car (cdr (cdr list))). */ -object *fn_caddr (object *args, object *env) { +object* fn_caddr (object* args, object* env) { (void) env; return cxxxr(args, 0b1011); } @@ -2734,7 +2900,7 @@ object *fn_caddr (object *args, object *env) { (cdaar list) Equivalent to (cdar (car (car list))). */ -object *fn_cdaar (object *args, object *env) { +object* fn_cdaar (object* args, object* env) { (void) env; return cxxxr(args, 0b1100); } @@ -2743,7 +2909,7 @@ object *fn_cdaar (object *args, object *env) { (cdadr list) Equivalent to (cdr (car (cdr list))). */ -object *fn_cdadr (object *args, object *env) { +object* fn_cdadr (object* args, object* env) { (void) env; return cxxxr(args, 0b1101); } @@ -2752,7 +2918,7 @@ object *fn_cdadr (object *args, object *env) { (cddar list) Equivalent to (cdr (cdr (car list))). */ -object *fn_cddar (object *args, object *env) { +object* fn_cddar (object* args, object* env) { (void) env; return cxxxr(args, 0b1110); } @@ -2761,7 +2927,7 @@ object *fn_cddar (object *args, object *env) { (cdddr list) Equivalent to (cdr (cdr (cdr list))). */ -object *fn_cdddr (object *args, object *env) { +object* fn_cdddr (object* args, object* env) { (void) env; return cxxxr(args, 0b1111); } @@ -2770,9 +2936,9 @@ object *fn_cdddr (object *args, object *env) { (length item) Returns the number of items in a list, the length of a string, or the length of a one-dimensional array. */ -object *fn_length (object *args, object *env) { +object* fn_length (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); if (listp(arg)) return number(listlength(arg)); if (stringp(arg)) return number(stringlength(arg)); if (!(arrayp(arg) && cdr(cddr(arg)) == NULL)) error(PSTR("argument is not a list, 1d array, or string"), arg); @@ -2783,11 +2949,11 @@ object *fn_length (object *args, object *env) { (array-dimensions item) Returns a list of the dimensions of an array. */ -object *fn_arraydimensions (object *args, object *env) { +object* fn_arraydimensions (object* args, object* env) { (void) env; - object *array = first(args); + object* array = first(args); if (!arrayp(array)) error(PSTR("argument is not an array"), array); - object *dimensions = cddr(array); + object* dimensions = cddr(array); return (first(dimensions)->integer < 0) ? cons(number(-(first(dimensions)->integer)), cdr(dimensions)) : dimensions; } @@ -2795,7 +2961,7 @@ object *fn_arraydimensions (object *args, object *env) { (list item*) Returns a list of the values of its arguments. */ -object *fn_list (object *args, object *env) { +object* fn_list (object* args, object* env) { (void) env; return args; } @@ -2806,16 +2972,16 @@ object *fn_list (object *args, object *env) { If size is a list of n integers it creates an n-dimensional array with those dimensions. If :element-type 'bit is specified the array is a bit array. */ -object *fn_makearray (object *args, object *env) { +object* fn_makearray (object* args, object* env) { (void) env; - object *def = nil; + object* def = nil; bool bitp = false; - object *dims = first(args); + object* dims = first(args); if (dims == NULL) error2(PSTR("dimensions can't be nil")); else if (atom(dims)) dims = cons(dims, NULL); args = cdr(args); while (args != NULL && cdr(args) != NULL) { - object *var = first(args); + object* var = first(args); if (isbuiltin(first(args), INITIALELEMENT)) def = second(args); else if (isbuiltin(first(args), ELEMENTTYPE) && isbuiltin(second(args), BIT)) bitp = true; else error(PSTR("argument not recognised"), var); @@ -2832,10 +2998,10 @@ object *fn_makearray (object *args, object *env) { (reverse list) Returns a list with the elements of list in reverse order. */ -object *fn_reverse (object *args, object *env) { +object* fn_reverse (object* args, object* env) { (void) env; - object *list = first(args); - object *result = NULL; + object* list = first(args); + object* result = NULL; while (list != NULL) { if (improperp(list)) error(notproper, list); push(first(list),result); @@ -2848,11 +3014,11 @@ object *fn_reverse (object *args, object *env) { (nth number list) Returns the nth item in list, counting from zero. */ -object *fn_nth (object *args, object *env) { +object* fn_nth (object* args, object* env) { (void) env; int n = checkinteger(first(args)); if (n < 0) error(indexnegative, first(args)); - object *list = second(args); + object* list = second(args); while (list != NULL) { if (improperp(list)) error(notproper, list); if (n == 0) return car(list); @@ -2866,12 +3032,12 @@ object *fn_nth (object *args, object *env) { (aref array index [index*]) Returns an element from the specified array. */ -object *fn_aref (object *args, object *env) { +object* fn_aref (object* args, object* env) { (void) env; int bit; - object *array = first(args); + object* array = first(args); if (!arrayp(array)) error(PSTR("first argument is not an array"), array); - object *loc = *getarray(array, cdr(args), 0, &bit); + object* loc = *getarray(array, cdr(args), 0, &bit); if (bit == -1) return loc; else return number((loc->integer)>>bit & 1); } @@ -2881,10 +3047,10 @@ object *fn_aref (object *args, object *env) { Looks up a key in an association list of (key . value) pairs, and returns the matching pair, or nil if no pair is found. */ -object *fn_assoc (object *args, object *env) { +object* fn_assoc (object* args, object* env) { (void) env; - object *key = first(args); - object *list = second(args); + object* key = first(args); + object* list = second(args); return assoc(key,list); } @@ -2893,10 +3059,10 @@ object *fn_assoc (object *args, object *env) { Searches for an item in a list, using eq, and returns the list starting from the first occurrence of the item, or nil if it is not found. */ -object *fn_member (object *args, object *env) { +object* fn_member (object* args, object* env) { (void) env; - object *item = first(args); - object *list = second(args); + object* item = first(args); + object* list = second(args); while (list != NULL) { if (improperp(list)) error(notproper, list); if (eq(item,car(list))) return list; @@ -2909,14 +3075,14 @@ object *fn_member (object *args, object *env) { (apply function list) Returns the result of evaluating function, with the list of arguments specified by the second parameter. */ -object *fn_apply (object *args, object *env) { - object *previous = NULL; - object *last = args; +object* fn_apply (object* args, object* env) { + object* previous = NULL; + object* last = args; while (cdr(last) != NULL) { previous = last; last = cdr(last); } - object *arg = car(last); + object* arg = car(last); if (!listp(arg)) error(notalist, arg); cdr(previous) = arg; return apply(first(args), cdr(args), env); @@ -2926,7 +3092,7 @@ object *fn_apply (object *args, object *env) { (funcall function argument*) Evaluates function with the specified arguments. */ -object *fn_funcall (object *args, object *env) { +object* fn_funcall (object* args, object* env) { return apply(first(args), cdr(args), env); } @@ -2934,15 +3100,15 @@ object *fn_funcall (object *args, object *env) { (append list*) Joins its arguments, which should be lists, into a single list. */ -object *fn_append (object *args, object *env) { +object* fn_append (object* args, object* env) { (void) env; - object *head = NULL; - object *tail; + object* head = NULL; + object* tail; while (args != NULL) { - object *list = first(args); + object* list = first(args); if (!listp(list)) error(notalist, list); while (consp(list)) { - object *obj = cons(car(list), cdr(list)); + object* obj = cons(car(list), cdr(list)); if (head == NULL) head = obj; else cdr(tail) = obj; tail = obj; @@ -2959,25 +3125,25 @@ object *fn_append (object *args, object *env) { Applies the function to each element in one or more lists, ignoring the results. It returns the first list argument. */ -object *fn_mapc (object *args, object *env) { - object *function = first(args); +object* fn_mapc (object* args, object* env) { + object* function = first(args); args = cdr(args); - object *result = first(args); + object* result = first(args); push(result,GCStack); - object *params = cons(NULL, NULL); + object* params = cons(NULL, NULL); push(params,GCStack); // Make parameters while (true) { - object *tailp = params; - object *lists = args; + object* tailp = params; + object* lists = args; while (lists != NULL) { - object *list = car(lists); + object* list = car(lists); if (list == NULL) { pop(GCStack); pop(GCStack); return result; } if (improperp(list)) error(notproper, list); - object *obj = cons(first(list),NULL); + object* obj = cons(first(list),NULL); car(lists) = cdr(list); cdr(tailp) = obj; tailp = obj; lists = cdr(lists); @@ -2990,7 +3156,7 @@ object *fn_mapc (object *args, object *env) { (mapcar function list1 [list]*) Applies the function to each element in one or more lists, and returns the resulting list. */ -object *fn_mapcar (object *args, object *env) { +object* fn_mapcar (object* args, object* env) { return mapcarcan(args, env, mapcarfun); } @@ -2999,7 +3165,7 @@ object *fn_mapcar (object *args, object *env) { Applies the function to each element in one or more lists. The results should be lists, and these are appended together to give the value returned. */ -object *fn_mapcan (object *args, object *env) { +object* fn_mapcan (object* args, object* env) { return mapcarcan(args, env, mapcanfun); } @@ -3011,11 +3177,11 @@ object *fn_mapcan (object *args, object *env) { If each argument is an integer, and the running total doesn't overflow, the result is an integer, otherwise a floating-point number. */ -object *fn_add (object *args, object *env) { +object* fn_add (object* args, object* env) { (void) env; int result = 0; while (args != NULL) { - object *arg = car(args); + object* arg = car(args); if (floatp(arg)) return add_floats(args, (float)result); else if (integerp(arg)) { int val = arg->integer; @@ -3035,9 +3201,9 @@ object *fn_add (object *args, object *env) { If each argument is an integer, and the running total doesn't overflow, returns the result as an integer, otherwise a floating-point number. */ -object *fn_subtract (object *args, object *env) { +object* fn_subtract (object* args, object* env) { (void) env; - object *arg = car(args); + object* arg = car(args); args = cdr(args); if (args == NULL) return negate(arg); else if (floatp(arg)) return subtract_floats(args, arg->single_float); @@ -3065,11 +3231,11 @@ object *fn_subtract (object *args, object *env) { If each argument is an integer, and the running total doesn't overflow, the result is an integer, otherwise it's a floating-point number. */ -object *fn_multiply (object *args, object *env) { +object* fn_multiply (object* args, object* env) { (void) env; int result = 1; while (args != NULL){ - object *arg = car(args); + object* arg = car(args); if (floatp(arg)) return multiply_floats(args, result); else if (integerp(arg)) { int64_t val = result * (int64_t)(arg->integer); @@ -3087,7 +3253,7 @@ object *fn_multiply (object *args, object *env) { If each argument is an integer, and each division produces an exact result, the result is an integer; otherwise it's a floating-point number. */ -object *fn_divide (object *args, object *env) { +object* fn_divide (object* args, object* env) { (void) env; object* arg = first(args); args = cdr(args); @@ -3131,10 +3297,10 @@ object *fn_divide (object *args, object *env) { Returns its first argument modulo the second argument. If both arguments are integers the result is an integer; otherwise it's a floating-point number. */ -object *fn_mod (object *args, object *env) { +object* fn_mod (object* args, object* env) { (void) env; - object *arg1 = first(args); - object *arg2 = second(args); + object* arg1 = first(args); + object* arg2 = second(args); if (integerp(arg1) && integerp(arg2)) { int divisor = arg2->integer; if (divisor == 0) error2(PSTR("division by zero")); @@ -3158,7 +3324,7 @@ object *fn_mod (object *args, object *env) { If the argument is an integer the result is an integer if possible; otherwise it's a floating-point number. */ -object *fn_oneplus (object *args, object *env) { +object* fn_oneplus (object* args, object* env) { (void) env; object* arg = first(args); if (floatp(arg)) return makefloat((arg->single_float) + 1.0); @@ -3176,7 +3342,7 @@ object *fn_oneplus (object *args, object *env) { If the argument is an integer the result is an integer if possible; otherwise it's a floating-point number. */ -object *fn_oneminus (object *args, object *env) { +object* fn_oneminus (object* args, object* env) { (void) env; object* arg = first(args); if (floatp(arg)) return makefloat((arg->single_float) - 1.0); @@ -3194,9 +3360,9 @@ object *fn_oneminus (object *args, object *env) { If the argument is an integer the result will be returned as an integer if possible, otherwise a floating-point number. */ -object *fn_abs (object *args, object *env) { +object* fn_abs (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); if (floatp(arg)) return makefloat(abs(arg->single_float)); else if (integerp(arg)) { int result = arg->integer; @@ -3211,9 +3377,9 @@ object *fn_abs (object *args, object *env) { If number is an integer returns a random number between 0 and one less than its argument. Otherwise returns a floating-point number between zero and number. */ -object *fn_random (object *args, object *env) { +object* fn_random (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); if (integerp(arg)) return number(random(arg->integer)); else if (floatp(arg)) return makefloat((float)rand()/(float)(RAND_MAX/(arg->single_float))); else error(notanumber, arg); @@ -3224,12 +3390,12 @@ object *fn_random (object *args, object *env) { (max number*) Returns the maximum of one or more arguments. */ -object *fn_maxfn (object *args, object *env) { +object* fn_maxfn (object* args, object* env) { (void) env; object* result = first(args); args = cdr(args); while (args != NULL) { - object *arg = car(args); + object* arg = car(args); if (integerp(result) && integerp(arg)) { if ((arg->integer) > (result->integer)) result = arg; } else if ((checkintfloat(arg) > checkintfloat(result))) result = arg; @@ -3242,12 +3408,12 @@ object *fn_maxfn (object *args, object *env) { (min number*) Returns the minimum of one or more arguments. */ -object *fn_minfn (object *args, object *env) { +object* fn_minfn (object* args, object* env) { (void) env; object* result = first(args); args = cdr(args); while (args != NULL) { - object *arg = car(args); + object* arg = car(args); if (integerp(result) && integerp(arg)) { if ((arg->integer) < (result->integer)) result = arg; } else if ((checkintfloat(arg) < checkintfloat(result))) result = arg; @@ -3262,14 +3428,14 @@ object *fn_minfn (object *args, object *env) { (/= number*) Returns t if none of the arguments are equal, or nil if two or more arguments are equal. */ -object *fn_noteq (object *args, object *env) { +object* fn_noteq (object* args, object* env) { (void) env; while (args != NULL) { - object *nargs = args; - object *arg1 = first(nargs); + object* nargs = args; + object* arg1 = first(nargs); nargs = cdr(nargs); while (nargs != NULL) { - object *arg2 = first(nargs); + object* arg2 = first(nargs); if (integerp(arg1) && integerp(arg2)) { if ((arg1->integer) == (arg2->integer)) return nil; } else if ((checkintfloat(arg1) == checkintfloat(arg2))) return nil; @@ -3284,7 +3450,7 @@ object *fn_noteq (object *args, object *env) { (= number*) Returns t if all the arguments, which must be numbers, are numerically equal, and nil otherwise. */ -object *fn_numeq (object *args, object *env) { +object* fn_numeq (object* args, object* env) { (void) env; return compare(args, false, false, true); } @@ -3293,7 +3459,7 @@ object *fn_numeq (object *args, object *env) { (< number*) Returns t if each argument is less than the next argument, and nil otherwise. */ -object *fn_less (object *args, object *env) { +object* fn_less (object* args, object* env) { (void) env; return compare(args, true, false, false); } @@ -3302,7 +3468,7 @@ object *fn_less (object *args, object *env) { (<= number*) Returns t if each argument is less than or equal to the next argument, and nil otherwise. */ -object *fn_lesseq (object *args, object *env) { +object* fn_lesseq (object* args, object* env) { (void) env; return compare(args, true, false, true); } @@ -3311,7 +3477,7 @@ object *fn_lesseq (object *args, object *env) { (> number*) Returns t if each argument is greater than the next argument, and nil otherwise. */ -object *fn_greater (object *args, object *env) { +object* fn_greater (object* args, object* env) { (void) env; return compare(args, false, true, false); } @@ -3320,7 +3486,7 @@ object *fn_greater (object *args, object *env) { (>= number*) Returns t if each argument is greater than or equal to the next argument, and nil otherwise. */ -object *fn_greatereq (object *args, object *env) { +object* fn_greatereq (object* args, object* env) { (void) env; return compare(args, false, true, true); } @@ -3329,9 +3495,9 @@ object *fn_greatereq (object *args, object *env) { (plusp number) Returns t if the argument is greater than zero, or nil otherwise. */ -object *fn_plusp (object *args, object *env) { +object* fn_plusp (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); if (floatp(arg)) return ((arg->single_float) > 0.0) ? tee : nil; else if (integerp(arg)) return ((arg->integer) > 0) ? tee : nil; else error(notanumber, arg); @@ -3342,9 +3508,9 @@ object *fn_plusp (object *args, object *env) { (minusp number) Returns t if the argument is less than zero, or nil otherwise. */ -object *fn_minusp (object *args, object *env) { +object* fn_minusp (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); if (floatp(arg)) return ((arg->single_float) < 0.0) ? tee : nil; else if (integerp(arg)) return ((arg->integer) < 0) ? tee : nil; else error(notanumber, arg); @@ -3355,9 +3521,9 @@ object *fn_minusp (object *args, object *env) { (zerop number) Returns t if the argument is zero. */ -object *fn_zerop (object *args, object *env) { +object* fn_zerop (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); if (floatp(arg)) return ((arg->single_float) == 0.0) ? tee : nil; else if (integerp(arg)) return ((arg->integer) == 0) ? tee : nil; else error(notanumber, arg); @@ -3368,7 +3534,7 @@ object *fn_zerop (object *args, object *env) { (oddp number) Returns t if the integer argument is odd. */ -object *fn_oddp (object *args, object *env) { +object* fn_oddp (object* args, object* env) { (void) env; int arg = checkinteger(first(args)); return ((arg & 1) == 1) ? tee : nil; @@ -3378,7 +3544,7 @@ object *fn_oddp (object *args, object *env) { (evenp number) Returns t if the integer argument is even. */ -object *fn_evenp (object *args, object *env) { +object* fn_evenp (object* args, object* env) { (void) env; int arg = checkinteger(first(args)); return ((arg & 1) == 0) ? tee : nil; @@ -3390,7 +3556,7 @@ object *fn_evenp (object *args, object *env) { (integerp number) Returns t if the argument is an integer. */ -object *fn_integerp (object *args, object *env) { +object* fn_integerp (object* args, object* env) { (void) env; return integerp(first(args)) ? tee : nil; } @@ -3399,9 +3565,9 @@ object *fn_integerp (object *args, object *env) { (numberp number) Returns t if the argument is a number. */ -object *fn_numberp (object *args, object *env) { +object* fn_numberp (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); return (integerp(arg) || floatp(arg)) ? tee : nil; } @@ -3411,9 +3577,9 @@ object *fn_numberp (object *args, object *env) { (float number) Returns its argument converted to a floating-point number. */ -object *fn_floatfn (object *args, object *env) { +object* fn_floatfn (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); return (floatp(arg)) ? arg : makefloat((float)(arg->integer)); } @@ -3421,7 +3587,7 @@ object *fn_floatfn (object *args, object *env) { (floatp number) Returns t if the argument is a floating-point number. */ -object *fn_floatp (object *args, object *env) { +object* fn_floatp (object* args, object* env) { (void) env; return floatp(first(args)) ? tee : nil; } @@ -3430,7 +3596,7 @@ object *fn_floatp (object *args, object *env) { (sin number) Returns sin(number). */ -object *fn_sin (object *args, object *env) { +object* fn_sin (object* args, object* env) { (void) env; return makefloat(sin(checkintfloat(first(args)))); } @@ -3439,7 +3605,7 @@ object *fn_sin (object *args, object *env) { (cos number) Returns cos(number). */ -object *fn_cos (object *args, object *env) { +object* fn_cos (object* args, object* env) { (void) env; return makefloat(cos(checkintfloat(first(args)))); } @@ -3448,7 +3614,7 @@ object *fn_cos (object *args, object *env) { (tan number) Returns tan(number). */ -object *fn_tan (object *args, object *env) { +object* fn_tan (object* args, object* env) { (void) env; return makefloat(tan(checkintfloat(first(args)))); } @@ -3457,7 +3623,7 @@ object *fn_tan (object *args, object *env) { (asin number) Returns asin(number). */ -object *fn_asin (object *args, object *env) { +object* fn_asin (object* args, object* env) { (void) env; return makefloat(asin(checkintfloat(first(args)))); } @@ -3466,7 +3632,7 @@ object *fn_asin (object *args, object *env) { (acos number) Returns acos(number). */ -object *fn_acos (object *args, object *env) { +object* fn_acos (object* args, object* env) { (void) env; return makefloat(acos(checkintfloat(first(args)))); } @@ -3475,9 +3641,9 @@ object *fn_acos (object *args, object *env) { (atan number1 [number2]) Returns the arc tangent of number1/number2, in radians. If number2 is omitted it defaults to 1. */ -object *fn_atan (object *args, object *env) { +object* fn_atan (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); float div = 1.0; args = cdr(args); if (args != NULL) div = checkintfloat(first(args)); @@ -3488,7 +3654,7 @@ object *fn_atan (object *args, object *env) { (sinh number) Returns sinh(number). */ -object *fn_sinh (object *args, object *env) { +object* fn_sinh (object* args, object* env) { (void) env; return makefloat(sinh(checkintfloat(first(args)))); } @@ -3497,7 +3663,7 @@ object *fn_sinh (object *args, object *env) { (cosh number) Returns cosh(number). */ -object *fn_cosh (object *args, object *env) { +object* fn_cosh (object* args, object* env) { (void) env; return makefloat(cosh(checkintfloat(first(args)))); } @@ -3506,7 +3672,7 @@ object *fn_cosh (object *args, object *env) { (tanh number) Returns tanh(number). */ -object *fn_tanh (object *args, object *env) { +object* fn_tanh (object* args, object* env) { (void) env; return makefloat(tanh(checkintfloat(first(args)))); } @@ -3515,7 +3681,7 @@ object *fn_tanh (object *args, object *env) { (exp number) Returns exp(number). */ -object *fn_exp (object *args, object *env) { +object* fn_exp (object* args, object* env) { (void) env; return makefloat(exp(checkintfloat(first(args)))); } @@ -3524,18 +3690,18 @@ object *fn_exp (object *args, object *env) { (sqrt number) Returns sqrt(number). */ -object *fn_sqrt (object *args, object *env) { +object* fn_sqrt (object* args, object* env) { (void) env; return makefloat(sqrt(checkintfloat(first(args)))); } /* - (number [base]) + (log number [base]) Returns the logarithm of number to the specified base. If base is omitted it defaults to e. */ -object *fn_log (object *args, object *env) { +object* fn_log (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); float fresult = log(checkintfloat(arg)); args = cdr(args); if (args == NULL) return makefloat(fresult); @@ -3548,16 +3714,16 @@ object *fn_log (object *args, object *env) { Returns the result as an integer if the arguments are integers and the result will be within range, otherwise a floating-point number. */ -object *fn_expt (object *args, object *env) { +object* fn_expt (object* args, object* env) { (void) env; - object *arg1 = first(args); object *arg2 = second(args); + object* arg1 = first(args); object* arg2 = second(args); float float1 = checkintfloat(arg1); float value = log(abs(float1)) * checkintfloat(arg2); if (integerp(arg1) && integerp(arg2) && ((arg2->integer) >= 0) && (abs(value) < 21.4875)) return number(intpower(arg1->integer, arg2->integer)); if (float1 < 0) { if (integerp(arg2)) return makefloat((arg2->integer & 1) ? -exp(value) : exp(value)); - else error2(PSTR("invalid result")); + else error2(PSTR("imaginary result")); } return makefloat(exp(value)); } @@ -3566,9 +3732,9 @@ object *fn_expt (object *args, object *env) { (ceiling number [divisor]) Returns ceil(number/divisor). If omitted, divisor is 1. */ -object *fn_ceiling (object *args, object *env) { +object* fn_ceiling (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); args = cdr(args); if (args != NULL) return number(ceil(checkintfloat(arg) / checkintfloat(first(args)))); else return number(ceil(checkintfloat(arg))); @@ -3578,33 +3744,33 @@ object *fn_ceiling (object *args, object *env) { (floor number [divisor]) Returns floor(number/divisor). If omitted, divisor is 1. */ -object *fn_floor (object *args, object *env) { +object* fn_floor (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); args = cdr(args); if (args != NULL) return number(floor(checkintfloat(arg) / checkintfloat(first(args)))); else return number(floor(checkintfloat(arg))); } /* - (truncate number) - Returns t if the argument is a floating-point number. + (truncate number [divisor]) + Returns the integer part of number/divisor. If divisor is omitted it defaults to 1. */ -object *fn_truncate (object *args, object *env) { +object* fn_truncate (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); args = cdr(args); if (args != NULL) return number((int)(checkintfloat(arg) / checkintfloat(first(args)))); else return number((int)(checkintfloat(arg))); } /* - (round number) - Returns t if the argument is a floating-point number. + (round number [divisor]) + Returns the integer closest to number/divisor. If divisor is omitted it defaults to 1. */ -object *fn_round (object *args, object *env) { +object* fn_round (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); args = cdr(args); if (args != NULL) return number(myround(checkintfloat(arg) / checkintfloat(first(args)))); else return number(myround(checkintfloat(arg))); @@ -3616,11 +3782,11 @@ object *fn_round (object *args, object *env) { (char string n) Returns the nth character in a string, counting from zero. */ -object *fn_char (object *args, object *env) { +object* fn_char (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); if (!stringp(arg)) error(notastring, arg); - object *n = second(args); + object* n = second(args); char c = nthchar(arg, checkinteger(n)); if (c == 0) error(indexrange, n); return character(c); @@ -3630,7 +3796,7 @@ object *fn_char (object *args, object *env) { (char-code character) Returns the ASCII code for a character, as an integer. */ -object *fn_charcode (object *args, object *env) { +object* fn_charcode (object* args, object* env) { (void) env; return number(checkchar(first(args))); } @@ -3639,7 +3805,7 @@ object *fn_charcode (object *args, object *env) { (code-char integer) Returns the character for the specified ASCII code. */ -object *fn_codechar (object *args, object *env) { +object* fn_codechar (object* args, object* env) { (void) env; return character(checkinteger(first(args))); } @@ -3648,7 +3814,7 @@ object *fn_codechar (object *args, object *env) { (characterp item) Returns t if the argument is a character and nil otherwise. */ -object *fn_characterp (object *args, object *env) { +object* fn_characterp (object* args, object* env) { (void) env; return characterp(first(args)) ? tee : nil; } @@ -3659,7 +3825,7 @@ object *fn_characterp (object *args, object *env) { (stringp item) Returns t if the argument is a string and nil otherwise. */ -object *fn_stringp (object *args, object *env) { +object* fn_stringp (object* args, object* env) { (void) env; return stringp(first(args)) ? tee : nil; } @@ -3668,7 +3834,7 @@ object *fn_stringp (object *args, object *env) { (string= string string) Tests whether two strings are the same. */ -object *fn_stringeq (object *args, object *env) { +object* fn_stringeq (object* args, object* env) { (void) env; return stringcompare(args, false, false, true) ? tee : nil; } @@ -3677,7 +3843,7 @@ object *fn_stringeq (object *args, object *env) { (string< string string) Returns t if the first string is alphabetically less than the second string, and nil otherwise. */ -object *fn_stringless (object *args, object *env) { +object* fn_stringless (object* args, object* env) { (void) env; return stringcompare(args, true, false, false) ? tee : nil; } @@ -3686,7 +3852,7 @@ object *fn_stringless (object *args, object *env) { (string> string string) Returns t if the first string is alphabetically greater than the second string, and nil otherwise. */ -object *fn_stringgreater (object *args, object *env) { +object* fn_stringgreater (object* args, object* env) { (void) env; return stringcompare(args, false, true, false) ? tee : nil; } @@ -3695,16 +3861,16 @@ object *fn_stringgreater (object *args, object *env) { (sort list test) Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list. */ -object *fn_sort (object *args, object *env) { +object* fn_sort (object* args, object* env) { if (first(args) == NULL) return nil; - object *list = cons(nil,first(args)); + object* list = cons(nil,first(args)); push(list,GCStack); - object *predicate = second(args); - object *compare = cons(NULL, cons(NULL, NULL)); + object* predicate = second(args); + object* compare = cons(NULL, cons(NULL, NULL)); push(compare,GCStack); - object *ptr = cdr(list); + object* ptr = cdr(list); while (cdr(ptr) != NULL) { - object *go = list; + object* go = list; while (go != ptr) { car(compare) = car(cdr(ptr)); car(cdr(compare)) = car(cdr(go)); @@ -3712,7 +3878,7 @@ object *fn_sort (object *args, object *env) { go = cdr(go); } if (go != ptr) { - object *obj = cdr(ptr); + object* obj = cdr(ptr); cdr(ptr) = cdr(obj); cdr(obj) = cdr(go); cdr(go) = obj; @@ -3726,7 +3892,7 @@ object *fn_sort (object *args, object *env) { (string item) Converts its argument to a string. */ -object *fn_stringfn (object *args, object *env) { +object* fn_stringfn (object* args, object* env) { return fn_princtostring(args, env); } @@ -3734,15 +3900,15 @@ object *fn_stringfn (object *args, object *env) { (concatenate 'string string*) Joins together the strings given in the second and subsequent arguments, and returns a single string. */ -object *fn_concatenate (object *args, object *env) { +object* fn_concatenate (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); if (builtin(arg->name) != STRINGFN) error2(PSTR("only supports strings")); args = cdr(args); - object *result = newstring(); - object *tail = result; + object* result = newstring(); + object* tail = result; while (args != NULL) { - object *obj = checkstring(first(args)); + object* obj = checkstring(first(args)); obj = cdr(obj); while (obj != NULL) { int quad = obj->chars; @@ -3762,9 +3928,9 @@ object *fn_concatenate (object *args, object *env) { (subseq seq start [end]) Returns a subsequence of a list or string from item start to item end-1. */ -object *fn_subseq (object *args, object *env) { +object* fn_subseq (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); int start = checkinteger(second(args)), end; if (start < 0) error(indexnegative, second(args)); args = cddr(args); @@ -3772,8 +3938,8 @@ object *fn_subseq (object *args, object *env) { int length = listlength(arg); if (args != NULL) end = checkinteger(car(args)); else end = length; if (start > end || end > length) error2(indexrange); - object *result = cons(NULL, NULL); - object *ptr = result; + object* result = cons(NULL, NULL); + object* ptr = result; for (int x = 0; x < end; x++) { if (x >= start) { cdr(ptr) = cons(car(arg), NULL); ptr = cdr(ptr); } arg = cdr(arg); @@ -3783,8 +3949,8 @@ object *fn_subseq (object *args, object *env) { int length = stringlength(arg); if (args != NULL) end = checkinteger(car(args)); else end = length; if (start > end || end > length) error2(indexrange); - object *result = newstring(); - object *tail = result; + object* result = newstring(); + object* tail = result; for (int i=start; iinteger; args = cdr(args); int read = 0; // Write I2Ccount = 0; if (args != NULL) { - object *rw = first(args); + object* rw = first(args); if (integerp(rw)) I2Ccount = rw->integer; read = (rw != NULL); } @@ -4163,7 +4327,7 @@ object *fn_restarti2c (object *args, object *env) { (gc) Forces a garbage collection and prints the number of objects collected, and the time taken. */ -object *fn_gc (object *obj, object *env) { +object* fn_gc (object* obj, object* env) { int initial = Freespace; unsigned long start = micros(); gc(obj, env); @@ -4180,7 +4344,7 @@ object *fn_gc (object *obj, object *env) { (room) Returns the number of free Lisp cells remaining. */ -object *fn_room (object *args, object *env) { +object* fn_room (object* args, object* env) { (void) args, (void) env; return number(Freespace); } @@ -4189,7 +4353,7 @@ object *fn_room (object *args, object *env) { (cls) Prints a clear-screen character. */ -object *fn_cls (object *args, object *env) { +object* fn_cls (object* args, object* env) { (void) args, (void) env; pserial(12); return nil; @@ -4202,9 +4366,9 @@ object *fn_cls (object *args, object *env) { Sets the input/output mode of an Arduino pin number, and returns nil. The mode parameter can be an integer, a keyword, or t or nil. */ -object *fn_pinmode (object *args, object *env) { +object* fn_pinmode (object* args, object* env) { (void) env; int pin; - object *arg = first(args); + object* arg = first(args); if (keywordp(arg)) pin = checkkeyword(arg); else pin = checkinteger(first(args)); int pm = INPUT; @@ -4225,10 +4389,10 @@ object *fn_pinmode (object *args, object *env) { (digitalread pin) Reads the state of the specified Arduino pin number and returns t (high) or nil (low). */ -object *fn_digitalread (object *args, object *env) { +object* fn_digitalread (object* args, object* env) { (void) env; int pin; - object *arg = first(args); + object* arg = first(args); if (keywordp(arg)) pin = checkkeyword(arg); else pin = checkinteger(arg); if (digitalRead(pin) != 0) return tee; else return nil; @@ -4238,10 +4402,10 @@ object *fn_digitalread (object *args, object *env) { (digitalwrite pin state) Sets the state of the specified Arduino pin number. */ -object *fn_digitalwrite (object *args, object *env) { +object* fn_digitalwrite (object* args, object* env) { (void) env; int pin; - object *arg = first(args); + object* arg = first(args); if (keywordp(arg)) pin = checkkeyword(arg); else pin = checkinteger(arg); arg = second(args); @@ -4257,10 +4421,10 @@ object *fn_digitalwrite (object *args, object *env) { (analogread pin) Reads the specified Arduino analogue pin number and returns the value. */ -object *fn_analogread (object *args, object *env) { +object* fn_analogread (object* args, object* env) { (void) env; int pin; - object *arg = first(args); + object* arg = first(args); if (keywordp(arg)) pin = checkkeyword(arg); else { pin = checkinteger(arg); @@ -4274,14 +4438,10 @@ object *fn_analogread (object *args, object *env) { Specifies the resolution for the analogue inputs on platforms that support it. The default resolution on all platforms is 10 bits. */ -object *fn_analogreadresolution (object *args, object *env) { +object* fn_analogreadresolution (object* args, object* env) { (void) env; - object *arg = first(args); - #if defined(ESP32) + object* arg = first(args); analogReadResolution(checkinteger(arg)); - #else - error2(PSTR("not supported")); - #endif return arg; } @@ -4289,14 +4449,14 @@ object *fn_analogreadresolution (object *args, object *env) { (analogwrite pin value) Writes the value to the specified Arduino pin number. */ -object *fn_analogwrite (object *args, object *env) { +object* fn_analogwrite (object* args, object* env) { (void) env; int pin; - object *arg = first(args); + object* arg = first(args); if (keywordp(arg)) pin = checkkeyword(arg); else pin = checkinteger(arg); checkanalogwrite(pin); - object *value = second(args); + object* value = second(args); analogWrite(pin, checkinteger(value)); return value; } @@ -4305,9 +4465,9 @@ object *fn_analogwrite (object *args, object *env) { (delay number) Delays for a specified number of milliseconds. */ -object *fn_delay (object *args, object *env) { +object* fn_delay (object* args, object* env) { (void) env; - object *arg1 = first(args); + object* arg1 = first(args); delay(checkinteger(arg1)); return arg1; } @@ -4316,7 +4476,7 @@ object *fn_delay (object *args, object *env) { (millis) Returns the time in milliseconds that uLisp has been running. */ -object *fn_millis (object *args, object *env) { +object* fn_millis (object* args, object* env) { (void) args, (void) env; return number(millis()); } @@ -4326,9 +4486,9 @@ object *fn_millis (object *args, object *env) { Puts the processor into a low-power sleep mode for secs. Only supported on some platforms. On other platforms it does delay(1000*secs). */ -object *fn_sleep (object *args, object *env) { +object* fn_sleep (object* args, object* env) { (void) env; - object *arg1 = first(args); + object* arg1 = first(args); doze(checkinteger(arg1)); return arg1; } @@ -4340,7 +4500,7 @@ object *fn_sleep (object *args, object *env) { where 0 represents C, 1 represents C#, and so on. The argument octave can be from 3 to 6. If omitted it defaults to 0. */ -object *fn_note (object *args, object *env) { +object* fn_note (object* args, object* env) { (void) env; static int pin = 255; if (args != NULL) { @@ -4360,9 +4520,9 @@ object *fn_note (object *args, object *env) { If value is not specified the function returns the value of the register at address. If value is specified the value is written to the register at address and the function returns value. */ -object *fn_register (object *args, object *env) { +object* fn_register (object* args, object* env) { (void) env; - object *arg = first(args); + object* arg = first(args); int addr; if (keywordp(arg)) addr = checkkeyword(arg); else addr = checkinteger(first(args)); @@ -4377,11 +4537,11 @@ object *fn_register (object *args, object *env) { (edit 'function) Calls the Lisp tree editor to allow you to edit a function definition. */ -object *fn_edit (object *args, object *env) { - object *fun = first(args); - object *pair = findvalue(fun, env); +object* fn_edit (object* args, object* env) { + object* fun = first(args); + object* pair = findvalue(fun, env); clrflag(EXITEDITOR); - object *arg = edit(eval(fun, env)); + object* arg = edit(eval(fun, env)); cdr(pair) = arg; return arg; } @@ -4393,9 +4553,9 @@ object *fn_edit (object *args, object *env) { Prints its argument, using the pretty printer, to display it formatted in a structured way. If str is specified it prints to the specified stream. It returns no value. */ -object *fn_pprint (object *args, object *env) { +object* fn_pprint (object* args, object* env) { (void) env; - object *obj = first(args); + object* obj = first(args); pfun_t pfun = pstreamfun(cdr(args)); #if defined(gfxsupport) if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; @@ -4411,17 +4571,17 @@ object *fn_pprint (object *args, object *env) { Pretty-prints the definition of every function and variable defined in the uLisp workspace. If str is specified it prints to the specified stream. It returns no value. */ -object *fn_pprintall (object *args, object *env) { +object* fn_pprintall (object* args, object* env) { (void) env; pfun_t pfun = pstreamfun(args); #if defined(gfxsupport) if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; #endif - object *globals = GlobalEnv; + object* globals = GlobalEnv; while (globals != NULL) { - object *pair = first(globals); - object *var = car(pair); - object *val = cdr(pair); + object* pair = first(globals); + object* var = car(pair); + object* val = cdr(pair); pln(pfun); if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) { superprint(cons(bsymbol(DEFUN), cons(var, cdr(val))), 0, pfun); @@ -4442,15 +4602,15 @@ object *fn_pprintall (object *args, object *env) { (format output controlstring [arguments]*) Outputs its arguments formatted according to the format directives in controlstring. */ -object *fn_format (object *args, object *env) { +object* fn_format (object* args, object* env) { (void) env; pfun_t pfun = pserial; - object *output = first(args); - object *obj; + object* output = first(args); + object* obj; if (output == nil) { obj = startstring(); pfun = pstr; } else if (output != tee) pfun = pstreamfun(args); - object *formatstr = checkstring(second(args)); - object *save = NULL; + object* formatstr = checkstring(second(args)); + object* save = NULL; args = cddr(args); int len = stringlength(formatstr); uint8_t n = 0, width = 0, w, bra = 0; @@ -4489,7 +4649,7 @@ object *fn_format (object *args, object *env) { } else if (ch2 == 'A' || ch2 == 'S' || ch2 == 'D' || ch2 == 'G' || ch2 == 'X' || ch2 == 'B') { if (args == NULL) formaterr(formatstr, noargument, n); - object *arg = first(args); args = cdr(args); + object* arg = first(args); args = cdr(args); uint8_t aw = atomwidth(arg); if (width < aw) w = 0; else w = width-aw; tilde = false; @@ -4525,18 +4685,18 @@ object *fn_format (object *args, object *env) { Loads the definition of a function defined with defun, or a variable defined with defvar, from the Lisp Library. It returns t if it was loaded, or nil if the symbol is already defined or isn't defined in the Lisp Library. */ -object *fn_require (object *args, object *env) { - object *arg = first(args); - object *globals = GlobalEnv; +object* fn_require (object* args, object* env) { + object* arg = first(args); + object* globals = GlobalEnv; if (!symbolp(arg)) error(notasymbol, arg); while (globals != NULL) { - object *pair = first(globals); - object *var = car(pair); + object* pair = first(globals); + object* var = car(pair); if (symbolp(var) && var == arg) return nil; globals = cdr(globals); } GlobalStringIndex = 0; - object *line = read(glibrary); + object* line = read(glibrary); while (line != NULL) { // Is this the definition we want symbol_t fname = first(line)->name; @@ -4553,10 +4713,10 @@ object *fn_require (object *args, object *env) { (list-library) Prints a list of the functions defined in the List Library. */ -object *fn_listlibrary (object *args, object *env) { +object* fn_listlibrary (object* args, object* env) { (void) args, (void) env; GlobalStringIndex = 0; - object *line = read(glibrary); + object* line = read(glibrary); while (line != NULL) { builtin_t bname = builtin(first(line)->name); if (bname == DEFUN || bname == DEFVAR) { @@ -4573,9 +4733,9 @@ object *fn_listlibrary (object *args, object *env) { (? item) Prints the documentation string of a built-in or user-defined function. */ -object *sp_help (object *args, object *env) { +object* sp_help (object* args, object* env) { if (args == NULL) error2(noargument); - object *docstring = documentation(first(args), env); + object* docstring = documentation(first(args), env); if (docstring) { char temp = Flags; clrflag(PRINTREADABLY); @@ -4589,7 +4749,7 @@ object *sp_help (object *args, object *env) { (documentation 'symbol [type]) Returns the documentation string of a built-in or user-defined function. The type argument is ignored. */ -object *fn_documentation (object *args, object *env) { +object* fn_documentation (object* args, object* env) { return documentation(first(args), env); } @@ -4597,7 +4757,7 @@ object *fn_documentation (object *args, object *env) { (apropos item) Prints the user-defined and built-in functions whose names contain the specified string or symbol. */ -object *fn_apropos (object *args, object *env) { +object* fn_apropos (object* args, object* env) { (void) env; apropos(first(args), true); return bsymbol(NOTHING); @@ -4607,7 +4767,7 @@ object *fn_apropos (object *args, object *env) { (apropos-list item) Returns a list of user-defined and built-in functions whose names contain the specified string or symbol. */ -object *fn_aproposlist (object *args, object *env) { +object* fn_aproposlist (object* args, object* env) { (void) env; return apropos(first(args), false); } @@ -4619,14 +4779,14 @@ object *fn_aproposlist (object *args, object *env) { Evaluates form1 and forms in order and returns the value of form1, but guarantees to evaluate forms even if an error occurs in form1. */ -object *sp_unwindprotect (object *args, object *env) { +object* sp_unwindprotect (object* args, object* env) { if (args == NULL) error2(toofewargs); - object *current_GCStack = GCStack; + object* current_GCStack = GCStack; jmp_buf dynamic_handler; jmp_buf *previous_handler = handler; handler = &dynamic_handler; - object *protected_form = first(args); - object *result; + object* protected_form = first(args); + object* result; bool signaled = false; if (!setjmp(dynamic_handler)) { @@ -4637,7 +4797,7 @@ object *sp_unwindprotect (object *args, object *env) { } handler = previous_handler; - object *protective_forms = cdr(args); + object* protective_forms = cdr(args); while (protective_forms != NULL) { eval(car(protective_forms), env); if (tstflag(RETURNFLAG)) break; @@ -4653,12 +4813,12 @@ object *sp_unwindprotect (object *args, object *env) { (ignore-errors [forms]*) Evaluates forms ignoring errors. */ -object *sp_ignoreerrors (object *args, object *env) { - object *current_GCStack = GCStack; +object* sp_ignoreerrors (object* args, object* env) { + object* current_GCStack = GCStack; jmp_buf dynamic_handler; jmp_buf *previous_handler = handler; handler = &dynamic_handler; - object *result = nil; + object* result = nil; bool muffled = tstflag(MUFFLEERRORS); setflag(MUFFLEERRORS); @@ -4684,8 +4844,8 @@ object *sp_ignoreerrors (object *args, object *env) { (error controlstring [arguments]*) Signals an error. The message is printed by format using the controlstring and arguments. */ -object *sp_error (object *args, object *env) { - object *message = eval(cons(bsymbol(FORMAT), cons(nil, args)), env); +object* sp_error (object* args, object* env) { + object* message = eval(cons(bsymbol(FORMAT), cons(nil, args)), env); if (!tstflag(MUFFLEERRORS)) { char temp = Flags; clrflag(PRINTREADABLY); @@ -4703,9 +4863,9 @@ object *sp_error (object *args, object *env) { (with-client (str [address port]) form*) Evaluates the forms with str bound to a wifi-stream. */ -object *sp_withclient (object *args, object *env) { - object *params = first(args); - object *var = first(params); +object* sp_withclient (object* args, object* env) { + object* params = first(args); + object* var = first(params); char buffer[BUFFERSIZE]; params = cdr(params); int n; @@ -4714,8 +4874,8 @@ object *sp_withclient (object *args, object *env) { if (!client) return nil; n = 2; } else { - object *address = eval(first(params), env); - object *port = eval(second(params), env); + object* address = eval(first(params), env); + object* port = eval(second(params), env); int success; if (stringp(address)) success = client.connect(cstring(address, buffer, BUFFERSIZE), checkinteger(port)); else if (integerp(address)) success = client.connect(address->integer, checkinteger(port)); @@ -4723,10 +4883,10 @@ object *sp_withclient (object *args, object *env) { if (!success) return nil; n = 1; } - object *pair = cons(var, stream(WIFISTREAM, n)); + object* pair = cons(var, stream(WIFISTREAM, n)); push(pair,env); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); + object* forms = cdr(args); + object* result = eval(tf_progn(forms,env), env); client.stop(); return result; } @@ -4735,7 +4895,7 @@ object *sp_withclient (object *args, object *env) { (available stream) Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available. */ -object *fn_available (object *args, object *env) { +object* fn_available (object* args, object* env) { (void) env; if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); return number(client.available()); @@ -4745,7 +4905,7 @@ object *fn_available (object *args, object *env) { (wifi-server) Starts a Wi-Fi server running. It returns nil. */ -object *fn_wifiserver (object *args, object *env) { +object* fn_wifiserver (object* args, object* env) { (void) args, (void) env; server.begin(); return nil; @@ -4756,14 +4916,14 @@ object *fn_wifiserver (object *args, object *env) { Set up a soft access point to establish a Wi-Fi network. Returns the IP address as a string or nil if unsuccessful. */ -object *fn_wifisoftap (object *args, object *env) { +object* fn_wifisoftap (object* args, object* env) { (void) env; char ssid[33], pass[65]; if (args == NULL) return WiFi.softAPdisconnect(true) ? tee : nil; - object *first = first(args); args = cdr(args); + object* first = first(args); args = cdr(args); if (args == NULL) WiFi.softAP(cstring(first, ssid, 33)); else { - object *second = first(args); + object* second = first(args); args = cdr(args); int channel = 1; bool hidden = false; @@ -4781,7 +4941,7 @@ object *fn_wifisoftap (object *args, object *env) { (connected stream) Returns t or nil to indicate if the client on stream is connected. */ -object *fn_connected (object *args, object *env) { +object* fn_connected (object* args, object* env) { (void) env; if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); return client.connected() ? tee : nil; @@ -4791,7 +4951,7 @@ object *fn_connected (object *args, object *env) { (wifi-localip) Returns the IP address of the local network as a string. */ -object *fn_wifilocalip (object *args, object *env) { +object* fn_wifilocalip (object* args, object* env) { (void) args, (void) env; return lispstring((char*)WiFi.localIP().toString().c_str()); } @@ -4800,7 +4960,7 @@ object *fn_wifilocalip (object *args, object *env) { (wifi-connect [ssid pass]) Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string. */ -object *fn_wificonnect (object *args, object *env) { +object* fn_wificonnect (object* args, object* env) { (void) env; char ssid[33], pass[65]; if (args == NULL) { WiFi.disconnect(true); return nil; } @@ -4821,14 +4981,14 @@ object *fn_wificonnect (object *args, object *env) { Evaluates the forms with str bound to an gfx-stream so you can print text to the graphics display using the standard uLisp print commands. */ -object *sp_withgfx (object *args, object *env) { +object* sp_withgfx (object* args, object* env) { #if defined(gfxsupport) - object *params = first(args); - object *var = first(params); - object *pair = cons(var, stream(GFXSTREAM, 1)); + object* params = first(args); + object* var = first(params); + object* pair = cons(var, stream(GFXSTREAM, 1)); push(pair,env); - object *forms = cdr(args); - object *result = eval(tf_progn(forms,env), env); + object* forms = cdr(args); + object* result = eval(tf_progn(forms,env), env); return result; #else (void) args, (void) env; @@ -4841,7 +5001,7 @@ object *sp_withgfx (object *args, object *env) { (draw-pixel x y [colour]) Draws a pixel at coordinates (x,y) in colour, or white if omitted. */ -object *fn_drawpixel (object *args, object *env) { +object* fn_drawpixel (object* args, object* env) { (void) env; #if defined(gfxsupport) uint16_t colour = COLOR_WHITE; @@ -4857,7 +5017,7 @@ object *fn_drawpixel (object *args, object *env) { (draw-line x0 y0 x1 y1 [colour]) Draws a line from (x0,y0) to (x1,y1) in colour, or white if omitted. */ -object *fn_drawline (object *args, object *env) { +object* fn_drawline (object* args, object* env) { (void) env; #if defined(gfxsupport) uint16_t params[4], colour = COLOR_WHITE; @@ -4875,7 +5035,7 @@ object *fn_drawline (object *args, object *env) { Draws an outline rectangle with its top left corner at (x,y), with width w, and with height h. The outline is drawn in colour, or white if omitted. */ -object *fn_drawrect (object *args, object *env) { +object* fn_drawrect (object* args, object* env) { (void) env; #if defined(gfxsupport) uint16_t params[4], colour = COLOR_WHITE; @@ -4893,7 +5053,7 @@ object *fn_drawrect (object *args, object *env) { Draws a filled rectangle with its top left corner at (x,y), with width w, and with height h. The outline is drawn in colour, or white if omitted. */ -object *fn_fillrect (object *args, object *env) { +object* fn_fillrect (object* args, object* env) { (void) env; #if defined(gfxsupport) uint16_t params[4], colour = COLOR_WHITE; @@ -4911,7 +5071,7 @@ object *fn_fillrect (object *args, object *env) { Draws an outline circle with its centre at (x, y) and with radius r. The circle is drawn in colour, or white if omitted. */ -object *fn_drawcircle (object *args, object *env) { +object* fn_drawcircle (object* args, object* env) { (void) env; #if defined(gfxsupport) uint16_t params[3], colour = COLOR_WHITE; @@ -4929,7 +5089,7 @@ object *fn_drawcircle (object *args, object *env) { Draws a filled circle with its centre at (x, y) and with radius r. The circle is drawn in colour, or white if omitted. */ -object *fn_fillcircle (object *args, object *env) { +object* fn_fillcircle (object* args, object* env) { (void) env; #if defined(gfxsupport) uint16_t params[3], colour = COLOR_WHITE; @@ -4947,7 +5107,7 @@ object *fn_fillcircle (object *args, object *env) { Draws an outline rounded rectangle with its top left corner at (x,y), with width w, height h, and corner radius radius. The outline is drawn in colour, or white if omitted. */ -object *fn_drawroundrect (object *args, object *env) { +object* fn_drawroundrect (object* args, object* env) { (void) env; #if defined(gfxsupport) uint16_t params[5], colour = COLOR_WHITE; @@ -4965,7 +5125,7 @@ object *fn_drawroundrect (object *args, object *env) { Draws a filled rounded rectangle with its top left corner at (x,y), with width w, height h, and corner radius radius. The outline is drawn in colour, or white if omitted. */ -object *fn_fillroundrect (object *args, object *env) { +object* fn_fillroundrect (object* args, object* env) { (void) env; #if defined(gfxsupport) uint16_t params[5], colour = COLOR_WHITE; @@ -4983,7 +5143,7 @@ object *fn_fillroundrect (object *args, object *env) { Draws an outline triangle between (x1,y1), (x2,y2), and (x3,y3). The outline is drawn in colour, or white if omitted. */ -object *fn_drawtriangle (object *args, object *env) { +object* fn_drawtriangle (object* args, object* env) { (void) env; #if defined(gfxsupport) uint16_t params[6], colour = COLOR_WHITE; @@ -5001,7 +5161,7 @@ object *fn_drawtriangle (object *args, object *env) { Draws a filled triangle between (x1,y1), (x2,y2), and (x3,y3). The outline is drawn in colour, or white if omitted. */ -object *fn_filltriangle (object *args, object *env) { +object* fn_filltriangle (object* args, object* env) { (void) env; #if defined(gfxsupport) uint16_t params[6], colour = COLOR_WHITE; @@ -5021,11 +5181,11 @@ object *fn_filltriangle (object *args, object *env) { which default to white and black respectively. The character can optionally be scaled by size. */ -object *fn_drawchar (object *args, object *env) { +object* fn_drawchar (object* args, object* env) { (void) env; #if defined(gfxsupport) uint16_t colour = COLOR_WHITE, bg = COLOR_BLACK, size = 1; - object *more = cdr(cddr(args)); + object* more = cdr(cddr(args)); if (more != NULL) { colour = checkinteger(car(more)); more = cdr(more); @@ -5047,7 +5207,7 @@ object *fn_drawchar (object *args, object *env) { (set-cursor x y) Sets the start point for text plotting to (x, y). */ -object *fn_setcursor (object *args, object *env) { +object* fn_setcursor (object* args, object* env) { (void) env; #if defined(gfxsupport) tft.setCursor(checkinteger(first(args)), checkinteger(second(args))); @@ -5061,7 +5221,7 @@ object *fn_setcursor (object *args, object *env) { (set-text-color colour [background]) Sets the text colour for text plotted using (with-gfx ...). */ -object *fn_settextcolor (object *args, object *env) { +object* fn_settextcolor (object* args, object* env) { (void) env; #if defined(gfxsupport) if (cdr(args) != NULL) tft.setTextColor(checkinteger(first(args)), checkinteger(second(args))); @@ -5076,7 +5236,7 @@ object *fn_settextcolor (object *args, object *env) { (set-text-size scale) Scales text by the specified size, default 1. */ -object *fn_settextsize (object *args, object *env) { +object* fn_settextsize (object* args, object* env) { (void) env; #if defined(gfxsupport) tft.setTextSize(checkinteger(first(args))); @@ -5090,7 +5250,7 @@ object *fn_settextsize (object *args, object *env) { (set-text-wrap boolean) Specified whether text wraps at the right-hand edge of the display; the default is t. */ -object *fn_settextwrap (object *args, object *env) { +object* fn_settextwrap (object* args, object* env) { (void) env; #if defined(gfxsupport) tft.setTextWrap(first(args) != NULL); @@ -5104,7 +5264,7 @@ object *fn_settextwrap (object *args, object *env) { (fill-screen [colour]) Fills or clears the screen with colour, default black. */ -object *fn_fillscreen (object *args, object *env) { +object* fn_fillscreen (object* args, object* env) { (void) env; #if defined(gfxsupport) uint16_t colour = COLOR_BLACK; @@ -5120,7 +5280,7 @@ object *fn_fillscreen (object *args, object *env) { (set-rotation option) Sets the display orientation for subsequent graphics commands; values are 0, 1, 2, or 3. */ -object *fn_setrotation (object *args, object *env) { +object* fn_setrotation (object* args, object* env) { (void) env; #if defined(gfxsupport) tft.setRotation(checkinteger(first(args))); @@ -5134,7 +5294,7 @@ object *fn_setrotation (object *args, object *env) { (invert-display boolean) Mirror-images the display. */ -object *fn_invertdisplay (object *args, object *env) { +object* fn_invertdisplay (object* args, object* env) { (void) env; #if defined(gfxsupport) tft.invertDisplay(first(args) != NULL); @@ -5323,6 +5483,8 @@ const char string174[] PROGMEM = "write-line"; const char string175[] PROGMEM = "restart-i2c"; const char string176[] PROGMEM = "gc"; const char string177[] PROGMEM = "room"; +const char string178[] PROGMEM = "save-image"; +const char string179[] PROGMEM = "load-image"; const char string180[] PROGMEM = "cls"; const char string181[] PROGMEM = "digitalread"; const char string182[] PROGMEM = "analogreadresolution"; @@ -5674,7 +5836,7 @@ const char doc131[] PROGMEM = "(exp number)\n" "Returns exp(number)."; const char doc132[] PROGMEM = "(sqrt number)\n" "Returns sqrt(number)."; -const char doc133[] PROGMEM = "(number [base])\n" +const char doc133[] PROGMEM = "(log number [base])\n" "Returns the logarithm of number to the specified base. If base is omitted it defaults to e."; const char doc134[] PROGMEM = "(expt number power)\n" "Returns number raised to the specified power.\n" @@ -5684,10 +5846,10 @@ const char doc135[] PROGMEM = "(ceiling number [divisor])\n" "Returns ceil(number/divisor). If omitted, divisor is 1."; const char doc136[] PROGMEM = "(floor number [divisor])\n" "Returns floor(number/divisor). If omitted, divisor is 1."; -const char doc137[] PROGMEM = "(truncate number)\n" -"Returns t if the argument is a floating-point number."; -const char doc138[] PROGMEM = "(round number)\n" -"Returns t if the argument is a floating-point number."; +const char doc137[] PROGMEM = "(truncate number [divisor])\n" +"Returns the integer part of number/divisor. If divisor is omitted it defaults to 1."; +const char doc138[] PROGMEM = "(round number [divisor])\n" +"Returns the integer closest to number/divisor. If divisor is omitted it defaults to 1."; const char doc139[] PROGMEM = "(char string n)\n" "Returns the nth character in a string, counting from zero."; const char doc140[] PROGMEM = "(char-code character)\n" @@ -5728,10 +5890,8 @@ const char doc155[] PROGMEM = "(logior [value*])\n" "Returns the bitwise | of the values."; const char doc156[] PROGMEM = "(logxor [value*])\n" "Returns the bitwise ^ of the values."; -const char doc157[] PROGMEM = "(prin1-to-string item [stream])\n" -"Prints its argument to a string, and returns the string.\n" -"Characters and strings are printed with quotation marks and escape characters,\n" -"in a format that will be suitable for read-from-string."; +const char doc157[] PROGMEM = "(lognot number)\n" +"Returns the bitwise inverse of the number."; const char doc158[] PROGMEM = "(ash value shift)\n" "Returns the result of bitwise shifting value by shift bits. If shift is positive, value is shifted to the left."; const char doc159[] PROGMEM = "(logbitp bit value)\n" @@ -6195,7 +6355,7 @@ void checkminmax (builtin_t name, int nargs) { /* lookupdoc - looks up the documentation string for the built-in function name */ -char *lookupdoc (builtin_t name) { +char* lookupdoc (builtin_t name) { int n = namename))) return false; builtin_t name = builtin(obj->name); int n = namename; - object *pair = value(name, env); + object* pair = value(name, env); if (pair != NULL) return cdr(pair); pair = value(name, GlobalEnv); if (pair != NULL) return cdr(pair); @@ -6264,8 +6424,8 @@ object *eval (object *form, object *env) { } // It's a list - object *function = car(form); - object *args = cdr(form); + object* function = car(form); + object* args = cdr(form); if (function == NULL) error(PSTR("illegal function"), nil); if (!listp(args)) error(PSTR("can't evaluate a dotted pair"), args); @@ -6277,13 +6437,13 @@ object *eval (object *form, object *env) { if ((name == LET) || (name == LETSTAR)) { int TCstart = TC; if (args == NULL) error2(noargument); - object *assigns = first(args); + object* assigns = first(args); if (!listp(assigns)) error(notalist, assigns); - object *forms = cdr(args); - object *newenv = env; + object* forms = cdr(args); + object* newenv = env; push(newenv, GCStack); while (assigns != NULL) { - object *assign = car(assigns); + object* assign = car(assigns); if (!consp(assign)) push(cons(assign,nil), newenv); else if (cdr(assign) == NULL) push(cons(first(assign),nil), newenv); else push(cons(first(assign),eval(second(assign),env)), newenv); @@ -6300,9 +6460,9 @@ object *eval (object *form, object *env) { if (name == LAMBDA) { if (env == NULL) return form; - object *envcopy = NULL; + object* envcopy = NULL; while (env != NULL) { - object *pair = first(env); + object* pair = first(env); if (pair != NULL) push(pair, envcopy); env = cdr(env); } @@ -6325,16 +6485,16 @@ object *eval (object *form, object *env) { } // Evaluate the parameters - result in head - object *fname = car(form); + object* fname = car(form); int TCstart = TC; - object *head = cons(eval(fname, env), NULL); + object* head = cons(eval(fname, env), NULL); push(head, GCStack); // Don't GC the result list - object *tail = head; + object* tail = head; form = cdr(form); int nargs = 0; while (form != NULL){ - object *obj = cons(eval(car(form),env),NULL); + object* obj = cons(eval(car(form),env),NULL); cdr(tail) = obj; tail = obj; form = cdr(form); @@ -6349,7 +6509,7 @@ object *eval (object *form, object *env) { if (!builtinp(function->name)) error(PSTR("not valid here"), fname); Context = bname; checkminmax(bname, nargs); - object *result = ((fn_ptr_type)lookupfn(bname))(args, env); + object* result = ((fn_ptr_type)lookupfn(bname))(args, env); pop(GCStack); return result; } @@ -6363,7 +6523,7 @@ object *eval (object *form, object *env) { pop(GCStack); int trace = tracing(fname->name); if (trace) { - object *result = eval(form, env); + object* result = eval(form, env); indent((--(TraceDepth[trace-1]))<<1, ' ', pserial); pint(TraceDepth[trace-1], pserial); pserial(':'); pserial(' '); @@ -6424,14 +6584,14 @@ void pcharacter (uint8_t c, pfun_t pfun) { /* pstring - prints a C string to the specified stream */ -void pstring (char *s, pfun_t pfun) { +void pstring (char* s, pfun_t pfun) { while (*s) pfun(*s++); } /* plispstring - prints a Lisp string object to the specified stream */ -void plispstring (object *form, pfun_t pfun) { +void plispstring (object* form, pfun_t pfun) { plispstr(form->name, pfun); } @@ -6439,7 +6599,7 @@ void plispstring (object *form, pfun_t pfun) { plispstr - prints a Lisp string name to the specified stream */ void plispstr (symbol_t name, pfun_t pfun) { - object *form = (object *)name; + object* form = (object*)name; while (form != NULL) { int chars = form->chars; for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { @@ -6455,7 +6615,7 @@ void plispstr (symbol_t name, pfun_t pfun) { printstring - prints a Lisp string object to the specified stream taking account of the PRINTREADABLY flag */ -void printstring (object *form, pfun_t pfun) { +void printstring (object* form, pfun_t pfun) { if (tstflag(PRINTREADABLY)) pfun('"'); plispstr(form->name, pfun); if (tstflag(PRINTREADABLY)) pfun('"'); @@ -6491,7 +6651,7 @@ void pradix40 (symbol_t name, pfun_t pfun) { /* printsymbol - prints any symbol from a symbol object to the specified stream */ -void printsymbol (object *form, pfun_t pfun) { +void printsymbol (object* form, pfun_t pfun) { psymbol(form->name, pfun); } @@ -6613,7 +6773,7 @@ void pfl (pfun_t pfun) { /* plist - prints a list to the specified stream */ -void plist (object *form, pfun_t pfun) { +void plist (object* form, pfun_t pfun) { pfun('('); printobject(car(form), pfun); form = cdr(form); @@ -6632,7 +6792,7 @@ void plist (object *form, pfun_t pfun) { /* pstream - prints a stream name to the specified stream */ -void pstream (object *form, pfun_t pfun) { +void pstream (object* form, pfun_t pfun) { pfun('<'); PGM_P s = (char*)pgm_read_ptr(&streamname[(form->integer)>>8]); pfstring(s, pfun); @@ -6644,7 +6804,7 @@ void pstream (object *form, pfun_t pfun) { /* printobject - prints any Lisp object to the specified stream */ -void printobject (object *form, pfun_t pfun) { +void printobject (object* form, pfun_t pfun) { if (form == NULL) pfstring(PSTR("nil"), pfun); else if (listp(form) && isbuiltin(car(form), CLOSURE)) pfstring(PSTR(""), pfun); else if (listp(form)) plist(form, pfun); @@ -6655,13 +6815,13 @@ void printobject (object *form, pfun_t pfun) { else if (stringp(form)) printstring(form, pfun); else if (arrayp(form)) printarray(form, pfun); else if (streamp(form)) pstream(form, pfun); - else error2(PSTR("error in print")); + else error2(PSTR("internal error in print")); } /* prin1object - prints any Lisp object to the specified stream escaping special characters */ -void prin1object (object *form, pfun_t pfun) { +void prin1object (object* form, pfun_t pfun) { char temp = Flags; clrflag(PRINTREADABLY); printobject(form, pfun); @@ -6686,9 +6846,9 @@ int glibrary () { /* loadfromlibrary - reads and evaluates a form from the Lisp Library */ -void loadfromlibrary (object *env) { +void loadfromlibrary (object* env) { GlobalStringIndex = 0; - object *line = read(glibrary); + object* line = read(glibrary); while (line != NULL) { push(line, GCStack); eval(line, env); @@ -6716,7 +6876,7 @@ int gserial () { /* nextitem - reads the next token from the specified stream */ -object *nextitem (gfun_t gfun) { +object* nextitem (gfun_t gfun) { int ch = gfun(); while(issp(ch)) ch = gfun(); @@ -6726,9 +6886,9 @@ object *nextitem (gfun_t gfun) { } if (ch == '\n') ch = gfun(); if (ch == -1) return nil; - if (ch == ')') return (object *)KET; - if (ch == '(') return (object *)BRA; - if (ch == '\'') return (object *)QUO; + if (ch == ')') return (object*)KET; + if (ch == '(') return (object*)BRA; + if (ch == '\'') return (object*)QUO; // Parse string if (ch == '"') return readstring('"', gfun); @@ -6751,7 +6911,7 @@ object *nextitem (gfun_t gfun) { } else if (ch == '.') { buffer[index++] = ch; ch = gfun(); - if (ch == ' ') return (object *)DOT; + if (ch == ' ') return (object*)DOT; isfloat = true; } @@ -6773,7 +6933,7 @@ object *nextitem (gfun_t gfun) { else if (ch == '\'') return nextitem(gfun); else if (ch == '.') { setflag(NOESC); - object *result = eval(read(gfun), NULL); + object* result = eval(read(gfun), NULL); clrflag(NOESC); return result; } @@ -6846,22 +7006,22 @@ object *nextitem (gfun_t gfun) { /* readrest - reads the remaining tokens from the specified stream */ -object *readrest (gfun_t gfun) { - object *item = nextitem(gfun); - object *head = NULL; - object *tail = NULL; +object* readrest (gfun_t gfun) { + object* item = nextitem(gfun); + object* head = NULL; + object* tail = NULL; - while (item != (object *)KET) { - if (item == (object *)BRA) { + while (item != (object*)KET) { + if (item == (object*)BRA) { item = readrest(gfun); - } else if (item == (object *)QUO) { + } else if (item == (object*)QUO) { item = cons(bsymbol(QUOTE), cons(read(gfun), NULL)); - } else if (item == (object *)DOT) { + } else if (item == (object*)DOT) { tail->cdr = read(gfun); if (readrest(gfun) != NULL) error2(PSTR("malformed list")); return head; } else { - object *cell = cons(item, NULL); + object* cell = cons(item, NULL); if (head == NULL) head = cell; else tail->cdr = cell; tail = cell; @@ -6874,12 +7034,12 @@ object *readrest (gfun_t gfun) { /* read - recursively reads a Lisp object from the stream gfun and returns it */ -object *read (gfun_t gfun) { - object *item = nextitem(gfun); - if (item == (object *)KET) error2(PSTR("incomplete list")); - if (item == (object *)BRA) return readrest(gfun); - if (item == (object *)DOT) return read(gfun); - if (item == (object *)QUO) return cons(bsymbol(QUOTE), cons(read(gfun), NULL)); +object* read (gfun_t gfun) { + object* item = nextitem(gfun); + if (item == (object*)KET) error2(PSTR("incomplete list")); + if (item == (object*)BRA) return readrest(gfun); + if (item == (object*)DOT) return read(gfun); + if (item == (object*)QUO) return cons(bsymbol(QUOTE), cons(read(gfun), NULL)); return item; } @@ -6912,26 +7072,12 @@ void initgfx () { #endif } -/* - setup - entry point from the Arduino IDE -*/ -void setup () { - Serial.begin(9600); - int start = millis(); - while ((millis() - start) < 5000) { if (Serial) break; } - initworkspace(); - initenv(); - initsleep(); - initgfx(); - pfstring(PSTR("uLisp 4.4 "), pserial); pln(pserial); -} - // Read/Evaluate/Print loop /* repl - the Lisp Read/Evaluate/Print loop */ -void repl (object *env) { +void repl (object* env) { for (;;) { randomSeed(micros()); gc(NULL, env); @@ -6944,9 +7090,9 @@ void repl (object *env) { } pserial('>'); pserial(' '); Context = 0; - object *line = read(gserial); + object* line = read(gserial); if (BreakLevel && line == nil) { pln(pserial); return; } - if (line == (object *)KET) error2(PSTR("unmatched right bracket")); + if (line == (object*)KET) error2(PSTR("unmatched right bracket")); push(line, GCStack); pfl(pserial); line = eval(line, env); @@ -6958,17 +7104,6 @@ void repl (object *env) { } } -/* - loop - the Arduino IDE main execution loop -*/ -void loop () { - if (!setjmp(toplevel_handler)) { - ; // noop - } - ulispreset(); - repl(NULL); -} - void ulispreset () { // Come here after error delay(100); while (Serial.available()) Serial.read(); @@ -6982,3 +7117,5 @@ void ulispreset () { #endif client.stop(); } + +#endif From 7b66436da9e67259a3d4c6b5506d76d48a55c9dd Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 10:38:26 -0400 Subject: [PATCH 008/109] add quoteit, keywords, insert tracemax --- ulisp.hpp | 41 ++++++++++++++++++++++++----------------- 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 88851dd..5471a51 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -103,13 +103,15 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define twist(x) ((uint32_t)((x)<<2) | (((x) & 0xC0000000)>>30)) #define untwist(x) (((x)>>2 & 0x3FFFFFFF) | ((x) & 0x03)<<30) #define arraysize(x) (sizeof(x) / sizeof(x[0])) +#define stringifyX(x) #x +#define stringify(x) stringifyX(x) #define PACKEDS 0x43238000 #define BUILTINS 0xF4240000 #define ENDFUNCTIONS 1536 // Constants -const int TRACEMAX = 3; // Number of traced functions +#define TRACEMAX 3; // Number of traced functions enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; // ARRAY STRING and PAIR must be last enum token { UNUSED, BRA, KET, QUO, DOT }; enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM }; @@ -610,7 +612,7 @@ void trace (symbol_t name) { if (TraceFn[i] == 0) { TraceFn[i] = name; TraceDepth[i] = 0; return; } i++; } - error2(PSTR("already tracing 3 functions")); + error2(PSTR("already tracing " stringify(TRACEMAX) " functions")); } /* @@ -655,8 +657,12 @@ bool listp (object* x) { */ #define improperp(x) (!listp(x)) -object* quote (object* arg) { - return cons(bsymbol(QUOTE), cons(arg,NULL)); +/* + quoteit - quote a symbol with the specified type of quote +*/ + +object* quoteit (symbol_t q, object* it) { + return cons(bsymbol(q), cons(it, nil)); } // Radix 40 encoding @@ -2610,7 +2616,7 @@ object* tf_cond (object* args, object* env) { object* test = eval(first(clause), env); object* forms = cdr(clause); if (test != nil) { - if (forms == NULL) return quote(test); else return tf_progn(forms, env); + if (forms == NULL) return quoteit(QUOTE, test); else return tf_progn(forms, env); } args = cdr(args); } @@ -4586,7 +4592,7 @@ object* fn_pprintall (object* args, object* env) { if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) { superprint(cons(bsymbol(DEFUN), cons(var, cdr(val))), 0, pfun); } else { - superprint(cons(bsymbol(DEFVAR), cons(var, cons(quote(val), NULL))), 0, pfun); + superprint(cons(bsymbol(DEFVAR), cons(var, cons(quoteit(QUOTE, val), NULL))), 0, pfun); } pln(pfun); testescape(); @@ -5617,10 +5623,10 @@ const char doc38[] PROGMEM = "(dotimes (var number [result]) form*)\n" "Executes the forms number times, with the local variable var set to each integer from 0 to number-1 in turn.\n" "It then returns result, or nil if result is omitted."; const char doc39[] PROGMEM = "(trace [function]*)\n" -"Turns on tracing of up to TRACEMAX user-defined functions,\n" +"Turns on tracing of up to " stringify(TRACEMAX) " user-defined functions,\n" "and returns a list of the functions currently being traced."; const char doc40[] PROGMEM = "(untrace [function]*)\n" -"Turns off tracing of up to TRACEMAX user-defined functions, and returns a list of the functions untraced.\n" +"Turns off tracing of up to " stringify(TRACEMAX) " user-defined functions, and returns a list of the functions untraced.\n" "If no functions are specified it untraces all functions."; const char doc41[] PROGMEM = "(for-millis ([number]) form*)\n" "Executes the forms and then waits until a total of number milliseconds have elapsed.\n" @@ -6998,9 +7004,16 @@ object* nextitem (gfun_t gfun) { builtin_t x = lookupbuiltin(buffer); if (x == NIL) return nil; if (x != ENDFUNCTIONS) return bsymbol(x); - else if ((index <= 6) && valid40(buffer)) return intern(twist(pack40(buffer))); - buffer[index+1] = '\0'; buffer[index+2] = '\0'; buffer[index+3] = '\0'; // For internlong - return internlong(buffer); + object* sym; + if ((index <= 6) && valid40(buffer)) sym = intern(twist(pack40(buffer))); + else { + buffer[index+1] = '\0'; buffer[index+2] = '\0'; buffer[index+3] = '\0'; // For internlong + sym = internlong(buffer); + } + if (buffer[0] == ':') { // Keywords quote themselves + sym = quoteit(QUOTE, sym); + } + return sym; } /* @@ -7059,13 +7072,7 @@ void initenv () { void initgfx () { #if defined(gfxsupport) tft.init(135, 240); - #if defined(ARDUINO_ADAFRUIT_FEATHER_ESP32S2_TFT) - pinMode(TFT_I2C_POWER, OUTPUT); - digitalWrite(TFT_I2C_POWER, HIGH); - tft.setRotation(3); - #else tft.setRotation(1); - #endif tft.fillScreen(ST77XX_BLACK); pinMode(TFT_BACKLITE, OUTPUT); digitalWrite(TFT_BACKLITE, HIGH); From 9b47e61370480b6fd41f04d04fe8116d41c1875a Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 11:10:50 -0400 Subject: [PATCH 009/109] enable analog on all pins capable --- ulisp.hpp | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 5471a51..3401ff4 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -1872,14 +1872,16 @@ pfun_t pstreamfun (object* args) { // Check pins void checkanalogread (int pin) { - - if (!(pin==0 || pin==2 || pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) - error(PSTR("invalid pin"), number(pin)); + +// if (!(pin==0 || pin==2 || pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) +// error(PSTR("invalid pin"), number(pin)); + (void)pin; } void checkanalogwrite (int pin) { - if (!(pin>=25 && pin<=26)) error(PSTR("invalid pin"), number(pin)); +// if (!(pin>=25 && pin<=26)) error(PSTR("invalid pin"), number(pin)); + (void)pin; } // Note From 39ef75bbccd9b906eacdb445987e6ff6140b8779 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 11:28:46 -0400 Subject: [PATCH 010/109] big buffer --- ulisp.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ulisp.hpp b/ulisp.hpp index 3401ff4..acfcdc5 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -50,7 +50,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); // Platform specific settings #define WORDALIGNED __attribute__((aligned (4))) -#define BUFFERSIZE 36 // Number of bits+4 +#define BUFFERSIZE 260 #define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ #define LITTLEFS From 163c7e59ad89ffd16bf2d984d72b9e7736db6ca1 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 11:30:13 -0400 Subject: [PATCH 011/109] Update README.md --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index 591a052..127621c 100644 --- a/README.md +++ b/README.md @@ -12,3 +12,4 @@ Patches: * Deleted load/save/autorunimage support * different garbage collect message * no line-editor support (you can just use `rlwrap` if you have it) +* Lisp `:keywords` From aea5c7f6420f7baa5d84d12d0de1c01dcfa2a2fe Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 11:38:35 -0400 Subject: [PATCH 012/109] sone functions, use 4 spaces for indent --- ulisp-esp32.ino | 31 +- ulisp.hpp | 8271 ++++++++++++++++++++++++----------------------- 2 files changed, 4153 insertions(+), 4149 deletions(-) diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index e7cea87..ac43a84 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -1,7 +1,7 @@ /* uLisp ESP Release 4.4 - www.ulisp.com - David Johnson-Davies - www.technoblogy.com - 21st March 2023 + David Johnson-Davies - www.technoblogy.com - 21st March 2023 - Licensed under the MIT license: https://opensource.org/licenses/MIT + Licensed under the MIT license: https://opensource.org/licenses/MIT */ // Compile options @@ -16,26 +16,23 @@ #include "ulisp.hpp" /* - setup - entry point from the Arduino IDE + setup - entry point from the Arduino IDE */ void setup () { - Serial.begin(9600); - int start = millis(); - while ((millis() - start) < 5000) { if (Serial) break; } - initworkspace(); - initenv(); - initsleep(); - initgfx(); - pfstring(PSTR("uLisp 4.4 "), pserial); pln(pserial); + Serial.begin(9600); + int start = millis(); + while ((millis() - start) < 5000) { if (Serial) break; } + ulispinit(); + pfstring(PSTR("uLisp 4.4 "), pserial); pln(pserial); } /* - loop - the Arduino IDE main execution loop + loop - the Arduino IDE main execution loop */ void loop () { - if (!setjmp(toplevel_handler)) { - ; // noop - } - ulispreset(); - repl(NULL); + if (!setjmp(toplevel_handler)) { + ; // noop + } + ulisperrcleanup(); + repl(NULL); } diff --git a/ulisp.hpp b/ulisp.hpp index acfcdc5..6b1a70f 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -1,7 +1,7 @@ /* uLisp ESP Release 4.4 - www.ulisp.com - David Johnson-Davies - www.technoblogy.com - 21st March 2023 + David Johnson-Davies - www.technoblogy.com - 21st March 2023 - Licensed under the MIT license: https://opensource.org/licenses/MIT + Licensed under the MIT license: https://opensource.org/licenses/MIT */ #ifndef ULISP_HPP @@ -132,31 +132,31 @@ PGM_P const streamname[] PROGMEM = {serialstream, i2cstream, spistream, sdstream typedef uint32_t symbol_t; typedef struct sobject { - union { - struct { - sobject* car; - sobject* cdr; + union { + struct { + sobject* car; + sobject* cdr; + }; + struct { + unsigned int type; + union { + symbol_t name; + int integer; + int chars; // For strings + float single_float; + }; + }; }; - struct { - unsigned int type; - union { - symbol_t name; - int integer; - int chars; // For strings - float single_float; - }; - }; - }; } object; typedef object* (*fn_ptr_type)(object* , object*); typedef void (*mapfun_t)(object* , object**); typedef const struct { - PGM_P string; - fn_ptr_type fptr; - uint8_t minmax; - const char* doc; + PGM_P string; + fn_ptr_type fptr; + uint8_t minmax; + const char* doc; } tbl_entry_t; typedef int (*gfun_t)(); @@ -248,75 +248,75 @@ void testescape (); // Error handling /* - errorsub - used by all the error routines. - Prints: "Error: 'fname' string", where fname is the name of the Lisp function in which the error occurred. + errorsub - used by all the error routines. + Prints: "Error: 'fname' string", where fname is the name of the Lisp function in which the error occurred. */ void errorsub (symbol_t fname, PGM_P string) { - pfl(pserial); pfstring(PSTR("Error: "), pserial); - if (fname != sym(NIL)) { - pserial('\''); - psymbol(fname, pserial); - pserial('\''); pserial(' '); - } - pfstring(string, pserial); + pfl(pserial); pfstring(PSTR("Error: "), pserial); + if (fname != sym(NIL)) { + pserial('\''); + psymbol(fname, pserial); + pserial('\''); pserial(' '); + } + pfstring(string, pserial); } void errorend () { GCStack = NULL; longjmp(*handler, 1); } /* - errorsym - prints an error message and reenters the REPL. - Prints: "Error: 'fname' string: symbol", where fname is the name of the user Lisp function in which the error occurred, - and symbol is the object generating the error. + errorsym - prints an error message and reenters the REPL. + Prints: "Error: 'fname' string: symbol", where fname is the name of the user Lisp function in which the error occurred, + and symbol is the object generating the error. */ void errorsym (symbol_t fname, PGM_P string, object* symbol) { - if (!tstflag(MUFFLEERRORS)) { - errorsub(fname, string); - pserial(':'); pserial(' '); - printobject(symbol, pserial); - pln(pserial); - } - errorend(); + if (!tstflag(MUFFLEERRORS)) { + errorsub(fname, string); + pserial(':'); pserial(' '); + printobject(symbol, pserial); + pln(pserial); + } + errorend(); } /* - errorsym2 - prints an error message and reenters the REPL. - Prints: "Error: 'fname' string", where fname is the name of the user Lisp function in which the error occurred. + errorsym2 - prints an error message and reenters the REPL. + Prints: "Error: 'fname' string", where fname is the name of the user Lisp function in which the error occurred. */ void errorsym2 (symbol_t fname, PGM_P string) { - if (!tstflag(MUFFLEERRORS)) { - errorsub(fname, string); - pln(pserial); - } - errorend(); + if (!tstflag(MUFFLEERRORS)) { + errorsub(fname, string); + pln(pserial); + } + errorend(); } /* - error - prints an error message and reenters the REPL. - Prints: "Error: 'Context' string: symbol", where Context is the name of the built-in Lisp function in which the error occurred, - and symbol is the object generating the error. + error - prints an error message and reenters the REPL. + Prints: "Error: 'Context' string: symbol", where Context is the name of the built-in Lisp function in which the error occurred, + and symbol is the object generating the error. */ void error (PGM_P string, object* symbol) { - errorsym(sym(Context), string, symbol); + errorsym(sym(Context), string, symbol); } /* - error2 - prints an error message and reenters the REPL. - Prints: "Error: 'Context' string", where Context is the name of the built-in Lisp function in which the error occurred. + error2 - prints an error message and reenters the REPL. + Prints: "Error: 'Context' string", where Context is the name of the built-in Lisp function in which the error occurred. */ void error2 (PGM_P string) { - errorsym2(sym(Context), string); + errorsym2(sym(Context), string); } /* - formaterr - displays a format error with a ^ pointing to the error + formaterr - displays a format error with a ^ pointing to the error */ void formaterr (object* formatstr, PGM_P string, uint8_t p) { - pln(pserial); indent(4, ' ', pserial); printstring(formatstr, pserial); pln(pserial); - indent(p+5, ' ', pserial); pserial('^'); - error2(string); - pln(pserial); - GCStack = NULL; - longjmp(*handler, 1); + pln(pserial); indent(4, ' ', pserial); printstring(formatstr, pserial); pln(pserial); + indent(p+5, ' ', pserial); pserial('^'); + error2(string); + pln(pserial); + GCStack = NULL; + longjmp(*handler, 1); } // Save space as these are used multiple times @@ -346,1430 +346,1430 @@ const char unknownstreamtype[] PROGMEM = "unknown stream type"; // Set up workspace /* - initworkspace - initialises the workspace into a linked list of free objects + initworkspace - initialises the workspace into a linked list of free objects */ 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++; - } + Freelist = NULL; + for (int i=WORKSPACESIZE-1; i>=0; i--) { + object* obj = &Workspace[i]; + car(obj) = NULL; + cdr(obj) = Freelist; + Freelist = obj; + Freespace++; + } } /* - myalloc - returns the first object from the linked list of free objects + myalloc - returns the first object from the linked list of free objects */ object* myalloc () { - if (Freespace == 0) error2(PSTR("no room")); - object* temp = Freelist; - Freelist = cdr(Freelist); - Freespace--; - return temp; + if (Freespace == 0) error2(PSTR("no room")); + object* temp = Freelist; + Freelist = cdr(Freelist); + Freespace--; + return temp; } /* - myfree - adds obj to the linked list of free objects. - inline makes gc significantly faster + myfree - adds obj to the linked list of free objects. + inline makes gc significantly faster */ inline void myfree (object* obj) { - car(obj) = NULL; - cdr(obj) = Freelist; - Freelist = obj; - Freespace++; + car(obj) = NULL; + cdr(obj) = Freelist; + Freelist = obj; + Freespace++; } // Make each type of object /* - number - make an integer object with value n and return it + number - make an integer object with value n and return it */ object* number (int n) { - object* ptr = myalloc(); - ptr->type = NUMBER; - ptr->integer = n; - return ptr; + object* ptr = myalloc(); + ptr->type = NUMBER; + ptr->integer = n; + return ptr; } /* - makefloat - make a floating point object with value f and return it + makefloat - make a floating point object with value f and return it */ object* makefloat (float f) { - object* ptr = myalloc(); - ptr->type = FLOAT; - ptr->single_float = f; - return ptr; + object* ptr = myalloc(); + ptr->type = FLOAT; + ptr->single_float = f; + return ptr; } /* - character - make a character object with value c and return it + character - make a character object with value c and return it */ object* character (uint8_t c) { - object* ptr = myalloc(); - ptr->type = CHARACTER; - ptr->chars = c; - return ptr; + object* ptr = myalloc(); + ptr->type = CHARACTER; + ptr->chars = c; + return ptr; } /* - cons - make a cons with arg1 and arg2 return it + cons - make a cons with arg1 and arg2 return it */ object* cons (object* arg1, object* arg2) { - object* ptr = myalloc(); - ptr->car = arg1; - ptr->cdr = arg2; - return ptr; + object* ptr = myalloc(); + ptr->car = arg1; + ptr->cdr = arg2; + return ptr; } /* - symbol - make a symbol object with value name and return it + symbol - make a symbol object with value name and return it */ object* symbol (symbol_t name) { - object* ptr = myalloc(); - ptr->type = SYMBOL; - ptr->name = name; - return ptr; + object* ptr = myalloc(); + ptr->type = SYMBOL; + ptr->name = name; + return ptr; } /* - bsymbol - make a built-in symbol + bsymbol - make a built-in symbol */ inline object* bsymbol (builtin_t name) { - return intern(twist(name+BUILTINS)); + return intern(twist(name+BUILTINS)); } /* - intern - looks through the workspace for an existing occurrence of symbol name and returns it, - otherwise calls symbol(name) to create a new symbol. + intern - looks through the workspace for an existing occurrence of symbol name and returns it, + otherwise calls symbol(name) to create a new symbol. */ object* intern (symbol_t name) { - for (int i=0; itype == SYMBOL && obj->name == name) return obj; - } - return symbol(name); + for (int i=0; itype == SYMBOL && obj->name == name) return obj; + } + return symbol(name); } /* - eqsymbols - compares the long string/symbol obj with the string in buffer. + eqsymbols - compares the long string/symbol obj with the string in buffer. */ bool eqsymbols (object* obj, char* buffer) { - object* arg = cdr(obj); - int i = 0; - while (!(arg == NULL && buffer[i] == 0)) { - if (arg == NULL || buffer[i] == 0 || - arg->chars != (buffer[i]<<24 | buffer[i+1]<<16 | buffer[i+2]<<8 | buffer[i+3])) return false; - arg = car(arg); - i = i + 4; - } - return true; + object* arg = cdr(obj); + int i = 0; + while (!(arg == NULL && buffer[i] == 0)) { + if (arg == NULL || buffer[i] == 0 || + arg->chars != (buffer[i]<<24 | buffer[i+1]<<16 | buffer[i+2]<<8 | buffer[i+3])) return false; + arg = car(arg); + i = i + 4; + } + return true; } /* - internlong - looks through the workspace for an existing occurrence of the long symbol in buffer and returns it, - otherwise calls lispstring(buffer) to create a new symbol. + internlong - looks through the workspace for an existing occurrence of the long symbol in buffer and returns it, + otherwise calls lispstring(buffer) to create a new symbol. */ object* internlong (char* buffer) { - for (int i=0; itype == SYMBOL && longsymbolp(obj) && eqsymbols(obj, buffer)) return obj; - } - object* obj = lispstring(buffer); - obj->type = SYMBOL; - return obj; + for (int i=0; itype == SYMBOL && longsymbolp(obj) && eqsymbols(obj, buffer)) return obj; + } + object* obj = lispstring(buffer); + obj->type = SYMBOL; + return obj; } /* - stream - makes a stream object defined by streamtype and address, and returns it + stream - makes a stream object defined by streamtype and address, and returns it */ object* stream (uint8_t streamtype, uint8_t address) { - object* ptr = myalloc(); - ptr->type = STREAM; - ptr->integer = streamtype<<8 | address; - return ptr; + object* ptr = myalloc(); + ptr->type = STREAM; + ptr->integer = streamtype<<8 | address; + return ptr; } /* - newstring - makes an empty string object and returns it + newstring - makes an empty string object and returns it */ object* newstring () { - object* ptr = myalloc(); - ptr->type = STRING; - ptr->chars = 0; - return ptr; + object* ptr = myalloc(); + ptr->type = STRING; + ptr->chars = 0; + return ptr; } // Garbage collection /* - markobject - recursively marks reachable objects, starting from obj + markobject - recursively marks reachable objects, starting from obj */ void markobject (object* obj) { - MARK: - if (obj == NULL) return; - if (marked(obj)) return; - - object* arg = car(obj); - unsigned int type = obj->type; - mark(obj); - - if (type >= PAIR || type == ZZERO) { // cons - markobject(arg); - obj = cdr(obj); - goto MARK; - } + MARK: + if (obj == NULL) return; + if (marked(obj)) return; + + object* arg = car(obj); + unsigned int type = obj->type; + mark(obj); + + if (type >= PAIR || type == ZZERO) { // cons + markobject(arg); + obj = cdr(obj); + goto MARK; + } - if (type == ARRAY) { - obj = cdr(obj); - goto MARK; - } + if (type == ARRAY) { + obj = cdr(obj); + goto MARK; + } - if ((type == STRING) || (type == SYMBOL && longsymbolp(obj))) { - obj = cdr(obj); - while (obj != NULL) { - arg = car(obj); - mark(obj); - obj = arg; + if ((type == STRING) || (type == SYMBOL && longsymbolp(obj))) { + obj = cdr(obj); + while (obj != NULL) { + arg = car(obj); + mark(obj); + obj = arg; + } } - } } /* - sweep - goes through the workspace freeing objects that have not been marked, - and unmarks marked objects + sweep - goes through the workspace freeing objects that have not been marked, + and unmarks marked objects */ void sweep () { - Freelist = NULL; - Freespace = 0; - for (int i=WORKSPACESIZE-1; i>=0; i--) { - object* obj = &Workspace[i]; - if (!marked(obj)) myfree(obj); else unmark(obj); - } + Freelist = NULL; + Freespace = 0; + for (int i=WORKSPACESIZE-1; i>=0; i--) { + object* obj = &Workspace[i]; + if (!marked(obj)) myfree(obj); else unmark(obj); + } } /* - gc - performs garbage collection by calling markobject() on each of the pointers to objects in use, - followed by sweep() to free unused objects. + gc - performs garbage collection by calling markobject() on each of the pointers to objects in use, + followed by sweep() to free unused objects. */ void gc (object* form, object* env) { - #if defined(printgcs) - int start = Freespace; - static int GC_Count = 0; - #endif - markobject(tee); - markobject(GlobalEnv); - markobject(GCStack); - markobject(form); - markobject(env); - sweep(); - #if defined(printgcs) - GC_Count++; - pfl(pserial); - pfstring(PSTR("{GC #"), pserial); - pint(GC_Count, pserial); - pfstring(PSTR(": "), pserial); - pint(Freespace - start, pserial); - pfstring(PSTR(" freed}"), pserial); - #endif + #if defined(printgcs) + int start = Freespace; + static int GC_Count = 0; + #endif + markobject(tee); + markobject(GlobalEnv); + markobject(GCStack); + markobject(form); + markobject(env); + sweep(); + #if defined(printgcs) + GC_Count++; + pfl(pserial); + pfstring(PSTR("{GC #"), pserial); + pint(GC_Count, pserial); + pfstring(PSTR(": "), pserial); + pint(Freespace - start, pserial); + pfstring(PSTR(" freed}"), pserial); + #endif } char *MakeFilename (object *arg, char *buffer) { - int max = BUFFERSIZE-1; - buffer[0]='/'; - int i = 1; - do { - char c = nthchar(arg, i-1); - if (c == '\0') break; - buffer[i++] = c; - } while (itype; - return type >= PAIR || type == ZZERO; + if (x == NULL) return false; + unsigned int type = x->type; + return type >= PAIR || type == ZZERO; } /* - atom - implements Lisp atom + atom - implements Lisp atom */ #define atom(x) (!consp(x)) /* - listp - implements Lisp listp + listp - implements Lisp listp */ bool listp (object* x) { - if (x == NULL) return true; - unsigned int type = x->type; - return type >= PAIR || type == ZZERO; + if (x == NULL) return true; + unsigned int type = x->type; + return type >= PAIR || type == ZZERO; } /* - improperp - tests whether x is an improper list + improperp - tests whether x is an improper list */ #define improperp(x) (!listp(x)) /* - quoteit - quote a symbol with the specified type of quote + quoteit - quote a symbol with the specified type of quote */ object* quoteit (symbol_t q, object* it) { - return cons(bsymbol(q), cons(it, nil)); + return cons(bsymbol(q), cons(it, nil)); } // Radix 40 encoding /* - builtin - converts a symbol name to builtin + builtin - converts a symbol name to builtin */ builtin_t builtin (symbol_t name) { - return (builtin_t)(untwist(name) - BUILTINS); + return (builtin_t)(untwist(name) - BUILTINS); } /* sym - converts a builtin to a symbol name */ symbol_t sym (builtin_t x) { - return twist(x + BUILTINS); + return twist(x + BUILTINS); } /* - toradix40 - returns a number from 0 to 39 if the character can be encoded, or -1 otherwise. + toradix40 - returns a number from 0 to 39 if the character can be encoded, or -1 otherwise. */ int8_t toradix40 (char ch) { - if (ch == 0) return 0; - if (ch >= '0' && ch <= '9') return ch-'0'+1; - if (ch == '-') return 37; if (ch == '*') return 38; if (ch == '$') return 39; - ch = ch | 0x20; - if (ch >= 'a' && ch <= 'z') return ch-'a'+11; - return -1; // Invalid + if (ch == 0) return 0; + if (ch >= '0' && ch <= '9') return ch-'0'+1; + if (ch == '-') return 37; if (ch == '*') return 38; if (ch == '$') return 39; + ch = ch | 0x20; + if (ch >= 'a' && ch <= 'z') return ch-'a'+11; + return -1; // Invalid } /* - fromradix40 - returns the character encoded by the number n. + fromradix40 - returns the character encoded by the number n. */ char fromradix40 (char n) { - if (n >= 1 && n <= 9) return '0'+n-1; - if (n >= 11 && n <= 36) return 'a'+n-11; - if (n == 37) return '-'; if (n == 38) return '*'; if (n == 39) return '$'; - return 0; + if (n >= 1 && n <= 9) return '0'+n-1; + if (n >= 11 && n <= 36) return 'a'+n-11; + if (n == 37) return '-'; if (n == 38) return '*'; if (n == 39) return '$'; + return 0; } /* - pack40 - packs six radix40-encoded characters from buffer into a 32-bit number and returns it. + pack40 - packs six radix40-encoded characters from buffer into a 32-bit number and returns it. */ uint32_t pack40 (char* buffer) { - int x = 0; - for (int i=0; i<6; i++) x = x * 40 + toradix40(buffer[i]); - return x; + int x = 0; + for (int i=0; i<6; i++) x = x * 40 + toradix40(buffer[i]); + return x; } /* - valid40 - returns true if the symbol in buffer can be encoded as six radix40-encoded characters. + valid40 - returns true if the symbol in buffer can be encoded as six radix40-encoded characters. */ bool valid40 (char* buffer) { - if (toradix40(buffer[0]) < 11) return false; - for (int i=1; i<6; i++) if (toradix40(buffer[i]) < 0) return false; - return true; + if (toradix40(buffer[0]) < 11) return false; + for (int i=1; i<6; i++) if (toradix40(buffer[i]) < 0) return false; + return true; } /* - digitvalue - returns the numerical value of a hexadecimal digit, or 16 if invalid. + digitvalue - returns the numerical value of a hexadecimal digit, or 16 if invalid. */ int8_t 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; + if (d>='0' && d<='9') return d-'0'; + d = d | 0x20; + if (d>='a' && d<='f') return d-'a'+10; + return 16; } /* - checkinteger - check that obj is an integer and return it + checkinteger - check that obj is an integer and return it */ int checkinteger (object* obj) { - if (!integerp(obj)) error(notaninteger, obj); - return obj->integer; + if (!integerp(obj)) error(notaninteger, obj); + return obj->integer; } /* - checkbitvalue - check that obj is an integer equal to 0 or 1 and return it + checkbitvalue - check that obj is an integer equal to 0 or 1 and return it */ int checkbitvalue (object* obj) { - if (!integerp(obj)) error(notaninteger, obj); - int n = obj->integer; - if (n & ~1) error(PSTR("argument is not a bit value"), obj); - return n; + if (!integerp(obj)) error(notaninteger, obj); + int n = obj->integer; + if (n & ~1) error(PSTR("argument is not a bit value"), obj); + return n; } /* - checkintfloat - check that obj is an integer or floating-point number and return the number + checkintfloat - check that obj is an integer or floating-point number and return the number */ float checkintfloat (object* obj){ - if (integerp(obj)) return obj->integer; - if (!floatp(obj)) error(notanumber, obj); - return obj->single_float; + if (integerp(obj)) return obj->integer; + if (!floatp(obj)) error(notanumber, obj); + return obj->single_float; } /* - checkchar - check that obj is a character and return the character + checkchar - check that obj is a character and return the character */ int checkchar (object* obj) { - if (!characterp(obj)) error(PSTR("argument is not a character"), obj); - return obj->chars; + if (!characterp(obj)) error(PSTR("argument is not a character"), obj); + return obj->chars; } /* - checkstring - check that obj is a string + checkstring - check that obj is a string */ object* checkstring (object* obj) { - if (!stringp(obj)) error(notastring, obj); - return obj; + if (!stringp(obj)) error(notastring, obj); + return obj; } int isstream (object* obj){ - if (!streamp(obj)) error(PSTR("not a stream"), obj); - return obj->integer; + if (!streamp(obj)) error(PSTR("not a stream"), obj); + return obj->integer; } int isbuiltin (object* obj, builtin_t n) { - return symbolp(obj) && obj->name == sym(n); + return symbolp(obj) && obj->name == sym(n); } bool builtinp (symbol_t name) { - return (untwist(name) >= BUILTINS); + return (untwist(name) >= BUILTINS); } int checkkeyword (object* obj) { - if (!keywordp(obj)) error(PSTR("argument is not a keyword"), obj); - builtin_t kname = builtin(obj->name); - uint8_t context = getminmax(kname); - if (context != 0 && context != Context) error(invalidkey, obj); - return ((int)lookupfn(kname)); + if (!keywordp(obj)) error(PSTR("argument is not a keyword"), obj); + builtin_t kname = builtin(obj->name); + uint8_t context = getminmax(kname); + if (context != 0 && context != Context) error(invalidkey, obj); + return ((int)lookupfn(kname)); } /* - checkargs - checks that the number of objects in the list args - is within the range specified in the symbol lookup table + checkargs - checks that the number of objects in the list args + is within the range specified in the symbol lookup table */ void checkargs (object* args) { - int nargs = listlength(args); - checkminmax(Context, nargs); + int nargs = listlength(args); + checkminmax(Context, nargs); } /* - eq - implements Lisp eq + eq - implements Lisp eq */ boolean eq (object* arg1, object* arg2) { - if (arg1 == arg2) return true; // Same object - if ((arg1 == nil) || (arg2 == nil)) return false; // Not both values - if (arg1->cdr != arg2->cdr) return false; // Different values - if (symbolp(arg1) && symbolp(arg2)) return true; // Same symbol - if (integerp(arg1) && integerp(arg2)) return true; // Same integer - if (floatp(arg1) && floatp(arg2)) return true; // Same float - if (characterp(arg1) && characterp(arg2)) return true; // Same character - return false; + if (arg1 == arg2) return true; // Same object + if ((arg1 == nil) || (arg2 == nil)) return false; // Not both values + if (arg1->cdr != arg2->cdr) return false; // Different values + if (symbolp(arg1) && symbolp(arg2)) return true; // Same symbol + if (integerp(arg1) && integerp(arg2)) return true; // Same integer + if (floatp(arg1) && floatp(arg2)) return true; // Same float + if (characterp(arg1) && characterp(arg2)) return true; // Same character + return false; } /* - equal - implements Lisp equal + equal - implements Lisp equal */ boolean equal (object* arg1, object* arg2) { - if (stringp(arg1) && stringp(arg2)) return stringcompare(cons(arg1, cons(arg2, nil)), false, false, true); - if (consp(arg1) && consp(arg2)) return (equal(car(arg1), car(arg2)) && equal(cdr(arg1), cdr(arg2))); - return eq(arg1, arg2); + if (stringp(arg1) && stringp(arg2)) return stringcompare(cons(arg1, cons(arg2, nil)), false, false, true); + if (consp(arg1) && consp(arg2)) return (equal(car(arg1), car(arg2)) && equal(cdr(arg1), cdr(arg2))); + return eq(arg1, arg2); } /* - listlength - returns the length of a list + listlength - returns the length of a list */ int listlength (object* list) { - int length = 0; - while (list != NULL) { - if (improperp(list)) error2(notproper); - list = cdr(list); - length++; - } - return length; + int length = 0; + while (list != NULL) { + if (improperp(list)) error2(notproper); + list = cdr(list); + length++; + } + return length; } // Mathematical helper functions /* - add_floats - used by fn_add - Converts the numbers in args to floats, adds them to fresult, and returns the sum as a Lisp float. + add_floats - used by fn_add + Converts the numbers in args to floats, adds them to fresult, and returns the sum as a Lisp float. */ object* add_floats (object* args, float fresult) { - while (args != NULL) { - object* arg = car(args); - fresult = fresult + checkintfloat(arg); - args = cdr(args); - } - return makefloat(fresult); + while (args != NULL) { + object* arg = car(args); + fresult = fresult + checkintfloat(arg); + args = cdr(args); + } + return makefloat(fresult); } /* - subtract_floats - used by fn_subtract with more than one argument - Converts the numbers in args to floats, subtracts them from fresult, and returns the result as a Lisp float. + subtract_floats - used by fn_subtract with more than one argument + Converts the numbers in args to floats, subtracts them from fresult, and returns the result as a Lisp float. */ object* subtract_floats (object* args, float fresult) { - while (args != NULL) { - object* arg = car(args); - fresult = fresult - checkintfloat(arg); - args = cdr(args); - } - return makefloat(fresult); + while (args != NULL) { + object* arg = car(args); + fresult = fresult - checkintfloat(arg); + args = cdr(args); + } + return makefloat(fresult); } /* - negate - used by fn_subtract with one argument - If the result is an integer, and negating it doesn't overflow, keep the result as an integer. - Otherwise convert the result to a float, negate it, and return the result as a Lisp float. + negate - used by fn_subtract with one argument + If the result is an integer, and negating it doesn't overflow, keep the result as an integer. + Otherwise convert the result to a float, negate it, and return the result as a Lisp float. */ object* negate (object* arg) { - if (integerp(arg)) { - int result = arg->integer; - if (result == INT_MIN) return makefloat(-result); - else return number(-result); - } else if (floatp(arg)) return makefloat(-(arg->single_float)); - else error(notanumber, arg); - return nil; + if (integerp(arg)) { + int result = arg->integer; + if (result == INT_MIN) return makefloat(-result); + else return number(-result); + } else if (floatp(arg)) return makefloat(-(arg->single_float)); + else error(notanumber, arg); + return nil; } /* - multiply_floats - used by fn_multiply - Converts the numbers in args to floats, adds them to fresult, and returns the result as a Lisp float. + multiply_floats - used by fn_multiply + Converts the numbers in args to floats, adds them to fresult, and returns the result as a Lisp float. */ object* multiply_floats (object* args, float fresult) { - while (args != NULL) { - object* arg = car(args); - fresult = fresult * checkintfloat(arg); - args = cdr(args); - } - return makefloat(fresult); + while (args != NULL) { + object* arg = car(args); + fresult = fresult * checkintfloat(arg); + args = cdr(args); + } + return makefloat(fresult); } /* - divide_floats - used by fn_divide - Converts the numbers in args to floats, divides fresult by them, and returns the result as a Lisp float. + divide_floats - used by fn_divide + Converts the numbers in args to floats, divides fresult by them, and returns the result as a Lisp float. */ object* divide_floats (object* args, float fresult) { - while (args != NULL) { - object* arg = car(args); - float f = checkintfloat(arg); - if (f == 0.0) error2(divisionbyzero); - fresult = fresult / f; - args = cdr(args); - } - return makefloat(fresult); + while (args != NULL) { + object* arg = car(args); + float f = checkintfloat(arg); + if (f == 0.0) error2(divisionbyzero); + fresult = fresult / f; + args = cdr(args); + } + return makefloat(fresult); } /* - myround - rounds - Returns t if the argument is a floating-point number. + myround - rounds + Returns t if the argument is a floating-point number. */ int myround (float number) { - return (number >= 0) ? (int)(number + 0.5) : (int)(number - 0.5); + return (number >= 0) ? (int)(number + 0.5) : (int)(number - 0.5); } /* - compare - a generic compare function - Used to implement the other comparison functions. - If lt is true the result is true if each argument is less than the next argument. - If gt is true the result is true if each argument is greater than the next argument. - If eq is true the result is true if each argument is equal to the next argument. + compare - a generic compare function + Used to implement the other comparison functions. + If lt is true the result is true if each argument is less than the next argument. + If gt is true the result is true if each argument is greater than the next argument. + If eq is true the result is true if each argument is equal to the next argument. */ object* compare (object* args, bool lt, bool gt, bool eq) { - object* arg1 = first(args); - args = cdr(args); - while (args != NULL) { - object* arg2 = first(args); - if (integerp(arg1) && integerp(arg2)) { - if (!lt && ((arg1->integer) < (arg2->integer))) return nil; - if (!eq && ((arg1->integer) == (arg2->integer))) return nil; - if (!gt && ((arg1->integer) > (arg2->integer))) return nil; - } else { - if (!lt && (checkintfloat(arg1) < checkintfloat(arg2))) return nil; - if (!eq && (checkintfloat(arg1) == checkintfloat(arg2))) return nil; - if (!gt && (checkintfloat(arg1) > checkintfloat(arg2))) return nil; - } - arg1 = arg2; + object* arg1 = first(args); args = cdr(args); - } - return tee; + while (args != NULL) { + object* arg2 = first(args); + if (integerp(arg1) && integerp(arg2)) { + if (!lt && ((arg1->integer) < (arg2->integer))) return nil; + if (!eq && ((arg1->integer) == (arg2->integer))) return nil; + if (!gt && ((arg1->integer) > (arg2->integer))) return nil; + } else { + if (!lt && (checkintfloat(arg1) < checkintfloat(arg2))) return nil; + if (!eq && (checkintfloat(arg1) == checkintfloat(arg2))) return nil; + if (!gt && (checkintfloat(arg1) > checkintfloat(arg2))) return nil; + } + arg1 = arg2; + args = cdr(args); + } + return tee; } /* - intpower - calculates base to the power exp as an integer + intpower - calculates base to the power exp as an integer */ int intpower (int base, int exp) { - int result = 1; - while (exp) { - if (exp & 1) result = result * base; - exp = exp / 2; - base = base * base; - } - return result; + int result = 1; + while (exp) { + if (exp & 1) result = result * base; + exp = exp / 2; + base = base * base; + } + return result; } // Association lists /* - assoc - looks for key in an association list and returns the matching pair, or nil if not found + assoc - looks for key in an association list and returns the matching pair, or nil if not found */ object* assoc (object* key, object* list) { - while (list != NULL) { - if (improperp(list)) error(notproper, list); - object* pair = first(list); - if (!listp(pair)) error(PSTR("element is not a list"), pair); - if (pair != NULL && eq(key,car(pair))) return pair; - list = cdr(list); - } - return nil; + while (list != NULL) { + if (improperp(list)) error(notproper, list); + object* pair = first(list); + if (!listp(pair)) error(PSTR("element is not a list"), pair); + if (pair != NULL && eq(key,car(pair))) return pair; + list = cdr(list); + } + return nil; } /* - delassoc - deletes the pair matching key from an association list and returns the key, or nil if not found + delassoc - deletes the pair matching key from an association list and returns the key, or nil if not found */ object* delassoc (object* key, object** alist) { - object* list = *alist; - object* prev = NULL; - while (list != NULL) { - object* pair = first(list); - if (eq(key,car(pair))) { - if (prev == NULL) *alist = cdr(list); - else cdr(prev) = cdr(list); - return key; + object* list = *alist; + object* prev = NULL; + while (list != NULL) { + object* pair = first(list); + if (eq(key,car(pair))) { + if (prev == NULL) *alist = cdr(list); + else cdr(prev) = cdr(list); + return key; + } + prev = list; + list = cdr(list); } - prev = list; - list = cdr(list); - } - return nil; + return nil; } // Array utilities /* - nextpower2 - returns the smallest power of 2 that is equal to or greater than n + nextpower2 - returns the smallest power of 2 that is equal to or greater than n */ int nextpower2 (int n) { - n--; n |= n >> 1; n |= n >> 2; n |= n >> 4; - n |= n >> 8; n |= n >> 16; n++; - return n<2 ? 2 : n; + n--; n |= n >> 1; n |= n >> 2; n |= n >> 4; + n |= n >> 8; n |= n >> 16; n++; + return n<2 ? 2 : n; } /* - buildarray - builds an array with n elements using a tree of size s which must be a power of 2 - The elements are initialised to the default def + buildarray - builds an array with n elements using a tree of size s which must be a power of 2 + The elements are initialised to the default def */ object* buildarray (int n, int s, object* def) { - int s2 = s>>1; - if (s2 == 1) { - if (n == 2) return cons(def, def); - else if (n == 1) return cons(def, NULL); - else return NULL; - } else if (n >= s2) return cons(buildarray(s2, s2, def), buildarray(n - s2, s2, def)); - else return cons(buildarray(n, s2, def), nil); + int s2 = s>>1; + if (s2 == 1) { + if (n == 2) return cons(def, def); + else if (n == 1) return cons(def, NULL); + else return NULL; + } else if (n >= s2) return cons(buildarray(s2, s2, def), buildarray(n - s2, s2, def)); + else return cons(buildarray(n, s2, def), nil); } object* makearray (object* dims, object* def, bool bitp) { - int size = 1; - object* dimensions = dims; - while (dims != NULL) { - int d = car(dims)->integer; - if (d < 0) error2(PSTR("dimension can't be negative")); - size = size * d; - dims = cdr(dims); - } - // Bit array identified by making first dimension negative - if (bitp) { - size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - car(dimensions) = number(-(car(dimensions)->integer)); - } - object* ptr = myalloc(); - ptr->type = ARRAY; - object* tree = nil; - if (size != 0) tree = buildarray(size, nextpower2(size), def); - ptr->cdr = cons(tree, dimensions); - return ptr; + int size = 1; + object* dimensions = dims; + while (dims != NULL) { + int d = car(dims)->integer; + if (d < 0) error2(PSTR("dimension can't be negative")); + size = size * d; + dims = cdr(dims); + } + // Bit array identified by making first dimension negative + if (bitp) { + size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); + car(dimensions) = number(-(car(dimensions)->integer)); + } + object* ptr = myalloc(); + ptr->type = ARRAY; + object* tree = nil; + if (size != 0) tree = buildarray(size, nextpower2(size), def); + ptr->cdr = cons(tree, dimensions); + return ptr; } /* - arrayref - returns a pointer to the element specified by index in the array of size s + arrayref - returns a pointer to the element specified by index in the array of size s */ object** arrayref (object* array, int index, int size) { - int mask = nextpower2(size)>>1; - object** p = &car(cdr(array)); - while (mask) { - if ((index & mask) == 0) p = &(car(*p)); else p = &(cdr(*p)); - mask = mask>>1; - } - return p; + int mask = nextpower2(size)>>1; + object** p = &car(cdr(array)); + while (mask) { + if ((index & mask) == 0) p = &(car(*p)); else p = &(cdr(*p)); + mask = mask>>1; + } + return p; } /* - getarray - gets a pointer to an element in a multi-dimensional array, given a list of the subscripts subs - If the first subscript is negative it's a bit array and bit is set to the bit number + getarray - gets a pointer to an element in a multi-dimensional array, given a list of the subscripts subs + If the first subscript is negative it's a bit array and bit is set to the bit number */ object** getarray (object* array, object* subs, object* env, int *bit) { - int index = 0, size = 1, s; - *bit = -1; - bool bitp = false; - object* dims = cddr(array); - while (dims != NULL && subs != NULL) { - int d = car(dims)->integer; - if (d < 0) { d = -d; bitp = true; } - if (env) s = checkinteger(eval(car(subs), env)); else s = checkinteger(car(subs)); - if (s < 0 || s >= d) error(PSTR("subscript out of range"), car(subs)); - size = size * d; - index = index * d + s; - dims = cdr(dims); subs = cdr(subs); - } - if (dims != NULL) error2(PSTR("too few subscripts")); - if (subs != NULL) error2(PSTR("too many subscripts")); - if (bitp) { - size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - *bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); - index = index>>(sizeof(int)==4 ? 5 : 4); - } - return arrayref(array, index, size); + int index = 0, size = 1, s; + *bit = -1; + bool bitp = false; + object* dims = cddr(array); + while (dims != NULL && subs != NULL) { + int d = car(dims)->integer; + if (d < 0) { d = -d; bitp = true; } + if (env) s = checkinteger(eval(car(subs), env)); else s = checkinteger(car(subs)); + if (s < 0 || s >= d) error(PSTR("subscript out of range"), car(subs)); + size = size * d; + index = index * d + s; + dims = cdr(dims); subs = cdr(subs); + } + if (dims != NULL) error2(PSTR("too few subscripts")); + if (subs != NULL) error2(PSTR("too many subscripts")); + if (bitp) { + size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); + *bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); + index = index>>(sizeof(int)==4 ? 5 : 4); + } + return arrayref(array, index, size); } /* - rslice - reads a slice of an array recursively + rslice - reads a slice of an array recursively */ void rslice (object* array, int size, int slice, object* dims, object* args) { - int d = first(dims)->integer; - for (int i = 0; i < d; i++) { - int index = slice * d + i; - if (!consp(args)) error2(PSTR("initial contents don't match array type")); - if (cdr(dims) == NULL) { - object** p = arrayref(array, index, size); - *p = car(args); - } else rslice(array, size, index, cdr(dims), car(args)); - args = cdr(args); - } + int d = first(dims)->integer; + for (int i = 0; i < d; i++) { + int index = slice * d + i; + if (!consp(args)) error2(PSTR("initial contents don't match array type")); + if (cdr(dims) == NULL) { + object** p = arrayref(array, index, size); + *p = car(args); + } else rslice(array, size, index, cdr(dims), car(args)); + args = cdr(args); + } } /* - readarray - reads a list structure from args and converts it to a d-dimensional array. - Uses rslice for each of the slices of the array. + readarray - reads a list structure from args and converts it to a d-dimensional array. + Uses rslice for each of the slices of the array. */ object* readarray (int d, object* args) { - object* list = args; - object* dims = NULL; object* head = NULL; - int size = 1; - for (int i = 0; i < d; i++) { - if (!listp(list)) error2(PSTR("initial contents don't match array type")); - int l = listlength(list); - if (dims == NULL) { dims = cons(number(l), NULL); head = dims; } - else { cdr(dims) = cons(number(l), NULL); dims = cdr(dims); } - size = size * l; - if (list != NULL) list = car(list); - } - object* array = makearray(head, NULL, false); - rslice(array, size, 0, head, args); - return array; -} - -/* - readbitarray - reads an item in the format #*1010101000110 by reading it and returning a list of integers, - and then converting that to a bit array + object* list = args; + object* dims = NULL; object* head = NULL; + int size = 1; + for (int i = 0; i < d; i++) { + if (!listp(list)) error2(PSTR("initial contents don't match array type")); + int l = listlength(list); + if (dims == NULL) { dims = cons(number(l), NULL); head = dims; } + else { cdr(dims) = cons(number(l), NULL); dims = cdr(dims); } + size = size * l; + if (list != NULL) list = car(list); + } + object* array = makearray(head, NULL, false); + rslice(array, size, 0, head, args); + return array; +} + +/* + readbitarray - reads an item in the format #*1010101000110 by reading it and returning a list of integers, + and then converting that to a bit array */ object* readbitarray (gfun_t gfun) { - char ch = gfun(); - object* head = NULL; - object* tail = NULL; - while (!issp(ch) && !isbr(ch)) { - if (ch != '0' && ch != '1') error2(PSTR("illegal character in bit array")); - object* cell = cons(number(ch - '0'), NULL); - if (head == NULL) head = cell; - else tail->cdr = cell; - tail = cell; - ch = gfun(); - } - LastChar = ch; - int size = listlength(head); - object* array = makearray(cons(number(size), NULL), number(0), true); - size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - int index = 0; - while (head != NULL) { - object** loc = arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size); - int bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); - *loc = number((((*loc)->integer) & ~(1<integer)<cdr = cell; + tail = cell; + ch = gfun(); + } + LastChar = ch; + int size = listlength(head); + object* array = makearray(cons(number(size), NULL), number(0), true); + size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); + int index = 0; + while (head != NULL) { + object** loc = arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size); + int bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); + *loc = number((((*loc)->integer) & ~(1<integer)<integer; - if (d < 0) d = -d; - for (int i = 0; i < d; i++) { - if (i && spaces) pfun(' '); - int index = slice * d + i; - if (cdr(dims) == NULL) { - if (bitp) pint(((*arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size))->integer)>> - (index & (sizeof(int)==4 ? 0x1F : 0x0F)) & 1, pfun); - else printobject(*arrayref(array, index, size), pfun); - } else { pfun('('); pslice(array, size, index, cdr(dims), pfun, bitp); pfun(')'); } - } + bool spaces = true; + if (slice == -1) { spaces = false; slice = 0; } + int d = first(dims)->integer; + if (d < 0) d = -d; + for (int i = 0; i < d; i++) { + if (i && spaces) pfun(' '); + int index = slice * d + i; + if (cdr(dims) == NULL) { + if (bitp) pint(((*arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size))->integer)>> + (index & (sizeof(int)==4 ? 0x1F : 0x0F)) & 1, pfun); + else printobject(*arrayref(array, index, size), pfun); + } else { pfun('('); pslice(array, size, index, cdr(dims), pfun, bitp); pfun(')'); } + } } /* - printarray - prints an array in the appropriate Lisp format + printarray - prints an array in the appropriate Lisp format */ void printarray (object* array, pfun_t pfun) { - object* dimensions = cddr(array); - object* dims = dimensions; - bool bitp = false; - int size = 1, n = 0; - while (dims != NULL) { - int d = car(dims)->integer; - if (d < 0) { bitp = true; d = -d; } - size = size * d; - dims = cdr(dims); n++; - } - if (bitp) size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - pfun('#'); - if (n == 1 && bitp) { pfun('*'); pslice(array, size, -1, dimensions, pfun, bitp); } - else { - if (n > 1) { pint(n, pfun); pfun('A'); } - pfun('('); pslice(array, size, 0, dimensions, pfun, bitp); pfun(')'); - } + object* dimensions = cddr(array); + object* dims = dimensions; + bool bitp = false; + int size = 1, n = 0; + while (dims != NULL) { + int d = car(dims)->integer; + if (d < 0) { bitp = true; d = -d; } + size = size * d; + dims = cdr(dims); n++; + } + if (bitp) size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); + pfun('#'); + if (n == 1 && bitp) { pfun('*'); pslice(array, size, -1, dimensions, pfun, bitp); } + else { + if (n > 1) { pint(n, pfun); pfun('A'); } + pfun('('); pslice(array, size, 0, dimensions, pfun, bitp); pfun(')'); + } } // String utilities void indent (uint8_t spaces, char ch, pfun_t pfun) { - for (uint8_t i=0; ichars & 0xFFFFFF) == 0) { - (*tail)->chars = (*tail)->chars | ch<<16; return; - } else if (((*tail)->chars & 0xFFFF) == 0) { - (*tail)->chars = (*tail)->chars | ch<<8; return; - } else if (((*tail)->chars & 0xFF) == 0) { - (*tail)->chars = (*tail)->chars | ch; return; - } else { - cell = myalloc(); car(*tail) = cell; - } - car(cell) = NULL; cell->chars = ch<<24; *tail = cell; + object* cell; + if (cdr(*tail) == NULL) { + cell = myalloc(); cdr(*tail) = cell; + } else if (((*tail)->chars & 0xFFFFFF) == 0) { + (*tail)->chars = (*tail)->chars | ch<<16; return; + } else if (((*tail)->chars & 0xFFFF) == 0) { + (*tail)->chars = (*tail)->chars | ch<<8; return; + } else if (((*tail)->chars & 0xFF) == 0) { + (*tail)->chars = (*tail)->chars | ch; return; + } else { + cell = myalloc(); car(*tail) = cell; + } + car(cell) = NULL; cell->chars = ch<<24; *tail = cell; } /* - copystring - returns a copy of a Lisp string + copystring - returns a copy of a Lisp string */ object* copystring (object* arg) { - object* obj = newstring(); - object* ptr = obj; - arg = cdr(arg); - while (arg != NULL) { - object* cell = myalloc(); car(cell) = NULL; - if (cdr(obj) == NULL) cdr(obj) = cell; else car(ptr) = cell; - ptr = cell; - ptr->chars = arg->chars; - arg = car(arg); - } - return obj; + object* obj = newstring(); + object* ptr = obj; + arg = cdr(arg); + while (arg != NULL) { + object* cell = myalloc(); car(cell) = NULL; + if (cdr(obj) == NULL) cdr(obj) = cell; else car(ptr) = cell; + ptr = cell; + ptr->chars = arg->chars; + arg = car(arg); + } + return obj; } /* - readstring - reads characters from an input stream up to delimiter delim - and returns a Lisp string + readstring - reads characters from an input stream up to delimiter delim + and returns a Lisp string */ object* readstring (uint8_t delim, gfun_t gfun) { - object* obj = newstring(); - object* tail = obj; - int ch = gfun(); - if (ch == -1) return nil; - while ((ch != delim) && (ch != -1)) { - if (ch == '\\') ch = gfun(); - buildstring(ch, &tail); - ch = gfun(); - } - return obj; + object* obj = newstring(); + object* tail = obj; + int ch = gfun(); + if (ch == -1) return nil; + while ((ch != delim) && (ch != -1)) { + if (ch == '\\') ch = gfun(); + buildstring(ch, &tail); + ch = gfun(); + } + return obj; } /* - stringlength - returns the length of a Lisp string - Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word + stringlength - returns the length of a Lisp string + Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word */ int stringlength (object* form) { - int length = 0; - form = cdr(form); - while (form != NULL) { - int chars = form->chars; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - if (chars>>i & 0xFF) length++; + int length = 0; + form = cdr(form); + while (form != NULL) { + int chars = form->chars; + for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { + if (chars>>i & 0xFF) length++; + } + form = car(form); } - form = car(form); - } - return length; + return length; } /* - nthchar - returns the nth character from a Lisp string - Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word + nthchar - returns the nth character from a Lisp string + Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word */ uint8_t nthchar (object* string, int n) { - object* arg = cdr(string); - int top; - if (sizeof(int) == 4) { top = n>>2; n = 3 - (n&3); } - else { top = n>>1; n = 1 - (n&1); } - for (int i=0; i>2; n = 3 - (n&3); } + else { top = n>>1; n = 1 - (n&1); } + for (int i=0; ichars)>>(n*8) & 0xFF; + return (arg->chars)>>(n*8) & 0xFF; } /* - gstr - reads a character from a string stream + gstr - reads a character from a string stream */ int gstr () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - char c = nthchar(GlobalString, GlobalStringIndex++); - if (c != 0) return c; - return '\n'; // -1? + if (LastChar) { + char temp = LastChar; + LastChar = 0; + return temp; + } + char c = nthchar(GlobalString, GlobalStringIndex++); + if (c != 0) return c; + return '\n'; // -1? } /* - pstr - prints a character to a string stream + pstr - prints a character to a string stream */ void pstr (char c) { - buildstring(c, &GlobalStringTail); + buildstring(c, &GlobalStringTail); } /* - lispstring - converts a C string to a Lisp string + lispstring - converts a C string to a Lisp string */ object* lispstring (char* s) { - object* obj = newstring(); - object* tail = obj; - while(1) { - char ch = *s++; - if (ch == 0) break; - if (ch == '\\') ch = *s++; - buildstring(ch, &tail); - } - return obj; + object* obj = newstring(); + object* tail = obj; + while(1) { + char ch = *s++; + if (ch == 0) break; + if (ch == '\\') ch = *s++; + buildstring(ch, &tail); + } + return obj; } /* - stringcompare - a generic string compare function - Used to implement the other string comparison functions. - If lt is true the result is true if each argument is less than the next argument. - If gt is true the result is true if each argument is greater than the next argument. - If eq is true the result is true if each argument is equal to the next argument. + stringcompare - a generic string compare function + Used to implement the other string comparison functions. + If lt is true the result is true if each argument is less than the next argument. + If gt is true the result is true if each argument is greater than the next argument. + If eq is true the result is true if each argument is equal to the next argument. */ bool stringcompare (object* args, bool lt, bool gt, bool eq) { - object* arg1 = checkstring(first(args)); - object* arg2 = checkstring(second(args)); - arg1 = cdr(arg1); - arg2 = cdr(arg2); - while ((arg1 != NULL) || (arg2 != NULL)) { - if (arg1 == NULL) return lt; - if (arg2 == NULL) return gt; - if (arg1->chars < arg2->chars) return lt; - if (arg1->chars > arg2->chars) return gt; - arg1 = car(arg1); - arg2 = car(arg2); - } - return eq; + object* arg1 = checkstring(first(args)); + object* arg2 = checkstring(second(args)); + arg1 = cdr(arg1); + arg2 = cdr(arg2); + while ((arg1 != NULL) || (arg2 != NULL)) { + if (arg1 == NULL) return lt; + if (arg2 == NULL) return gt; + if (arg1->chars < arg2->chars) return lt; + if (arg1->chars > arg2->chars) return gt; + arg1 = car(arg1); + arg2 = car(arg2); + } + return eq; } /* - documentation - returns the documentation string of a built-in or user-defined function. + documentation - returns the documentation string of a built-in or user-defined function. */ object* documentation (object* arg, object* env) { - if (arg == NULL) return nil; - if (!symbolp(arg)) error(notasymbol, arg); - object* pair = findpair(arg, env); - if (pair != NULL) { - object* val = cdr(pair); - if (listp(val) && first(val)->name == sym(LAMBDA) && cdr(val) != NULL && cddr(val) != NULL) { - if (stringp(third(val))) return third(val); + if (arg == NULL) return nil; + if (!symbolp(arg)) error(notasymbol, arg); + object* pair = findpair(arg, env); + if (pair != NULL) { + object* val = cdr(pair); + if (listp(val) && first(val)->name == sym(LAMBDA) && cdr(val) != NULL && cddr(val) != NULL) { + if (stringp(third(val))) return third(val); + } } - } - symbol_t docname = arg->name; - if (!builtinp(docname)) return nil; - char* docstring = lookupdoc(builtin(docname)); - if (docstring == NULL) return nil; - object* obj = startstring(); - pfstring(docstring, pstr); - return obj; + symbol_t docname = arg->name; + if (!builtinp(docname)) return nil; + char* docstring = lookupdoc(builtin(docname)); + if (docstring == NULL) return nil; + object* obj = startstring(); + pfstring(docstring, pstr); + return obj; } /* - apropos - finds the user-defined and built-in functions whose names contain the specified string or symbol, - and prints them if print is true, or returns them in a list. + apropos - finds the user-defined and built-in functions whose names contain the specified string or symbol, + and prints them if print is true, or returns them in a list. */ object* apropos (object* arg, bool print) { - char buf[17], buf2[33]; - char* part = cstring(princtostring(arg), buf, 17); - object* result = cons(NULL, NULL); - object* ptr = result; - // User-defined? - object* globals = GlobalEnv; - while (globals != NULL) { - object* pair = first(globals); - object* var = car(pair); - object* val = cdr(pair); - char* full = cstring(princtostring(var), buf2, 33); - if (strstr(full, part) != NULL) { - if (print) { - printsymbol(var, pserial); pserial(' '); pserial('('); - if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) pfstring(PSTR("user function"), pserial); - else if (consp(val) && car(val)->type == CODE) pfstring(PSTR("code"), pserial); - else pfstring(PSTR("user symbol"), pserial); - pserial(')'); pln(pserial); - } else { - cdr(ptr) = cons(var, NULL); ptr = cdr(ptr); - } - } - globals = cdr(globals); - } - // Built-in? - int entries = tablesize(0) + tablesize(1); - for (int i = 0; i < entries; i++) { - if (findsubstring(part, (builtin_t)i)) { - if (print) { - uint8_t fntype = getminmax(i)>>6; - pbuiltin((builtin_t)i, pserial); pserial(' '); pserial('('); - if (fntype == FUNCTIONS) pfstring(PSTR("function"), pserial); - else if (fntype == SPECIAL_FORMS) pfstring(PSTR("special form"), pserial); - else pfstring(PSTR("symbol/keyword"), pserial); - pserial(')'); pln(pserial); - } else { - cdr(ptr) = cons(bsymbol(i), NULL); ptr = cdr(ptr); - } - } - } - return cdr(result); -} - -/* - cstring - converts a Lisp string to a C string in buffer and returns buffer - Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word + char buf[17], buf2[33]; + char* part = cstring(princtostring(arg), buf, 17); + object* result = cons(NULL, NULL); + object* ptr = result; + // User-defined? + object* globals = GlobalEnv; + while (globals != NULL) { + object* pair = first(globals); + object* var = car(pair); + object* val = cdr(pair); + char* full = cstring(princtostring(var), buf2, 33); + if (strstr(full, part) != NULL) { + if (print) { + printsymbol(var, pserial); pserial(' '); pserial('('); + if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) pfstring(PSTR("user function"), pserial); + else if (consp(val) && car(val)->type == CODE) pfstring(PSTR("code"), pserial); + else pfstring(PSTR("user symbol"), pserial); + pserial(')'); pln(pserial); + } else { + cdr(ptr) = cons(var, NULL); ptr = cdr(ptr); + } + } + globals = cdr(globals); + } + // Built-in? + int entries = tablesize(0) + tablesize(1); + for (int i = 0; i < entries; i++) { + if (findsubstring(part, (builtin_t)i)) { + if (print) { + uint8_t fntype = getminmax(i)>>6; + pbuiltin((builtin_t)i, pserial); pserial(' '); pserial('('); + if (fntype == FUNCTIONS) pfstring(PSTR("function"), pserial); + else if (fntype == SPECIAL_FORMS) pfstring(PSTR("special form"), pserial); + else pfstring(PSTR("symbol/keyword"), pserial); + pserial(')'); pln(pserial); + } else { + cdr(ptr) = cons(bsymbol(i), NULL); ptr = cdr(ptr); + } + } + } + return cdr(result); +} + +/* + cstring - converts a Lisp string to a C string in buffer and returns buffer + Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word */ char* cstring (object* form, char* buffer, int buflen) { - form = cdr(checkstring(form)); - int index = 0; - while (form != NULL) { - int chars = form->integer; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; - if (ch) { - if (index >= buflen-1) error2(PSTR("no room for string")); - buffer[index++] = ch; - } + form = cdr(checkstring(form)); + int index = 0; + while (form != NULL) { + int chars = form->integer; + for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { + char ch = chars>>i & 0xFF; + if (ch) { + if (index >= buflen-1) error2(PSTR("no room for string")); + buffer[index++] = ch; + } + } + form = car(form); } - form = car(form); - } - buffer[index] = '\0'; - return buffer; + buffer[index] = '\0'; + return buffer; } /* - ipstring - parses an IP address from a Lisp string and returns it as an IPAddress type (uint32_t) - Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word + ipstring - parses an IP address from a Lisp string and returns it as an IPAddress type (uint32_t) + Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word */ uint32_t ipstring (object* form) { - form = cdr(checkstring(form)); - int p = 0; - union { uint32_t ipaddress; uint8_t ipbytes[4]; } ; - ipaddress = 0; - while (form != NULL) { - int chars = form->integer; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; - if (ch) { - if (ch == '.') { p++; if (p > 3) error2(PSTR("illegal IP address")); } - else ipbytes[p] = (ipbytes[p] * 10) + ch - '0'; - } - } - form = car(form); - } - return ipaddress; + form = cdr(checkstring(form)); + int p = 0; + union { uint32_t ipaddress; uint8_t ipbytes[4]; } ; + ipaddress = 0; + while (form != NULL) { + int chars = form->integer; + for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { + char ch = chars>>i & 0xFF; + if (ch) { + if (ch == '.') { p++; if (p > 3) error2(PSTR("illegal IP address")); } + else ipbytes[p] = (ipbytes[p] * 10) + ch - '0'; + } + } + form = car(form); + } + return ipaddress; } // Lookup variable in environment object* value (symbol_t n, object* env) { - while (env != NULL) { - object* pair = car(env); - if (pair != NULL && car(pair)->name == n) return pair; - env = cdr(env); - } - return nil; + while (env != NULL) { + object* pair = car(env); + if (pair != NULL && car(pair)->name == n) return pair; + env = cdr(env); + } + return nil; } /* - findpair - returns the (var . value) pair bound to variable var in the local or global environment + findpair - returns the (var . value) pair bound to variable var in the local or global environment */ object* findpair (object* var, object* env) { - symbol_t name = var->name; - object* pair = value(name, env); - if (pair == NULL) pair = value(name, GlobalEnv); - return pair; + symbol_t name = var->name; + object* pair = value(name, env); + if (pair == NULL) pair = value(name, GlobalEnv); + return pair; } /* - boundp - tests whether var is bound to a value + boundp - tests whether var is bound to a value */ bool boundp (object* var, object* env) { - if (!symbolp(var)) error(notasymbol, var); - return (findpair(var, env) != NULL); + if (!symbolp(var)) error(notasymbol, var); + return (findpair(var, env) != NULL); } /* - findvalue - returns the value bound to variable var, or gives an error if unbound + findvalue - returns the value bound to variable var, or gives an error if unbound */ object* findvalue (object* var, object* env) { - object* pair = findpair(var, env); - if (pair == NULL) error(PSTR("unknown variable"), var); - return pair; + object* pair = findpair(var, env); + if (pair == NULL) error(PSTR("unknown variable"), var); + return pair; } // Handling closures object* closure (int tc, symbol_t name, object* function, object* args, object** env) { - object* state = car(function); - function = cdr(function); - int trace = 0; - if (name) trace = tracing(name); - if (trace) { - indent(TraceDepth[trace-1]<<1, ' ', pserial); - pint(TraceDepth[trace-1]++, pserial); - pserial(':'); pserial(' '); pserial('('); printsymbol(symbol(name), pserial); - } - object* params = first(function); - if (!listp(params)) errorsym(name, notalist, params); - function = cdr(function); - // Dropframe - if (tc) { - if (*env != NULL && car(*env) == NULL) { - pop(*env); - while (*env != NULL && car(*env) != NULL) pop(*env); - } else push(nil, *env); - } - // Push state - while (consp(state)) { - object* pair = first(state); - push(pair, *env); - state = cdr(state); - } - // Add arguments to environment - bool optional = false; - while (params != NULL) { - object* value; - object* var = first(params); - if (isbuiltin(var, OPTIONAL)) optional = true; - else { - if (consp(var)) { - if (!optional) errorsym(name, PSTR("invalid default value"), var); - if (args == NULL) value = eval(second(var), *env); - else { value = first(args); args = cdr(args); } - var = first(var); - if (!symbolp(var)) errorsym(name, PSTR("illegal optional parameter"), var); - } else if (!symbolp(var)) { - errorsym(name, PSTR("illegal function parameter"), var); - } else if (isbuiltin(var, AMPREST)) { + object* state = car(function); + function = cdr(function); + int trace = 0; + if (name) trace = tracing(name); + if (trace) { + indent(TraceDepth[trace-1]<<1, ' ', pserial); + pint(TraceDepth[trace-1]++, pserial); + pserial(':'); pserial(' '); pserial('('); printsymbol(symbol(name), pserial); + } + object* params = first(function); + if (!listp(params)) errorsym(name, notalist, params); + function = cdr(function); + // Dropframe + if (tc) { + if (*env != NULL && car(*env) == NULL) { + pop(*env); + while (*env != NULL && car(*env) != NULL) pop(*env); + } else push(nil, *env); + } + // Push state + while (consp(state)) { + object* pair = first(state); + push(pair, *env); + state = cdr(state); + } + // Add arguments to environment + bool optional = false; + while (params != NULL) { + object* value; + object* var = first(params); + if (isbuiltin(var, OPTIONAL)) optional = true; + else { + if (consp(var)) { + if (!optional) errorsym(name, PSTR("invalid default value"), var); + if (args == NULL) value = eval(second(var), *env); + else { value = first(args); args = cdr(args); } + var = first(var); + if (!symbolp(var)) errorsym(name, PSTR("illegal optional parameter"), var); + } else if (!symbolp(var)) { + errorsym(name, PSTR("illegal function parameter"), var); + } else if (isbuiltin(var, AMPREST)) { + params = cdr(params); + var = first(params); + value = args; + args = NULL; + } else { + if (args == NULL) { + if (optional) value = nil; + else errorsym2(name, toofewargs); + } else { value = first(args); args = cdr(args); } + } + push(cons(var,value), *env); + if (trace) { pserial(' '); printobject(value, pserial); } + } params = cdr(params); - var = first(params); - value = args; - args = NULL; - } else { - if (args == NULL) { - if (optional) value = nil; - else errorsym2(name, toofewargs); - } else { value = first(args); args = cdr(args); } - } - push(cons(var,value), *env); - if (trace) { pserial(' '); printobject(value, pserial); } } - params = cdr(params); - } - if (args != NULL) errorsym2(name, toomanyargs); - if (trace) { pserial(')'); pln(pserial); } - // Do an implicit progn - if (tc) push(nil, *env); - return tf_progn(function, *env); + if (args != NULL) errorsym2(name, toomanyargs); + if (trace) { pserial(')'); pln(pserial); } + // Do an implicit progn + if (tc) push(nil, *env); + return tf_progn(function, *env); } object* apply (object* function, object* args, object* env) { - if (symbolp(function)) { - builtin_t fname = builtin(function->name); - if ((fname < ENDFUNCTIONS) && ((getminmax(fname)>>6) == FUNCTIONS)) { - Context = fname; - checkargs(args); - return ((fn_ptr_type)lookupfn(fname))(args, env); - } else function = eval(function, env); - } - if (consp(function) && isbuiltin(car(function), LAMBDA)) { - object* result = closure(0, sym(NIL), function, args, &env); - return eval(result, env); - } - if (consp(function) && isbuiltin(car(function), CLOSURE)) { - function = cdr(function); - object* result = closure(0, sym(NIL), function, args, &env); - return eval(result, env); - } - error(PSTR("illegal function"), function); - return NULL; + if (symbolp(function)) { + builtin_t fname = builtin(function->name); + if ((fname < ENDFUNCTIONS) && ((getminmax(fname)>>6) == FUNCTIONS)) { + Context = fname; + checkargs(args); + return ((fn_ptr_type)lookupfn(fname))(args, env); + } else function = eval(function, env); + } + if (consp(function) && isbuiltin(car(function), LAMBDA)) { + object* result = closure(0, sym(NIL), function, args, &env); + return eval(result, env); + } + if (consp(function) && isbuiltin(car(function), CLOSURE)) { + function = cdr(function); + object* result = closure(0, sym(NIL), function, args, &env); + return eval(result, env); + } + error(PSTR("illegal function"), function); + return NULL; } // In-place operations /* - place - returns a pointer to an object referenced in the second argument of an - in-place operation such as setf. bit is used to indicate the bit position in a bit array + place - returns a pointer to an object referenced in the second argument of an + in-place operation such as setf. bit is used to indicate the bit position in a bit array */ object** place (object* args, object* env, int *bit) { - *bit = -1; - if (atom(args)) return &cdr(findvalue(args, env)); - object* function = first(args); - if (symbolp(function)) { - symbol_t sname = function->name; - if (sname == sym(CAR) || sname == sym(FIRST)) { - object* value = eval(second(args), env); - if (!listp(value)) error(canttakecar, value); - return &car(value); - } - if (sname == sym(CDR) || sname == sym(REST)) { - object* value = eval(second(args), env); - if (!listp(value)) error(canttakecdr, value); - return &cdr(value); - } - if (sname == sym(NTH)) { - int index = checkinteger(eval(second(args), env)); - object* list = eval(third(args), env); - if (atom(list)) error(PSTR("second argument to nth is not a list"), list); - while (index > 0) { - list = cdr(list); - if (list == NULL) error2(PSTR("index to nth is out of range")); - index--; - } - return &car(list); - } - if (sname == sym(AREF)) { - object* array = eval(second(args), env); - if (!arrayp(array)) error(PSTR("first argument is not an array"), array); - return getarray(array, cddr(args), env, bit); + *bit = -1; + if (atom(args)) return &cdr(findvalue(args, env)); + object* function = first(args); + if (symbolp(function)) { + symbol_t sname = function->name; + if (sname == sym(CAR) || sname == sym(FIRST)) { + object* value = eval(second(args), env); + if (!listp(value)) error(canttakecar, value); + return &car(value); + } + if (sname == sym(CDR) || sname == sym(REST)) { + object* value = eval(second(args), env); + if (!listp(value)) error(canttakecdr, value); + return &cdr(value); + } + if (sname == sym(NTH)) { + int index = checkinteger(eval(second(args), env)); + object* list = eval(third(args), env); + if (atom(list)) error(PSTR("second argument to nth is not a list"), list); + while (index > 0) { + list = cdr(list); + if (list == NULL) error2(PSTR("index to nth is out of range")); + index--; + } + return &car(list); + } + if (sname == sym(AREF)) { + object* array = eval(second(args), env); + if (!arrayp(array)) error(PSTR("first argument is not an array"), array); + return getarray(array, cddr(args), env, bit); + } } - } - error2(PSTR("illegal place")); - return nil; + error2(PSTR("illegal place")); + return nil; } // Checked car and cdr /* - carx - car with error checking + carx - car with error checking */ object* carx (object* arg) { - if (!listp(arg)) error(canttakecar, arg); - if (arg == nil) return nil; - return car(arg); + if (!listp(arg)) error(canttakecar, arg); + if (arg == nil) return nil; + return car(arg); } /* - cdrx - cdr with error checking + cdrx - cdr with error checking */ object* cdrx (object* arg) { - if (!listp(arg)) error(canttakecdr, arg); - if (arg == nil) return nil; - return cdr(arg); + if (!listp(arg)) error(canttakecdr, arg); + if (arg == nil) return nil; + return cdr(arg); } /* - cxxxr - implements a general cxxxr function, - pattern is a sequence of bits 0b1xxx where x is 0 for a and 1 for d. + cxxxr - implements a general cxxxr function, + pattern is a sequence of bits 0b1xxx where x is 0 for a and 1 for d. */ object* cxxxr (object* args, uint8_t pattern) { - object* arg = first(args); - while (pattern != 1) { - if ((pattern & 1) == 0) arg = carx(arg); else arg = cdrx(arg); - pattern = pattern>>1; - } - return arg; + object* arg = first(args); + while (pattern != 1) { + if ((pattern & 1) == 0) arg = carx(arg); else arg = cdrx(arg); + pattern = pattern>>1; + } + return arg; } // Mapping helper functions /* - mapcarfun - function specifying how to combine the results in mapcar + mapcarfun - function specifying how to combine the results in mapcar */ void mapcarfun (object* result, object** tail) { - object* obj = cons(result,NULL); - cdr(*tail) = obj; *tail = obj; + object* obj = cons(result,NULL); + cdr(*tail) = obj; *tail = obj; } /* - mapcanfun - function specifying how to combine the results in mapcan + mapcanfun - function specifying how to combine the results in mapcan */ void mapcanfun (object* result, object** tail) { - if (cdr(*tail) != NULL) error(notproper, *tail); - while (consp(result)) { - cdr(*tail) = result; *tail = result; - result = cdr(result); - } + if (cdr(*tail) != NULL) error(notproper, *tail); + while (consp(result)) { + cdr(*tail) = result; *tail = result; + result = cdr(result); + } } /* - mapcarcan - function used by marcar and mapcan - It takes the arguments, the env, and a function specifying how the results are combined. + mapcarcan - function used by marcar and mapcan + It takes the arguments, the env, and a function specifying how the results are combined. */ object* mapcarcan (object* args, object* env, mapfun_t fun) { - object* function = first(args); - args = cdr(args); - object* params = cons(NULL, NULL); - push(params,GCStack); - object* head = cons(NULL, NULL); - push(head,GCStack); - object* tail = head; - // Make parameters - while (true) { - object* tailp = params; - object* lists = args; - while (lists != NULL) { - object* list = car(lists); - if (list == NULL) { - pop(GCStack); pop(GCStack); - return cdr(head); - } - if (improperp(list)) error(notproper, list); - object* obj = cons(first(list),NULL); - car(lists) = cdr(list); - cdr(tailp) = obj; tailp = obj; - lists = cdr(lists); - } - object* result = apply(function, cdr(params), env); - fun(result, &tail); - } + object* function = first(args); + args = cdr(args); + object* params = cons(NULL, NULL); + push(params,GCStack); + object* head = cons(NULL, NULL); + push(head,GCStack); + object* tail = head; + // Make parameters + while (true) { + object* tailp = params; + object* lists = args; + while (lists != NULL) { + object* list = car(lists); + if (list == NULL) { + pop(GCStack); pop(GCStack); + return cdr(head); + } + if (improperp(list)) error(notproper, list); + object* obj = cons(first(list),NULL); + car(lists) = cdr(list); + cdr(tailp) = obj; tailp = obj; + lists = cdr(lists); + } + object* result = apply(function, cdr(params), env); + fun(result, &tail); + } } // I2C interface for one port, using Arduino Wire void I2Cinit (bool enablePullup) { - (void) enablePullup; - Wire.begin(); + (void) enablePullup; + Wire.begin(); } int I2Cread () { - return Wire.read(); + return Wire.read(); } void I2Cwrite (uint8_t data) { - Wire.write(data); + Wire.write(data); } bool I2Cstart (uint8_t address, uint8_t read) { int ok = true; if (read == 0) { - Wire.beginTransmission(address); - ok = (Wire.endTransmission(true) == 0); - Wire.beginTransmission(address); + Wire.beginTransmission(address); + ok = (Wire.endTransmission(true) == 0); + Wire.beginTransmission(address); } else Wire.requestFrom(address, I2Ccount); return ok; } bool I2Crestart (uint8_t address, uint8_t read) { - int error = (Wire.endTransmission(false) != 0); - if (read == 0) Wire.beginTransmission(address); - else Wire.requestFrom(address, I2Ccount); - return error ? false : true; + int error = (Wire.endTransmission(false) != 0); + if (read == 0) Wire.beginTransmission(address); + else Wire.requestFrom(address, I2Ccount); + return error ? false : true; } void I2Cstop (uint8_t read) { - if (read == 0) Wire.endTransmission(); // Check for error? + if (read == 0) Wire.endTransmission(); // Check for error? } // Streams @@ -1779,12 +1779,12 @@ inline int serial1read () { while (!Serial1.available()) testescape(); return Se #if defined(sdcardsupport) File SDpfile, SDgfile; inline int SDread () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - return SDgfile.read(); + if (LastChar) { + char temp = LastChar; + LastChar = 0; + return temp; + } + return SDgfile.read(); } #endif @@ -1792,43 +1792,43 @@ WiFiClient client; WiFiServer server(80); inline int WiFiread () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - return client.read(); + if (LastChar) { + char temp = LastChar; + LastChar = 0; + return temp; + } + return client.read(); } void serialbegin (int address, int baud) { - if (address == 1) Serial1.begin((long)baud*100); - else error(PSTR("port not supported"), number(address)); + if (address == 1) Serial1.begin((long)baud*100); + else error(PSTR("port not supported"), number(address)); } void serialend (int address) { - if (address == 1) {Serial1.flush(); Serial1.end(); } + if (address == 1) {Serial1.flush(); Serial1.end(); } } gfun_t gstreamfun (object* args) { - int streamtype = SERIALSTREAM; - int address = 0; - gfun_t gfun = gserial; - if (args != NULL) { - int stream = isstream(first(args)); - streamtype = stream>>8; address = stream & 0xFF; - } - if (streamtype == I2CSTREAM) gfun = (gfun_t)I2Cread; - else if (streamtype == SPISTREAM) gfun = spiread; - else if (streamtype == SERIALSTREAM) { - if (address == 0) gfun = gserial; - else if (address == 1) gfun = serial1read; - } - #if defined(sdcardsupport) - else if (streamtype == SDSTREAM) gfun = (gfun_t)SDread; - #endif - else if (streamtype == WIFISTREAM) gfun = (gfun_t)WiFiread; - else error2(PSTR("unknown stream type")); - return gfun; + int streamtype = SERIALSTREAM; + int address = 0; + gfun_t gfun = gserial; + if (args != NULL) { + int stream = isstream(first(args)); + streamtype = stream>>8; address = stream & 0xFF; + } + if (streamtype == I2CSTREAM) gfun = (gfun_t)I2Cread; + else if (streamtype == SPISTREAM) gfun = spiread; + else if (streamtype == SERIALSTREAM) { + if (address == 0) gfun = gserial; + else if (address == 1) gfun = serial1read; + } + #if defined(sdcardsupport) + else if (streamtype == SDSTREAM) gfun = (gfun_t)SDread; + #endif + else if (streamtype == WIFISTREAM) gfun = (gfun_t)WiFiread; + else error2(PSTR("unknown stream type")); + return gfun; } inline void spiwrite (char c) { SPI.transfer(c); } @@ -1842,68 +1842,68 @@ inline void gfxwrite (char c) { tft.write(c); } #endif pfun_t pstreamfun (object* args) { - int streamtype = SERIALSTREAM; - int address = 0; - pfun_t pfun = pserial; - if (args != NULL && first(args) != NULL) { - int stream = isstream(first(args)); - streamtype = stream>>8; address = stream & 0xFF; - } - if (streamtype == I2CSTREAM) pfun = (pfun_t)I2Cwrite; - else if (streamtype == SPISTREAM) pfun = spiwrite; - else if (streamtype == SERIALSTREAM) { - if (address == 0) pfun = pserial; - else if (address == 1) pfun = serial1write; - } - else if (streamtype == STRINGSTREAM) { - pfun = pstr; - } - #if defined(sdcardsupport) - else if (streamtype == SDSTREAM) pfun = (pfun_t)SDwrite; - #endif - #if defined(gfxsupport) - else if (streamtype == GFXSTREAM) pfun = (pfun_t)gfxwrite; - #endif - else if (streamtype == WIFISTREAM) pfun = (pfun_t)WiFiwrite; - else error2(PSTR("unknown stream type")); - return pfun; + int streamtype = SERIALSTREAM; + int address = 0; + pfun_t pfun = pserial; + if (args != NULL && first(args) != NULL) { + int stream = isstream(first(args)); + streamtype = stream>>8; address = stream & 0xFF; + } + if (streamtype == I2CSTREAM) pfun = (pfun_t)I2Cwrite; + else if (streamtype == SPISTREAM) pfun = spiwrite; + else if (streamtype == SERIALSTREAM) { + if (address == 0) pfun = pserial; + else if (address == 1) pfun = serial1write; + } + else if (streamtype == STRINGSTREAM) { + pfun = pstr; + } + #if defined(sdcardsupport) + else if (streamtype == SDSTREAM) pfun = (pfun_t)SDwrite; + #endif + #if defined(gfxsupport) + else if (streamtype == GFXSTREAM) pfun = (pfun_t)gfxwrite; + #endif + else if (streamtype == WIFISTREAM) pfun = (pfun_t)WiFiwrite; + else error2(PSTR("unknown stream type")); + return pfun; } // Check pins void checkanalogread (int pin) { - + // if (!(pin==0 || pin==2 || pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) // error(PSTR("invalid pin"), number(pin)); - (void)pin; + (void)pin; } void checkanalogwrite (int pin) { // if (!(pin>=25 && pin<=26)) error(PSTR("invalid pin"), number(pin)); - (void)pin; + (void)pin; } // Note void tone (int pin, int note) { - (void) pin, (void) note; + (void) pin, (void) note; } void noTone (int pin) { - (void) pin; + (void) pin; } const int scale[] PROGMEM = {4186,4435,4699,4978,5274,5588,5920,6272,6645,7040,7459,7902}; void playnote (int pin, int note, int octave) { - int prescaler = 8 - octave - note/12; - if (prescaler<0 || prescaler>8) error(PSTR("octave out of range"), number(prescaler)); - tone(pin, pgm_read_word(&scale[note%12])>>prescaler); + int prescaler = 8 - octave - note/12; + if (prescaler<0 || prescaler>8) error(PSTR("octave out of range"), number(prescaler)); + tone(pin, pgm_read_word(&scale[note%12])>>prescaler); } void nonote (int pin) { - noTone(pin); + noTone(pin); } // Sleep @@ -1911,7 +1911,7 @@ void nonote (int pin) { void initsleep () { } void doze (int secs) { - delay(1000 * secs); + delay(1000 * secs); } // Prettyprint @@ -1922,3394 +1922,3394 @@ const int GFXPPWIDTH = 52; // 320 pixel wide screen int ppwidth = PPWIDTH; void pcount (char c) { - if (c == '\n') PrintCount++; - PrintCount++; + if (c == '\n') PrintCount++; + PrintCount++; } /* - atomwidth - calculates the character width of an atom + atomwidth - calculates the character width of an atom */ uint8_t atomwidth (object* obj) { - PrintCount = 0; - printobject(obj, pcount); - return PrintCount; + PrintCount = 0; + printobject(obj, pcount); + return PrintCount; } uint8_t basewidth (object* obj, uint8_t base) { - PrintCount = 0; - pintbase(obj->integer, base, pcount); - return PrintCount; + PrintCount = 0; + pintbase(obj->integer, base, pcount); + return PrintCount; } bool quoted (object* obj) { - return (consp(obj) && car(obj) != NULL && car(obj)->name == sym(QUOTE) && consp(cdr(obj)) && cddr(obj) == NULL); + return (consp(obj) && car(obj) != NULL && car(obj)->name == sym(QUOTE) && consp(cdr(obj)) && cddr(obj) == NULL); } int subwidth (object* obj, int w) { - if (atom(obj)) return w - atomwidth(obj); - if (quoted(obj)) obj = car(cdr(obj)); - return subwidthlist(obj, w - 1); + if (atom(obj)) return w - atomwidth(obj); + if (quoted(obj)) obj = car(cdr(obj)); + return subwidthlist(obj, w - 1); } int subwidthlist (object* form, int w) { - while (form != NULL && w >= 0) { - if (atom(form)) return w - (2 + atomwidth(form)); - w = subwidth(car(form), w - 1); - form = cdr(form); - } - return w; + while (form != NULL && w >= 0) { + if (atom(form)) return w - (2 + atomwidth(form)); + w = subwidth(car(form), w - 1); + form = cdr(form); + } + return w; } /* - superprint - the main pretty-print subroutine + superprint - the main pretty-print subroutine */ void superprint (object* form, int lm, pfun_t pfun) { - if (atom(form)) { - if (symbolp(form) && form->name == sym(NOTHING)) printsymbol(form, pfun); - else printobject(form, pfun); - } - else if (quoted(form)) { pfun('\''); superprint(car(cdr(form)), lm + 1, pfun); } - else if (subwidth(form, ppwidth - lm) >= 0) supersub(form, lm + PPINDENT, 0, pfun); - else supersub(form, lm + PPINDENT, 1, pfun); + if (atom(form)) { + if (symbolp(form) && form->name == sym(NOTHING)) printsymbol(form, pfun); + else printobject(form, pfun); + } + else if (quoted(form)) { pfun('\''); superprint(car(cdr(form)), lm + 1, pfun); } + else if (subwidth(form, ppwidth - lm) >= 0) supersub(form, lm + PPINDENT, 0, pfun); + else supersub(form, lm + PPINDENT, 1, pfun); } /* - supersub - subroutine used by pprint + supersub - subroutine used by pprint */ void supersub (object* form, int lm, int super, pfun_t pfun) { - int special = 0, separate = 1; - object* arg = car(form); - if (symbolp(arg) && builtinp(arg->name)) { - uint8_t minmax = getminmax(builtin(arg->name)); - if (minmax == 0327 || minmax == 0313) special = 2; // defun, setq, setf, defvar - else if (minmax == 0317 || minmax == 0017 || minmax == 0117 || minmax == 0123) special = 1; - } - while (form != NULL) { - if (atom(form)) { pfstring(PSTR(" . "), pfun); printobject(form, pfun); pfun(')'); return; } - else if (separate) { pfun('('); separate = 0; } - else if (special) { pfun(' '); special--; } - else if (!super) pfun(' '); - else { pln(pfun); indent(lm, ' ', pfun); } - superprint(car(form), lm, pfun); - form = cdr(form); - } - pfun(')'); return; + int special = 0, separate = 1; + object* arg = car(form); + if (symbolp(arg) && builtinp(arg->name)) { + uint8_t minmax = getminmax(builtin(arg->name)); + if (minmax == 0327 || minmax == 0313) special = 2; // defun, setq, setf, defvar + else if (minmax == 0317 || minmax == 0017 || minmax == 0117 || minmax == 0123) special = 1; + } + while (form != NULL) { + if (atom(form)) { pfstring(PSTR(" . "), pfun); printobject(form, pfun); pfun(')'); return; } + else if (separate) { pfun('('); separate = 0; } + else if (special) { pfun(' '); special--; } + else if (!super) pfun(' '); + else { pln(pfun); indent(lm, ' ', pfun); } + superprint(car(form), lm, pfun); + form = cdr(form); + } + pfun(')'); return; } /* - edit - the Lisp tree editor - Steps through a function definition, editing it a bit at a time, using single-key editing commands. + edit - the Lisp tree editor + Steps through a function definition, editing it a bit at a time, using single-key editing commands. */ object* edit (object* fun) { - while (1) { - if (tstflag(EXITEDITOR)) return fun; - char c = gserial(); - if (c == 'q') setflag(EXITEDITOR); - else if (c == 'b') return fun; - else if (c == 'r') fun = read(gserial); - else if (c == '\n') { pfl(pserial); superprint(fun, 0, pserial); pln(pserial); } - else if (c == 'c') fun = cons(read(gserial), fun); - else if (atom(fun)) pserial('!'); - else if (c == 'd') fun = cons(car(fun), edit(cdr(fun))); - else if (c == 'a') fun = cons(edit(car(fun)), cdr(fun)); - else if (c == 'x') fun = cdr(fun); - else pserial('?'); - } + while (1) { + if (tstflag(EXITEDITOR)) return fun; + char c = gserial(); + if (c == 'q') setflag(EXITEDITOR); + else if (c == 'b') return fun; + else if (c == 'r') fun = read(gserial); + else if (c == '\n') { pfl(pserial); superprint(fun, 0, pserial); pln(pserial); } + else if (c == 'c') fun = cons(read(gserial), fun); + else if (atom(fun)) pserial('!'); + else if (c == 'd') fun = cons(car(fun), edit(cdr(fun))); + else if (c == 'a') fun = cons(edit(car(fun)), cdr(fun)); + else if (c == 'x') fun = cdr(fun); + else pserial('?'); + } } // Special forms object* sp_quote (object* args, object* env) { - (void) env; - checkargs(args); - return first(args); + (void) env; + checkargs(args); + return first(args); } /* - (or item*) - Evaluates its arguments until one returns non-nil, and returns its value. + (or item*) + Evaluates its arguments until one returns non-nil, and returns its value. */ object* sp_or (object* args, object* env) { - while (args != NULL) { - object* val = eval(car(args), env); - if (val != NULL) return val; - args = cdr(args); - } - return nil; + while (args != NULL) { + object* val = eval(car(args), env); + if (val != NULL) return val; + args = cdr(args); + } + return nil; } /* - (defun name (parameters) form*) - Defines a function. + (defun name (parameters) form*) + Defines a function. */ object* sp_defun (object* args, object* env) { - (void) env; - checkargs(args); - object* var = first(args); - if (!symbolp(var)) error(notasymbol, var); - object* val = cons(bsymbol(LAMBDA), cdr(args)); - object* pair = value(var->name, GlobalEnv); - if (pair != NULL) cdr(pair) = val; - else push(cons(var, val), GlobalEnv); - return var; + (void) env; + checkargs(args); + object* var = first(args); + if (!symbolp(var)) error(notasymbol, var); + object* val = cons(bsymbol(LAMBDA), cdr(args)); + object* pair = value(var->name, GlobalEnv); + if (pair != NULL) cdr(pair) = val; + else push(cons(var, val), GlobalEnv); + return var; } /* - (defvar variable form) - Defines a global variable. + (defvar variable form) + Defines a global variable. */ object* sp_defvar (object* args, object* env) { - checkargs(args); - object* var = first(args); - if (!symbolp(var)) error(notasymbol, var); - object* val = NULL; - args = cdr(args); - if (args != NULL) { setflag(NOESC); val = eval(first(args), env); clrflag(NOESC); } - object* pair = value(var->name, GlobalEnv); - if (pair != NULL) cdr(pair) = val; - else push(cons(var, val), GlobalEnv); - return var; + checkargs(args); + object* var = first(args); + if (!symbolp(var)) error(notasymbol, var); + object* val = NULL; + args = cdr(args); + if (args != NULL) { setflag(NOESC); val = eval(first(args), env); clrflag(NOESC); } + object* pair = value(var->name, GlobalEnv); + if (pair != NULL) cdr(pair) = val; + else push(cons(var, val), GlobalEnv); + return var; } /* - (setq symbol value [symbol value]*) - For each pair of arguments assigns the value of the second argument - to the variable specified in the first argument. + (setq symbol value [symbol value]*) + For each pair of arguments assigns the value of the second argument + to the variable specified in the first argument. */ object* sp_setq (object* args, object* env) { - object* arg = nil; - while (args != NULL) { - if (cdr(args) == NULL) error2(oddargs); - object* pair = findvalue(first(args), env); - arg = eval(second(args), env); - cdr(pair) = arg; - args = cddr(args); - } - return arg; + object* arg = nil; + while (args != NULL) { + if (cdr(args) == NULL) error2(oddargs); + object* pair = findvalue(first(args), env); + arg = eval(second(args), env); + cdr(pair) = arg; + args = cddr(args); + } + return arg; } /* - (loop forms*) - Executes its arguments repeatedly until one of the arguments calls (return), - which then causes an exit from the loop. + (loop forms*) + Executes its arguments repeatedly until one of the arguments calls (return), + which then causes an exit from the loop. */ object* sp_loop (object* args, object* env) { - object* start = args; - for (;;) { - yield(); - args = start; - while (args != NULL) { - object* result = eval(car(args),env); - if (tstflag(RETURNFLAG)) { - clrflag(RETURNFLAG); - return result; - } - args = cdr(args); + object* start = args; + for (;;) { + yield(); + args = start; + while (args != NULL) { + object* result = eval(car(args),env); + if (tstflag(RETURNFLAG)) { + clrflag(RETURNFLAG); + return result; + } + args = cdr(args); + } } - } } /* - (return [value]) - Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value. + (return [value]) + Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value. */ object* sp_return (object* args, object* env) { - object* result = eval(tf_progn(args,env), env); - setflag(RETURNFLAG); - return result; + object* result = eval(tf_progn(args,env), env); + setflag(RETURNFLAG); + return result; } /* - (push item place) - Modifies the value of place, which should be a list, to add item onto the front of the list, - and returns the new list. + (push item place) + Modifies the value of place, which should be a list, to add item onto the front of the list, + and returns the new list. */ object* sp_push (object* args, object* env) { - int bit; - checkargs(args); - object* item = eval(first(args), env); - object** loc = place(second(args), env, &bit); - push(item, *loc); - return *loc; + int bit; + checkargs(args); + object* item = eval(first(args), env); + object** loc = place(second(args), env, &bit); + push(item, *loc); + return *loc; } /* - (pop place) - Modifies the value of place, which should be a list, to remove its first item, and returns that item. + (pop place) + Modifies the value of place, which should be a list, to remove its first item, and returns that item. */ object* sp_pop (object* args, object* env) { - int bit; - checkargs(args); - object** loc = place(first(args), env, &bit); - object* result = car(*loc); - pop(*loc); - return result; + int bit; + checkargs(args); + object** loc = place(first(args), env, &bit); + object* result = car(*loc); + pop(*loc); + return result; } // Accessors /* - (incf place [number]) - Increments a place, which should have an numeric value, and returns the result. - The third argument is an optional increment which defaults to 1. + (incf place [number]) + Increments a place, which should have an numeric value, and returns the result. + The third argument is an optional increment which defaults to 1. */ object* sp_incf (object* args, object* env) { - int bit; - checkargs(args); - object** loc = place(first(args), env, &bit); - args = cdr(args); + int bit; + checkargs(args); + object** loc = place(first(args), env, &bit); + args = cdr(args); - object* x = *loc; - object* inc = (args != NULL) ? eval(first(args), env) : NULL; + object* x = *loc; + object* inc = (args != NULL) ? eval(first(args), env) : NULL; - if (bit != -1) { - int increment; - if (inc == NULL) increment = 1; else increment = checkbitvalue(inc); - int newvalue = (((*loc)->integer)>>bit & 1) + increment; + if (bit != -1) { + int increment; + if (inc == NULL) increment = 1; else increment = checkbitvalue(inc); + int newvalue = (((*loc)->integer)>>bit & 1) + increment; - if (newvalue & ~1) error2(PSTR("result is not a bit value")); - *loc = number((((*loc)->integer) & ~(1<integer) & ~(1<integer; + *loc = makefloat(value + increment); + } else if (integerp(x) && (integerp(inc) || inc == NULL)) { + int increment; + int value = x->integer; - if (inc == NULL) increment = 1; else increment = inc->integer; + if (inc == NULL) increment = 1; else increment = inc->integer; - if (increment < 1) { - if (INT_MIN - increment > value) *loc = makefloat((float)value + (float)increment); - else *loc = number(value + increment); - } else { - if (INT_MAX - increment < value) *loc = makefloat((float)value + (float)increment); - else *loc = number(value + increment); - } - } else error2(notanumber); - return *loc; + if (increment < 1) { + if (INT_MIN - increment > value) *loc = makefloat((float)value + (float)increment); + else *loc = number(value + increment); + } else { + if (INT_MAX - increment < value) *loc = makefloat((float)value + (float)increment); + else *loc = number(value + increment); + } + } else error2(notanumber); + return *loc; } /* - (decf place [number]) - Decrements a place, which should have an numeric value, and returns the result. - The third argument is an optional decrement which defaults to 1. + (decf place [number]) + Decrements a place, which should have an numeric value, and returns the result. + The third argument is an optional decrement which defaults to 1. */ object* sp_decf (object* args, object* env) { - int bit; - checkargs(args); - object** loc = place(first(args), env, &bit); - args = cdr(args); + int bit; + checkargs(args); + object** loc = place(first(args), env, &bit); + args = cdr(args); - object* x = *loc; - object* dec = (args != NULL) ? eval(first(args), env) : NULL; + object* x = *loc; + object* dec = (args != NULL) ? eval(first(args), env) : NULL; - if (bit != -1) { - int decrement; - if (dec == NULL) decrement = 1; else decrement = checkbitvalue(dec); - int newvalue = (((*loc)->integer)>>bit & 1) - decrement; + if (bit != -1) { + int decrement; + if (dec == NULL) decrement = 1; else decrement = checkbitvalue(dec); + int newvalue = (((*loc)->integer)>>bit & 1) - decrement; - if (newvalue & ~1) error2(PSTR("result is not a bit value")); - *loc = number((((*loc)->integer) & ~(1<integer) & ~(1<integer; + *loc = makefloat(value - decrement); + } else if (integerp(x) && (integerp(dec) || dec == NULL)) { + int decrement; + int value = x->integer; - if (dec == NULL) decrement = 1; else decrement = dec->integer; + if (dec == NULL) decrement = 1; else decrement = dec->integer; - if (decrement < 1) { - if (INT_MAX + decrement < value) *loc = makefloat((float)value - (float)decrement); - else *loc = number(value - decrement); - } else { - if (INT_MIN + decrement > value) *loc = makefloat((float)value - (float)decrement); - else *loc = number(value - decrement); - } - } else error2(notanumber); - return *loc; + if (decrement < 1) { + if (INT_MAX + decrement < value) *loc = makefloat((float)value - (float)decrement); + else *loc = number(value - decrement); + } else { + if (INT_MIN + decrement > value) *loc = makefloat((float)value - (float)decrement); + else *loc = number(value - decrement); + } + } else error2(notanumber); + return *loc; } /* - (setf place value [place value]*) - For each pair of arguments modifies a place to the result of evaluating value. + (setf place value [place value]*) + For each pair of arguments modifies a place to the result of evaluating value. */ object* sp_setf (object* args, object* env) { - int bit; - object* arg = nil; - while (args != NULL) { - if (cdr(args) == NULL) error2(oddargs); - object** loc = place(first(args), env, &bit); - arg = eval(second(args), env); - if (bit == -1) *loc = arg; - else *loc = number((checkinteger(*loc) & ~(1<name); - args = cdr(args); - } - int i = 0; - while (i < TRACEMAX) { - if (TraceFn[i] != 0) args = cons(symbol(TraceFn[i]), args); - i++; - } - return args; + (void) env; + while (args != NULL) { + object* var = first(args); + if (!symbolp(var)) error(notasymbol, var); + trace(var->name); + args = cdr(args); + } + int i = 0; + while (i < TRACEMAX) { + if (TraceFn[i] != 0) args = cons(symbol(TraceFn[i]), args); + i++; + } + return args; } /* - (untrace [function]*) - Turns off tracing of up to TRACEMAX user-defined functions, and returns a list of the functions untraced. - If no functions are specified it untraces all functions. + (untrace [function]*) + Turns off tracing of up to TRACEMAX user-defined functions, and returns a list of the functions untraced. + If no functions are specified it untraces all functions. */ object* sp_untrace (object* args, object* env) { - (void) env; - if (args == NULL) { - int i = 0; - while (i < TRACEMAX) { - if (TraceFn[i] != 0) args = cons(symbol(TraceFn[i]), args); - TraceFn[i] = 0; - i++; - } - } else { - while (args != NULL) { - object* var = first(args); - if (!symbolp(var)) error(notasymbol, var); - untrace(var->name); - args = cdr(args); + (void) env; + if (args == NULL) { + int i = 0; + while (i < TRACEMAX) { + if (TraceFn[i] != 0) args = cons(symbol(TraceFn[i]), args); + TraceFn[i] = 0; + i++; + } + } else { + while (args != NULL) { + object* var = first(args); + if (!symbolp(var)) error(notasymbol, var); + untrace(var->name); + args = cdr(args); + } } - } - return args; + return args; } /* - (for-millis ([number]) form*) - Executes the forms and then waits until a total of number milliseconds have elapsed. - Returns the total number of milliseconds taken. + (for-millis ([number]) form*) + Executes the forms and then waits until a total of number milliseconds have elapsed. + Returns the total number of milliseconds taken. */ object* sp_formillis (object* args, object* env) { - if (args == NULL) error2(noargument); - object* param = first(args); - unsigned long start = millis(); - unsigned long now, total = 0; - if (param != NULL) total = checkinteger(eval(first(param), env)); - eval(tf_progn(cdr(args),env), env); - do { - now = millis() - start; - testescape(); - } while (now < total); - if (now <= INT_MAX) return number(now); - return nil; + if (args == NULL) error2(noargument); + object* param = first(args); + unsigned long start = millis(); + unsigned long now, total = 0; + if (param != NULL) total = checkinteger(eval(first(param), env)); + eval(tf_progn(cdr(args),env), env); + do { + now = millis() - start; + testescape(); + } while (now < total); + if (now <= INT_MAX) return number(now); + return nil; } /* - (time form) - Prints the value returned by the form, and the time taken to evaluate the form - in milliseconds or seconds. + (time form) + Prints the value returned by the form, and the time taken to evaluate the form + in milliseconds or seconds. */ object* sp_time (object* args, object* env) { - unsigned long start = millis(); - object* result = eval(first(args), env); - unsigned long elapsed = millis() - start; - printobject(result, pserial); - pfstring(PSTR("\nTime: "), pserial); - if (elapsed < 1000) { - pint(elapsed, pserial); - pfstring(PSTR(" ms\n"), pserial); - } else { - elapsed = elapsed+50; - pint(elapsed/1000, pserial); - pserial('.'); pint((elapsed/100)%10, pserial); - pfstring(PSTR(" s\n"), pserial); - } - return bsymbol(NOTHING); + unsigned long start = millis(); + object* result = eval(first(args), env); + unsigned long elapsed = millis() - start; + printobject(result, pserial); + pfstring(PSTR("\nTime: "), pserial); + if (elapsed < 1000) { + pint(elapsed, pserial); + pfstring(PSTR(" ms\n"), pserial); + } else { + elapsed = elapsed+50; + pint(elapsed/1000, pserial); + pserial('.'); pint((elapsed/100)%10, pserial); + pfstring(PSTR(" s\n"), pserial); + } + return bsymbol(NOTHING); } /* - (with-output-to-string (str) form*) - Returns a string containing the output to the stream variable str. + (with-output-to-string (str) form*) + Returns a string containing the output to the stream variable str. */ object* sp_withoutputtostring (object* args, object* env) { - if (args == NULL) error2(noargument); - object* params = first(args); - if (params == NULL) error2(nostream); - object* var = first(params); - object* pair = cons(var, stream(STRINGSTREAM, 0)); - push(pair,env); - object* string = startstring(); - push(string, GCStack); - object* forms = cdr(args); - eval(tf_progn(forms,env), env); - pop(GCStack); - return string; + if (args == NULL) error2(noargument); + object* params = first(args); + if (params == NULL) error2(nostream); + object* var = first(params); + object* pair = cons(var, stream(STRINGSTREAM, 0)); + push(pair,env); + object* string = startstring(); + push(string, GCStack); + object* forms = cdr(args); + eval(tf_progn(forms,env), env); + pop(GCStack); + return string; } /* - (with-serial (str port [baud]) form*) - Evaluates the forms with str bound to a serial-stream using port. - The optional baud gives the baud rate divided by 100, default 96. + (with-serial (str port [baud]) form*) + Evaluates the forms with str bound to a serial-stream using port. + The optional baud gives the baud rate divided by 100, default 96. */ object* sp_withserial (object* args, object* env) { - object* params = first(args); - if (params == NULL) error2(nostream); - object* var = first(params); - int address = checkinteger(eval(second(params), env)); - params = cddr(params); - int baud = 96; - if (params != NULL) baud = checkinteger(eval(first(params), env)); - object* pair = cons(var, stream(SERIALSTREAM, address)); - push(pair,env); - serialbegin(address, baud); - object* forms = cdr(args); - object* result = eval(tf_progn(forms,env), env); - serialend(address); - return result; -} - -/* - (with-i2c (str [port] address [read-p]) form*) - Evaluates the forms with str bound to an i2c-stream defined by address. - If read-p is nil or omitted the stream is written to, otherwise it specifies the number of bytes - to be read from the stream. The port if specified is ignored. + object* params = first(args); + if (params == NULL) error2(nostream); + object* var = first(params); + int address = checkinteger(eval(second(params), env)); + params = cddr(params); + int baud = 96; + if (params != NULL) baud = checkinteger(eval(first(params), env)); + object* pair = cons(var, stream(SERIALSTREAM, address)); + push(pair,env); + serialbegin(address, baud); + object* forms = cdr(args); + object* result = eval(tf_progn(forms,env), env); + serialend(address); + return result; +} + +/* + (with-i2c (str [port] address [read-p]) form*) + Evaluates the forms with str bound to an i2c-stream defined by address. + If read-p is nil or omitted the stream is written to, otherwise it specifies the number of bytes + to be read from the stream. The port if specified is ignored. */ object* sp_withi2c (object* args, object* env) { - object* params = first(args); - if (params == NULL) error2(nostream); - object* var = first(params); - int address = checkinteger(eval(second(params), env)); - params = cddr(params); - if (address == 0 && params != NULL) params = cdr(params); // Ignore port - int read = 0; // Write - I2Ccount = 0; - if (params != NULL) { - object* rw = eval(first(params), env); - if (integerp(rw)) I2Ccount = rw->integer; - read = (rw != NULL); - } - I2Cinit(1); // Pullups - object* pair = cons(var, (I2Cstart(address, read)) ? stream(I2CSTREAM, address) : nil); - push(pair,env); - object* forms = cdr(args); - object* result = eval(tf_progn(forms,env), env); - I2Cstop(read); - return result; -} - -/* - (with-spi (str pin [clock] [bitorder] [mode]) form*) - Evaluates the forms with str bound to an spi-stream. - The parameters specify the enable pin, clock in kHz (default 4000), - bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0). + object* params = first(args); + if (params == NULL) error2(nostream); + object* var = first(params); + int address = checkinteger(eval(second(params), env)); + params = cddr(params); + if (address == 0 && params != NULL) params = cdr(params); // Ignore port + int read = 0; // Write + I2Ccount = 0; + if (params != NULL) { + object* rw = eval(first(params), env); + if (integerp(rw)) I2Ccount = rw->integer; + read = (rw != NULL); + } + I2Cinit(1); // Pullups + object* pair = cons(var, (I2Cstart(address, read)) ? stream(I2CSTREAM, address) : nil); + push(pair,env); + object* forms = cdr(args); + object* result = eval(tf_progn(forms,env), env); + I2Cstop(read); + return result; +} + +/* + (with-spi (str pin [clock] [bitorder] [mode]) form*) + Evaluates the forms with str bound to an spi-stream. + The parameters specify the enable pin, clock in kHz (default 4000), + bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0). */ object* sp_withspi (object* args, object* env) { - object* params = first(args); - if (params == NULL) error2(nostream); - object* var = first(params); - params = cdr(params); - if (params == NULL) error2(nostream); - int pin = checkinteger(eval(car(params), env)); - pinMode(pin, OUTPUT); - digitalWrite(pin, HIGH); - params = cdr(params); - int clock = 4000, mode = SPI_MODE0; // Defaults - int bitorder = MSBFIRST; - if (params != NULL) { - clock = checkinteger(eval(car(params), env)); + object* params = first(args); + if (params == NULL) error2(nostream); + object* var = first(params); params = cdr(params); + if (params == NULL) error2(nostream); + int pin = checkinteger(eval(car(params), env)); + pinMode(pin, OUTPUT); + digitalWrite(pin, HIGH); + params = cdr(params); + int clock = 4000, mode = SPI_MODE0; // Defaults + int bitorder = MSBFIRST; if (params != NULL) { - bitorder = (checkinteger(eval(car(params), env)) == 0) ? LSBFIRST : MSBFIRST; - params = cdr(params); - if (params != NULL) { - int modeval = checkinteger(eval(car(params), env)); - mode = (modeval == 3) ? SPI_MODE3 : (modeval == 2) ? SPI_MODE2 : (modeval == 1) ? SPI_MODE1 : SPI_MODE0; - } - } - } - object* pair = cons(var, stream(SPISTREAM, pin)); - push(pair,env); - SPI.begin(); - SPI.beginTransaction(SPISettings(((unsigned long)clock * 1000), bitorder, mode)); - digitalWrite(pin, LOW); - object* forms = cdr(args); - object* result = eval(tf_progn(forms,env), env); - digitalWrite(pin, HIGH); - SPI.endTransaction(); - return result; -} - -/* - (with-sd-card (str filename [mode]) form*) - Evaluates the forms with str bound to an sd-stream reading from or writing to the file filename. - If mode is omitted the file is read, otherwise 0 means read, 1 write-append, or 2 write-overwrite. + clock = checkinteger(eval(car(params), env)); + params = cdr(params); + if (params != NULL) { + bitorder = (checkinteger(eval(car(params), env)) == 0) ? LSBFIRST : MSBFIRST; + params = cdr(params); + if (params != NULL) { + int modeval = checkinteger(eval(car(params), env)); + mode = (modeval == 3) ? SPI_MODE3 : (modeval == 2) ? SPI_MODE2 : (modeval == 1) ? SPI_MODE1 : SPI_MODE0; + } + } + } + object* pair = cons(var, stream(SPISTREAM, pin)); + push(pair,env); + SPI.begin(); + SPI.beginTransaction(SPISettings(((unsigned long)clock * 1000), bitorder, mode)); + digitalWrite(pin, LOW); + object* forms = cdr(args); + object* result = eval(tf_progn(forms,env), env); + digitalWrite(pin, HIGH); + SPI.endTransaction(); + return result; +} + +/* + (with-sd-card (str filename [mode]) form*) + Evaluates the forms with str bound to an sd-stream reading from or writing to the file filename. + If mode is omitted the file is read, otherwise 0 means read, 1 write-append, or 2 write-overwrite. */ object* sp_withsdcard (object* args, object* env) { #if defined(sdcardsupport) - object* params = first(args); - if (params == NULL) error2(nostream); - object* var = first(params); - params = cdr(params); - if (params == NULL) error2(PSTR("no filename specified")); - object* filename = eval(first(params), env); - params = cdr(params); - SD.begin(); - int mode = 0; - if (params != NULL && first(params) != NULL) mode = checkinteger(first(params)); - const char* oflag = FILE_READ; - if (mode == 1) oflag = FILE_APPEND; else if (mode == 2) oflag = FILE_WRITE; - if (mode >= 1) { - char buffer[BUFFERSIZE]; - SDpfile = SD.open(MakeFilename(filename, buffer), oflag); - if (!SDpfile) error2(PSTR("problem writing to SD card or invalid filename")); - } else { - char buffer[BUFFERSIZE]; - SDgfile = SD.open(MakeFilename(filename, buffer), oflag); - if (!SDgfile) error2(PSTR("problem reading from SD card or invalid filename")); - } - object* pair = cons(var, stream(SDSTREAM, 1)); - push(pair,env); - object* forms = cdr(args); - object* result = eval(tf_progn(forms,env), env); - if (mode >= 1) SDpfile.close(); else SDgfile.close(); - return result; + object* params = first(args); + if (params == NULL) error2(nostream); + object* var = first(params); + params = cdr(params); + if (params == NULL) error2(PSTR("no filename specified")); + object* filename = eval(first(params), env); + params = cdr(params); + SD.begin(); + int mode = 0; + if (params != NULL && first(params) != NULL) mode = checkinteger(first(params)); + const char* oflag = FILE_READ; + if (mode == 1) oflag = FILE_APPEND; else if (mode == 2) oflag = FILE_WRITE; + if (mode >= 1) { + char buffer[BUFFERSIZE]; + SDpfile = SD.open(MakeFilename(filename, buffer), oflag); + if (!SDpfile) error2(PSTR("problem writing to SD card or invalid filename")); + } else { + char buffer[BUFFERSIZE]; + SDgfile = SD.open(MakeFilename(filename, buffer), oflag); + if (!SDgfile) error2(PSTR("problem reading from SD card or invalid filename")); + } + object* pair = cons(var, stream(SDSTREAM, 1)); + push(pair,env); + object* forms = cdr(args); + object* result = eval(tf_progn(forms,env), env); + if (mode >= 1) SDpfile.close(); else SDgfile.close(); + return result; #else - (void) args, (void) env; - error2(PSTR("not supported")); - return nil; + (void) args, (void) env; + error2(PSTR("not supported")); + return nil; #endif } // Tail-recursive forms /* - (progn form*) - Evaluates several forms grouped together into a block, and returns the result of evaluating the last form. + (progn form*) + Evaluates several forms grouped together into a block, and returns the result of evaluating the last form. */ object* tf_progn (object* args, object* env) { - if (args == NULL) return nil; - object* more = cdr(args); - while (more != NULL) { - object* result = eval(car(args),env); - if (tstflag(RETURNFLAG)) return result; - args = more; - more = cdr(args); - } - return car(args); + if (args == NULL) return nil; + object* more = cdr(args); + while (more != NULL) { + object* result = eval(car(args),env); + if (tstflag(RETURNFLAG)) return result; + args = more; + more = cdr(args); + } + return car(args); } /* - (if test then [else]) - Evaluates test. If it's non-nil the form then is evaluated and returned; - otherwise the form else is evaluated and returned. + (if test then [else]) + Evaluates test. If it's non-nil the form then is evaluated and returned; + otherwise the form else is evaluated and returned. */ object* tf_if (object* args, object* env) { - if (args == NULL || cdr(args) == NULL) error2(toofewargs); - if (eval(first(args), env) != nil) return second(args); - args = cddr(args); - return (args != NULL) ? first(args) : nil; + if (args == NULL || cdr(args) == NULL) error2(toofewargs); + if (eval(first(args), env) != nil) return second(args); + args = cddr(args); + return (args != NULL) ? first(args) : nil; } /* - (cond ((test form*) (test form*) ... )) - Each argument is a list consisting of a test optionally followed by one or more forms. - If the test evaluates to non-nil the forms are evaluated, and the last value is returned as the result of the cond. - If the test evaluates to nil, none of the forms are evaluated, and the next argument is processed in the same way. + (cond ((test form*) (test form*) ... )) + Each argument is a list consisting of a test optionally followed by one or more forms. + If the test evaluates to non-nil the forms are evaluated, and the last value is returned as the result of the cond. + If the test evaluates to nil, none of the forms are evaluated, and the next argument is processed in the same way. */ object* tf_cond (object* args, object* env) { - while (args != NULL) { - object* clause = first(args); - if (!consp(clause)) error(illegalclause, clause); - object* test = eval(first(clause), env); - object* forms = cdr(clause); - if (test != nil) { - if (forms == NULL) return quoteit(QUOTE, test); else return tf_progn(forms, env); + while (args != NULL) { + object* clause = first(args); + if (!consp(clause)) error(illegalclause, clause); + object* test = eval(first(clause), env); + object* forms = cdr(clause); + if (test != nil) { + if (forms == NULL) return quoteit(QUOTE, test); else return tf_progn(forms, env); + } + args = cdr(args); } - args = cdr(args); - } - return nil; + return nil; } /* - (when test form*) - Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned. + (when test form*) + Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned. */ object* tf_when (object* args, object* env) { - if (args == NULL) error2(noargument); - if (eval(first(args), env) != nil) return tf_progn(cdr(args),env); - else return nil; + if (args == NULL) error2(noargument); + if (eval(first(args), env) != nil) return tf_progn(cdr(args),env); + else return nil; } /* - (unless test form*) - Evaluates the test. If it's nil the forms are evaluated and the last value is returned. + (unless test form*) + Evaluates the test. If it's nil the forms are evaluated and the last value is returned. */ object* tf_unless (object* args, object* env) { - if (args == NULL) error2(noargument); - if (eval(first(args), env) != nil) return nil; - else return tf_progn(cdr(args),env); + if (args == NULL) error2(noargument); + if (eval(first(args), env) != nil) return nil; + else return tf_progn(cdr(args),env); } /* - (case keyform ((key form*) (key form*) ... )) - Evaluates a keyform to produce a test key, and then tests this against a series of arguments, - each of which is a list containing a key optionally followed by one or more forms. + (case keyform ((key form*) (key form*) ... )) + Evaluates a keyform to produce a test key, and then tests this against a series of arguments, + each of which is a list containing a key optionally followed by one or more forms. */ object* tf_case (object* args, object* env) { - object* test = eval(first(args), env); - args = cdr(args); - while (args != NULL) { - object* clause = first(args); - if (!consp(clause)) error(illegalclause, clause); - object* key = car(clause); - object* forms = cdr(clause); - if (consp(key)) { - while (key != NULL) { - if (eq(test,car(key))) return tf_progn(forms, env); - key = cdr(key); - } - } else if (eq(test,key) || eq(key,tee)) return tf_progn(forms, env); + object* test = eval(first(args), env); args = cdr(args); - } - return nil; + while (args != NULL) { + object* clause = first(args); + if (!consp(clause)) error(illegalclause, clause); + object* key = car(clause); + object* forms = cdr(clause); + if (consp(key)) { + while (key != NULL) { + if (eq(test,car(key))) return tf_progn(forms, env); + key = cdr(key); + } + } else if (eq(test,key) || eq(key,tee)) return tf_progn(forms, env); + args = cdr(args); + } + return nil; } /* - (and item*) - Evaluates its arguments until one returns nil, and returns the last value. + (and item*) + Evaluates its arguments until one returns nil, and returns the last value. */ 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); + 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); } // Core functions /* - (not item) - Returns t if its argument is nil, or nil otherwise. Equivalent to null. + (not item) + Returns t if its argument is nil, or nil otherwise. Equivalent to null. */ object* fn_not (object* args, object* env) { - (void) env; - return (first(args) == nil) ? tee : nil; + (void) env; + return (first(args) == nil) ? tee : nil; } /* - (cons item item) - If the second argument is a list, cons returns a new list with item added to the front of the list. - If the second argument isn't a list cons returns a dotted pair. + (cons item item) + If the second argument is a list, cons returns a new list with item added to the front of the list. + If the second argument isn't a list cons returns a dotted pair. */ object* fn_cons (object* args, object* env) { - (void) env; - return cons(first(args), second(args)); + (void) env; + return cons(first(args), second(args)); } /* - (atom item) - Returns t if its argument is a single number, symbol, or nil. + (atom item) + Returns t if its argument is a single number, symbol, or nil. */ object* fn_atom (object* args, object* env) { - (void) env; - return atom(first(args)) ? tee : nil; + (void) env; + return atom(first(args)) ? tee : nil; } /* - (listp item) - Returns t if its argument is a list. + (listp item) + Returns t if its argument is a list. */ object* fn_listp (object* args, object* env) { - (void) env; - return listp(first(args)) ? tee : nil; + (void) env; + return listp(first(args)) ? tee : nil; } /* - (consp item) - Returns t if its argument is a non-null list. + (consp item) + Returns t if its argument is a non-null list. */ object* fn_consp (object* args, object* env) { - (void) env; - return consp(first(args)) ? tee : nil; + (void) env; + return consp(first(args)) ? tee : nil; } /* - (symbolp item) - Returns t if its argument is a symbol. + (symbolp item) + Returns t if its argument is a symbol. */ object* fn_symbolp (object* args, object* env) { - (void) env; - object* arg = first(args); - return (arg == NULL || symbolp(arg)) ? tee : nil; + (void) env; + object* arg = first(args); + return (arg == NULL || symbolp(arg)) ? tee : nil; } /* - (arrayp item) - Returns t if its argument is an array. + (arrayp item) + Returns t if its argument is an array. */ object* fn_arrayp (object* args, object* env) { - (void) env; - return arrayp(first(args)) ? tee : nil; + (void) env; + return arrayp(first(args)) ? tee : nil; } /* - (boundp item) - Returns t if its argument is a symbol with a value. + (boundp item) + Returns t if its argument is a symbol with a value. */ object* fn_boundp (object* args, object* env) { - return boundp(first(args), env) ? tee : nil; + return boundp(first(args), env) ? tee : nil; } /* - (keywordp item) - Returns t if its argument is a keyword. + (keywordp item) + Returns t if its argument is a keyword. */ object* fn_keywordp (object* args, object* env) { - (void) env; - return keywordp(first(args)) ? tee : nil; + (void) env; + return keywordp(first(args)) ? tee : nil; } /* - (set symbol value [symbol value]*) - For each pair of arguments, assigns the value of the second argument to the value of the first argument. + (set symbol value [symbol value]*) + For each pair of arguments, assigns the value of the second argument to the value of the first argument. */ object* fn_setfn (object* args, object* env) { - object* arg = nil; - while (args != NULL) { - if (cdr(args) == NULL) error2(oddargs); - object* pair = findvalue(first(args), env); - arg = second(args); - cdr(pair) = arg; - args = cddr(args); - } - return arg; + object* arg = nil; + while (args != NULL) { + if (cdr(args) == NULL) error2(oddargs); + object* pair = findvalue(first(args), env); + arg = second(args); + cdr(pair) = arg; + args = cddr(args); + } + return arg; } /* - (streamp item) - Returns t if its argument is a stream. + (streamp item) + Returns t if its argument is a stream. */ object* fn_streamp (object* args, object* env) { - (void) env; - object* arg = first(args); - return streamp(arg) ? tee : nil; + (void) env; + object* arg = first(args); + return streamp(arg) ? tee : nil; } /* - (eq item item) - Tests whether the two arguments are the same symbol, same character, equal numbers, - or point to the same cons, and returns t or nil as appropriate. + (eq item item) + Tests whether the two arguments are the same symbol, same character, equal numbers, + or point to the same cons, and returns t or nil as appropriate. */ object* fn_eq (object* args, object* env) { - (void) env; - return eq(first(args), second(args)) ? tee : nil; + (void) env; + return eq(first(args), second(args)) ? tee : nil; } /* - (equal item item) - Tests whether the two arguments are the same symbol, same character, equal numbers, - or point to the same cons, and returns t or nil as appropriate. + (equal item item) + Tests whether the two arguments are the same symbol, same character, equal numbers, + or point to the same cons, and returns t or nil as appropriate. */ object* fn_equal (object* args, object* env) { - (void) env; - return equal(first(args), second(args)) ? tee : nil; + (void) env; + return equal(first(args), second(args)) ? tee : nil; } // List functions /* - (car list) - Returns the first item in a list. + (car list) + Returns the first item in a list. */ object* fn_car (object* args, object* env) { - (void) env; - return carx(first(args)); + (void) env; + return carx(first(args)); } /* - (cdr list) - Returns a list with the first item removed. + (cdr list) + Returns a list with the first item removed. */ object* fn_cdr (object* args, object* env) { - (void) env; - return cdrx(first(args)); + (void) env; + return cdrx(first(args)); } /* - (caar list) + (caar list) */ object* fn_caar (object* args, object* env) { - (void) env; - return cxxxr(args, 0b100); + (void) env; + return cxxxr(args, 0b100); } /* - (cadr list) + (cadr list) */ object* fn_cadr (object* args, object* env) { - (void) env; - return cxxxr(args, 0b101); + (void) env; + return cxxxr(args, 0b101); } /* - (cdar list) - Equivalent to (cdr (car list)). + (cdar list) + Equivalent to (cdr (car list)). */ object* fn_cdar (object* args, object* env) { - (void) env; - return cxxxr(args, 0b110); + (void) env; + return cxxxr(args, 0b110); } /* - (cddr list) - Equivalent to (cdr (cdr list)). + (cddr list) + Equivalent to (cdr (cdr list)). */ object* fn_cddr (object* args, object* env) { - (void) env; - return cxxxr(args, 0b111); + (void) env; + return cxxxr(args, 0b111); } /* - (caaar list) - Equivalent to (car (car (car list))). + (caaar list) + Equivalent to (car (car (car list))). */ object* fn_caaar (object* args, object* env) { - (void) env; - return cxxxr(args, 0b1000); + (void) env; + return cxxxr(args, 0b1000); } /* - (caadr list) - Equivalent to (car (car (cdar list))). + (caadr list) + Equivalent to (car (car (cdar list))). */ object* fn_caadr (object* args, object* env) { - (void) env; - return cxxxr(args, 0b1001);; + (void) env; + return cxxxr(args, 0b1001);; } /* - (cadar list) - Equivalent to (car (cdr (car list))). + (cadar list) + Equivalent to (car (cdr (car list))). */ object* fn_cadar (object* args, object* env) { - (void) env; - return cxxxr(args, 0b1010); + (void) env; + return cxxxr(args, 0b1010); } /* - (caddr list) - Equivalent to (car (cdr (cdr list))). + (caddr list) + Equivalent to (car (cdr (cdr list))). */ object* fn_caddr (object* args, object* env) { - (void) env; - return cxxxr(args, 0b1011); + (void) env; + return cxxxr(args, 0b1011); } /* - (cdaar list) - Equivalent to (cdar (car (car list))). + (cdaar list) + Equivalent to (cdar (car (car list))). */ object* fn_cdaar (object* args, object* env) { - (void) env; - return cxxxr(args, 0b1100); + (void) env; + return cxxxr(args, 0b1100); } /* - (cdadr list) - Equivalent to (cdr (car (cdr list))). + (cdadr list) + Equivalent to (cdr (car (cdr list))). */ object* fn_cdadr (object* args, object* env) { - (void) env; - return cxxxr(args, 0b1101); + (void) env; + return cxxxr(args, 0b1101); } /* - (cddar list) - Equivalent to (cdr (cdr (car list))). + (cddar list) + Equivalent to (cdr (cdr (car list))). */ object* fn_cddar (object* args, object* env) { - (void) env; - return cxxxr(args, 0b1110); + (void) env; + return cxxxr(args, 0b1110); } /* - (cdddr list) - Equivalent to (cdr (cdr (cdr list))). + (cdddr list) + Equivalent to (cdr (cdr (cdr list))). */ object* fn_cdddr (object* args, object* env) { - (void) env; - return cxxxr(args, 0b1111); + (void) env; + return cxxxr(args, 0b1111); } /* - (length item) - Returns the number of items in a list, the length of a string, or the length of a one-dimensional array. + (length item) + Returns the number of items in a list, the length of a string, or the length of a one-dimensional array. */ object* fn_length (object* args, object* env) { - (void) env; - object* arg = first(args); - if (listp(arg)) return number(listlength(arg)); - if (stringp(arg)) return number(stringlength(arg)); - if (!(arrayp(arg) && cdr(cddr(arg)) == NULL)) error(PSTR("argument is not a list, 1d array, or string"), arg); - return number(abs(first(cddr(arg))->integer)); + (void) env; + object* arg = first(args); + if (listp(arg)) return number(listlength(arg)); + if (stringp(arg)) return number(stringlength(arg)); + if (!(arrayp(arg) && cdr(cddr(arg)) == NULL)) error(PSTR("argument is not a list, 1d array, or string"), arg); + return number(abs(first(cddr(arg))->integer)); } /* - (array-dimensions item) - Returns a list of the dimensions of an array. + (array-dimensions item) + Returns a list of the dimensions of an array. */ object* fn_arraydimensions (object* args, object* env) { - (void) env; - object* array = first(args); - if (!arrayp(array)) error(PSTR("argument is not an array"), array); - object* dimensions = cddr(array); - return (first(dimensions)->integer < 0) ? cons(number(-(first(dimensions)->integer)), cdr(dimensions)) : dimensions; + (void) env; + object* array = first(args); + if (!arrayp(array)) error(PSTR("argument is not an array"), array); + object* dimensions = cddr(array); + return (first(dimensions)->integer < 0) ? cons(number(-(first(dimensions)->integer)), cdr(dimensions)) : dimensions; } /* - (list item*) - Returns a list of the values of its arguments. + (list item*) + Returns a list of the values of its arguments. */ object* fn_list (object* args, object* env) { - (void) env; - return args; + (void) env; + return args; } /* - (make-array size [:initial-element element] [:element-type 'bit]) - If size is an integer it creates a one-dimensional array with elements from 0 to size-1. - If size is a list of n integers it creates an n-dimensional array with those dimensions. - If :element-type 'bit is specified the array is a bit array. + (make-array size [:initial-element element] [:element-type 'bit]) + If size is an integer it creates a one-dimensional array with elements from 0 to size-1. + If size is a list of n integers it creates an n-dimensional array with those dimensions. + If :element-type 'bit is specified the array is a bit array. */ object* fn_makearray (object* args, object* env) { - (void) env; - object* def = nil; - bool bitp = false; - object* dims = first(args); - if (dims == NULL) error2(PSTR("dimensions can't be nil")); - else if (atom(dims)) dims = cons(dims, NULL); - args = cdr(args); - while (args != NULL && cdr(args) != NULL) { - object* var = first(args); - if (isbuiltin(first(args), INITIALELEMENT)) def = second(args); - else if (isbuiltin(first(args), ELEMENTTYPE) && isbuiltin(second(args), BIT)) bitp = true; - else error(PSTR("argument not recognised"), var); - args = cddr(args); - } - if (bitp) { - if (def == nil) def = number(0); - else def = number(-checkbitvalue(def)); // 1 becomes all ones - } - return makearray(dims, def, bitp); + (void) env; + object* def = nil; + bool bitp = false; + object* dims = first(args); + if (dims == NULL) error2(PSTR("dimensions can't be nil")); + else if (atom(dims)) dims = cons(dims, NULL); + args = cdr(args); + while (args != NULL && cdr(args) != NULL) { + object* var = first(args); + if (isbuiltin(first(args), INITIALELEMENT)) def = second(args); + else if (isbuiltin(first(args), ELEMENTTYPE) && isbuiltin(second(args), BIT)) bitp = true; + else error(PSTR("argument not recognised"), var); + args = cddr(args); + } + if (bitp) { + if (def == nil) def = number(0); + else def = number(-checkbitvalue(def)); // 1 becomes all ones + } + return makearray(dims, def, bitp); } /* - (reverse list) - Returns a list with the elements of list in reverse order. + (reverse list) + Returns a list with the elements of list in reverse order. */ object* fn_reverse (object* args, object* env) { - (void) env; - object* list = first(args); - object* result = NULL; - while (list != NULL) { - if (improperp(list)) error(notproper, list); - push(first(list),result); - list = cdr(list); - } - return result; + (void) env; + object* list = first(args); + object* result = NULL; + while (list != NULL) { + if (improperp(list)) error(notproper, list); + push(first(list),result); + list = cdr(list); + } + return result; } /* - (nth number list) - Returns the nth item in list, counting from zero. + (nth number list) + Returns the nth item in list, counting from zero. */ object* fn_nth (object* args, object* env) { - (void) env; - int n = checkinteger(first(args)); - if (n < 0) error(indexnegative, first(args)); - object* list = second(args); - while (list != NULL) { - if (improperp(list)) error(notproper, list); - if (n == 0) return car(list); - list = cdr(list); - n--; - } - return nil; + (void) env; + int n = checkinteger(first(args)); + if (n < 0) error(indexnegative, first(args)); + object* list = second(args); + while (list != NULL) { + if (improperp(list)) error(notproper, list); + if (n == 0) return car(list); + list = cdr(list); + n--; + } + return nil; } /* - (aref array index [index*]) - Returns an element from the specified array. + (aref array index [index*]) + Returns an element from the specified array. */ object* fn_aref (object* args, object* env) { - (void) env; - int bit; - object* array = first(args); - if (!arrayp(array)) error(PSTR("first argument is not an array"), array); - object* loc = *getarray(array, cdr(args), 0, &bit); - if (bit == -1) return loc; - else return number((loc->integer)>>bit & 1); + (void) env; + int bit; + object* array = first(args); + if (!arrayp(array)) error(PSTR("first argument is not an array"), array); + object* loc = *getarray(array, cdr(args), 0, &bit); + if (bit == -1) return loc; + else return number((loc->integer)>>bit & 1); } /* - (assoc key list) - Looks up a key in an association list of (key . value) pairs, - and returns the matching pair, or nil if no pair is found. + (assoc key list) + Looks up a key in an association list of (key . value) pairs, + and returns the matching pair, or nil if no pair is found. */ object* fn_assoc (object* args, object* env) { - (void) env; - object* key = first(args); - object* list = second(args); - return assoc(key,list); + (void) env; + object* key = first(args); + object* list = second(args); + return assoc(key,list); } /* - (member item list) - Searches for an item in a list, using eq, and returns the list starting from the first occurrence of the item, - or nil if it is not found. + (member item list) + Searches for an item in a list, using eq, and returns the list starting from the first occurrence of the item, + or nil if it is not found. */ object* fn_member (object* args, object* env) { - (void) env; - object* item = first(args); - object* list = second(args); - while (list != NULL) { - if (improperp(list)) error(notproper, list); - if (eq(item,car(list))) return list; - list = cdr(list); - } - return nil; + (void) env; + object* item = first(args); + object* list = second(args); + while (list != NULL) { + if (improperp(list)) error(notproper, list); + if (eq(item,car(list))) return list; + list = cdr(list); + } + return nil; } /* - (apply function list) - Returns the result of evaluating function, with the list of arguments specified by the second parameter. + (apply function list) + Returns the result of evaluating function, with the list of arguments specified by the second parameter. */ object* fn_apply (object* args, object* env) { - object* previous = NULL; - object* last = args; - while (cdr(last) != NULL) { - previous = last; - last = cdr(last); - } - object* arg = car(last); - if (!listp(arg)) error(notalist, arg); - cdr(previous) = arg; - return apply(first(args), cdr(args), env); + object* previous = NULL; + object* last = args; + while (cdr(last) != NULL) { + previous = last; + last = cdr(last); + } + object* arg = car(last); + if (!listp(arg)) error(notalist, arg); + cdr(previous) = arg; + return apply(first(args), cdr(args), env); } /* - (funcall function argument*) - Evaluates function with the specified arguments. + (funcall function argument*) + Evaluates function with the specified arguments. */ object* fn_funcall (object* args, object* env) { - return apply(first(args), cdr(args), env); + return apply(first(args), cdr(args), env); } /* - (append list*) - Joins its arguments, which should be lists, into a single list. + (append list*) + Joins its arguments, which should be lists, into a single list. */ object* fn_append (object* args, object* env) { - (void) env; - object* head = NULL; - object* tail; - while (args != NULL) { - object* list = first(args); - if (!listp(list)) error(notalist, list); - while (consp(list)) { - object* obj = cons(car(list), cdr(list)); - if (head == NULL) head = obj; - else cdr(tail) = obj; - tail = obj; - list = cdr(list); - if (cdr(args) != NULL && improperp(list)) error(notproper, first(args)); + (void) env; + object* head = NULL; + object* tail; + while (args != NULL) { + object* list = first(args); + if (!listp(list)) error(notalist, list); + while (consp(list)) { + object* obj = cons(car(list), cdr(list)); + if (head == NULL) head = obj; + else cdr(tail) = obj; + tail = obj; + list = cdr(list); + if (cdr(args) != NULL && improperp(list)) error(notproper, first(args)); + } + args = cdr(args); } - args = cdr(args); - } - return head; + return head; } /* - (mapc function list1 [list]*) - Applies the function to each element in one or more lists, ignoring the results. - It returns the first list argument. + (mapc function list1 [list]*) + Applies the function to each element in one or more lists, ignoring the results. + It returns the first list argument. */ object* fn_mapc (object* args, object* env) { - object* function = first(args); - args = cdr(args); - object* result = first(args); - push(result,GCStack); - object* params = cons(NULL, NULL); - push(params,GCStack); - // Make parameters - while (true) { - object* tailp = params; - object* lists = args; - while (lists != NULL) { - object* list = car(lists); - if (list == NULL) { - pop(GCStack); pop(GCStack); - return result; - } - if (improperp(list)) error(notproper, list); - object* obj = cons(first(list),NULL); - car(lists) = cdr(list); - cdr(tailp) = obj; tailp = obj; - lists = cdr(lists); - } - apply(function, cdr(params), env); - } -} - -/* - (mapcar function list1 [list]*) - Applies the function to each element in one or more lists, and returns the resulting list. + object* function = first(args); + args = cdr(args); + object* result = first(args); + push(result,GCStack); + object* params = cons(NULL, NULL); + push(params,GCStack); + // Make parameters + while (true) { + object* tailp = params; + object* lists = args; + while (lists != NULL) { + object* list = car(lists); + if (list == NULL) { + pop(GCStack); pop(GCStack); + return result; + } + if (improperp(list)) error(notproper, list); + object* obj = cons(first(list),NULL); + car(lists) = cdr(list); + cdr(tailp) = obj; tailp = obj; + lists = cdr(lists); + } + apply(function, cdr(params), env); + } +} + +/* + (mapcar function list1 [list]*) + Applies the function to each element in one or more lists, and returns the resulting list. */ object* fn_mapcar (object* args, object* env) { - return mapcarcan(args, env, mapcarfun); + return mapcarcan(args, env, mapcarfun); } /* - (mapcan function list1 [list]*) - Applies the function to each element in one or more lists. The results should be lists, - and these are appended together to give the value returned. + (mapcan function list1 [list]*) + Applies the function to each element in one or more lists. The results should be lists, + and these are appended together to give the value returned. */ object* fn_mapcan (object* args, object* env) { - return mapcarcan(args, env, mapcanfun); + return mapcarcan(args, env, mapcanfun); } // Arithmetic functions /* - (+ number*) - Adds its arguments together. - If each argument is an integer, and the running total doesn't overflow, the result is an integer, - otherwise a floating-point number. + (+ number*) + Adds its arguments together. + If each argument is an integer, and the running total doesn't overflow, the result is an integer, + otherwise a floating-point number. */ object* fn_add (object* args, object* env) { - (void) env; - int result = 0; - while (args != NULL) { + (void) env; + int result = 0; + while (args != NULL) { + object* arg = car(args); + if (floatp(arg)) return add_floats(args, (float)result); + else if (integerp(arg)) { + int val = arg->integer; + if (val < 1) { if (INT_MIN - val > result) return add_floats(args, (float)result); } + else { if (INT_MAX - val < result) return add_floats(args, (float)result); } + result = result + val; + } else error(notanumber, arg); + args = cdr(args); + } + return number(result); +} + +/* + (- number*) + If there is one argument, negates the argument. + If there are two or more arguments, subtracts the second and subsequent arguments from the first argument. + If each argument is an integer, and the running total doesn't overflow, returns the result as an integer, + otherwise a floating-point number. +*/ +object* fn_subtract (object* args, object* env) { + (void) env; object* arg = car(args); - if (floatp(arg)) return add_floats(args, (float)result); + args = cdr(args); + if (args == NULL) return negate(arg); + else if (floatp(arg)) return subtract_floats(args, arg->single_float); else if (integerp(arg)) { - int val = arg->integer; - if (val < 1) { if (INT_MIN - val > result) return add_floats(args, (float)result); } - else { if (INT_MAX - val < result) return add_floats(args, (float)result); } - result = result + val; + int result = arg->integer; + while (args != NULL) { + arg = car(args); + if (floatp(arg)) return subtract_floats(args, result); + else if (integerp(arg)) { + int val = (car(args))->integer; + if (val < 1) { if (INT_MAX + val < result) return subtract_floats(args, result); } + else { if (INT_MIN + val > result) return subtract_floats(args, result); } + result = result - val; + } else error(notanumber, arg); + args = cdr(args); + } + return number(result); } else error(notanumber, arg); - args = cdr(args); - } - return number(result); + return nil; } /* - (- number*) - If there is one argument, negates the argument. - If there are two or more arguments, subtracts the second and subsequent arguments from the first argument. - If each argument is an integer, and the running total doesn't overflow, returns the result as an integer, - otherwise a floating-point number. + (* number*) + Multiplies its arguments together. + If each argument is an integer, and the running total doesn't overflow, the result is an integer, + otherwise it's a floating-point number. */ -object* fn_subtract (object* args, object* env) { - (void) env; - object* arg = car(args); - args = cdr(args); - if (args == NULL) return negate(arg); - else if (floatp(arg)) return subtract_floats(args, arg->single_float); - else if (integerp(arg)) { - int result = arg->integer; - while (args != NULL) { - arg = car(args); - if (floatp(arg)) return subtract_floats(args, result); - else if (integerp(arg)) { - int val = (car(args))->integer; - if (val < 1) { if (INT_MAX + val < result) return subtract_floats(args, result); } - else { if (INT_MIN + val > result) return subtract_floats(args, result); } - result = result - val; - } else error(notanumber, arg); - args = cdr(args); +object* fn_multiply (object* args, object* env) { + (void) env; + int result = 1; + while (args != NULL){ + object* arg = car(args); + if (floatp(arg)) return multiply_floats(args, result); + else if (integerp(arg)) { + int64_t val = result * (int64_t)(arg->integer); + if ((val > INT_MAX) || (val < INT_MIN)) return multiply_floats(args, result); + result = val; + } else error(notanumber, arg); + args = cdr(args); } return number(result); - } else error(notanumber, arg); - return nil; } /* - (* number*) - Multiplies its arguments together. - If each argument is an integer, and the running total doesn't overflow, the result is an integer, - otherwise it's a floating-point number. + (/ number*) + Divides the first argument by the second and subsequent arguments. + If each argument is an integer, and each division produces an exact result, the result is an integer; + otherwise it's a floating-point number. */ -object* fn_multiply (object* args, object* env) { - (void) env; - int result = 1; - while (args != NULL){ - object* arg = car(args); - if (floatp(arg)) return multiply_floats(args, result); +object* fn_divide (object* args, object* env) { + (void) env; + object* arg = first(args); + args = cdr(args); + // One argument + if (args == NULL) { + if (floatp(arg)) { + float f = arg->single_float; + if (f == 0.0) error2(PSTR("division by zero")); + return makefloat(1.0 / f); + } else if (integerp(arg)) { + int i = arg->integer; + if (i == 0) error2(PSTR("division by zero")); + else if (i == 1) return number(1); + else return makefloat(1.0 / i); + } else error(notanumber, arg); + } + // Multiple arguments + if (floatp(arg)) return divide_floats(args, arg->single_float); else if (integerp(arg)) { - int64_t val = result * (int64_t)(arg->integer); - if ((val > INT_MAX) || (val < INT_MIN)) return multiply_floats(args, result); - result = val; + int result = arg->integer; + while (args != NULL) { + arg = car(args); + if (floatp(arg)) { + return divide_floats(args, result); + } else if (integerp(arg)) { + int i = arg->integer; + if (i == 0) error2(PSTR("division by zero")); + if ((result % i) != 0) return divide_floats(args, result); + if ((result == INT_MIN) && (i == -1)) return divide_floats(args, result); + result = result / i; + args = cdr(args); + } else error(notanumber, arg); + } + return number(result); } else error(notanumber, arg); - args = cdr(args); - } - return number(result); + return nil; } /* - (/ number*) - Divides the first argument by the second and subsequent arguments. - If each argument is an integer, and each division produces an exact result, the result is an integer; - otherwise it's a floating-point number. + (mod number number) + Returns its first argument modulo the second argument. + If both arguments are integers the result is an integer; otherwise it's a floating-point number. */ -object* fn_divide (object* args, object* env) { - (void) env; - object* arg = first(args); - args = cdr(args); - // One argument - if (args == NULL) { - if (floatp(arg)) { - float f = arg->single_float; - if (f == 0.0) error2(PSTR("division by zero")); - return makefloat(1.0 / f); - } else if (integerp(arg)) { - int i = arg->integer; - if (i == 0) error2(PSTR("division by zero")); - else if (i == 1) return number(1); - else return makefloat(1.0 / i); - } else error(notanumber, arg); - } - // Multiple arguments - if (floatp(arg)) return divide_floats(args, arg->single_float); - else if (integerp(arg)) { - int result = arg->integer; - while (args != NULL) { - arg = car(args); - if (floatp(arg)) { - return divide_floats(args, result); - } else if (integerp(arg)) { - int i = arg->integer; - if (i == 0) error2(PSTR("division by zero")); - if ((result % i) != 0) return divide_floats(args, result); - if ((result == INT_MIN) && (i == -1)) return divide_floats(args, result); - result = result / i; - args = cdr(args); - } else error(notanumber, arg); +object* fn_mod (object* args, object* env) { + (void) env; + object* arg1 = first(args); + object* arg2 = second(args); + if (integerp(arg1) && integerp(arg2)) { + int divisor = arg2->integer; + if (divisor == 0) error2(PSTR("division by zero")); + int dividend = arg1->integer; + int remainder = dividend % divisor; + if ((dividend<0) != (divisor<0)) remainder = remainder + divisor; + return number(remainder); + } else { + float fdivisor = checkintfloat(arg2); + if (fdivisor == 0.0) error2(PSTR("division by zero")); + float fdividend = checkintfloat(arg1); + float fremainder = fmod(fdividend , fdivisor); + if ((fdividend<0) != (fdivisor<0)) fremainder = fremainder + fdivisor; + return makefloat(fremainder); } - return number(result); - } else error(notanumber, arg); - return nil; } /* - (mod number number) - Returns its first argument modulo the second argument. - If both arguments are integers the result is an integer; otherwise it's a floating-point number. -*/ -object* fn_mod (object* args, object* env) { - (void) env; - object* arg1 = first(args); - object* arg2 = second(args); - if (integerp(arg1) && integerp(arg2)) { - int divisor = arg2->integer; - if (divisor == 0) error2(PSTR("division by zero")); - int dividend = arg1->integer; - int remainder = dividend % divisor; - if ((dividend<0) != (divisor<0)) remainder = remainder + divisor; - return number(remainder); - } else { - float fdivisor = checkintfloat(arg2); - if (fdivisor == 0.0) error2(PSTR("division by zero")); - float fdividend = checkintfloat(arg1); - float fremainder = fmod(fdividend , fdivisor); - if ((fdividend<0) != (fdivisor<0)) fremainder = fremainder + fdivisor; - return makefloat(fremainder); - } -} - -/* - (1+ number) - Adds one to its argument and returns it. - If the argument is an integer the result is an integer if possible; - otherwise it's a floating-point number. + (1+ number) + Adds one to its argument and returns it. + If the argument is an integer the result is an integer if possible; + otherwise it's a floating-point number. */ object* fn_oneplus (object* args, object* env) { - (void) env; - object* arg = first(args); - if (floatp(arg)) return makefloat((arg->single_float) + 1.0); - else if (integerp(arg)) { - int result = arg->integer; - if (result == INT_MAX) return makefloat((arg->integer) + 1.0); - else return number(result + 1); - } else error(notanumber, arg); - return nil; + (void) env; + object* arg = first(args); + if (floatp(arg)) return makefloat((arg->single_float) + 1.0); + else if (integerp(arg)) { + int result = arg->integer; + if (result == INT_MAX) return makefloat((arg->integer) + 1.0); + else return number(result + 1); + } else error(notanumber, arg); + return nil; } /* - (1- number) - Subtracts one from its argument and returns it. - If the argument is an integer the result is an integer if possible; - otherwise it's a floating-point number. + (1- number) + Subtracts one from its argument and returns it. + If the argument is an integer the result is an integer if possible; + otherwise it's a floating-point number. */ object* fn_oneminus (object* args, object* env) { - (void) env; - object* arg = first(args); - if (floatp(arg)) return makefloat((arg->single_float) - 1.0); - else if (integerp(arg)) { - int result = arg->integer; - if (result == INT_MIN) return makefloat((arg->integer) - 1.0); - else return number(result - 1); - } else error(notanumber, arg); - return nil; + (void) env; + object* arg = first(args); + if (floatp(arg)) return makefloat((arg->single_float) - 1.0); + else if (integerp(arg)) { + int result = arg->integer; + if (result == INT_MIN) return makefloat((arg->integer) - 1.0); + else return number(result - 1); + } else error(notanumber, arg); + return nil; } /* - (abs number) - Returns the absolute, positive value of its argument. - If the argument is an integer the result will be returned as an integer if possible, - otherwise a floating-point number. + (abs number) + Returns the absolute, positive value of its argument. + If the argument is an integer the result will be returned as an integer if possible, + otherwise a floating-point number. */ object* fn_abs (object* args, object* env) { - (void) env; - object* arg = first(args); - if (floatp(arg)) return makefloat(abs(arg->single_float)); - else if (integerp(arg)) { - int result = arg->integer; - if (result == INT_MIN) return makefloat(abs((float)result)); - else return number(abs(result)); - } else error(notanumber, arg); - return nil; + (void) env; + object* arg = first(args); + if (floatp(arg)) return makefloat(abs(arg->single_float)); + else if (integerp(arg)) { + int result = arg->integer; + if (result == INT_MIN) return makefloat(abs((float)result)); + else return number(abs(result)); + } else error(notanumber, arg); + return nil; } /* - (random number) - If number is an integer returns a random number between 0 and one less than its argument. - Otherwise returns a floating-point number between zero and number. + (random number) + If number is an integer returns a random number between 0 and one less than its argument. + Otherwise returns a floating-point number between zero and number. */ object* fn_random (object* args, object* env) { - (void) env; - object* arg = first(args); - if (integerp(arg)) return number(random(arg->integer)); - else if (floatp(arg)) return makefloat((float)rand()/(float)(RAND_MAX/(arg->single_float))); - else error(notanumber, arg); - return nil; + (void) env; + object* arg = first(args); + if (integerp(arg)) return number(random(arg->integer)); + else if (floatp(arg)) return makefloat((float)rand()/(float)(RAND_MAX/(arg->single_float))); + else error(notanumber, arg); + return nil; } /* - (max number*) - Returns the maximum of one or more arguments. + (max number*) + Returns the maximum of one or more arguments. */ object* fn_maxfn (object* args, object* env) { - (void) env; - object* result = first(args); - args = cdr(args); - while (args != NULL) { - object* arg = car(args); - if (integerp(result) && integerp(arg)) { - if ((arg->integer) > (result->integer)) result = arg; - } else if ((checkintfloat(arg) > checkintfloat(result))) result = arg; + (void) env; + object* result = first(args); args = cdr(args); - } - return result; + while (args != NULL) { + object* arg = car(args); + if (integerp(result) && integerp(arg)) { + if ((arg->integer) > (result->integer)) result = arg; + } else if ((checkintfloat(arg) > checkintfloat(result))) result = arg; + args = cdr(args); + } + return result; } /* - (min number*) - Returns the minimum of one or more arguments. + (min number*) + Returns the minimum of one or more arguments. */ object* fn_minfn (object* args, object* env) { - (void) env; - object* result = first(args); - args = cdr(args); - while (args != NULL) { - object* arg = car(args); - if (integerp(result) && integerp(arg)) { - if ((arg->integer) < (result->integer)) result = arg; - } else if ((checkintfloat(arg) < checkintfloat(result))) result = arg; + (void) env; + object* result = first(args); args = cdr(args); - } - return result; + while (args != NULL) { + object* arg = car(args); + if (integerp(result) && integerp(arg)) { + if ((arg->integer) < (result->integer)) result = arg; + } else if ((checkintfloat(arg) < checkintfloat(result))) result = arg; + args = cdr(args); + } + return result; } // Arithmetic comparisons /* - (/= number*) - Returns t if none of the arguments are equal, or nil if two or more arguments are equal. + (/= number*) + Returns t if none of the arguments are equal, or nil if two or more arguments are equal. */ object* fn_noteq (object* args, object* env) { - (void) env; - while (args != NULL) { - object* nargs = args; - object* arg1 = first(nargs); - nargs = cdr(nargs); - while (nargs != NULL) { - object* arg2 = first(nargs); - if (integerp(arg1) && integerp(arg2)) { - if ((arg1->integer) == (arg2->integer)) return nil; - } else if ((checkintfloat(arg1) == checkintfloat(arg2))) return nil; - nargs = cdr(nargs); + (void) env; + while (args != NULL) { + object* nargs = args; + object* arg1 = first(nargs); + nargs = cdr(nargs); + while (nargs != NULL) { + object* arg2 = first(nargs); + if (integerp(arg1) && integerp(arg2)) { + if ((arg1->integer) == (arg2->integer)) return nil; + } else if ((checkintfloat(arg1) == checkintfloat(arg2))) return nil; + nargs = cdr(nargs); + } + args = cdr(args); } - args = cdr(args); - } - return tee; + return tee; } /* - (= number*) - Returns t if all the arguments, which must be numbers, are numerically equal, and nil otherwise. + (= number*) + Returns t if all the arguments, which must be numbers, are numerically equal, and nil otherwise. */ object* fn_numeq (object* args, object* env) { - (void) env; - return compare(args, false, false, true); + (void) env; + return compare(args, false, false, true); } /* - (< number*) - Returns t if each argument is less than the next argument, and nil otherwise. + (< number*) + Returns t if each argument is less than the next argument, and nil otherwise. */ object* fn_less (object* args, object* env) { - (void) env; - return compare(args, true, false, false); + (void) env; + return compare(args, true, false, false); } /* - (<= number*) - Returns t if each argument is less than or equal to the next argument, and nil otherwise. + (<= number*) + Returns t if each argument is less than or equal to the next argument, and nil otherwise. */ object* fn_lesseq (object* args, object* env) { - (void) env; - return compare(args, true, false, true); + (void) env; + return compare(args, true, false, true); } /* - (> number*) - Returns t if each argument is greater than the next argument, and nil otherwise. + (> number*) + Returns t if each argument is greater than the next argument, and nil otherwise. */ object* fn_greater (object* args, object* env) { - (void) env; - return compare(args, false, true, false); + (void) env; + return compare(args, false, true, false); } /* - (>= number*) - Returns t if each argument is greater than or equal to the next argument, and nil otherwise. + (>= number*) + Returns t if each argument is greater than or equal to the next argument, and nil otherwise. */ object* fn_greatereq (object* args, object* env) { - (void) env; - return compare(args, false, true, true); + (void) env; + return compare(args, false, true, true); } /* - (plusp number) - Returns t if the argument is greater than zero, or nil otherwise. + (plusp number) + Returns t if the argument is greater than zero, or nil otherwise. */ object* fn_plusp (object* args, object* env) { - (void) env; - object* arg = first(args); - if (floatp(arg)) return ((arg->single_float) > 0.0) ? tee : nil; - else if (integerp(arg)) return ((arg->integer) > 0) ? tee : nil; - else error(notanumber, arg); - return nil; + (void) env; + object* arg = first(args); + if (floatp(arg)) return ((arg->single_float) > 0.0) ? tee : nil; + else if (integerp(arg)) return ((arg->integer) > 0) ? tee : nil; + else error(notanumber, arg); + return nil; } /* - (minusp number) - Returns t if the argument is less than zero, or nil otherwise. + (minusp number) + Returns t if the argument is less than zero, or nil otherwise. */ object* fn_minusp (object* args, object* env) { - (void) env; - object* arg = first(args); - if (floatp(arg)) return ((arg->single_float) < 0.0) ? tee : nil; - else if (integerp(arg)) return ((arg->integer) < 0) ? tee : nil; - else error(notanumber, arg); - return nil; + (void) env; + object* arg = first(args); + if (floatp(arg)) return ((arg->single_float) < 0.0) ? tee : nil; + else if (integerp(arg)) return ((arg->integer) < 0) ? tee : nil; + else error(notanumber, arg); + return nil; } /* - (zerop number) - Returns t if the argument is zero. + (zerop number) + Returns t if the argument is zero. */ object* fn_zerop (object* args, object* env) { - (void) env; - object* arg = first(args); - if (floatp(arg)) return ((arg->single_float) == 0.0) ? tee : nil; - else if (integerp(arg)) return ((arg->integer) == 0) ? tee : nil; - else error(notanumber, arg); - return nil; + (void) env; + object* arg = first(args); + if (floatp(arg)) return ((arg->single_float) == 0.0) ? tee : nil; + else if (integerp(arg)) return ((arg->integer) == 0) ? tee : nil; + else error(notanumber, arg); + return nil; } /* - (oddp number) - Returns t if the integer argument is odd. + (oddp number) + Returns t if the integer argument is odd. */ object* fn_oddp (object* args, object* env) { - (void) env; - int arg = checkinteger(first(args)); - return ((arg & 1) == 1) ? tee : nil; + (void) env; + int arg = checkinteger(first(args)); + return ((arg & 1) == 1) ? tee : nil; } /* - (evenp number) - Returns t if the integer argument is even. + (evenp number) + Returns t if the integer argument is even. */ object* fn_evenp (object* args, object* env) { - (void) env; - int arg = checkinteger(first(args)); - return ((arg & 1) == 0) ? tee : nil; + (void) env; + int arg = checkinteger(first(args)); + return ((arg & 1) == 0) ? tee : nil; } // Number functions /* - (integerp number) - Returns t if the argument is an integer. + (integerp number) + Returns t if the argument is an integer. */ object* fn_integerp (object* args, object* env) { - (void) env; - return integerp(first(args)) ? tee : nil; + (void) env; + return integerp(first(args)) ? tee : nil; } /* - (numberp number) - Returns t if the argument is a number. + (numberp number) + Returns t if the argument is a number. */ object* fn_numberp (object* args, object* env) { - (void) env; - object* arg = first(args); - return (integerp(arg) || floatp(arg)) ? tee : nil; + (void) env; + object* arg = first(args); + return (integerp(arg) || floatp(arg)) ? tee : nil; } // Floating-point functions /* - (float number) - Returns its argument converted to a floating-point number. + (float number) + Returns its argument converted to a floating-point number. */ object* fn_floatfn (object* args, object* env) { - (void) env; - object* arg = first(args); - return (floatp(arg)) ? arg : makefloat((float)(arg->integer)); + (void) env; + object* arg = first(args); + return (floatp(arg)) ? arg : makefloat((float)(arg->integer)); } /* - (floatp number) - Returns t if the argument is a floating-point number. + (floatp number) + Returns t if the argument is a floating-point number. */ object* fn_floatp (object* args, object* env) { - (void) env; - return floatp(first(args)) ? tee : nil; + (void) env; + return floatp(first(args)) ? tee : nil; } /* - (sin number) - Returns sin(number). + (sin number) + Returns sin(number). */ object* fn_sin (object* args, object* env) { - (void) env; - return makefloat(sin(checkintfloat(first(args)))); + (void) env; + return makefloat(sin(checkintfloat(first(args)))); } /* - (cos number) - Returns cos(number). + (cos number) + Returns cos(number). */ object* fn_cos (object* args, object* env) { - (void) env; - return makefloat(cos(checkintfloat(first(args)))); + (void) env; + return makefloat(cos(checkintfloat(first(args)))); } /* - (tan number) - Returns tan(number). + (tan number) + Returns tan(number). */ object* fn_tan (object* args, object* env) { - (void) env; - return makefloat(tan(checkintfloat(first(args)))); + (void) env; + return makefloat(tan(checkintfloat(first(args)))); } /* - (asin number) - Returns asin(number). + (asin number) + Returns asin(number). */ object* fn_asin (object* args, object* env) { - (void) env; - return makefloat(asin(checkintfloat(first(args)))); + (void) env; + return makefloat(asin(checkintfloat(first(args)))); } /* - (acos number) - Returns acos(number). + (acos number) + Returns acos(number). */ object* fn_acos (object* args, object* env) { - (void) env; - return makefloat(acos(checkintfloat(first(args)))); + (void) env; + return makefloat(acos(checkintfloat(first(args)))); } /* - (atan number1 [number2]) - Returns the arc tangent of number1/number2, in radians. If number2 is omitted it defaults to 1. + (atan number1 [number2]) + Returns the arc tangent of number1/number2, in radians. If number2 is omitted it defaults to 1. */ object* fn_atan (object* args, object* env) { - (void) env; - object* arg = first(args); - float div = 1.0; - args = cdr(args); - if (args != NULL) div = checkintfloat(first(args)); - return makefloat(atan2(checkintfloat(arg), div)); + (void) env; + object* arg = first(args); + float div = 1.0; + args = cdr(args); + if (args != NULL) div = checkintfloat(first(args)); + return makefloat(atan2(checkintfloat(arg), div)); } /* - (sinh number) - Returns sinh(number). + (sinh number) + Returns sinh(number). */ object* fn_sinh (object* args, object* env) { - (void) env; - return makefloat(sinh(checkintfloat(first(args)))); + (void) env; + return makefloat(sinh(checkintfloat(first(args)))); } /* - (cosh number) - Returns cosh(number). + (cosh number) + Returns cosh(number). */ object* fn_cosh (object* args, object* env) { - (void) env; - return makefloat(cosh(checkintfloat(first(args)))); + (void) env; + return makefloat(cosh(checkintfloat(first(args)))); } /* - (tanh number) - Returns tanh(number). + (tanh number) + Returns tanh(number). */ object* fn_tanh (object* args, object* env) { - (void) env; - return makefloat(tanh(checkintfloat(first(args)))); + (void) env; + return makefloat(tanh(checkintfloat(first(args)))); } /* - (exp number) - Returns exp(number). + (exp number) + Returns exp(number). */ object* fn_exp (object* args, object* env) { - (void) env; - return makefloat(exp(checkintfloat(first(args)))); + (void) env; + return makefloat(exp(checkintfloat(first(args)))); } /* - (sqrt number) - Returns sqrt(number). + (sqrt number) + Returns sqrt(number). */ object* fn_sqrt (object* args, object* env) { - (void) env; - return makefloat(sqrt(checkintfloat(first(args)))); + (void) env; + return makefloat(sqrt(checkintfloat(first(args)))); } /* - (log number [base]) - Returns the logarithm of number to the specified base. If base is omitted it defaults to e. + (log number [base]) + Returns the logarithm of number to the specified base. If base is omitted it defaults to e. */ object* fn_log (object* args, object* env) { - (void) env; - object* arg = first(args); - float fresult = log(checkintfloat(arg)); - args = cdr(args); - if (args == NULL) return makefloat(fresult); - else return makefloat(fresult / log(checkintfloat(first(args)))); + (void) env; + object* arg = first(args); + float fresult = log(checkintfloat(arg)); + args = cdr(args); + if (args == NULL) return makefloat(fresult); + else return makefloat(fresult / log(checkintfloat(first(args)))); } /* - (expt number power) - Returns number raised to the specified power. - Returns the result as an integer if the arguments are integers and the result will be within range, - otherwise a floating-point number. + (expt number power) + Returns number raised to the specified power. + Returns the result as an integer if the arguments are integers and the result will be within range, + otherwise a floating-point number. */ object* fn_expt (object* args, object* env) { - (void) env; - object* arg1 = first(args); object* arg2 = second(args); - float float1 = checkintfloat(arg1); - float value = log(abs(float1)) * checkintfloat(arg2); - if (integerp(arg1) && integerp(arg2) && ((arg2->integer) >= 0) && (abs(value) < 21.4875)) - return number(intpower(arg1->integer, arg2->integer)); - if (float1 < 0) { - if (integerp(arg2)) return makefloat((arg2->integer & 1) ? -exp(value) : exp(value)); - else error2(PSTR("imaginary result")); - } - return makefloat(exp(value)); + (void) env; + object* arg1 = first(args); object* arg2 = second(args); + float float1 = checkintfloat(arg1); + float value = log(abs(float1)) * checkintfloat(arg2); + if (integerp(arg1) && integerp(arg2) && ((arg2->integer) >= 0) && (abs(value) < 21.4875)) + return number(intpower(arg1->integer, arg2->integer)); + if (float1 < 0) { + if (integerp(arg2)) return makefloat((arg2->integer & 1) ? -exp(value) : exp(value)); + else error2(PSTR("imaginary result")); + } + return makefloat(exp(value)); } /* - (ceiling number [divisor]) - Returns ceil(number/divisor). If omitted, divisor is 1. + (ceiling number [divisor]) + Returns ceil(number/divisor). If omitted, divisor is 1. */ object* fn_ceiling (object* args, object* env) { - (void) env; - object* arg = first(args); - args = cdr(args); - if (args != NULL) return number(ceil(checkintfloat(arg) / checkintfloat(first(args)))); - else return number(ceil(checkintfloat(arg))); + (void) env; + object* arg = first(args); + args = cdr(args); + if (args != NULL) return number(ceil(checkintfloat(arg) / checkintfloat(first(args)))); + else return number(ceil(checkintfloat(arg))); } /* - (floor number [divisor]) - Returns floor(number/divisor). If omitted, divisor is 1. + (floor number [divisor]) + Returns floor(number/divisor). If omitted, divisor is 1. */ object* fn_floor (object* args, object* env) { - (void) env; - object* arg = first(args); - args = cdr(args); - if (args != NULL) return number(floor(checkintfloat(arg) / checkintfloat(first(args)))); - else return number(floor(checkintfloat(arg))); + (void) env; + object* arg = first(args); + args = cdr(args); + if (args != NULL) return number(floor(checkintfloat(arg) / checkintfloat(first(args)))); + else return number(floor(checkintfloat(arg))); } /* - (truncate number [divisor]) - Returns the integer part of number/divisor. If divisor is omitted it defaults to 1. + (truncate number [divisor]) + Returns the integer part of number/divisor. If divisor is omitted it defaults to 1. */ object* fn_truncate (object* args, object* env) { - (void) env; - object* arg = first(args); - args = cdr(args); - if (args != NULL) return number((int)(checkintfloat(arg) / checkintfloat(first(args)))); - else return number((int)(checkintfloat(arg))); + (void) env; + object* arg = first(args); + args = cdr(args); + if (args != NULL) return number((int)(checkintfloat(arg) / checkintfloat(first(args)))); + else return number((int)(checkintfloat(arg))); } /* - (round number [divisor]) - Returns the integer closest to number/divisor. If divisor is omitted it defaults to 1. + (round number [divisor]) + Returns the integer closest to number/divisor. If divisor is omitted it defaults to 1. */ object* fn_round (object* args, object* env) { - (void) env; - object* arg = first(args); - args = cdr(args); - if (args != NULL) return number(myround(checkintfloat(arg) / checkintfloat(first(args)))); - else return number(myround(checkintfloat(arg))); + (void) env; + object* arg = first(args); + args = cdr(args); + if (args != NULL) return number(myround(checkintfloat(arg) / checkintfloat(first(args)))); + else return number(myround(checkintfloat(arg))); } // Characters /* - (char string n) - Returns the nth character in a string, counting from zero. + (char string n) + Returns the nth character in a string, counting from zero. */ object* fn_char (object* args, object* env) { - (void) env; - object* arg = first(args); - if (!stringp(arg)) error(notastring, arg); - object* n = second(args); - char c = nthchar(arg, checkinteger(n)); - if (c == 0) error(indexrange, n); - return character(c); + (void) env; + object* arg = first(args); + if (!stringp(arg)) error(notastring, arg); + object* n = second(args); + char c = nthchar(arg, checkinteger(n)); + if (c == 0) error(indexrange, n); + return character(c); } /* - (char-code character) - Returns the ASCII code for a character, as an integer. + (char-code character) + Returns the ASCII code for a character, as an integer. */ object* fn_charcode (object* args, object* env) { - (void) env; - return number(checkchar(first(args))); + (void) env; + return number(checkchar(first(args))); } /* - (code-char integer) - Returns the character for the specified ASCII code. + (code-char integer) + Returns the character for the specified ASCII code. */ object* fn_codechar (object* args, object* env) { - (void) env; - return character(checkinteger(first(args))); + (void) env; + return character(checkinteger(first(args))); } /* - (characterp item) - Returns t if the argument is a character and nil otherwise. + (characterp item) + Returns t if the argument is a character and nil otherwise. */ object* fn_characterp (object* args, object* env) { - (void) env; - return characterp(first(args)) ? tee : nil; + (void) env; + return characterp(first(args)) ? tee : nil; } // Strings /* - (stringp item) - Returns t if the argument is a string and nil otherwise. + (stringp item) + Returns t if the argument is a string and nil otherwise. */ object* fn_stringp (object* args, object* env) { - (void) env; - return stringp(first(args)) ? tee : nil; + (void) env; + return stringp(first(args)) ? tee : nil; } /* - (string= string string) - Tests whether two strings are the same. + (string= string string) + Tests whether two strings are the same. */ object* fn_stringeq (object* args, object* env) { - (void) env; - return stringcompare(args, false, false, true) ? tee : nil; + (void) env; + return stringcompare(args, false, false, true) ? tee : nil; } /* - (string< string string) - Returns t if the first string is alphabetically less than the second string, and nil otherwise. + (string< string string) + Returns t if the first string is alphabetically less than the second string, and nil otherwise. */ object* fn_stringless (object* args, object* env) { - (void) env; - return stringcompare(args, true, false, false) ? tee : nil; + (void) env; + return stringcompare(args, true, false, false) ? tee : nil; } /* - (string> string string) - Returns t if the first string is alphabetically greater than the second string, and nil otherwise. + (string> string string) + Returns t if the first string is alphabetically greater than the second string, and nil otherwise. */ object* fn_stringgreater (object* args, object* env) { - (void) env; - return stringcompare(args, false, true, false) ? tee : nil; + (void) env; + return stringcompare(args, false, true, false) ? tee : nil; } /* - (sort list test) - Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list. + (sort list test) + Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list. */ object* fn_sort (object* args, object* env) { - if (first(args) == NULL) return nil; - object* list = cons(nil,first(args)); - push(list,GCStack); - object* predicate = second(args); - object* compare = cons(NULL, cons(NULL, NULL)); - push(compare,GCStack); - object* ptr = cdr(list); - while (cdr(ptr) != NULL) { - object* go = list; - while (go != ptr) { - car(compare) = car(cdr(ptr)); - car(cdr(compare)) = car(cdr(go)); - if (apply(predicate, compare, env)) break; - go = cdr(go); - } - if (go != ptr) { - object* obj = cdr(ptr); - cdr(ptr) = cdr(obj); - cdr(obj) = cdr(go); - cdr(go) = obj; - } else ptr = cdr(ptr); - } - pop(GCStack); pop(GCStack); - return cdr(list); -} - -/* - (string item) - Converts its argument to a string. + if (first(args) == NULL) return nil; + object* list = cons(nil,first(args)); + push(list,GCStack); + object* predicate = second(args); + object* compare = cons(NULL, cons(NULL, NULL)); + push(compare,GCStack); + object* ptr = cdr(list); + while (cdr(ptr) != NULL) { + object* go = list; + while (go != ptr) { + car(compare) = car(cdr(ptr)); + car(cdr(compare)) = car(cdr(go)); + if (apply(predicate, compare, env)) break; + go = cdr(go); + } + if (go != ptr) { + object* obj = cdr(ptr); + cdr(ptr) = cdr(obj); + cdr(obj) = cdr(go); + cdr(go) = obj; + } else ptr = cdr(ptr); + } + pop(GCStack); pop(GCStack); + return cdr(list); +} + +/* + (string item) + Converts its argument to a string. */ object* fn_stringfn (object* args, object* env) { - return fn_princtostring(args, env); + return fn_princtostring(args, env); } /* - (concatenate 'string string*) - Joins together the strings given in the second and subsequent arguments, and returns a single string. + (concatenate 'string string*) + Joins together the strings given in the second and subsequent arguments, and returns a single string. */ object* fn_concatenate (object* args, object* env) { - (void) env; - object* arg = first(args); - if (builtin(arg->name) != STRINGFN) error2(PSTR("only supports strings")); - args = cdr(args); - object* result = newstring(); - object* tail = result; - while (args != NULL) { - object* obj = checkstring(first(args)); - obj = cdr(obj); - while (obj != NULL) { - int quad = obj->chars; - while (quad != 0) { - char ch = quad>>((sizeof(int)-1)*8) & 0xFF; - buildstring(ch, &tail); - quad = quad<<8; - } - obj = car(obj); - } + (void) env; + object* arg = first(args); + if (builtin(arg->name) != STRINGFN) error2(PSTR("only supports strings")); args = cdr(args); - } - return result; + object* result = newstring(); + object* tail = result; + while (args != NULL) { + object* obj = checkstring(first(args)); + obj = cdr(obj); + while (obj != NULL) { + int quad = obj->chars; + while (quad != 0) { + char ch = quad>>((sizeof(int)-1)*8) & 0xFF; + buildstring(ch, &tail); + quad = quad<<8; + } + obj = car(obj); + } + args = cdr(args); + } + return result; } /* - (subseq seq start [end]) - Returns a subsequence of a list or string from item start to item end-1. + (subseq seq start [end]) + Returns a subsequence of a list or string from item start to item end-1. */ object* fn_subseq (object* args, object* env) { - (void) env; - object* arg = first(args); - int start = checkinteger(second(args)), end; - if (start < 0) error(indexnegative, second(args)); - args = cddr(args); - if (listp(arg)) { - int length = listlength(arg); - if (args != NULL) end = checkinteger(car(args)); else end = length; - if (start > end || end > length) error2(indexrange); - object* result = cons(NULL, NULL); - object* ptr = result; - for (int x = 0; x < end; x++) { - if (x >= start) { cdr(ptr) = cons(car(arg), NULL); ptr = cdr(ptr); } - arg = cdr(arg); - } - return cdr(result); - } else if (stringp(arg)) { - int length = stringlength(arg); - if (args != NULL) end = checkinteger(car(args)); else end = length; - if (start > end || end > length) error2(indexrange); - object* result = newstring(); - object* tail = result; - for (int i=start; i end || end > length) error2(indexrange); + object* result = cons(NULL, NULL); + object* ptr = result; + for (int x = 0; x < end; x++) { + if (x >= start) { cdr(ptr) = cons(car(arg), NULL); ptr = cdr(ptr); } + arg = cdr(arg); + } + return cdr(result); + } else if (stringp(arg)) { + int length = stringlength(arg); + if (args != NULL) end = checkinteger(car(args)); else end = length; + if (start > end || end > length) error2(indexrange); + object* result = newstring(); + object* tail = result; + for (int i=start; i= 0) return number(value << count); - else return number(value >> abs(count)); + (void) env; + int value = checkinteger(first(args)); + int count = checkinteger(second(args)); + if (count >= 0) return number(value << count); + else return number(value >> abs(count)); } /* - (logbitp bit value) - Returns t if bit number bit in value is a '1', and nil if it is a '0'. + (logbitp bit value) + Returns t if bit number bit in value is a '1', and nil if it is a '0'. */ object* fn_logbitp (object* args, object* env) { - (void) env; - int index = checkinteger(first(args)); - int value = checkinteger(second(args)); - return (bitRead(value, index) == 1) ? tee : nil; + (void) env; + int index = checkinteger(first(args)); + int value = checkinteger(second(args)); + return (bitRead(value, index) == 1) ? tee : nil; } // System functions /* - (eval form*) - Evaluates its argument an extra time. + (eval form*) + Evaluates its argument an extra time. */ object* fn_eval (object* args, object* env) { - return eval(first(args), env); + return eval(first(args), env); } /* - (globals) - Returns a list of global variables. + (globals) + Returns a list of global variables. */ object* fn_globals (object* args, object* env) { - (void) args, (void) env; - object* result = cons(NULL, NULL); - object* ptr = result; - object* arg = GlobalEnv; - while (arg != NULL) { - cdr(ptr) = cons(car(car(arg)), NULL); ptr = cdr(ptr); - arg = cdr(arg); - } - return cdr(result); + (void) args, (void) env; + object* result = cons(NULL, NULL); + object* ptr = result; + object* arg = GlobalEnv; + while (arg != NULL) { + cdr(ptr) = cons(car(car(arg)), NULL); ptr = cdr(ptr); + arg = cdr(arg); + } + return cdr(result); } /* - (locals) - Returns an association list of local variables and their values. + (locals) + Returns an association list of local variables and their values. */ object* fn_locals (object* args, object* env) { - (void) args; - return env; + (void) args; + return env; } /* - (makunbound symbol) - Removes the value of the symbol from GlobalEnv and returns the symbol. + (makunbound symbol) + Removes the value of the symbol from GlobalEnv and returns the symbol. */ object* fn_makunbound (object* args, object* env) { - (void) env; - object* var = first(args); - if (!symbolp(var)) error(notasymbol, var); - delassoc(var, &GlobalEnv); - return var; + (void) env; + object* var = first(args); + if (!symbolp(var)) error(notasymbol, var); + delassoc(var, &GlobalEnv); + return var; } /* - (break) - Inserts a breakpoint in the program. When evaluated prints Break! and reenters the REPL. + (break) + Inserts a breakpoint in the program. When evaluated prints Break! and reenters the REPL. */ object* fn_break (object* args, object* env) { - (void) args; - pfstring(PSTR("\nBreak!\n"), pserial); - BreakLevel++; - repl(env); - BreakLevel--; - return nil; + (void) args; + pfstring(PSTR("\nBreak!\n"), pserial); + BreakLevel++; + repl(env); + BreakLevel--; + return nil; } /* - (read [stream]) - Reads an atom or list from the serial input and returns it. - If stream is specified the item is read from the specified stream. + (read [stream]) + Reads an atom or list from the serial input and returns it. + If stream is specified the item is read from the specified stream. */ object* fn_read (object* args, object* env) { - (void) env; - gfun_t gfun = gstreamfun(args); - return read(gfun); + (void) env; + gfun_t gfun = gstreamfun(args); + return read(gfun); } /* - (prin1 item [stream]) - Prints its argument, and returns its value. - Strings are printed with quotation marks and escape characters. + (prin1 item [stream]) + Prints its argument, and returns its value. + Strings are printed with quotation marks and escape characters. */ object* fn_prin1 (object* args, object* env) { - (void) env; - object* obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - printobject(obj, pfun); - return obj; + (void) env; + object* obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); + printobject(obj, pfun); + return obj; } /* - (print item [stream]) - Prints its argument with quotation marks and escape characters, on a new line, and followed by a space. - If stream is specified the argument is printed to the specified stream. + (print item [stream]) + Prints its argument with quotation marks and escape characters, on a new line, and followed by a space. + If stream is specified the argument is printed to the specified stream. */ object* fn_print (object* args, object* env) { - (void) env; - object* obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - pln(pfun); - printobject(obj, pfun); - pfun(' '); - return obj; + (void) env; + object* obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); + pln(pfun); + printobject(obj, pfun); + pfun(' '); + return obj; } /* - (princ item [stream]) - Prints its argument, and returns its value. - Characters and strings are printed without quotation marks or escape characters. + (princ item [stream]) + Prints its argument, and returns its value. + Characters and strings are printed without quotation marks or escape characters. */ object* fn_princ (object* args, object* env) { - (void) env; - object* obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - prin1object(obj, pfun); - return obj; + (void) env; + object* obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); + prin1object(obj, pfun); + return obj; } /* - (terpri [stream]) - Prints a new line, and returns nil. - If stream is specified the new line is written to the specified stream. + (terpri [stream]) + Prints a new line, and returns nil. + If stream is specified the new line is written to the specified stream. */ object* fn_terpri (object* args, object* env) { - (void) env; - pfun_t pfun = pstreamfun(args); - pln(pfun); - return nil; + (void) env; + pfun_t pfun = pstreamfun(args); + pln(pfun); + return nil; } /* - (read-byte stream) - Reads a byte from a stream and returns it. + (read-byte stream) + Reads a byte from a stream and returns it. */ object* fn_readbyte (object* args, object* env) { - (void) env; - gfun_t gfun = gstreamfun(args); - int c = gfun(); - return (c == -1) ? nil : number(c); + (void) env; + gfun_t gfun = gstreamfun(args); + int c = gfun(); + return (c == -1) ? nil : number(c); } /* - (read-line [stream]) - Reads characters from the serial input up to a newline character, and returns them as a string, excluding the newline. - If stream is specified the line is read from the specified stream. + (read-line [stream]) + Reads characters from the serial input up to a newline character, and returns them as a string, excluding the newline. + If stream is specified the line is read from the specified stream. */ object* fn_readline (object* args, object* env) { - (void) env; - gfun_t gfun = gstreamfun(args); - return readstring('\n', gfun); + (void) env; + gfun_t gfun = gstreamfun(args); + return readstring('\n', gfun); } /* - (write-byte number [stream]) - Writes a byte to a stream. + (write-byte number [stream]) + Writes a byte to a stream. */ object* fn_writebyte (object* args, object* env) { - (void) env; - int value = checkinteger(first(args)); - pfun_t pfun = pstreamfun(cdr(args)); - (pfun)(value); - return nil; + (void) env; + int value = checkinteger(first(args)); + pfun_t pfun = pstreamfun(cdr(args)); + (pfun)(value); + return nil; } /* - (write-string string [stream]) - Writes a string. If stream is specified the string is written to the stream. + (write-string string [stream]) + Writes a string. If stream is specified the string is written to the stream. */ object* fn_writestring (object* args, object* env) { - (void) env; - object* obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - char temp = Flags; - clrflag(PRINTREADABLY); - printstring(obj, pfun); - Flags = temp; - return nil; + (void) env; + object* obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); + char temp = Flags; + clrflag(PRINTREADABLY); + printstring(obj, pfun); + Flags = temp; + return nil; } /* - (write-line string [stream]) - Writes a string terminated by a newline character. If stream is specified the string is written to the stream. + (write-line string [stream]) + Writes a string terminated by a newline character. If stream is specified the string is written to the stream. */ object* fn_writeline (object* args, object* env) { - (void) env; - object* obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - char temp = Flags; - clrflag(PRINTREADABLY); - printstring(obj, pfun); - pln(pfun); - Flags = temp; - return nil; + (void) env; + object* obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); + char temp = Flags; + clrflag(PRINTREADABLY); + printstring(obj, pfun); + pln(pfun); + Flags = temp; + return nil; } /* - (restart-i2c stream [read-p]) - Restarts an i2c-stream. - If read-p is nil or omitted the stream is written to. - If read-p is an integer it specifies the number of bytes to be read from the stream. + (restart-i2c stream [read-p]) + Restarts an i2c-stream. + If read-p is nil or omitted the stream is written to. + If read-p is an integer it specifies the number of bytes to be read from the stream. */ 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 (integerp(rw)) I2Ccount = rw->integer; - read = (rw != NULL); - } - int address = stream & 0xFF; - if (stream>>8 != I2CSTREAM) error2(PSTR("not an i2c stream")); - return I2Crestart(address, read) ? tee : nil; + (void) env; + int stream = first(args)->integer; + args = cdr(args); + int read = 0; // Write + I2Ccount = 0; + if (args != NULL) { + object* rw = first(args); + if (integerp(rw)) I2Ccount = rw->integer; + read = (rw != NULL); + } + int address = stream & 0xFF; + if (stream>>8 != I2CSTREAM) error2(PSTR("not an i2c stream")); + return I2Crestart(address, read) ? tee : nil; } /* - (gc) - Forces a garbage collection and prints the number of objects collected, and the time taken. + (gc) + Forces a garbage collection and prints the number of objects collected, and the time taken. */ object* fn_gc (object* obj, object* env) { - int initial = Freespace; - unsigned long start = micros(); - gc(obj, env); - unsigned long elapsed = micros() - start; - pfstring(PSTR("Space: "), pserial); - pint(Freespace - initial, pserial); - pfstring(PSTR(" bytes, Time: "), pserial); - pint(elapsed, pserial); - pfstring(PSTR(" us\n"), pserial); - return nil; + int initial = Freespace; + unsigned long start = micros(); + gc(obj, env); + unsigned long elapsed = micros() - start; + pfstring(PSTR("Space: "), pserial); + pint(Freespace - initial, pserial); + pfstring(PSTR(" bytes, Time: "), pserial); + pint(elapsed, pserial); + pfstring(PSTR(" us\n"), pserial); + return nil; } /* - (room) - Returns the number of free Lisp cells remaining. + (room) + Returns the number of free Lisp cells remaining. */ object* fn_room (object* args, object* env) { - (void) args, (void) env; - return number(Freespace); + (void) args, (void) env; + return number(Freespace); } /* - (cls) - Prints a clear-screen character. + (cls) + Prints a clear-screen character. */ object* fn_cls (object* args, object* env) { - (void) args, (void) env; - pserial(12); - return nil; + (void) args, (void) env; + pserial(12); + return nil; } // Arduino procedures /* - (pinmode pin mode) - Sets the input/output mode of an Arduino pin number, and returns nil. - The mode parameter can be an integer, a keyword, or t or nil. + (pinmode pin mode) + Sets the input/output mode of an Arduino pin number, and returns nil. + The mode parameter can be an integer, a keyword, or t or nil. */ object* fn_pinmode (object* args, object* env) { - (void) env; int pin; - object* arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else pin = checkinteger(first(args)); - int pm = INPUT; - arg = second(args); - if (keywordp(arg)) pm = checkkeyword(arg); - else if (integerp(arg)) { - int mode = arg->integer; - if (mode == 1) pm = OUTPUT; else if (mode == 2) pm = INPUT_PULLUP; - #if defined(INPUT_PULLDOWN) - else if (mode == 4) pm = INPUT_PULLDOWN; - #endif - } else if (arg != nil) pm = OUTPUT; - pinMode(pin, pm); - return nil; + (void) env; int pin; + object* arg = first(args); + if (keywordp(arg)) pin = checkkeyword(arg); + else pin = checkinteger(first(args)); + int pm = INPUT; + arg = second(args); + if (keywordp(arg)) pm = checkkeyword(arg); + else if (integerp(arg)) { + int mode = arg->integer; + if (mode == 1) pm = OUTPUT; else if (mode == 2) pm = INPUT_PULLUP; + #if defined(INPUT_PULLDOWN) + else if (mode == 4) pm = INPUT_PULLDOWN; + #endif + } else if (arg != nil) pm = OUTPUT; + pinMode(pin, pm); + return nil; } /* - (digitalread pin) - Reads the state of the specified Arduino pin number and returns t (high) or nil (low). + (digitalread pin) + Reads the state of the specified Arduino pin number and returns t (high) or nil (low). */ object* fn_digitalread (object* args, object* env) { - (void) env; - int pin; - object* arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else pin = checkinteger(arg); - if (digitalRead(pin) != 0) return tee; else return nil; + (void) env; + int pin; + object* arg = first(args); + if (keywordp(arg)) pin = checkkeyword(arg); + else pin = checkinteger(arg); + if (digitalRead(pin) != 0) return tee; else return nil; } /* - (digitalwrite pin state) - Sets the state of the specified Arduino pin number. + (digitalwrite pin state) + Sets the state of the specified Arduino pin number. */ object* fn_digitalwrite (object* args, object* env) { - (void) env; - int pin; - object* arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else pin = checkinteger(arg); - arg = second(args); - int mode; - if (keywordp(arg)) mode = checkkeyword(arg); - else if (integerp(arg)) mode = arg->integer ? HIGH : LOW; - else mode = (arg != nil) ? HIGH : LOW; - digitalWrite(pin, mode); - return arg; + (void) env; + int pin; + object* arg = first(args); + if (keywordp(arg)) pin = checkkeyword(arg); + else pin = checkinteger(arg); + arg = second(args); + int mode; + if (keywordp(arg)) mode = checkkeyword(arg); + else if (integerp(arg)) mode = arg->integer ? HIGH : LOW; + else mode = (arg != nil) ? HIGH : LOW; + digitalWrite(pin, mode); + return arg; } /* - (analogread pin) - Reads the specified Arduino analogue pin number and returns the value. + (analogread pin) + Reads the specified Arduino analogue pin number and returns the value. */ object* fn_analogread (object* args, object* env) { - (void) env; - int pin; - object* arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else { - pin = checkinteger(arg); - checkanalogread(pin); - } - return number(analogRead(pin)); + (void) env; + int pin; + object* arg = first(args); + if (keywordp(arg)) pin = checkkeyword(arg); + else { + pin = checkinteger(arg); + checkanalogread(pin); + } + return number(analogRead(pin)); } /* - (analogreadresolution bits) - Specifies the resolution for the analogue inputs on platforms that support it. - The default resolution on all platforms is 10 bits. + (analogreadresolution bits) + Specifies the resolution for the analogue inputs on platforms that support it. + The default resolution on all platforms is 10 bits. */ object* fn_analogreadresolution (object* args, object* env) { - (void) env; - object* arg = first(args); - analogReadResolution(checkinteger(arg)); - return arg; + (void) env; + object* arg = first(args); + analogReadResolution(checkinteger(arg)); + return arg; } /* - (analogwrite pin value) - Writes the value to the specified Arduino pin number. + (analogwrite pin value) + Writes the value to the specified Arduino pin number. */ object* fn_analogwrite (object* args, object* env) { - (void) env; - int pin; - object* arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); - else pin = checkinteger(arg); - checkanalogwrite(pin); - object* value = second(args); - analogWrite(pin, checkinteger(value)); - return value; + (void) env; + int pin; + object* arg = first(args); + if (keywordp(arg)) pin = checkkeyword(arg); + else pin = checkinteger(arg); + checkanalogwrite(pin); + object* value = second(args); + analogWrite(pin, checkinteger(value)); + return value; } /* - (delay number) - Delays for a specified number of milliseconds. + (delay number) + Delays for a specified number of milliseconds. */ object* fn_delay (object* args, object* env) { - (void) env; - object* arg1 = first(args); - delay(checkinteger(arg1)); - return arg1; + (void) env; + object* arg1 = first(args); + delay(checkinteger(arg1)); + return arg1; } /* - (millis) - Returns the time in milliseconds that uLisp has been running. + (millis) + Returns the time in milliseconds that uLisp has been running. */ object* fn_millis (object* args, object* env) { - (void) args, (void) env; - return number(millis()); + (void) args, (void) env; + return number(millis()); } /* - (sleep secs) - Puts the processor into a low-power sleep mode for secs. - Only supported on some platforms. On other platforms it does delay(1000*secs). + (sleep secs) + Puts the processor into a low-power sleep mode for secs. + Only supported on some platforms. On other platforms it does delay(1000*secs). */ object* fn_sleep (object* args, object* env) { - (void) env; - object* arg1 = first(args); - doze(checkinteger(arg1)); - return arg1; + (void) env; + object* arg1 = first(args); + doze(checkinteger(arg1)); + return arg1; } /* - (note [pin] [note] [octave]) - Generates a square wave on pin. - The argument note represents the note in the well-tempered scale, from 0 to 11, - where 0 represents C, 1 represents C#, and so on. - The argument octave can be from 3 to 6. If omitted it defaults to 0. + (note [pin] [note] [octave]) + Generates a square wave on pin. + The argument note represents the note in the well-tempered scale, from 0 to 11, + where 0 represents C, 1 represents C#, and so on. + The argument octave can be from 3 to 6. If omitted it defaults to 0. */ object* fn_note (object* args, object* env) { - (void) env; - static int pin = 255; - if (args != NULL) { - pin = checkinteger(first(args)); - int note = 0; - if (cddr(args) != NULL) note = checkinteger(second(args)); - int octave = 0; - if (cddr(args) != NULL) octave = checkinteger(third(args)); - playnote(pin, note, octave); - } else nonote(pin); - return nil; + (void) env; + static int pin = 255; + if (args != NULL) { + pin = checkinteger(first(args)); + int note = 0; + if (cddr(args) != NULL) note = checkinteger(second(args)); + int octave = 0; + if (cddr(args) != NULL) octave = checkinteger(third(args)); + playnote(pin, note, octave); + } else nonote(pin); + return nil; } /* - (register address [value]) - Reads or writes the value of a peripheral register. - If value is not specified the function returns the value of the register at address. - If value is specified the value is written to the register at address and the function returns value. + (register address [value]) + Reads or writes the value of a peripheral register. + If value is not specified the function returns the value of the register at address. + If value is specified the value is written to the register at address and the function returns value. */ object* fn_register (object* args, object* env) { - (void) env; - object* arg = first(args); - int addr; - if (keywordp(arg)) addr = checkkeyword(arg); - else addr = checkinteger(first(args)); - if (cdr(args) == NULL) return number(*(uint32_t *)addr); - (*(uint32_t *)addr) = checkinteger(second(args)); - return second(args); + (void) env; + object* arg = first(args); + int addr; + if (keywordp(arg)) addr = checkkeyword(arg); + else addr = checkinteger(first(args)); + if (cdr(args) == NULL) return number(*(uint32_t *)addr); + (*(uint32_t *)addr) = checkinteger(second(args)); + return second(args); } // Tree Editor /* - (edit 'function) - Calls the Lisp tree editor to allow you to edit a function definition. + (edit 'function) + Calls the Lisp tree editor to allow you to edit a function definition. */ object* fn_edit (object* args, object* env) { - object* fun = first(args); - object* pair = findvalue(fun, env); - clrflag(EXITEDITOR); - object* arg = edit(eval(fun, env)); - cdr(pair) = arg; - return arg; + object* fun = first(args); + object* pair = findvalue(fun, env); + clrflag(EXITEDITOR); + object* arg = edit(eval(fun, env)); + cdr(pair) = arg; + return arg; } // Pretty printer /* - (pprint item [str]) - Prints its argument, using the pretty printer, to display it formatted in a structured way. - If str is specified it prints to the specified stream. It returns no value. + (pprint item [str]) + Prints its argument, using the pretty printer, to display it formatted in a structured way. + If str is specified it prints to the specified stream. It returns no value. */ object* fn_pprint (object* args, object* env) { - (void) env; - object* obj = first(args); - pfun_t pfun = pstreamfun(cdr(args)); - #if defined(gfxsupport) - if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; - #endif - pln(pfun); - superprint(obj, 0, pfun); - ppwidth = PPWIDTH; - return bsymbol(NOTHING); + (void) env; + object* obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); + #if defined(gfxsupport) + if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; + #endif + pln(pfun); + superprint(obj, 0, pfun); + ppwidth = PPWIDTH; + return bsymbol(NOTHING); } /* - (pprintall [str]) - Pretty-prints the definition of every function and variable defined in the uLisp workspace. - If str is specified it prints to the specified stream. It returns no value. + (pprintall [str]) + Pretty-prints the definition of every function and variable defined in the uLisp workspace. + If str is specified it prints to the specified stream. It returns no value. */ object* fn_pprintall (object* args, object* env) { - (void) env; - pfun_t pfun = pstreamfun(args); - #if defined(gfxsupport) - if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; - #endif - object* globals = GlobalEnv; - while (globals != NULL) { - object* pair = first(globals); - object* var = car(pair); - object* val = cdr(pair); - pln(pfun); - if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) { - superprint(cons(bsymbol(DEFUN), cons(var, cdr(val))), 0, pfun); - } else { - superprint(cons(bsymbol(DEFVAR), cons(var, cons(quoteit(QUOTE, val), NULL))), 0, pfun); + (void) env; + pfun_t pfun = pstreamfun(args); + #if defined(gfxsupport) + if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; + #endif + object* globals = GlobalEnv; + while (globals != NULL) { + object* pair = first(globals); + object* var = car(pair); + object* val = cdr(pair); + pln(pfun); + if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) { + superprint(cons(bsymbol(DEFUN), cons(var, cdr(val))), 0, pfun); + } else { + superprint(cons(bsymbol(DEFVAR), cons(var, cons(quoteit(QUOTE, val), NULL))), 0, pfun); + } + pln(pfun); + testescape(); + globals = cdr(globals); } - pln(pfun); - testescape(); - globals = cdr(globals); - } - ppwidth = PPWIDTH; - return bsymbol(NOTHING); + ppwidth = PPWIDTH; + return bsymbol(NOTHING); } // Format /* - (format output controlstring [arguments]*) - Outputs its arguments formatted according to the format directives in controlstring. + (format output controlstring [arguments]*) + Outputs its arguments formatted according to the format directives in controlstring. */ object* fn_format (object* args, object* env) { - (void) env; - pfun_t pfun = pserial; - object* output = first(args); - object* obj; - if (output == nil) { obj = startstring(); pfun = pstr; } - else if (output != tee) pfun = pstreamfun(args); - object* formatstr = checkstring(second(args)); - object* save = NULL; - args = cddr(args); - int len = stringlength(formatstr); - uint8_t n = 0, width = 0, w, bra = 0; - char pad = ' '; - bool tilde = false, mute = false, comma = false, quote = false; - while (n < len) { - char ch = nthchar(formatstr, n); - char ch2 = ch & ~0x20; // force to upper case - if (tilde) { - if (ch == '}') { - if (save == NULL) formaterr(formatstr, PSTR("no matching ~{"), n); - if (args == NULL) { args = cdr(save); save = NULL; } else n = bra; - mute = false; tilde = false; - } - else if (!mute) { - if (comma && quote) { pad = ch; comma = false, quote = false; } - else if (ch == '\'') { - if (comma) quote = true; - else formaterr(formatstr, PSTR("quote not valid"), n); - } - else if (ch == '~') { pfun('~'); tilde = false; } - else if (ch >= '0' && ch <= '9') width = width*10 + ch - '0'; - else if (ch == ',') comma = true; - else if (ch == '%') { pln(pfun); tilde = false; } - else if (ch == '&') { pfl(pfun); tilde = false; } - else if (ch == '^') { - if (save != NULL && args == NULL) mute = true; - tilde = false; - } - else if (ch == '{') { - if (save != NULL) formaterr(formatstr, PSTR("can't nest ~{"), n); - if (args == NULL) formaterr(formatstr, noargument, n); - if (!listp(first(args))) formaterr(formatstr, notalist, n); - save = args; args = first(args); bra = n; tilde = false; - if (args == NULL) mute = true; - } - else if (ch2 == 'A' || ch2 == 'S' || ch2 == 'D' || ch2 == 'G' || ch2 == 'X' || ch2 == 'B') { - if (args == NULL) formaterr(formatstr, noargument, n); - object* arg = first(args); args = cdr(args); - uint8_t aw = atomwidth(arg); - if (width < aw) w = 0; else w = width-aw; - tilde = false; - if (ch2 == 'A') { prin1object(arg, pfun); indent(w, pad, pfun); } - else if (ch2 == 'S') { printobject(arg, pfun); indent(w, pad, pfun); } - else if (ch2 == 'D' || ch2 == 'G') { indent(w, pad, pfun); prin1object(arg, pfun); } - else if (ch2 == 'X' || ch2 == 'B') { - if (integerp(arg)) { - uint8_t base = (ch2 == 'B') ? 2 : 16; - uint8_t hw = basewidth(arg, base); if (width < hw) w = 0; else w = width-hw; - indent(w, pad, pfun); pintbase(arg->integer, base, pfun); - } else { - indent(w, pad, pfun); prin1object(arg, pfun); + (void) env; + pfun_t pfun = pserial; + object* output = first(args); + object* obj; + if (output == nil) { obj = startstring(); pfun = pstr; } + else if (output != tee) pfun = pstreamfun(args); + object* formatstr = checkstring(second(args)); + object* save = NULL; + args = cddr(args); + int len = stringlength(formatstr); + uint8_t n = 0, width = 0, w, bra = 0; + char pad = ' '; + bool tilde = false, mute = false, comma = false, quote = false; + while (n < len) { + char ch = nthchar(formatstr, n); + char ch2 = ch & ~0x20; // force to upper case + if (tilde) { + if (ch == '}') { + if (save == NULL) formaterr(formatstr, PSTR("no matching ~{"), n); + if (args == NULL) { args = cdr(save); save = NULL; } else n = bra; + mute = false; tilde = false; } - } - tilde = false; - } else formaterr(formatstr, PSTR("invalid directive"), n); - } - } else { - if (ch == '~') { tilde = true; pad = ' '; width = 0; comma = false; quote = false; } - else if (!mute) pfun(ch); + else if (!mute) { + if (comma && quote) { pad = ch; comma = false, quote = false; } + else if (ch == '\'') { + if (comma) quote = true; + else formaterr(formatstr, PSTR("quote not valid"), n); + } + else if (ch == '~') { pfun('~'); tilde = false; } + else if (ch >= '0' && ch <= '9') width = width*10 + ch - '0'; + else if (ch == ',') comma = true; + else if (ch == '%') { pln(pfun); tilde = false; } + else if (ch == '&') { pfl(pfun); tilde = false; } + else if (ch == '^') { + if (save != NULL && args == NULL) mute = true; + tilde = false; + } + else if (ch == '{') { + if (save != NULL) formaterr(formatstr, PSTR("can't nest ~{"), n); + if (args == NULL) formaterr(formatstr, noargument, n); + if (!listp(first(args))) formaterr(formatstr, notalist, n); + save = args; args = first(args); bra = n; tilde = false; + if (args == NULL) mute = true; + } + else if (ch2 == 'A' || ch2 == 'S' || ch2 == 'D' || ch2 == 'G' || ch2 == 'X' || ch2 == 'B') { + if (args == NULL) formaterr(formatstr, noargument, n); + object* arg = first(args); args = cdr(args); + uint8_t aw = atomwidth(arg); + if (width < aw) w = 0; else w = width-aw; + tilde = false; + if (ch2 == 'A') { prin1object(arg, pfun); indent(w, pad, pfun); } + else if (ch2 == 'S') { printobject(arg, pfun); indent(w, pad, pfun); } + else if (ch2 == 'D' || ch2 == 'G') { indent(w, pad, pfun); prin1object(arg, pfun); } + else if (ch2 == 'X' || ch2 == 'B') { + if (integerp(arg)) { + uint8_t base = (ch2 == 'B') ? 2 : 16; + uint8_t hw = basewidth(arg, base); if (width < hw) w = 0; else w = width-hw; + indent(w, pad, pfun); pintbase(arg->integer, base, pfun); + } else { + indent(w, pad, pfun); prin1object(arg, pfun); + } + } + tilde = false; + } else formaterr(formatstr, PSTR("invalid directive"), n); + } + } else { + if (ch == '~') { tilde = true; pad = ' '; width = 0; comma = false; quote = false; } + else if (!mute) pfun(ch); + } + n++; } - n++; - } - if (output == nil) return obj; - else return nil; + if (output == nil) return obj; + else return nil; } // LispLibrary /* - (require 'symbol) - Loads the definition of a function defined with defun, or a variable defined with defvar, from the Lisp Library. - It returns t if it was loaded, or nil if the symbol is already defined or isn't defined in the Lisp Library. + (require 'symbol) + Loads the definition of a function defined with defun, or a variable defined with defvar, from the Lisp Library. + It returns t if it was loaded, or nil if the symbol is already defined or isn't defined in the Lisp Library. */ object* fn_require (object* args, object* env) { - object* arg = first(args); - object* globals = GlobalEnv; - if (!symbolp(arg)) error(notasymbol, arg); - while (globals != NULL) { - object* pair = first(globals); - object* var = car(pair); - if (symbolp(var) && var == arg) return nil; - globals = cdr(globals); - } - GlobalStringIndex = 0; - object* line = read(glibrary); - while (line != NULL) { - // Is this the definition we want - symbol_t fname = first(line)->name; - if ((fname == sym(DEFUN) || fname == sym(DEFVAR)) && symbolp(second(line)) && second(line)->name == arg->name) { - eval(line, env); - return tee; - } - line = read(glibrary); - } - return nil; -} - -/* - (list-library) - Prints a list of the functions defined in the List Library. + object* arg = first(args); + object* globals = GlobalEnv; + if (!symbolp(arg)) error(notasymbol, arg); + while (globals != NULL) { + object* pair = first(globals); + object* var = car(pair); + if (symbolp(var) && var == arg) return nil; + globals = cdr(globals); + } + GlobalStringIndex = 0; + object* line = read(glibrary); + while (line != NULL) { + // Is this the definition we want + symbol_t fname = first(line)->name; + if ((fname == sym(DEFUN) || fname == sym(DEFVAR)) && symbolp(second(line)) && second(line)->name == arg->name) { + eval(line, env); + return tee; + } + line = read(glibrary); + } + return nil; +} + +/* + (list-library) + Prints a list of the functions defined in the List Library. */ object* fn_listlibrary (object* args, object* env) { - (void) args, (void) env; - GlobalStringIndex = 0; - object* line = read(glibrary); - while (line != NULL) { - builtin_t bname = builtin(first(line)->name); - if (bname == DEFUN || bname == DEFVAR) { - printsymbol(second(line), pserial); pserial(' '); + (void) args, (void) env; + GlobalStringIndex = 0; + object* line = read(glibrary); + while (line != NULL) { + builtin_t bname = builtin(first(line)->name); + if (bname == DEFUN || bname == DEFVAR) { + printsymbol(second(line), pserial); pserial(' '); + } + line = read(glibrary); } - line = read(glibrary); - } - return bsymbol(NOTHING); + return bsymbol(NOTHING); } // Documentation /* - (? item) - Prints the documentation string of a built-in or user-defined function. + (? item) + Prints the documentation string of a built-in or user-defined function. */ object* sp_help (object* args, object* env) { - if (args == NULL) error2(noargument); - object* docstring = documentation(first(args), env); - if (docstring) { - char temp = Flags; - clrflag(PRINTREADABLY); - printstring(docstring, pserial); - Flags = temp; - } - return bsymbol(NOTHING); + if (args == NULL) error2(noargument); + object* docstring = documentation(first(args), env); + if (docstring) { + char temp = Flags; + clrflag(PRINTREADABLY); + printstring(docstring, pserial); + Flags = temp; + } + return bsymbol(NOTHING); } /* - (documentation 'symbol [type]) - Returns the documentation string of a built-in or user-defined function. The type argument is ignored. + (documentation 'symbol [type]) + Returns the documentation string of a built-in or user-defined function. The type argument is ignored. */ object* fn_documentation (object* args, object* env) { - return documentation(first(args), env); + return documentation(first(args), env); } /* - (apropos item) - Prints the user-defined and built-in functions whose names contain the specified string or symbol. + (apropos item) + Prints the user-defined and built-in functions whose names contain the specified string or symbol. */ object* fn_apropos (object* args, object* env) { - (void) env; - apropos(first(args), true); - return bsymbol(NOTHING); + (void) env; + apropos(first(args), true); + return bsymbol(NOTHING); } /* - (apropos-list item) - Returns a list of user-defined and built-in functions whose names contain the specified string or symbol. + (apropos-list item) + Returns a list of user-defined and built-in functions whose names contain the specified string or symbol. */ object* fn_aproposlist (object* args, object* env) { - (void) env; - return apropos(first(args), false); + (void) env; + return apropos(first(args), false); } // Error handling /* - (unwind-protect form1 [forms]*) - Evaluates form1 and forms in order and returns the value of form1, - but guarantees to evaluate forms even if an error occurs in form1. + (unwind-protect form1 [forms]*) + Evaluates form1 and forms in order and returns the value of form1, + but guarantees to evaluate forms even if an error occurs in form1. */ object* sp_unwindprotect (object* args, object* env) { - if (args == NULL) error2(toofewargs); - object* current_GCStack = GCStack; - jmp_buf dynamic_handler; - jmp_buf *previous_handler = handler; - handler = &dynamic_handler; - object* protected_form = first(args); - object* result; - - bool signaled = false; - if (!setjmp(dynamic_handler)) { - result = eval(protected_form, env); - } else { - GCStack = current_GCStack; - signaled = true; - } - handler = previous_handler; - - object* protective_forms = cdr(args); - while (protective_forms != NULL) { - eval(car(protective_forms), env); - if (tstflag(RETURNFLAG)) break; - protective_forms = cdr(protective_forms); - } - - if (!signaled) return result; - GCStack = NULL; - longjmp(*handler, 1); -} - -/* - (ignore-errors [forms]*) - Evaluates forms ignoring errors. + if (args == NULL) error2(toofewargs); + object* current_GCStack = GCStack; + jmp_buf dynamic_handler; + jmp_buf *previous_handler = handler; + handler = &dynamic_handler; + object* protected_form = first(args); + object* result; + + bool signaled = false; + if (!setjmp(dynamic_handler)) { + result = eval(protected_form, env); + } else { + GCStack = current_GCStack; + signaled = true; + } + handler = previous_handler; + + object* protective_forms = cdr(args); + while (protective_forms != NULL) { + eval(car(protective_forms), env); + if (tstflag(RETURNFLAG)) break; + protective_forms = cdr(protective_forms); + } + + if (!signaled) return result; + GCStack = NULL; + longjmp(*handler, 1); +} + +/* + (ignore-errors [forms]*) + Evaluates forms ignoring errors. */ object* sp_ignoreerrors (object* args, object* env) { - object* current_GCStack = GCStack; - jmp_buf dynamic_handler; - jmp_buf *previous_handler = handler; - handler = &dynamic_handler; - object* result = nil; - - bool muffled = tstflag(MUFFLEERRORS); - setflag(MUFFLEERRORS); - bool signaled = false; - if (!setjmp(dynamic_handler)) { - while (args != NULL) { - result = eval(car(args), env); - if (tstflag(RETURNFLAG)) break; - args = cdr(args); + object* current_GCStack = GCStack; + jmp_buf dynamic_handler; + jmp_buf *previous_handler = handler; + handler = &dynamic_handler; + object* result = nil; + + bool muffled = tstflag(MUFFLEERRORS); + setflag(MUFFLEERRORS); + bool signaled = false; + if (!setjmp(dynamic_handler)) { + while (args != NULL) { + result = eval(car(args), env); + if (tstflag(RETURNFLAG)) break; + args = cdr(args); + } + } else { + GCStack = current_GCStack; + signaled = true; } - } else { - GCStack = current_GCStack; - signaled = true; - } - handler = previous_handler; - if (!muffled) clrflag(MUFFLEERRORS); + handler = previous_handler; + if (!muffled) clrflag(MUFFLEERRORS); - if (signaled) return bsymbol(NOTHING); - else return result; + if (signaled) return bsymbol(NOTHING); + else return result; } /* - (error controlstring [arguments]*) - Signals an error. The message is printed by format using the controlstring and arguments. + (error controlstring [arguments]*) + Signals an error. The message is printed by format using the controlstring and arguments. */ object* sp_error (object* args, object* env) { - object* message = eval(cons(bsymbol(FORMAT), cons(nil, args)), env); - if (!tstflag(MUFFLEERRORS)) { - char temp = Flags; - clrflag(PRINTREADABLY); - pfstring(PSTR("Error: "), pserial); printstring(message, pserial); - Flags = temp; - pln(pserial); - } - GCStack = NULL; - longjmp(*handler, 1); + object* message = eval(cons(bsymbol(FORMAT), cons(nil, args)), env); + if (!tstflag(MUFFLEERRORS)) { + char temp = Flags; + clrflag(PRINTREADABLY); + pfstring(PSTR("Error: "), pserial); printstring(message, pserial); + Flags = temp; + pln(pserial); + } + GCStack = NULL; + longjmp(*handler, 1); } // Wi-Fi /* - (with-client (str [address port]) form*) - Evaluates the forms with str bound to a wifi-stream. + (with-client (str [address port]) form*) + Evaluates the forms with str bound to a wifi-stream. */ object* sp_withclient (object* args, object* env) { - object* params = first(args); - object* var = first(params); - char buffer[BUFFERSIZE]; - params = cdr(params); - int n; - if (params == NULL) { - client = server.available(); - if (!client) return nil; - n = 2; - } else { - object* address = eval(first(params), env); - object* port = eval(second(params), env); - int success; - if (stringp(address)) success = client.connect(cstring(address, buffer, BUFFERSIZE), checkinteger(port)); - else if (integerp(address)) success = client.connect(address->integer, checkinteger(port)); - else error2(PSTR("invalid address")); - if (!success) return nil; - n = 1; - } - object* pair = cons(var, stream(WIFISTREAM, n)); - push(pair,env); - object* forms = cdr(args); - object* result = eval(tf_progn(forms,env), env); - client.stop(); - return result; -} - -/* - (available stream) - Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available. + object* params = first(args); + object* var = first(params); + char buffer[BUFFERSIZE]; + params = cdr(params); + int n; + if (params == NULL) { + client = server.available(); + if (!client) return nil; + n = 2; + } else { + object* address = eval(first(params), env); + object* port = eval(second(params), env); + int success; + if (stringp(address)) success = client.connect(cstring(address, buffer, BUFFERSIZE), checkinteger(port)); + else if (integerp(address)) success = client.connect(address->integer, checkinteger(port)); + else error2(PSTR("invalid address")); + if (!success) return nil; + n = 1; + } + object* pair = cons(var, stream(WIFISTREAM, n)); + push(pair,env); + object* forms = cdr(args); + object* result = eval(tf_progn(forms,env), env); + client.stop(); + return result; +} + +/* + (available stream) + Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available. */ object* fn_available (object* args, object* env) { - (void) env; - if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); - return number(client.available()); + (void) env; + if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); + return number(client.available()); } /* - (wifi-server) - Starts a Wi-Fi server running. It returns nil. + (wifi-server) + Starts a Wi-Fi server running. It returns nil. */ object* fn_wifiserver (object* args, object* env) { - (void) args, (void) env; - server.begin(); - return nil; + (void) args, (void) env; + server.begin(); + return nil; } /* - (wifi-softap ssid [password channel hidden]) - Set up a soft access point to establish a Wi-Fi network. - Returns the IP address as a string or nil if unsuccessful. + (wifi-softap ssid [password channel hidden]) + Set up a soft access point to establish a Wi-Fi network. + Returns the IP address as a string or nil if unsuccessful. */ object* fn_wifisoftap (object* args, object* env) { - (void) env; - char ssid[33], pass[65]; - if (args == NULL) return WiFi.softAPdisconnect(true) ? tee : nil; - object* first = first(args); args = cdr(args); - if (args == NULL) WiFi.softAP(cstring(first, ssid, 33)); - else { - object* second = first(args); - args = cdr(args); - int channel = 1; - bool hidden = false; - if (args != NULL) { - channel = checkinteger(first(args)); - args = cdr(args); - if (args != NULL) hidden = (first(args) != nil); + (void) env; + char ssid[33], pass[65]; + if (args == NULL) return WiFi.softAPdisconnect(true) ? tee : nil; + object* first = first(args); args = cdr(args); + if (args == NULL) WiFi.softAP(cstring(first, ssid, 33)); + else { + object* second = first(args); + args = cdr(args); + int channel = 1; + bool hidden = false; + if (args != NULL) { + channel = checkinteger(first(args)); + args = cdr(args); + if (args != NULL) hidden = (first(args) != nil); + } + WiFi.softAP(cstring(first, ssid, 33), cstring(second, pass, 65), channel, hidden); } - WiFi.softAP(cstring(first, ssid, 33), cstring(second, pass, 65), channel, hidden); - } - return lispstring((char*)WiFi.softAPIP().toString().c_str()); + return lispstring((char*)WiFi.softAPIP().toString().c_str()); } /* - (connected stream) - Returns t or nil to indicate if the client on stream is connected. + (connected stream) + Returns t or nil to indicate if the client on stream is connected. */ object* fn_connected (object* args, object* env) { - (void) env; - if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); - return client.connected() ? tee : nil; + (void) env; + if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); + return client.connected() ? tee : nil; } /* - (wifi-localip) - Returns the IP address of the local network as a string. + (wifi-localip) + Returns the IP address of the local network as a string. */ object* fn_wifilocalip (object* args, object* env) { - (void) args, (void) env; - return lispstring((char*)WiFi.localIP().toString().c_str()); + (void) args, (void) env; + return lispstring((char*)WiFi.localIP().toString().c_str()); } /* - (wifi-connect [ssid pass]) - Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string. + (wifi-connect [ssid pass]) + Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string. */ object* fn_wificonnect (object* args, object* env) { - (void) env; - char ssid[33], pass[65]; - if (args == NULL) { WiFi.disconnect(true); return nil; } - if (cdr(args) == NULL) WiFi.begin(cstring(first(args), ssid, 33)); - else WiFi.begin(cstring(first(args), ssid, 33), cstring(second(args), pass, 65)); - int result = WiFi.waitForConnectResult(); - if (result == WL_CONNECTED) return lispstring((char*)WiFi.localIP().toString().c_str()); - else if (result == WL_NO_SSID_AVAIL) error2(PSTR("network not found")); - else if (result == WL_CONNECT_FAILED) error2(PSTR("connection failed")); - else error2(PSTR("unable to connect")); - return nil; + (void) env; + char ssid[33], pass[65]; + if (args == NULL) { WiFi.disconnect(true); return nil; } + if (cdr(args) == NULL) WiFi.begin(cstring(first(args), ssid, 33)); + else WiFi.begin(cstring(first(args), ssid, 33), cstring(second(args), pass, 65)); + int result = WiFi.waitForConnectResult(); + if (result == WL_CONNECTED) return lispstring((char*)WiFi.localIP().toString().c_str()); + else if (result == WL_NO_SSID_AVAIL) error2(PSTR("network not found")); + else if (result == WL_CONNECT_FAILED) error2(PSTR("connection failed")); + else error2(PSTR("unable to connect")); + return nil; } // Graphics functions /* - (with-gfx (str) form*) - Evaluates the forms with str bound to an gfx-stream so you can print text - to the graphics display using the standard uLisp print commands. + (with-gfx (str) form*) + Evaluates the forms with str bound to an gfx-stream so you can print text + to the graphics display using the standard uLisp print commands. */ object* sp_withgfx (object* args, object* env) { #if defined(gfxsupport) - object* params = first(args); - object* var = first(params); - object* pair = cons(var, stream(GFXSTREAM, 1)); - push(pair,env); - object* forms = cdr(args); - object* result = eval(tf_progn(forms,env), env); - return result; + object* params = first(args); + object* var = first(params); + object* pair = cons(var, stream(GFXSTREAM, 1)); + push(pair,env); + object* forms = cdr(args); + object* result = eval(tf_progn(forms,env), env); + return result; #else - (void) args, (void) env; - error2(PSTR("not supported")); - return nil; + (void) args, (void) env; + error2(PSTR("not supported")); + return nil; #endif } /* - (draw-pixel x y [colour]) - Draws a pixel at coordinates (x,y) in colour, or white if omitted. + (draw-pixel x y [colour]) + Draws a pixel at coordinates (x,y) in colour, or white if omitted. */ object* fn_drawpixel (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - uint16_t colour = COLOR_WHITE; - if (cddr(args) != NULL) colour = checkinteger(third(args)); - tft.drawPixel(checkinteger(first(args)), checkinteger(second(args)), colour); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + uint16_t colour = COLOR_WHITE; + if (cddr(args) != NULL) colour = checkinteger(third(args)); + tft.drawPixel(checkinteger(first(args)), checkinteger(second(args)), colour); + #else + (void) args; + #endif + return nil; } /* - (draw-line x0 y0 x1 y1 [colour]) - Draws a line from (x0,y0) to (x1,y1) in colour, or white if omitted. + (draw-line x0 y0 x1 y1 [colour]) + Draws a line from (x0,y0) to (x1,y1) in colour, or white if omitted. */ object* fn_drawline (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[4], colour = COLOR_WHITE; - for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawLine(params[0], params[1], params[2], params[3], colour); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + uint16_t params[4], colour = COLOR_WHITE; + for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.drawLine(params[0], params[1], params[2], params[3], colour); + #else + (void) args; + #endif + return nil; } /* - (draw-rect x y w h [colour]) - Draws an outline rectangle with its top left corner at (x,y), with width w, - and with height h. The outline is drawn in colour, or white if omitted. + (draw-rect x y w h [colour]) + Draws an outline rectangle with its top left corner at (x,y), with width w, + and with height h. The outline is drawn in colour, or white if omitted. */ object* fn_drawrect (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[4], colour = COLOR_WHITE; - for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawRect(params[0], params[1], params[2], params[3], colour); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + uint16_t params[4], colour = COLOR_WHITE; + for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.drawRect(params[0], params[1], params[2], params[3], colour); + #else + (void) args; + #endif + return nil; } /* - (fill-rect x y w h [colour]) - Draws a filled rectangle with its top left corner at (x,y), with width w, - and with height h. The outline is drawn in colour, or white if omitted. + (fill-rect x y w h [colour]) + Draws a filled rectangle with its top left corner at (x,y), with width w, + and with height h. The outline is drawn in colour, or white if omitted. */ object* fn_fillrect (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[4], colour = COLOR_WHITE; - for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.fillRect(params[0], params[1], params[2], params[3], colour); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + uint16_t params[4], colour = COLOR_WHITE; + for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.fillRect(params[0], params[1], params[2], params[3], colour); + #else + (void) args; + #endif + return nil; } /* - (draw-circle x y r [colour]) - Draws an outline circle with its centre at (x, y) and with radius r. - The circle is drawn in colour, or white if omitted. + (draw-circle x y r [colour]) + Draws an outline circle with its centre at (x, y) and with radius r. + The circle is drawn in colour, or white if omitted. */ object* fn_drawcircle (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[3], colour = COLOR_WHITE; - for (int i=0; i<3; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawCircle(params[0], params[1], params[2], colour); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + uint16_t params[3], colour = COLOR_WHITE; + for (int i=0; i<3; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.drawCircle(params[0], params[1], params[2], colour); + #else + (void) args; + #endif + return nil; } /* - (fill-circle x y r [colour]) - Draws a filled circle with its centre at (x, y) and with radius r. - The circle is drawn in colour, or white if omitted. + (fill-circle x y r [colour]) + Draws a filled circle with its centre at (x, y) and with radius r. + The circle is drawn in colour, or white if omitted. */ object* fn_fillcircle (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[3], colour = COLOR_WHITE; - for (int i=0; i<3; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.fillCircle(params[0], params[1], params[2], colour); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + uint16_t params[3], colour = COLOR_WHITE; + for (int i=0; i<3; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.fillCircle(params[0], params[1], params[2], colour); + #else + (void) args; + #endif + return nil; } /* - (draw-round-rect x y w h radius [colour]) - Draws an outline rounded rectangle with its top left corner at (x,y), with width w, - height h, and corner radius radius. The outline is drawn in colour, or white if omitted. + (draw-round-rect x y w h radius [colour]) + Draws an outline rounded rectangle with its top left corner at (x,y), with width w, + height h, and corner radius radius. The outline is drawn in colour, or white if omitted. */ object* fn_drawroundrect (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[5], colour = COLOR_WHITE; - for (int i=0; i<5; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawRoundRect(params[0], params[1], params[2], params[3], params[4], colour); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + uint16_t params[5], colour = COLOR_WHITE; + for (int i=0; i<5; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.drawRoundRect(params[0], params[1], params[2], params[3], params[4], colour); + #else + (void) args; + #endif + return nil; } /* - (fill-round-rect x y w h radius [colour]) - Draws a filled rounded rectangle with its top left corner at (x,y), with width w, - height h, and corner radius radius. The outline is drawn in colour, or white if omitted. + (fill-round-rect x y w h radius [colour]) + Draws a filled rounded rectangle with its top left corner at (x,y), with width w, + height h, and corner radius radius. The outline is drawn in colour, or white if omitted. */ object* fn_fillroundrect (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[5], colour = COLOR_WHITE; - for (int i=0; i<5; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.fillRoundRect(params[0], params[1], params[2], params[3], params[4], colour); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + uint16_t params[5], colour = COLOR_WHITE; + for (int i=0; i<5; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.fillRoundRect(params[0], params[1], params[2], params[3], params[4], colour); + #else + (void) args; + #endif + return nil; } /* - (draw-triangle x0 y0 x1 y1 x2 y2 [colour]) - Draws an outline triangle between (x1,y1), (x2,y2), and (x3,y3). - The outline is drawn in colour, or white if omitted. + (draw-triangle x0 y0 x1 y1 x2 y2 [colour]) + Draws an outline triangle between (x1,y1), (x2,y2), and (x3,y3). + The outline is drawn in colour, or white if omitted. */ object* fn_drawtriangle (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[6], colour = COLOR_WHITE; - for (int i=0; i<6; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.drawTriangle(params[0], params[1], params[2], params[3], params[4], params[5], colour); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + uint16_t params[6], colour = COLOR_WHITE; + for (int i=0; i<6; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.drawTriangle(params[0], params[1], params[2], params[3], params[4], params[5], colour); + #else + (void) args; + #endif + return nil; } /* - (fill-triangle x0 y0 x1 y1 x2 y2 [colour]) - Draws a filled triangle between (x1,y1), (x2,y2), and (x3,y3). - The outline is drawn in colour, or white if omitted. + (fill-triangle x0 y0 x1 y1 x2 y2 [colour]) + Draws a filled triangle between (x1,y1), (x2,y2), and (x3,y3). + The outline is drawn in colour, or white if omitted. */ object* fn_filltriangle (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - uint16_t params[6], colour = COLOR_WHITE; - for (int i=0; i<6; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } - if (args != NULL) colour = checkinteger(car(args)); - tft.fillTriangle(params[0], params[1], params[2], params[3], params[4], params[5], colour); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + uint16_t params[6], colour = COLOR_WHITE; + for (int i=0; i<6; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + if (args != NULL) colour = checkinteger(car(args)); + tft.fillTriangle(params[0], params[1], params[2], params[3], params[4], params[5], colour); + #else + (void) args; + #endif + return nil; } /* - (draw-char x y char [colour background size]) - Draws the character char with its top left corner at (x,y). - The character is drawn in a 5 x 7 pixel font in colour against background, - which default to white and black respectively. - The character can optionally be scaled by size. + (draw-char x y char [colour background size]) + Draws the character char with its top left corner at (x,y). + The character is drawn in a 5 x 7 pixel font in colour against background, + which default to white and black respectively. + The character can optionally be scaled by size. */ object* fn_drawchar (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - uint16_t colour = COLOR_WHITE, bg = COLOR_BLACK, size = 1; - object* more = cdr(cddr(args)); - if (more != NULL) { - colour = checkinteger(car(more)); - more = cdr(more); + (void) env; + #if defined(gfxsupport) + uint16_t colour = COLOR_WHITE, bg = COLOR_BLACK, size = 1; + object* more = cdr(cddr(args)); if (more != NULL) { - bg = checkinteger(car(more)); - more = cdr(more); - if (more != NULL) size = checkinteger(car(more)); + colour = checkinteger(car(more)); + more = cdr(more); + if (more != NULL) { + bg = checkinteger(car(more)); + more = cdr(more); + if (more != NULL) size = checkinteger(car(more)); + } } - } - tft.drawChar(checkinteger(first(args)), checkinteger(second(args)), checkchar(third(args)), - colour, bg, size); - #else - (void) args; - #endif - return nil; + tft.drawChar(checkinteger(first(args)), checkinteger(second(args)), checkchar(third(args)), + colour, bg, size); + #else + (void) args; + #endif + return nil; } /* - (set-cursor x y) - Sets the start point for text plotting to (x, y). + (set-cursor x y) + Sets the start point for text plotting to (x, y). */ object* fn_setcursor (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - tft.setCursor(checkinteger(first(args)), checkinteger(second(args))); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + tft.setCursor(checkinteger(first(args)), checkinteger(second(args))); + #else + (void) args; + #endif + return nil; } /* - (set-text-color colour [background]) - Sets the text colour for text plotted using (with-gfx ...). + (set-text-color colour [background]) + Sets the text colour for text plotted using (with-gfx ...). */ object* fn_settextcolor (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - if (cdr(args) != NULL) tft.setTextColor(checkinteger(first(args)), checkinteger(second(args))); - else tft.setTextColor(checkinteger(first(args))); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + if (cdr(args) != NULL) tft.setTextColor(checkinteger(first(args)), checkinteger(second(args))); + else tft.setTextColor(checkinteger(first(args))); + #else + (void) args; + #endif + return nil; } /* - (set-text-size scale) - Scales text by the specified size, default 1. + (set-text-size scale) + Scales text by the specified size, default 1. */ object* fn_settextsize (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - tft.setTextSize(checkinteger(first(args))); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + tft.setTextSize(checkinteger(first(args))); + #else + (void) args; + #endif + return nil; } /* - (set-text-wrap boolean) - Specified whether text wraps at the right-hand edge of the display; the default is t. + (set-text-wrap boolean) + Specified whether text wraps at the right-hand edge of the display; the default is t. */ object* fn_settextwrap (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - tft.setTextWrap(first(args) != NULL); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + tft.setTextWrap(first(args) != NULL); + #else + (void) args; + #endif + return nil; } /* - (fill-screen [colour]) - Fills or clears the screen with colour, default black. + (fill-screen [colour]) + Fills or clears the screen with colour, default black. */ object* fn_fillscreen (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - uint16_t colour = COLOR_BLACK; - if (args != NULL) colour = checkinteger(first(args)); - tft.fillScreen(colour); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + uint16_t colour = COLOR_BLACK; + if (args != NULL) colour = checkinteger(first(args)); + tft.fillScreen(colour); + #else + (void) args; + #endif + return nil; } /* - (set-rotation option) - Sets the display orientation for subsequent graphics commands; values are 0, 1, 2, or 3. + (set-rotation option) + Sets the display orientation for subsequent graphics commands; values are 0, 1, 2, or 3. */ object* fn_setrotation (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - tft.setRotation(checkinteger(first(args))); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + tft.setRotation(checkinteger(first(args))); + #else + (void) args; + #endif + return nil; } /* - (invert-display boolean) - Mirror-images the display. + (invert-display boolean) + Mirror-images the display. */ object* fn_invertdisplay (object* args, object* env) { - (void) env; - #if defined(gfxsupport) - tft.invertDisplay(first(args) != NULL); - #else - (void) args; - #endif - return nil; + (void) env; + #if defined(gfxsupport) + tft.invertDisplay(first(args) != NULL); + #else + (void) args; + #endif + return nil; } // Built-in symbol names @@ -6065,237 +6065,237 @@ const char doc225[] PROGMEM = "(invert-display boolean)\n" // Built-in symbol lookup table const tbl_entry_t lookup_table[] PROGMEM = { - { string0, NULL, 0000, doc0 }, - { string1, NULL, 0000, doc1 }, - { string2, NULL, 0000, doc2 }, - { string3, NULL, 0000, doc3 }, - { string4, NULL, 0000, NULL }, - { string5, NULL, 0000, NULL }, - { string6, NULL, 0000, NULL }, - { string7, NULL, 0000, doc7 }, - { string8, NULL, 0017, doc8 }, - { string9, NULL, 0017, doc9 }, - { string10, NULL, 0017, doc10 }, - { string11, NULL, 0017, NULL }, - { string12, NULL, 0007, NULL }, - { string13, sp_quote, 0311, NULL }, - { string14, sp_defun, 0327, doc14 }, - { string15, sp_defvar, 0313, doc15 }, - { string16, fn_car, 0211, doc16 }, - { string17, fn_car, 0211, NULL }, - { string18, fn_cdr, 0211, doc18 }, - { string19, fn_cdr, 0211, NULL }, - { string20, fn_nth, 0222, doc20 }, - { string21, fn_aref, 0227, doc21 }, - { string22, fn_stringfn, 0211, doc22 }, - { string23, fn_pinmode, 0222, doc23 }, - { string24, fn_digitalwrite, 0222, doc24 }, - { string25, fn_analogread, 0211, doc25 }, - { string26, fn_register, 0212, doc26 }, - { string27, fn_format, 0227, doc27 }, - { string28, sp_or, 0307, doc28 }, - { string29, sp_setq, 0327, doc29 }, - { string30, sp_loop, 0307, doc30 }, - { string31, sp_return, 0307, doc31 }, - { string32, sp_push, 0322, doc32 }, - { string33, sp_pop, 0311, doc33 }, - { string34, sp_incf, 0312, doc34 }, - { string35, sp_decf, 0312, doc35 }, - { string36, sp_setf, 0327, doc36 }, - { string37, sp_dolist, 0317, doc37 }, - { string38, sp_dotimes, 0317, doc38 }, - { string39, sp_trace, 0301, doc39 }, - { string40, sp_untrace, 0301, doc40 }, - { string41, sp_formillis, 0317, doc41 }, - { string42, sp_time, 0311, doc42 }, - { string43, sp_withoutputtostring, 0317, doc43 }, - { string44, sp_withserial, 0317, doc44 }, - { string45, sp_withi2c, 0317, doc45 }, - { string46, sp_withspi, 0317, doc46 }, - { string47, sp_withsdcard, 0327, doc47 }, - { string48, tf_progn, 0107, doc48 }, - { string49, tf_if, 0123, doc49 }, - { string50, tf_cond, 0107, doc50 }, - { string51, tf_when, 0117, doc51 }, - { string52, tf_unless, 0117, doc52 }, - { string53, tf_case, 0117, doc53 }, - { string54, tf_and, 0107, doc54 }, - { string55, fn_not, 0211, doc55 }, - { string56, fn_not, 0211, NULL }, - { string57, fn_cons, 0222, doc57 }, - { string58, fn_atom, 0211, doc58 }, - { string59, fn_listp, 0211, doc59 }, - { string60, fn_consp, 0211, doc60 }, - { string61, fn_symbolp, 0211, doc61 }, - { string62, fn_arrayp, 0211, doc62 }, - { string63, fn_boundp, 0211, doc63 }, - { string64, fn_keywordp, 0211, doc64 }, - { string65, fn_setfn, 0227, doc65 }, - { string66, fn_streamp, 0211, doc66 }, - { string67, fn_eq, 0222, doc67 }, - { string68, fn_equal, 0222, doc68 }, - { string69, fn_caar, 0211, doc69 }, - { string70, fn_cadr, 0211, doc70 }, - { string71, fn_cadr, 0211, NULL }, - { string72, fn_cdar, 0211, doc72 }, - { string73, fn_cddr, 0211, doc73 }, - { string74, fn_caaar, 0211, doc74 }, - { string75, fn_caadr, 0211, doc75 }, - { string76, fn_cadar, 0211, doc76 }, - { string77, fn_caddr, 0211, doc77 }, - { string78, fn_caddr, 0211, NULL }, - { string79, fn_cdaar, 0211, doc79 }, - { string80, fn_cdadr, 0211, doc80 }, - { string81, fn_cddar, 0211, doc81 }, - { string82, fn_cdddr, 0211, doc82 }, - { string83, fn_length, 0211, doc83 }, - { string84, fn_arraydimensions, 0211, doc84 }, - { string85, fn_list, 0207, doc85 }, - { string86, fn_makearray, 0215, doc86 }, - { string87, fn_reverse, 0211, doc87 }, - { string88, fn_assoc, 0222, doc88 }, - { string89, fn_member, 0222, doc89 }, - { string90, fn_apply, 0227, doc90 }, - { string91, fn_funcall, 0217, doc91 }, - { string92, fn_append, 0207, doc92 }, - { string93, fn_mapc, 0227, doc93 }, - { string94, fn_mapcar, 0227, doc94 }, - { string95, fn_mapcan, 0227, doc95 }, - { string96, fn_add, 0207, doc96 }, - { string97, fn_subtract, 0217, doc97 }, - { string98, fn_multiply, 0207, doc98 }, - { string99, fn_divide, 0217, doc99 }, - { string100, fn_mod, 0222, doc100 }, - { string101, fn_oneplus, 0211, doc101 }, - { string102, fn_oneminus, 0211, doc102 }, - { string103, fn_abs, 0211, doc103 }, - { string104, fn_random, 0211, doc104 }, - { string105, fn_maxfn, 0217, doc105 }, - { string106, fn_minfn, 0217, doc106 }, - { string107, fn_noteq, 0217, doc107 }, - { string108, fn_numeq, 0217, doc108 }, - { string109, fn_less, 0217, doc109 }, - { string110, fn_lesseq, 0217, doc110 }, - { string111, fn_greater, 0217, doc111 }, - { string112, fn_greatereq, 0217, doc112 }, - { string113, fn_plusp, 0211, doc113 }, - { string114, fn_minusp, 0211, doc114 }, - { string115, fn_zerop, 0211, doc115 }, - { string116, fn_oddp, 0211, doc116 }, - { string117, fn_evenp, 0211, doc117 }, - { string118, fn_integerp, 0211, doc118 }, - { string119, fn_numberp, 0211, doc119 }, - { string120, fn_floatfn, 0211, doc120 }, - { string121, fn_floatp, 0211, doc121 }, - { string122, fn_sin, 0211, doc122 }, - { string123, fn_cos, 0211, doc123 }, - { string124, fn_tan, 0211, doc124 }, - { string125, fn_asin, 0211, doc125 }, - { string126, fn_acos, 0211, doc126 }, - { string127, fn_atan, 0212, doc127 }, - { string128, fn_sinh, 0211, doc128 }, - { string129, fn_cosh, 0211, doc129 }, - { string130, fn_tanh, 0211, doc130 }, - { string131, fn_exp, 0211, doc131 }, - { string132, fn_sqrt, 0211, doc132 }, - { string133, fn_log, 0212, doc133 }, - { string134, fn_expt, 0222, doc134 }, - { string135, fn_ceiling, 0212, doc135 }, - { string136, fn_floor, 0212, doc136 }, - { string137, fn_truncate, 0212, doc137 }, - { string138, fn_round, 0212, doc138 }, - { string139, fn_char, 0222, doc139 }, - { string140, fn_charcode, 0211, doc140 }, - { string141, fn_codechar, 0211, doc141 }, - { string142, fn_characterp, 0211, doc142 }, - { string143, fn_stringp, 0211, doc143 }, - { string144, fn_stringeq, 0222, doc144 }, - { string145, fn_stringless, 0222, doc145 }, - { string146, fn_stringgreater, 0222, doc146 }, - { string147, fn_sort, 0222, doc147 }, - { string148, fn_concatenate, 0217, doc148 }, - { string149, fn_subseq, 0223, doc149 }, - { string150, fn_search, 0222, doc150 }, - { string151, fn_readfromstring, 0211, doc151 }, - { string152, fn_princtostring, 0211, doc152 }, - { string153, fn_prin1tostring, 0211, doc153 }, - { string154, fn_logand, 0207, doc154 }, - { string155, fn_logior, 0207, doc155 }, - { string156, fn_logxor, 0207, doc156 }, - { string157, fn_lognot, 0211, doc157 }, - { string158, fn_ash, 0222, doc158 }, - { string159, fn_logbitp, 0222, doc159 }, - { string160, fn_eval, 0211, doc160 }, - { string161, fn_globals, 0200, doc161 }, - { string162, fn_locals, 0200, doc162 }, - { string163, fn_makunbound, 0211, doc163 }, - { string164, fn_break, 0200, doc164 }, - { string165, fn_read, 0201, doc165 }, - { string166, fn_prin1, 0212, doc166 }, - { string167, fn_print, 0212, doc167 }, - { string168, fn_princ, 0212, doc168 }, - { string169, fn_terpri, 0201, doc169 }, - { string170, fn_readbyte, 0202, doc170 }, - { string171, fn_readline, 0201, doc171 }, - { string172, fn_writebyte, 0212, doc172 }, - { string173, fn_writestring, 0212, doc173 }, - { string174, fn_writeline, 0212, doc174 }, - { string175, fn_restarti2c, 0212, doc175 }, - { string176, fn_gc, 0200, doc176 }, - { string177, fn_room, 0200, doc177 }, - { string180, fn_cls, 0200, doc180 }, - { string181, fn_digitalread, 0211, doc181 }, - { string182, fn_analogreadresolution, 0211, doc182 }, - { string183, fn_analogwrite, 0222, doc183 }, - { string184, fn_delay, 0211, doc184 }, - { string185, fn_millis, 0200, doc185 }, - { string186, fn_sleep, 0201, doc186 }, - { string187, fn_note, 0203, doc187 }, - { string188, fn_edit, 0211, doc188 }, - { string189, fn_pprint, 0212, doc189 }, - { string190, fn_pprintall, 0201, doc190 }, - { string191, fn_require, 0211, doc191 }, - { string192, fn_listlibrary, 0200, doc192 }, - { string193, sp_help, 0311, doc193 }, - { string194, fn_documentation, 0212, doc194 }, - { string195, fn_apropos, 0211, doc195 }, - { string196, fn_aproposlist, 0211, doc196 }, - { string197, sp_unwindprotect, 0307, doc197 }, - { string198, sp_ignoreerrors, 0307, doc198 }, - { string199, sp_error, 0317, doc199 }, - { string200, sp_withclient, 0312, doc200 }, - { string201, fn_available, 0211, doc201 }, - { string202, fn_wifiserver, 0200, doc202 }, - { string203, fn_wifisoftap, 0204, doc203 }, - { string204, fn_connected, 0211, doc204 }, - { string205, fn_wifilocalip, 0200, doc205 }, - { string206, fn_wificonnect, 0203, doc206 }, - { string207, sp_withgfx, 0317, doc207 }, - { string208, fn_drawpixel, 0223, doc208 }, - { string209, fn_drawline, 0245, doc209 }, - { string210, fn_drawrect, 0245, doc210 }, - { string211, fn_fillrect, 0245, doc211 }, - { string212, fn_drawcircle, 0234, doc212 }, - { string213, fn_fillcircle, 0234, doc213 }, - { string214, fn_drawroundrect, 0256, doc214 }, - { string215, fn_fillroundrect, 0256, doc215 }, - { string216, fn_drawtriangle, 0267, doc216 }, - { string217, fn_filltriangle, 0267, doc217 }, - { string218, fn_drawchar, 0236, doc218 }, - { string219, fn_setcursor, 0222, doc219 }, - { string220, fn_settextcolor, 0212, doc220 }, - { string221, fn_settextsize, 0211, doc221 }, - { string222, fn_settextwrap, 0211, doc222 }, - { string223, fn_fillscreen, 0201, doc223 }, - { string224, fn_setrotation, 0211, doc224 }, - { string225, fn_invertdisplay, 0211, doc225 }, - { string226, (fn_ptr_type)LED_BUILTIN, 0, NULL }, - { string227, (fn_ptr_type)HIGH, DIGITALWRITE, NULL }, - { string228, (fn_ptr_type)LOW, DIGITALWRITE, NULL }, - { string229, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string230, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string231, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, - { string232, (fn_ptr_type)OUTPUT, PINMODE, NULL }, + { string0, NULL, 0000, doc0 }, + { string1, NULL, 0000, doc1 }, + { string2, NULL, 0000, doc2 }, + { string3, NULL, 0000, doc3 }, + { string4, NULL, 0000, NULL }, + { string5, NULL, 0000, NULL }, + { string6, NULL, 0000, NULL }, + { string7, NULL, 0000, doc7 }, + { string8, NULL, 0017, doc8 }, + { string9, NULL, 0017, doc9 }, + { string10, NULL, 0017, doc10 }, + { string11, NULL, 0017, NULL }, + { string12, NULL, 0007, NULL }, + { string13, sp_quote, 0311, NULL }, + { string14, sp_defun, 0327, doc14 }, + { string15, sp_defvar, 0313, doc15 }, + { string16, fn_car, 0211, doc16 }, + { string17, fn_car, 0211, NULL }, + { string18, fn_cdr, 0211, doc18 }, + { string19, fn_cdr, 0211, NULL }, + { string20, fn_nth, 0222, doc20 }, + { string21, fn_aref, 0227, doc21 }, + { string22, fn_stringfn, 0211, doc22 }, + { string23, fn_pinmode, 0222, doc23 }, + { string24, fn_digitalwrite, 0222, doc24 }, + { string25, fn_analogread, 0211, doc25 }, + { string26, fn_register, 0212, doc26 }, + { string27, fn_format, 0227, doc27 }, + { string28, sp_or, 0307, doc28 }, + { string29, sp_setq, 0327, doc29 }, + { string30, sp_loop, 0307, doc30 }, + { string31, sp_return, 0307, doc31 }, + { string32, sp_push, 0322, doc32 }, + { string33, sp_pop, 0311, doc33 }, + { string34, sp_incf, 0312, doc34 }, + { string35, sp_decf, 0312, doc35 }, + { string36, sp_setf, 0327, doc36 }, + { string37, sp_dolist, 0317, doc37 }, + { string38, sp_dotimes, 0317, doc38 }, + { string39, sp_trace, 0301, doc39 }, + { string40, sp_untrace, 0301, doc40 }, + { string41, sp_formillis, 0317, doc41 }, + { string42, sp_time, 0311, doc42 }, + { string43, sp_withoutputtostring, 0317, doc43 }, + { string44, sp_withserial, 0317, doc44 }, + { string45, sp_withi2c, 0317, doc45 }, + { string46, sp_withspi, 0317, doc46 }, + { string47, sp_withsdcard, 0327, doc47 }, + { string48, tf_progn, 0107, doc48 }, + { string49, tf_if, 0123, doc49 }, + { string50, tf_cond, 0107, doc50 }, + { string51, tf_when, 0117, doc51 }, + { string52, tf_unless, 0117, doc52 }, + { string53, tf_case, 0117, doc53 }, + { string54, tf_and, 0107, doc54 }, + { string55, fn_not, 0211, doc55 }, + { string56, fn_not, 0211, NULL }, + { string57, fn_cons, 0222, doc57 }, + { string58, fn_atom, 0211, doc58 }, + { string59, fn_listp, 0211, doc59 }, + { string60, fn_consp, 0211, doc60 }, + { string61, fn_symbolp, 0211, doc61 }, + { string62, fn_arrayp, 0211, doc62 }, + { string63, fn_boundp, 0211, doc63 }, + { string64, fn_keywordp, 0211, doc64 }, + { string65, fn_setfn, 0227, doc65 }, + { string66, fn_streamp, 0211, doc66 }, + { string67, fn_eq, 0222, doc67 }, + { string68, fn_equal, 0222, doc68 }, + { string69, fn_caar, 0211, doc69 }, + { string70, fn_cadr, 0211, doc70 }, + { string71, fn_cadr, 0211, NULL }, + { string72, fn_cdar, 0211, doc72 }, + { string73, fn_cddr, 0211, doc73 }, + { string74, fn_caaar, 0211, doc74 }, + { string75, fn_caadr, 0211, doc75 }, + { string76, fn_cadar, 0211, doc76 }, + { string77, fn_caddr, 0211, doc77 }, + { string78, fn_caddr, 0211, NULL }, + { string79, fn_cdaar, 0211, doc79 }, + { string80, fn_cdadr, 0211, doc80 }, + { string81, fn_cddar, 0211, doc81 }, + { string82, fn_cdddr, 0211, doc82 }, + { string83, fn_length, 0211, doc83 }, + { string84, fn_arraydimensions, 0211, doc84 }, + { string85, fn_list, 0207, doc85 }, + { string86, fn_makearray, 0215, doc86 }, + { string87, fn_reverse, 0211, doc87 }, + { string88, fn_assoc, 0222, doc88 }, + { string89, fn_member, 0222, doc89 }, + { string90, fn_apply, 0227, doc90 }, + { string91, fn_funcall, 0217, doc91 }, + { string92, fn_append, 0207, doc92 }, + { string93, fn_mapc, 0227, doc93 }, + { string94, fn_mapcar, 0227, doc94 }, + { string95, fn_mapcan, 0227, doc95 }, + { string96, fn_add, 0207, doc96 }, + { string97, fn_subtract, 0217, doc97 }, + { string98, fn_multiply, 0207, doc98 }, + { string99, fn_divide, 0217, doc99 }, + { string100, fn_mod, 0222, doc100 }, + { string101, fn_oneplus, 0211, doc101 }, + { string102, fn_oneminus, 0211, doc102 }, + { string103, fn_abs, 0211, doc103 }, + { string104, fn_random, 0211, doc104 }, + { string105, fn_maxfn, 0217, doc105 }, + { string106, fn_minfn, 0217, doc106 }, + { string107, fn_noteq, 0217, doc107 }, + { string108, fn_numeq, 0217, doc108 }, + { string109, fn_less, 0217, doc109 }, + { string110, fn_lesseq, 0217, doc110 }, + { string111, fn_greater, 0217, doc111 }, + { string112, fn_greatereq, 0217, doc112 }, + { string113, fn_plusp, 0211, doc113 }, + { string114, fn_minusp, 0211, doc114 }, + { string115, fn_zerop, 0211, doc115 }, + { string116, fn_oddp, 0211, doc116 }, + { string117, fn_evenp, 0211, doc117 }, + { string118, fn_integerp, 0211, doc118 }, + { string119, fn_numberp, 0211, doc119 }, + { string120, fn_floatfn, 0211, doc120 }, + { string121, fn_floatp, 0211, doc121 }, + { string122, fn_sin, 0211, doc122 }, + { string123, fn_cos, 0211, doc123 }, + { string124, fn_tan, 0211, doc124 }, + { string125, fn_asin, 0211, doc125 }, + { string126, fn_acos, 0211, doc126 }, + { string127, fn_atan, 0212, doc127 }, + { string128, fn_sinh, 0211, doc128 }, + { string129, fn_cosh, 0211, doc129 }, + { string130, fn_tanh, 0211, doc130 }, + { string131, fn_exp, 0211, doc131 }, + { string132, fn_sqrt, 0211, doc132 }, + { string133, fn_log, 0212, doc133 }, + { string134, fn_expt, 0222, doc134 }, + { string135, fn_ceiling, 0212, doc135 }, + { string136, fn_floor, 0212, doc136 }, + { string137, fn_truncate, 0212, doc137 }, + { string138, fn_round, 0212, doc138 }, + { string139, fn_char, 0222, doc139 }, + { string140, fn_charcode, 0211, doc140 }, + { string141, fn_codechar, 0211, doc141 }, + { string142, fn_characterp, 0211, doc142 }, + { string143, fn_stringp, 0211, doc143 }, + { string144, fn_stringeq, 0222, doc144 }, + { string145, fn_stringless, 0222, doc145 }, + { string146, fn_stringgreater, 0222, doc146 }, + { string147, fn_sort, 0222, doc147 }, + { string148, fn_concatenate, 0217, doc148 }, + { string149, fn_subseq, 0223, doc149 }, + { string150, fn_search, 0222, doc150 }, + { string151, fn_readfromstring, 0211, doc151 }, + { string152, fn_princtostring, 0211, doc152 }, + { string153, fn_prin1tostring, 0211, doc153 }, + { string154, fn_logand, 0207, doc154 }, + { string155, fn_logior, 0207, doc155 }, + { string156, fn_logxor, 0207, doc156 }, + { string157, fn_lognot, 0211, doc157 }, + { string158, fn_ash, 0222, doc158 }, + { string159, fn_logbitp, 0222, doc159 }, + { string160, fn_eval, 0211, doc160 }, + { string161, fn_globals, 0200, doc161 }, + { string162, fn_locals, 0200, doc162 }, + { string163, fn_makunbound, 0211, doc163 }, + { string164, fn_break, 0200, doc164 }, + { string165, fn_read, 0201, doc165 }, + { string166, fn_prin1, 0212, doc166 }, + { string167, fn_print, 0212, doc167 }, + { string168, fn_princ, 0212, doc168 }, + { string169, fn_terpri, 0201, doc169 }, + { string170, fn_readbyte, 0202, doc170 }, + { string171, fn_readline, 0201, doc171 }, + { string172, fn_writebyte, 0212, doc172 }, + { string173, fn_writestring, 0212, doc173 }, + { string174, fn_writeline, 0212, doc174 }, + { string175, fn_restarti2c, 0212, doc175 }, + { string176, fn_gc, 0200, doc176 }, + { string177, fn_room, 0200, doc177 }, + { string180, fn_cls, 0200, doc180 }, + { string181, fn_digitalread, 0211, doc181 }, + { string182, fn_analogreadresolution, 0211, doc182 }, + { string183, fn_analogwrite, 0222, doc183 }, + { string184, fn_delay, 0211, doc184 }, + { string185, fn_millis, 0200, doc185 }, + { string186, fn_sleep, 0201, doc186 }, + { string187, fn_note, 0203, doc187 }, + { string188, fn_edit, 0211, doc188 }, + { string189, fn_pprint, 0212, doc189 }, + { string190, fn_pprintall, 0201, doc190 }, + { string191, fn_require, 0211, doc191 }, + { string192, fn_listlibrary, 0200, doc192 }, + { string193, sp_help, 0311, doc193 }, + { string194, fn_documentation, 0212, doc194 }, + { string195, fn_apropos, 0211, doc195 }, + { string196, fn_aproposlist, 0211, doc196 }, + { string197, sp_unwindprotect, 0307, doc197 }, + { string198, sp_ignoreerrors, 0307, doc198 }, + { string199, sp_error, 0317, doc199 }, + { string200, sp_withclient, 0312, doc200 }, + { string201, fn_available, 0211, doc201 }, + { string202, fn_wifiserver, 0200, doc202 }, + { string203, fn_wifisoftap, 0204, doc203 }, + { string204, fn_connected, 0211, doc204 }, + { string205, fn_wifilocalip, 0200, doc205 }, + { string206, fn_wificonnect, 0203, doc206 }, + { string207, sp_withgfx, 0317, doc207 }, + { string208, fn_drawpixel, 0223, doc208 }, + { string209, fn_drawline, 0245, doc209 }, + { string210, fn_drawrect, 0245, doc210 }, + { string211, fn_fillrect, 0245, doc211 }, + { string212, fn_drawcircle, 0234, doc212 }, + { string213, fn_fillcircle, 0234, doc213 }, + { string214, fn_drawroundrect, 0256, doc214 }, + { string215, fn_fillroundrect, 0256, doc215 }, + { string216, fn_drawtriangle, 0267, doc216 }, + { string217, fn_filltriangle, 0267, doc217 }, + { string218, fn_drawchar, 0236, doc218 }, + { string219, fn_setcursor, 0222, doc219 }, + { string220, fn_settextcolor, 0212, doc220 }, + { string221, fn_settextsize, 0211, doc221 }, + { string222, fn_settextwrap, 0211, doc222 }, + { string223, fn_fillscreen, 0201, doc223 }, + { string224, fn_setrotation, 0211, doc224 }, + { string225, fn_invertdisplay, 0211, doc225 }, + { string226, (fn_ptr_type)LED_BUILTIN, 0, NULL }, + { string227, (fn_ptr_type)HIGH, DIGITALWRITE, NULL }, + { string228, (fn_ptr_type)LOW, DIGITALWRITE, NULL }, + { string229, (fn_ptr_type)INPUT, PINMODE, NULL }, + { string230, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, + { string231, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, + { string232, (fn_ptr_type)OUTPUT, PINMODE, NULL }, }; #if !defined(extensions) @@ -6305,826 +6305,833 @@ tbl_entry_t *tables[] = {lookup_table, NULL}; const unsigned int tablesizes[] = { arraysize(lookup_table), 0 }; const tbl_entry_t *table (int n) { - return tables[n]; + return tables[n]; } unsigned int tablesize (int n) { - return tablesizes[n]; + return tablesizes[n]; } #endif // Table lookup functions /* - lookupbuiltin - looks up a string in lookup_table[], and returns the index of its entry, - or ENDFUNCTIONS if no match is found + lookupbuiltin - looks up a string in lookup_table[], and returns the index of its entry, + or ENDFUNCTIONS if no match is found */ builtin_t lookupbuiltin (char* c) { - unsigned int end = 0, start; - for (int n=0; n<2; n++) { - start = end; - int entries = tablesize(n); - end = end + entries; - for (int i=0; i> 3) & 0x07)) error2(toofewargs); - if ((minmax & 0x07) != 0x07 && nargs>(minmax & 0x07)) error2(toomanyargs); + if (!(name < ENDFUNCTIONS)) error2(PSTR("not a builtin")); + uint8_t minmax = getminmax(name); + if (nargs<((minmax >> 3) & 0x07)) error2(toofewargs); + if ((minmax & 0x07) != 0x07 && nargs>(minmax & 0x07)) error2(toomanyargs); } /* - lookupdoc - looks up the documentation string for the built-in function name + lookupdoc - looks up the documentation string for the built-in function name */ char* lookupdoc (builtin_t name) { - int n = namename))) return false; - builtin_t name = builtin(obj->name); - int n = namename))) return false; + builtin_t name = builtin(obj->name); + int n = name>4) gc(form, env); - // Escape - if (tstflag(ESCAPE)) { clrflag(ESCAPE); error2(PSTR("escape!"));} - if (!tstflag(NOESC)) testescape(); + int TC=0; + EVAL: + // Enough space? + if (Freespace <= WORKSPACESIZE>>4) gc(form, env); + // Escape + if (tstflag(ESCAPE)) { clrflag(ESCAPE); error2(PSTR("escape!"));} + if (!tstflag(NOESC)) testescape(); + + if (form == NULL) return nil; + + if (form->type >= NUMBER && form->type <= STRING) return form; + + if (symbolp(form)) { + symbol_t name = form->name; + object* pair = value(name, env); + if (pair != NULL) return cdr(pair); + pair = value(name, GlobalEnv); + if (pair != NULL) return cdr(pair); + else if (builtinp(name)) return form; + error(PSTR("undefined"), form); + } - if (form == NULL) return nil; + // It's a list + object* function = car(form); + object* args = cdr(form); + + if (function == NULL) error(PSTR("illegal function"), nil); + if (!listp(args)) error(PSTR("can't evaluate a dotted pair"), args); + + // List starts with a builtin symbol? + if (symbolp(function) && builtinp(function->name)) { + builtin_t name = builtin(function->name); + + if ((name == LET) || (name == LETSTAR)) { + int TCstart = TC; + if (args == NULL) error2(noargument); + object* assigns = first(args); + if (!listp(assigns)) error(notalist, assigns); + object* forms = cdr(args); + object* newenv = env; + push(newenv, GCStack); + while (assigns != NULL) { + object* assign = car(assigns); + if (!consp(assign)) push(cons(assign,nil), newenv); + else if (cdr(assign) == NULL) push(cons(first(assign),nil), newenv); + else push(cons(first(assign),eval(second(assign),env)), newenv); + car(GCStack) = newenv; + if (name == LETSTAR) env = newenv; + assigns = cdr(assigns); + } + env = newenv; + pop(GCStack); + form = tf_progn(forms,env); + TC = TCstart; + goto EVAL; + } + + if (name == LAMBDA) { + if (env == NULL) return form; + object* envcopy = NULL; + while (env != NULL) { + object* pair = first(env); + if (pair != NULL) push(pair, envcopy); + env = cdr(env); + } + return cons(bsymbol(CLOSURE), cons(envcopy,args)); + } + uint8_t fntype = getminmax(name)>>6; - if (form->type >= NUMBER && form->type <= STRING) return form; + if (fntype == SPECIAL_FORMS) { + Context = name; + return ((fn_ptr_type)lookupfn(name))(args, env); + } - if (symbolp(form)) { - symbol_t name = form->name; - object* pair = value(name, env); - if (pair != NULL) return cdr(pair); - pair = value(name, GlobalEnv); - if (pair != NULL) return cdr(pair); - else if (builtinp(name)) return form; - error(PSTR("undefined"), form); - } - - // It's a list - object* function = car(form); - object* args = cdr(form); - - if (function == NULL) error(PSTR("illegal function"), nil); - if (!listp(args)) error(PSTR("can't evaluate a dotted pair"), args); - - // List starts with a builtin symbol? - if (symbolp(function) && builtinp(function->name)) { - builtin_t name = builtin(function->name); - - if ((name == LET) || (name == LETSTAR)) { - int TCstart = TC; - if (args == NULL) error2(noargument); - object* assigns = first(args); - if (!listp(assigns)) error(notalist, assigns); - object* forms = cdr(args); - object* newenv = env; - push(newenv, GCStack); - while (assigns != NULL) { - object* assign = car(assigns); - if (!consp(assign)) push(cons(assign,nil), newenv); - else if (cdr(assign) == NULL) push(cons(first(assign),nil), newenv); - else push(cons(first(assign),eval(second(assign),env)), newenv); - car(GCStack) = newenv; - if (name == LETSTAR) env = newenv; - assigns = cdr(assigns); - } - env = newenv; - pop(GCStack); - form = tf_progn(forms,env); - TC = TCstart; - goto EVAL; - } - - if (name == LAMBDA) { - if (env == NULL) return form; - object* envcopy = NULL; - while (env != NULL) { - object* pair = first(env); - if (pair != NULL) push(pair, envcopy); - env = cdr(env); - } - return cons(bsymbol(CLOSURE), cons(envcopy,args)); - } - uint8_t fntype = getminmax(name)>>6; - - if (fntype == SPECIAL_FORMS) { - Context = name; - return ((fn_ptr_type)lookupfn(name))(args, env); - } - - if (fntype == TAIL_FORMS) { - Context = name; - form = ((fn_ptr_type)lookupfn(name))(args, env); - TC = 1; - goto EVAL; - } - if (fntype == OTHER_FORMS) error(PSTR("can't be used as a function"), function); - } - - // Evaluate the parameters - result in head - object* fname = car(form); - int TCstart = TC; - object* head = cons(eval(fname, 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; + if (fntype == TAIL_FORMS) { + Context = name; + form = ((fn_ptr_type)lookupfn(name))(args, env); + TC = 1; + goto EVAL; + } + if (fntype == OTHER_FORMS) error(PSTR("can't be used as a function"), function); + } + + // Evaluate the parameters - result in head + object* fname = car(form); + int TCstart = TC; + object* head = cons(eval(fname, env), NULL); + push(head, GCStack); // Don't GC the result list + object* tail = head; form = cdr(form); - nargs++; - } - - function = car(head); - args = cdr(head); - - if (symbolp(function)) { - builtin_t bname = builtin(function->name); - if (!builtinp(function->name)) error(PSTR("not valid here"), fname); - Context = bname; - checkminmax(bname, nargs); - object* result = ((fn_ptr_type)lookupfn(bname))(args, env); - pop(GCStack); - return result; - } - - if (consp(function)) { - symbol_t name = sym(NIL); - if (!listp(fname)) name = fname->name; - - if (isbuiltin(car(function), LAMBDA)) { - form = closure(TCstart, name, function, args, &env); - pop(GCStack); - int trace = tracing(fname->name); - if (trace) { - object* result = eval(form, env); - indent((--(TraceDepth[trace-1]))<<1, ' ', pserial); - pint(TraceDepth[trace-1], pserial); - pserial(':'); pserial(' '); - printobject(fname, pserial); pfstring(PSTR(" returned "), pserial); - printobject(result, pserial); pln(pserial); - return result; - } else { - TC = 1; - goto EVAL; - } + int nargs = 0; + + while (form != NULL){ + object* obj = cons(eval(car(form),env),NULL); + cdr(tail) = obj; + tail = obj; + form = cdr(form); + nargs++; } - if (isbuiltin(car(function), CLOSURE)) { - function = cdr(function); - form = closure(TCstart, name, function, args, &env); - pop(GCStack); - TC = 1; - goto EVAL; + function = car(head); + args = cdr(head); + + if (symbolp(function)) { + builtin_t bname = builtin(function->name); + if (!builtinp(function->name)) error(PSTR("not valid here"), fname); + Context = bname; + checkminmax(bname, nargs); + object* result = ((fn_ptr_type)lookupfn(bname))(args, env); + pop(GCStack); + return result; } - } - error(PSTR("illegal function"), fname); return nil; + if (consp(function)) { + symbol_t name = sym(NIL); + if (!listp(fname)) name = fname->name; + + if (isbuiltin(car(function), LAMBDA)) { + form = closure(TCstart, name, function, args, &env); + pop(GCStack); + int trace = tracing(fname->name); + if (trace) { + object* result = eval(form, env); + indent((--(TraceDepth[trace-1]))<<1, ' ', pserial); + pint(TraceDepth[trace-1], pserial); + pserial(':'); pserial(' '); + printobject(fname, pserial); pfstring(PSTR(" returned "), pserial); + printobject(result, pserial); pln(pserial); + return result; + } else { + TC = 1; + goto EVAL; + } + } + + if (isbuiltin(car(function), CLOSURE)) { + function = cdr(function); + form = closure(TCstart, name, function, args, &env); + pop(GCStack); + TC = 1; + goto EVAL; + } + + } + error(PSTR("illegal function"), fname); return nil; } // Print functions /* - pserial - prints a character to the serial port + pserial - prints a character to the serial port */ void pserial (char c) { - LastPrint = c; - if (c == '\n') Serial.write('\r'); - Serial.write(c); + LastPrint = c; + if (c == '\n') Serial.write('\r'); + Serial.write(c); } const char ControlCodes[] PROGMEM = "Null\0SOH\0STX\0ETX\0EOT\0ENQ\0ACK\0Bell\0Backspace\0Tab\0Newline\0VT\0" "Page\0Return\0SO\0SI\0DLE\0DC1\0DC2\0DC3\0DC4\0NAK\0SYN\0ETB\0CAN\0EM\0SUB\0Escape\0FS\0GS\0RS\0US\0Space\0"; /* - pcharacter - prints a character to a stream, escaping special characters if PRINTREADABLY is false - If <= 32 prints character name; eg #\Space - If < 127 prints ASCII; eg #\A - Otherwise prints decimal; eg #\234 + pcharacter - prints a character to a stream, escaping special characters if PRINTREADABLY is false + If <= 32 prints character name; eg #\Space + If < 127 prints ASCII; eg #\A + Otherwise prints decimal; eg #\234 */ void pcharacter (uint8_t c, pfun_t pfun) { - if (!tstflag(PRINTREADABLY)) pfun(c); - else { - pfun('#'); pfun('\\'); - if (c <= 32) { - PGM_P p = ControlCodes; - while (c > 0) {p = p + strlen_P(p) + 1; c--; } - pfstring(p, pfun); - } else if (c < 127) pfun(c); - else pint(c, pfun); - } + if (!tstflag(PRINTREADABLY)) pfun(c); + else { + pfun('#'); pfun('\\'); + if (c <= 32) { + PGM_P p = ControlCodes; + while (c > 0) {p = p + strlen_P(p) + 1; c--; } + pfstring(p, pfun); + } else if (c < 127) pfun(c); + else pint(c, pfun); + } } /* - pstring - prints a C string to the specified stream + pstring - prints a C string to the specified stream */ void pstring (char* s, pfun_t pfun) { - while (*s) pfun(*s++); + while (*s) pfun(*s++); } /* - plispstring - prints a Lisp string object to the specified stream + plispstring - prints a Lisp string object to the specified stream */ void plispstring (object* form, pfun_t pfun) { - plispstr(form->name, pfun); + plispstr(form->name, pfun); } /* - plispstr - prints a Lisp string name to the specified stream + plispstr - prints a Lisp string name to the specified stream */ void plispstr (symbol_t name, pfun_t pfun) { - object* form = (object*)name; - while (form != NULL) { - int chars = form->chars; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; - if (tstflag(PRINTREADABLY) && (ch == '"' || ch == '\\')) pfun('\\'); - if (ch) pfun(ch); + object* form = (object*)name; + while (form != NULL) { + int chars = form->chars; + for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { + char ch = chars>>i & 0xFF; + if (tstflag(PRINTREADABLY) && (ch == '"' || ch == '\\')) pfun('\\'); + if (ch) pfun(ch); + } + form = car(form); } - form = car(form); - } } /* - printstring - prints a Lisp string object to the specified stream - taking account of the PRINTREADABLY flag + printstring - prints a Lisp string object to the specified stream + taking account of the PRINTREADABLY flag */ void printstring (object* form, pfun_t pfun) { - if (tstflag(PRINTREADABLY)) pfun('"'); - plispstr(form->name, pfun); - if (tstflag(PRINTREADABLY)) pfun('"'); + if (tstflag(PRINTREADABLY)) pfun('"'); + plispstr(form->name, pfun); + if (tstflag(PRINTREADABLY)) pfun('"'); } /* - pbuiltin - prints a built-in symbol to the specified stream + pbuiltin - prints a built-in symbol to the specified stream */ void pbuiltin (builtin_t name, pfun_t pfun) { - int p = 0; - int n = name0; d = d/40) { - uint32_t j = x/d; - char c = fromradix40(j); - if (c == 0) return; - pfun(c); x = x - j*d; - } + uint32_t x = untwist(name); + for (int d=102400000; d>0; d = d/40) { + uint32_t j = x/d; + char c = fromradix40(j); + if (c == 0) return; + pfun(c); x = x - j*d; + } } /* - printsymbol - prints any symbol from a symbol object to the specified stream + printsymbol - prints any symbol from a symbol object to the specified stream */ void printsymbol (object* form, pfun_t pfun) { - psymbol(form->name, pfun); + psymbol(form->name, pfun); } /* - psymbol - prints any symbol from a symbol name to the specified stream + psymbol - prints any symbol from a symbol name to the specified stream */ void psymbol (symbol_t name, pfun_t pfun) { - if ((name & 0x03) == 0) plispstr(name, pfun); - else { - uint32_t value = untwist(name); - if (value < PACKEDS) error2(PSTR("invalid symbol")); - else if (value >= BUILTINS) pbuiltin((builtin_t)(value-BUILTINS), pfun); - else pradix40(name, pfun); - } + if ((name & 0x03) == 0) plispstr(name, pfun); + else { + uint32_t value = untwist(name); + if (value < PACKEDS) error2(PSTR("invalid symbol")); + else if (value >= BUILTINS) pbuiltin((builtin_t)(value-BUILTINS), pfun); + else pradix40(name, pfun); + } } /* - pfstring - prints a string from flash memory to the specified stream + pfstring - prints a string from flash memory to the specified stream */ void pfstring (PGM_P s, pfun_t pfun) { - int p = 0; - while (1) { - char c = pgm_read_byte(&s[p++]); - if (c == 0) return; - pfun(c); - } + int p = 0; + while (1) { + char c = pgm_read_byte(&s[p++]); + if (c == 0) return; + pfun(c); + } } /* - pint - prints an integer in decimal to the specified stream + pint - prints an integer in decimal to the specified stream */ void pint (int i, pfun_t pfun) { - uint32_t j = i; - if (i<0) { pfun('-'); j=-i; } - pintbase(j, 10, pfun); + uint32_t j = i; + if (i<0) { pfun('-'); j=-i; } + pintbase(j, 10, pfun); } /* - pintbase - prints an integer in base 'base' to the specified stream + pintbase - prints an integer in base 'base' to the specified stream */ void pintbase (uint32_t i, uint8_t base, pfun_t pfun) { - int lead = 0; uint32_t p = 1000000000; - if (base == 2) p = 0x80000000; else if (base == 16) p = 0x10000000; - for (uint32_t d=p; d>0; d=d/base) { - uint32_t j = i/d; - if (j!=0 || lead || d==1) { pfun((j<10) ? j+'0' : j+'W'); lead=1;} - i = i - j*d; - } + int lead = 0; uint32_t p = 1000000000; + if (base == 2) p = 0x80000000; else if (base == 16) p = 0x10000000; + for (uint32_t d=p; d>0; d=d/base) { + uint32_t j = i/d; + if (j!=0 || lead || d==1) { pfun((j<10) ? j+'0' : j+'W'); lead=1;} + i = i - j*d; + } } /* - pmantissa - prints the mantissa of a floating-point number to the specified stream + pmantissa - prints the mantissa of a floating-point number to the specified stream */ void pmantissa (float f, pfun_t pfun) { - int sig = floor(log10(f)); - int mul = pow(10, 5 - sig); - int i = round(f * mul); - bool point = false; - if (i == 1000000) { i = 100000; sig++; } - if (sig < 0) { - pfun('0'); pfun('.'); point = true; - for (int j=0; j < - sig - 1; j++) pfun('0'); - } - mul = 100000; - for (int j=0; j<7; j++) { - int d = (int)(i / mul); - pfun(d + '0'); - i = i - d * mul; - if (i == 0) { - if (!point) { - for (int k=j; k= 0) { pfun('.'); point = true; } - mul = mul / 10; - } -} - -/* - pfloat - prints a floating-point number to the specified stream + int sig = floor(log10(f)); + int mul = pow(10, 5 - sig); + int i = round(f * mul); + bool point = false; + if (i == 1000000) { i = 100000; sig++; } + if (sig < 0) { + pfun('0'); pfun('.'); point = true; + for (int j=0; j < - sig - 1; j++) pfun('0'); + } + mul = 100000; + for (int j=0; j<7; j++) { + int d = (int)(i / mul); + pfun(d + '0'); + i = i - d * mul; + if (i == 0) { + if (!point) { + for (int k=j; k= 0) { pfun('.'); point = true; } + mul = mul / 10; + } +} + +/* + pfloat - prints a floating-point number to the specified stream */ void pfloat (float f, pfun_t pfun) { - if (isnan(f)) { pfstring(PSTR("NaN"), pfun); return; } - if (f == 0.0) { pfun('0'); return; } - if (isinf(f)) { pfstring(PSTR("Inf"), pfun); return; } - if (f < 0) { pfun('-'); f = -f; } - // Calculate exponent - int e = 0; - if (f < 1e-3 || f >= 1e5) { - e = floor(log(f) / 2.302585); // log10 gives wrong result - f = f / pow(10, e); - } + if (isnan(f)) { pfstring(PSTR("NaN"), pfun); return; } + if (f == 0.0) { pfun('0'); return; } + if (isinf(f)) { pfstring(PSTR("Inf"), pfun); return; } + if (f < 0) { pfun('-'); f = -f; } + // Calculate exponent + int e = 0; + if (f < 1e-3 || f >= 1e5) { + e = floor(log(f) / 2.302585); // log10 gives wrong result + f = f / pow(10, e); + } - pmantissa (f, pfun); + pmantissa (f, pfun); - // Exponent - if (e != 0) { - pfun('e'); - pint(e, pfun); - } + // Exponent + if (e != 0) { + pfun('e'); + pint(e, pfun); + } } /* - pln - prints a newline to the specified stream + pln - prints a newline to the specified stream */ inline void pln (pfun_t pfun) { - pfun('\n'); + pfun('\n'); } /* - pfl - prints a newline to the specified stream if a newline has not just been printed + pfl - prints a newline to the specified stream if a newline has not just been printed */ void pfl (pfun_t pfun) { - if (LastPrint != '\n') pfun('\n'); + if (LastPrint != '\n') pfun('\n'); } /* - plist - prints a list to the specified stream + plist - prints a list to the specified stream */ void plist (object* form, pfun_t pfun) { - pfun('('); - printobject(car(form), pfun); - form = cdr(form); - while (form != NULL && listp(form)) { - pfun(' '); + pfun('('); printobject(car(form), pfun); form = cdr(form); - } - if (form != NULL) { - pfstring(PSTR(" . "), pfun); - printobject(form, pfun); - } - pfun(')'); + while (form != NULL && listp(form)) { + pfun(' '); + printobject(car(form), pfun); + form = cdr(form); + } + if (form != NULL) { + pfstring(PSTR(" . "), pfun); + printobject(form, pfun); + } + pfun(')'); } /* - pstream - prints a stream name to the specified stream + pstream - prints a stream name to the specified stream */ void pstream (object* form, pfun_t pfun) { - pfun('<'); - PGM_P s = (char*)pgm_read_ptr(&streamname[(form->integer)>>8]); - pfstring(s, pfun); - pfstring(PSTR("-stream "), pfun); - pint(form->integer & 0xFF, pfun); - pfun('>'); + pfun('<'); + PGM_P s = (char*)pgm_read_ptr(&streamname[(form->integer)>>8]); + pfstring(s, pfun); + pfstring(PSTR("-stream "), pfun); + pint(form->integer & 0xFF, pfun); + pfun('>'); } /* - printobject - prints any Lisp object to the specified stream + printobject - prints any Lisp object to the specified stream */ void printobject (object* form, pfun_t pfun) { - if (form == NULL) pfstring(PSTR("nil"), pfun); - else if (listp(form) && isbuiltin(car(form), CLOSURE)) pfstring(PSTR(""), pfun); - else if (listp(form)) plist(form, pfun); - else if (integerp(form)) pint(form->integer, pfun); - else if (floatp(form)) pfloat(form->single_float, pfun); - else if (symbolp(form)) { if (form->name != sym(NOTHING)) printsymbol(form, pfun); } - else if (characterp(form)) pcharacter(form->chars, pfun); - else if (stringp(form)) printstring(form, pfun); - else if (arrayp(form)) printarray(form, pfun); - else if (streamp(form)) pstream(form, pfun); - else error2(PSTR("internal error in print")); + if (form == NULL) pfstring(PSTR("nil"), pfun); + else if (listp(form) && isbuiltin(car(form), CLOSURE)) pfstring(PSTR(""), pfun); + else if (listp(form)) plist(form, pfun); + else if (integerp(form)) pint(form->integer, pfun); + else if (floatp(form)) pfloat(form->single_float, pfun); + else if (symbolp(form)) { if (form->name != sym(NOTHING)) printsymbol(form, pfun); } + else if (characterp(form)) pcharacter(form->chars, pfun); + else if (stringp(form)) printstring(form, pfun); + else if (arrayp(form)) printarray(form, pfun); + else if (streamp(form)) pstream(form, pfun); + else error2(PSTR("internal error in print")); } /* - prin1object - prints any Lisp object to the specified stream escaping special characters + prin1object - prints any Lisp object to the specified stream escaping special characters */ void prin1object (object* form, pfun_t pfun) { - char temp = Flags; - clrflag(PRINTREADABLY); - printobject(form, pfun); - Flags = temp; + char temp = Flags; + clrflag(PRINTREADABLY); + printobject(form, pfun); + Flags = temp; } // Read functions /* - glibrary - reads a character from the Lisp Library + glibrary - reads a character from the Lisp Library */ int glibrary () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - char c = pgm_read_byte(&LispLibrary[GlobalStringIndex++]); - return (c != 0) ? c : -1; // -1? + if (LastChar) { + char temp = LastChar; + LastChar = 0; + return temp; + } + char c = pgm_read_byte(&LispLibrary[GlobalStringIndex++]); + return (c != 0) ? c : -1; // -1? } /* - loadfromlibrary - reads and evaluates a form from the Lisp Library + loadfromlibrary - reads and evaluates a form from the Lisp Library */ void loadfromlibrary (object* env) { - GlobalStringIndex = 0; - object* line = read(glibrary); - while (line != NULL) { - push(line, GCStack); - eval(line, env); - pop(GCStack); - line = read(glibrary); - } + GlobalStringIndex = 0; + object* line = read(glibrary); + while (line != NULL) { + push(line, GCStack); + eval(line, env); + pop(GCStack); + line = read(glibrary); + } } /* - gserial - gets a character from the serial port + gserial - gets a character from the serial port */ int gserial () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; + if (LastChar) { + char temp = LastChar; + LastChar = 0; + return temp; + } + unsigned long start = millis(); + while (!Serial.available()) { delay(1); if (millis() - start > 1000) clrflag(NOECHO); } + char temp = Serial.read(); + if (temp != '\n' && !tstflag(NOECHO)) pserial(temp); return temp; - } - unsigned long start = millis(); - while (!Serial.available()) { delay(1); if (millis() - start > 1000) clrflag(NOECHO); } - char temp = Serial.read(); - if (temp != '\n' && !tstflag(NOECHO)) pserial(temp); - return temp; } /* - nextitem - reads the next token from the specified stream + nextitem - reads the next token from the specified stream */ object* nextitem (gfun_t gfun) { - int ch = gfun(); - while(issp(ch)) ch = gfun(); - - if (ch == ';') { - do { ch = gfun(); if (ch == ';' || ch == '(') setflag(NOECHO); } - while(ch != '('); - } - if (ch == '\n') ch = gfun(); - if (ch == -1) return nil; - if (ch == ')') return (object*)KET; - if (ch == '(') return (object*)BRA; - if (ch == '\'') return (object*)QUO; - - // Parse string - if (ch == '"') return readstring('"', gfun); - - // Parse symbol, character, or number - int index = 0, base = 10, sign = 1; - char buffer[BUFFERSIZE]; - int bufmax = BUFFERSIZE-3; // Max index - unsigned int result = 0; - bool isfloat = false; - float fresult = 0.0; - - if (ch == '+') { - buffer[index++] = ch; - ch = gfun(); - } else if (ch == '-') { - sign = -1; - buffer[index++] = ch; - ch = gfun(); - } else if (ch == '.') { - buffer[index++] = ch; - ch = gfun(); - if (ch == ' ') return (object*)DOT; - isfloat = true; - } - - // Parse reader macros - else if (ch == '#') { - ch = gfun(); - char ch2 = ch & ~0x20; // force to upper case - if (ch == '\\') { // Character - base = 0; ch = gfun(); - if (issp(ch) || isbr(ch)) return character(ch); - else LastChar = ch; - } else if (ch == '|') { - do { while (gfun() != '|'); } - while (gfun() != '#'); - return nextitem(gfun); - } else if (ch2 == 'B') base = 2; - else if (ch2 == 'O') base = 8; - else if (ch2 == 'X') base = 16; - else if (ch == '\'') return nextitem(gfun); - else if (ch == '.') { - setflag(NOESC); - object* result = eval(read(gfun), NULL); - clrflag(NOESC); - return result; - } - else if (ch == '(') { LastChar = ch; return readarray(1, read(gfun)); } - else if (ch == '*') return readbitarray(gfun); - else if (ch >= '1' && ch <= '9' && (gfun() & ~0x20) == 'A') return readarray(ch - '0', read(gfun)); - else error2(PSTR("illegal character after #")); - ch = gfun(); - } - int valid; // 0=undecided, -1=invalid, +1=valid - if (ch == '.') valid = 0; else if (digitvalue(ch) ((unsigned int)INT_MAX+(1-sign)/2)) - return makefloat((float)result*sign); - return number(result*sign); - } else if (base == 0) { - if (index == 1) return character(buffer[0]); - PGM_P p = ControlCodes; char c = 0; - while (c < 33) { - if (strcasecmp_P(buffer, p) == 0) return character(c); - p = p + strlen_P(p) + 1; c++; - } - if (index == 3) return character((buffer[0]*10+buffer[1])*10+buffer[2]-5328); - error2(PSTR("unknown character")); - } - - builtin_t x = lookupbuiltin(buffer); - if (x == NIL) return nil; - if (x != ENDFUNCTIONS) return bsymbol(x); - object* sym; - if ((index <= 6) && valid40(buffer)) sym = intern(twist(pack40(buffer))); - else { - buffer[index+1] = '\0'; buffer[index+2] = '\0'; buffer[index+3] = '\0'; // For internlong - sym = internlong(buffer); - } - if (buffer[0] == ':') { // Keywords quote themselves - sym = quoteit(QUOTE, sym); - } - return sym; -} - -/* - readrest - reads the remaining tokens from the specified stream + int ch = gfun(); + while(issp(ch)) ch = gfun(); + + if (ch == ';') { + do { ch = gfun(); if (ch == ';' || ch == '(') setflag(NOECHO); } + while(ch != '('); + } + if (ch == '\n') ch = gfun(); + if (ch == -1) return nil; + if (ch == ')') return (object*)KET; + if (ch == '(') return (object*)BRA; + if (ch == '\'') return (object*)QUO; + + // Parse string + if (ch == '"') return readstring('"', gfun); + + // Parse symbol, character, or number + int index = 0, base = 10, sign = 1; + char buffer[BUFFERSIZE]; + int bufmax = BUFFERSIZE-3; // Max index + unsigned int result = 0; + bool isfloat = false; + float fresult = 0.0; + + if (ch == '+') { + buffer[index++] = ch; + ch = gfun(); + } else if (ch == '-') { + sign = -1; + buffer[index++] = ch; + ch = gfun(); + } else if (ch == '.') { + buffer[index++] = ch; + ch = gfun(); + if (ch == ' ') return (object*)DOT; + isfloat = true; + } + + // Parse reader macros + else if (ch == '#') { + ch = gfun(); + char ch2 = ch & ~0x20; // force to upper case + if (ch == '\\') { // Character + base = 0; ch = gfun(); + if (issp(ch) || isbr(ch)) return character(ch); + else LastChar = ch; + } else if (ch == '|') { + do { while (gfun() != '|'); } + while (gfun() != '#'); + return nextitem(gfun); + } else if (ch2 == 'B') base = 2; + else if (ch2 == 'O') base = 8; + else if (ch2 == 'X') base = 16; + else if (ch == '\'') return nextitem(gfun); + else if (ch == '.') { + setflag(NOESC); + object* result = eval(read(gfun), NULL); + clrflag(NOESC); + return result; + } + else if (ch == '(') { LastChar = ch; return readarray(1, read(gfun)); } + else if (ch == '*') return readbitarray(gfun); + else if (ch >= '1' && ch <= '9' && (gfun() & ~0x20) == 'A') return readarray(ch - '0', read(gfun)); + else error2(PSTR("illegal character after #")); + ch = gfun(); + } + int valid; // 0=undecided, -1=invalid, +1=valid + if (ch == '.') valid = 0; else if (digitvalue(ch) ((unsigned int)INT_MAX+(1-sign)/2)) + return makefloat((float)result*sign); + return number(result*sign); + } else if (base == 0) { + if (index == 1) return character(buffer[0]); + PGM_P p = ControlCodes; char c = 0; + while (c < 33) { + if (strcasecmp_P(buffer, p) == 0) return character(c); + p = p + strlen_P(p) + 1; c++; + } + if (index == 3) return character((buffer[0]*10+buffer[1])*10+buffer[2]-5328); + error2(PSTR("unknown character")); + } + + builtin_t x = lookupbuiltin(buffer); + if (x == NIL) return nil; + if (x != ENDFUNCTIONS) return bsymbol(x); + object* sym; + if ((index <= 6) && valid40(buffer)) sym = intern(twist(pack40(buffer))); + else { + buffer[index+1] = '\0'; buffer[index+2] = '\0'; buffer[index+3] = '\0'; // For internlong + sym = internlong(buffer); + } + if (buffer[0] == ':') { // Keywords quote themselves + sym = quoteit(QUOTE, sym); + } + return sym; +} + +/* + readrest - reads the remaining tokens from the specified stream */ object* readrest (gfun_t gfun) { - object* item = nextitem(gfun); - object* head = NULL; - object* tail = NULL; - - while (item != (object*)KET) { - if (item == (object*)BRA) { - item = readrest(gfun); - } else if (item == (object*)QUO) { - item = cons(bsymbol(QUOTE), cons(read(gfun), NULL)); - } else if (item == (object*)DOT) { - tail->cdr = read(gfun); - if (readrest(gfun) != NULL) error2(PSTR("malformed list")); - return head; - } else { - object* cell = cons(item, NULL); - if (head == NULL) head = cell; - else tail->cdr = cell; - tail = cell; - item = nextitem(gfun); + object* item = nextitem(gfun); + object* head = NULL; + object* tail = NULL; + + while (item != (object*)KET) { + if (item == (object*)BRA) { + item = readrest(gfun); + } else if (item == (object*)QUO) { + item = cons(bsymbol(QUOTE), cons(read(gfun), NULL)); + } else if (item == (object*)DOT) { + tail->cdr = read(gfun); + if (readrest(gfun) != NULL) error2(PSTR("malformed list")); + return head; + } else { + object* cell = cons(item, NULL); + if (head == NULL) head = cell; + else tail->cdr = cell; + tail = cell; + item = nextitem(gfun); + } } - } - return head; + return head; } /* - read - recursively reads a Lisp object from the stream gfun and returns it + read - recursively reads a Lisp object from the stream gfun and returns it */ object* read (gfun_t gfun) { - object* item = nextitem(gfun); - if (item == (object*)KET) error2(PSTR("incomplete list")); - if (item == (object*)BRA) return readrest(gfun); - if (item == (object*)DOT) return read(gfun); - if (item == (object*)QUO) return cons(bsymbol(QUOTE), cons(read(gfun), NULL)); - return item; + object* item = nextitem(gfun); + if (item == (object*)KET) error2(PSTR("incomplete list")); + if (item == (object*)BRA) return readrest(gfun); + if (item == (object*)DOT) return read(gfun); + if (item == (object*)QUO) return cons(bsymbol(QUOTE), cons(read(gfun), NULL)); + return item; } // Setup /* - initenv - initialises the uLisp environment + initenv - initialises the uLisp environment */ void initenv () { - GlobalEnv = NULL; - tee = bsymbol(TEE); + GlobalEnv = NULL; + tee = bsymbol(TEE); } /* - initgfx - initialises the graphics + initgfx - initialises the graphics */ void initgfx () { - #if defined(gfxsupport) - tft.init(135, 240); - tft.setRotation(1); - tft.fillScreen(ST77XX_BLACK); - pinMode(TFT_BACKLITE, OUTPUT); - digitalWrite(TFT_BACKLITE, HIGH); - #endif + #if defined(gfxsupport) + tft.init(135, 240); + tft.setRotation(1); + tft.fillScreen(ST77XX_BLACK); + pinMode(TFT_BACKLITE, OUTPUT); + digitalWrite(TFT_BACKLITE, HIGH); + #endif +} + +void ulispinit () { + initworkspace(); + initenv(); + initsleep(); + initgfx(); } // Read/Evaluate/Print loop /* - repl - the Lisp Read/Evaluate/Print loop + repl - the Lisp Read/Evaluate/Print loop */ void repl (object* env) { - for (;;) { - randomSeed(micros()); - gc(NULL, env); - #if defined(printfreespace) - pint(Freespace, pserial); + for (;;) { + randomSeed(micros()); + gc(NULL, env); + #if defined(printfreespace) + pint(Freespace, pserial); + #endif + if (BreakLevel) { + pfstring(PSTR(" : "), pserial); + pint(BreakLevel, pserial); + } + pserial('>'); pserial(' '); + Context = 0; + object* line = read(gserial); + if (BreakLevel && line == nil) { pln(pserial); return; } + if (line == (object*)KET) error2(PSTR("unmatched right bracket")); + push(line, GCStack); + pfl(pserial); + line = eval(line, env); + pfl(pserial); + printobject(line, pserial); + pop(GCStack); + pfl(pserial); + pln(pserial); + } +} + +void ulisperrcleanup () { + // Come here after error + delay(100); while (Serial.available()) Serial.read(); + clrflag(NOESC); BreakLevel = 0; + for (int i=0; i'); pserial(' '); - Context = 0; - object* line = read(gserial); - if (BreakLevel && line == nil) { pln(pserial); return; } - if (line == (object*)KET) error2(PSTR("unmatched right bracket")); - push(line, GCStack); - pfl(pserial); - line = eval(line, env); - pfl(pserial); - printobject(line, pserial); - pop(GCStack); - pfl(pserial); - pln(pserial); - } -} - -void ulispreset () { - // Come here after error - delay(100); while (Serial.available()) Serial.read(); - clrflag(NOESC); BreakLevel = 0; - for (int i=0; i Date: Mon, 27 Mar 2023 12:05:49 -0400 Subject: [PATCH 013/109] add metatable --- README.md | 10 +++--- ulisp-esp32.ino | 1 - ulisp.hpp | 94 +++++++++++++++++++++++++++++++++---------------- 3 files changed, 70 insertions(+), 35 deletions(-) diff --git a/README.md b/README.md index 127621c..bdc565f 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,9 @@ uLisp 4.3a please see the [4.3a-old](https://github.com/dragoncoder047/ulisp-esp Patches: -* Deleted load/save/autorunimage support -* different garbage collect message -* no line-editor support (you can just use `rlwrap` if you have it) -* Lisp `:keywords` +* Deleted: load/save/autorunimage support +* Modified: garbage collect message +* Deleted: line-editor support (you can just use `rlwrap` if you have it) +* Added: Lisp `:keywords` that auto-quote themselves +* Added: Ability to add multiple (more than one) extension tables (using `calloc()`) *may not be portable to other platforms* +* diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index ac43a84..ef08aff 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -10,7 +10,6 @@ #define sdcardsupport // #define gfxsupport // #define lisplibrary -// #define extensions // Includes #include "ulisp.hpp" diff --git a/ulisp.hpp b/ulisp.hpp index 6b1a70f..d16583d 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -19,15 +19,15 @@ const char LispLibrary[] PROGMEM = ""; #define sdcardsupport // #define gfxsupport // #define lisplibrary -// #define extensions // Includes // #include "LispLibrary.h" #include +#include +#include #include #include -#include #include #include @@ -159,6 +159,11 @@ typedef const struct { const char* doc; } tbl_entry_t; +typedef struct { + tbl_entry_t** table; + size_t size; +} mtbl_entry_t; + typedef int (*gfun_t)(); typedef void (*pfun_t)(char); @@ -175,7 +180,7 @@ object Workspace[WORKSPACESIZE] WORDALIGNED; jmp_buf toplevel_handler; jmp_buf *handler = &toplevel_handler; -unsigned int Freespace = 0; +size_t Freespace = 0; object* Freelist; unsigned int I2Ccount; unsigned int TraceFn[TRACEMAX]; @@ -227,7 +232,7 @@ object* findvalue (object*, object*); char* lookupdoc (builtin_t); void printsymbol (object*, pfun_t); void psymbol (symbol_t, pfun_t); -unsigned int tablesize (int); +size_t tablesize (int); bool findsubstring (char*, builtin_t); bool stringcompare (object*, bool, bool, bool); void pbuiltin (builtin_t, pfun_t); @@ -6064,7 +6069,7 @@ const char doc225[] PROGMEM = "(invert-display boolean)\n" "Mirror-images the display."; // Built-in symbol lookup table -const tbl_entry_t lookup_table[] PROGMEM = { +const tbl_entry_t BuiltinTable[] PROGMEM = { { string0, NULL, 0000, doc0 }, { string1, NULL, 0000, doc1 }, { string2, NULL, 0000, doc2 }, @@ -6298,56 +6303,89 @@ const tbl_entry_t lookup_table[] PROGMEM = { { string232, (fn_ptr_type)OUTPUT, PINMODE, NULL }, }; -#if !defined(extensions) -// Table cross-reference functions +// Metatable cross-reference functions -tbl_entry_t *tables[] = {lookup_table, NULL}; -const unsigned int tablesizes[] = { arraysize(lookup_table), 0 }; +mtbl_entry_t* Metatable; +size_t NumTables; const tbl_entry_t *table (int n) { - return tables[n]; + return Metatable[n].table; } -unsigned int tablesize (int n) { - return tablesizes[n]; +size_t tablesize (int n) { + return Metatable[n].size; +} + +void inittables () { + Metatable = (mtbl_entry_t*)calloc(1, sizeof(mtbl_entry_t)); + NumTables = 1; + Metatable[0].table = BuiltinTable; + Metatable[0].size = arraysize(BuiltinTable); +} + +void addtable (const tbl_entry_t table) { + NumTables++; + Metatable = (mtbl_entry_t*)realloc(Metatable, NumTables * sizeof(mtbl_entry_t)); + Metatable[NumTables-1].table = table; + Metatable[NumTables-1].size = arraysize(table); +} + +int whichtable (builtin_t x) { + int t = 0; + while (x >= tablesize(t)) { + x -= tablesize(t); + t++; + } + return t; +} + +int tableindex (builtin_t x) { + int t = 0; + while (x >= tablesize(t)) { + x -= tablesize(t); + t++; + } + return x; +} + +tbl_entry_t* getentry(builtin_t name) { + return &table(whichtable(name))[tableindex(name)] } -#endif // Table lookup functions /* - lookupbuiltin - looks up a string in lookup_table[], and returns the index of its entry, + lookupbuiltin - looks up a string in BuiltinTable[], and returns the index of its entry, or ENDFUNCTIONS if no match is found */ builtin_t lookupbuiltin (char* c) { unsigned int end = 0, start; - for (int n=0; n<2; n++) { + for (int n=0; nfptr); } /* - getminmax - gets the minmax byte from lookup_table[] whose octets specify the type of function + getminmax - gets the minmax byte from BuiltinTable[] whose octets specify the type of function and minimum and maximum number of arguments for name */ uint8_t getminmax (builtin_t name) { - int n = nameminmax); } /* @@ -6364,16 +6402,14 @@ void checkminmax (builtin_t name, int nargs) { lookupdoc - looks up the documentation string for the built-in function name */ char* lookupdoc (builtin_t name) { - int n = namedoc); } /* findsubstring - tests whether a specified substring occurs in the name of a built-in function */ bool findsubstring (char* part, builtin_t name) { - int n = namestring); int l = strlen_P(s); int m = strlen(part); for (int i = 0; i <= l-m; i++) { @@ -6397,8 +6433,7 @@ void testescape () { bool keywordp (object* obj) { if (!(symbolp(obj) && builtinp(obj->name))) return false; builtin_t name = builtin(obj->name); - int n = namestring); char c = pgm_read_byte(&s[0]); return (c == ':'); } @@ -6634,8 +6669,7 @@ void printstring (object* form, pfun_t pfun) { */ void pbuiltin (builtin_t name, pfun_t pfun) { int p = 0; - int n = namestring); while (1) { char c = pgm_read_byte(&s[p++]); if (c == 0) return; From 3662d13c341159414e1e23ec38dc5868bdf48291 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 12:17:03 -0400 Subject: [PATCH 014/109] reorder #includes --- ulisp.hpp | 40 +++++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index d16583d..3849612 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -7,6 +7,18 @@ #ifndef ULISP_HPP #define ULISP_HPP +// Includes + +// #include "LispLibrary.h" +#include +#include +#include +#include +#include +#include +#include +#include + // Lisp Library #ifndef LispLibrary const char LispLibrary[] PROGMEM = ""; @@ -20,17 +32,6 @@ const char LispLibrary[] PROGMEM = ""; // #define gfxsupport // #define lisplibrary -// Includes - -// #include "LispLibrary.h" -#include -#include -#include -#include -#include -#include -#include - #if defined(gfxsupport) #define COLOR_WHITE ST77XX_WHITE #define COLOR_BLACK ST77XX_BLACK @@ -69,15 +70,16 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); // C Macros #define nil NULL -#define car(x) (((object*) (x))->car) -#define cdr(x) (((object*) (x))->cdr) +#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 first(x) (car(x)) +#define rest(x) (cdr(x)) +#define second(x) (first(rest(x))) #define cddr(x) (cdr(cdr(x))) -#define third(x) (car(cdr(cdr(x)))) +#define third(x) (first(cddr(x))) -#define push(x, y) ((y) = cons((x),(y))) +#define push(x, y) ((y) = cons((x), (y))) #define pop(y) ((y) = cdr(y)) #define integerp(x) ((x) != NULL && (x)->type == NUMBER) @@ -93,8 +95,8 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define marked(x) ((((uintptr_t)(car(x))) & MARKBIT) != 0) #define MARKBIT 1 -#define setflag(x) (Flags = Flags | 1<<(x)) -#define clrflag(x) (Flags = Flags & ~(1<<(x))) +#define setflag(x) (Flags |= 1<<(x)) +#define clrflag(x) (Flags &= ~(1<<(x))) #define tstflag(x) (Flags & 1<<(x)) #define issp(x) (x == ' ' || x == '\n' || x == '\r' || x == '\t') From 1c5345597ff81ebac87526007aca23e3fdd42e86 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 12:23:26 -0400 Subject: [PATCH 015/109] use semsible types --- ulisp.hpp | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 3849612..f62a0d3 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -116,7 +116,6 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define TRACEMAX 3; // Number of traced functions enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; // ARRAY STRING and PAIR must be last enum token { UNUSED, BRA, KET, QUO, DOT }; -enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM }; enum fntypes_t { OTHER_FORMS, TAIL_FORMS, FUNCTIONS, SPECIAL_FORMS }; // Stream names used by printobject @@ -128,11 +127,14 @@ const char wifistream[] PROGMEM = "wifi"; const char stringstream[] PROGMEM = "string"; const char gfxstream[] PROGMEM = "gfx"; PGM_P const streamname[] PROGMEM = {serialstream, i2cstream, spistream, sdstream, wifistream, stringstream, gfxstream}; +enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM}; // Typedefs typedef uint32_t symbol_t; +typedef uint8_t minmax_t; + typedef struct sobject { union { struct { @@ -157,7 +159,7 @@ typedef void (*mapfun_t)(object* , object**); typedef const struct { PGM_P string; fn_ptr_type fptr; - uint8_t minmax; + minmax_t minmax; const char* doc; } tbl_entry_t; @@ -207,7 +209,7 @@ volatile uint8_t Flags = 0b00001; // PRINTREADABLY set by default object* tee; bool keywordp (object*); void pfstring (PGM_P, pfun_t); -uint8_t nthchar (object*, int); +char nthchar (object*, int); void pfl (pfun_t); void pln (pfun_t); void pserial (char); @@ -225,7 +227,7 @@ void pint (int, pfun_t); void pintbase (uint32_t, uint8_t, pfun_t); void printstring (object*, pfun_t); int subwidthlist (object*, int); -uint8_t getminmax (builtin_t); +minmax_t getminmax (builtin_t); intptr_t lookupfn (builtin_t); int listlength (object*); void checkminmax (builtin_t, int); @@ -413,7 +415,7 @@ object* makefloat (float f) { /* character - make a character object with value c and return it */ -object* character (uint8_t c) { +object* character (char c) { object* ptr = myalloc(); ptr->type = CHARACTER; ptr->chars = c; @@ -797,8 +799,8 @@ bool builtinp (symbol_t name) { int checkkeyword (object* obj) { if (!keywordp(obj)) error(PSTR("argument is not a keyword"), obj); builtin_t kname = builtin(obj->name); - uint8_t context = getminmax(kname); - if (context != 0 && context != Context) error(invalidkey, obj); + minmax_t context = getminmax(kname); + if (context != 0 && context != (minmax_t)Context) error(invalidkey, obj); return ((int)lookupfn(kname)); } @@ -1265,7 +1267,7 @@ object* copystring (object* arg) { readstring - reads characters from an input stream up to delimiter delim and returns a Lisp string */ -object* readstring (uint8_t delim, gfun_t gfun) { +object* readstring (char delim, gfun_t gfun) { object* obj = newstring(); object* tail = obj; int ch = gfun(); @@ -1299,7 +1301,7 @@ int stringlength (object* form) { nthchar - returns the nth character from a Lisp string Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word */ -uint8_t nthchar (object* string, int n) { +char nthchar (object* string, int n) { object* arg = cdr(string); int top; if (sizeof(int) == 4) { top = n>>2; n = 3 - (n&3); } @@ -1987,7 +1989,7 @@ void supersub (object* form, int lm, int super, pfun_t pfun) { int special = 0, separate = 1; object* arg = car(form); if (symbolp(arg) && builtinp(arg->name)) { - uint8_t minmax = getminmax(builtin(arg->name)); + minmax_t minmax = getminmax(builtin(arg->name)); if (minmax == 0327 || minmax == 0313) special = 2; // defun, setq, setf, defvar else if (minmax == 0317 || minmax == 0017 || minmax == 0117 || minmax == 0123) special = 1; } @@ -6386,7 +6388,7 @@ intptr_t lookupfn (builtin_t name) { getminmax - gets the minmax byte from BuiltinTable[] whose octets specify the type of function and minimum and maximum number of arguments for name */ -uint8_t getminmax (builtin_t name) { +minmax_t getminmax (builtin_t name) { return pgm_read_byte(getentry(name)->minmax); } @@ -6395,7 +6397,7 @@ uint8_t getminmax (builtin_t name) { */ void checkminmax (builtin_t name, int nargs) { if (!(name < ENDFUNCTIONS)) error2(PSTR("not a builtin")); - uint8_t minmax = getminmax(name); + minmax_t minmax = getminmax(name); if (nargs<((minmax >> 3) & 0x07)) error2(toofewargs); if ((minmax & 0x07) != 0x07 && nargs>(minmax & 0x07)) error2(toomanyargs); } @@ -6613,7 +6615,7 @@ const char ControlCodes[] PROGMEM = "Null\0SOH\0STX\0ETX\0EOT\0ENQ\0ACK\0Bell\0B If < 127 prints ASCII; eg #\A Otherwise prints decimal; eg #\234 */ -void pcharacter (uint8_t c, pfun_t pfun) { +void pcharacter (char c, pfun_t pfun) { if (!tstflag(PRINTREADABLY)) pfun(c); else { pfun('#'); pfun('\\'); From 085848db58374b63202ff9904f62b0ffc45b659d Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 12:46:19 -0400 Subject: [PATCH 016/109] use macros for minmax --- ulisp.hpp | 483 +++++++++++++++++++++++++++--------------------------- 1 file changed, 246 insertions(+), 237 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index f62a0d3..2e31a6e 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -111,6 +111,15 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define BUILTINS 0xF4240000 #define ENDFUNCTIONS 1536 +#define fntype(x) (((uint8_t)(x))>>6) +#define getminargs(x) ((((uint8_t)(x))>>3)&7) +#define getmaxargs(x) (((uint8_t)(x))&7) +#define unlimitedp(x) (((uint8_t)(x))&7==UNLIMITED) +#define UNLIMITED 7 + +// let's hope the compiler can do constant folding!! +#define MINMAX(fntype, min, max) (((fntype)<<6)|((min)<<3)|(max)) + // Constants #define TRACEMAX 3; // Number of traced functions @@ -1429,10 +1438,10 @@ object* apropos (object* arg, bool print) { for (int i = 0; i < entries; i++) { if (findsubstring(part, (builtin_t)i)) { if (print) { - uint8_t fntype = getminmax(i)>>6; + uint8_t ft = fntype(getminmax(i)); pbuiltin((builtin_t)i, pserial); pserial(' '); pserial('('); - if (fntype == FUNCTIONS) pfstring(PSTR("function"), pserial); - else if (fntype == SPECIAL_FORMS) pfstring(PSTR("special form"), pserial); + if (ft == FUNCTIONS) pfstring(PSTR("function"), pserial); + else if (ft == SPECIAL_FORMS) pfstring(PSTR("special form"), pserial); else pfstring(PSTR("symbol/keyword"), pserial); pserial(')'); pln(pserial); } else { @@ -1595,7 +1604,7 @@ object* closure (int tc, symbol_t name, object* function, object* args, object** object* apply (object* function, object* args, object* env) { if (symbolp(function)) { builtin_t fname = builtin(function->name); - if ((fname < ENDFUNCTIONS) && ((getminmax(fname)>>6) == FUNCTIONS)) { + if ((fname < ENDFUNCTIONS) && (fntype(getminmax(fname)) == FUNCTIONS)) { Context = fname; checkargs(args); return ((fn_ptr_type)lookupfn(fname))(args, env); @@ -1990,8 +1999,8 @@ void supersub (object* form, int lm, int super, pfun_t pfun) { object* arg = car(form); if (symbolp(arg) && builtinp(arg->name)) { minmax_t minmax = getminmax(builtin(arg->name)); - if (minmax == 0327 || minmax == 0313) special = 2; // defun, setq, setf, defvar - else if (minmax == 0317 || minmax == 0017 || minmax == 0117 || minmax == 0123) special = 1; + if (minmax == MINMAX(SPECIAL_FORMS, 2, UNLIMITED) || minmax == MINMAX(SPECIAL_FORMS, 1, 3)) special = 2; // defun, setq, setf, defvar + else if (minmax == MINMAX(SPECIAL_FORMS, 1, UNLIMITED) || minmax == MINMAX(OTHER_FORMS, 1, UNLIMITED) || minmax == MINMAX(TAIL_FORMS, 1, UNLIMITED) || minmax == MINMAX(TAIL_FORMS, 2, 3)) special = 1; } while (form != NULL) { if (atom(form)) { pfstring(PSTR(" . "), pfun); printobject(form, pfun); pfun(')'); return; } @@ -6074,230 +6083,230 @@ const char doc225[] PROGMEM = "(invert-display boolean)\n" // Built-in symbol lookup table const tbl_entry_t BuiltinTable[] PROGMEM = { - { string0, NULL, 0000, doc0 }, - { string1, NULL, 0000, doc1 }, - { string2, NULL, 0000, doc2 }, - { string3, NULL, 0000, doc3 }, - { string4, NULL, 0000, NULL }, - { string5, NULL, 0000, NULL }, - { string6, NULL, 0000, NULL }, - { string7, NULL, 0000, doc7 }, - { string8, NULL, 0017, doc8 }, - { string9, NULL, 0017, doc9 }, - { string10, NULL, 0017, doc10 }, - { string11, NULL, 0017, NULL }, - { string12, NULL, 0007, NULL }, - { string13, sp_quote, 0311, NULL }, - { string14, sp_defun, 0327, doc14 }, - { string15, sp_defvar, 0313, doc15 }, - { string16, fn_car, 0211, doc16 }, - { string17, fn_car, 0211, NULL }, - { string18, fn_cdr, 0211, doc18 }, - { string19, fn_cdr, 0211, NULL }, - { string20, fn_nth, 0222, doc20 }, - { string21, fn_aref, 0227, doc21 }, - { string22, fn_stringfn, 0211, doc22 }, - { string23, fn_pinmode, 0222, doc23 }, - { string24, fn_digitalwrite, 0222, doc24 }, - { string25, fn_analogread, 0211, doc25 }, - { string26, fn_register, 0212, doc26 }, - { string27, fn_format, 0227, doc27 }, - { string28, sp_or, 0307, doc28 }, - { string29, sp_setq, 0327, doc29 }, - { string30, sp_loop, 0307, doc30 }, - { string31, sp_return, 0307, doc31 }, - { string32, sp_push, 0322, doc32 }, - { string33, sp_pop, 0311, doc33 }, - { string34, sp_incf, 0312, doc34 }, - { string35, sp_decf, 0312, doc35 }, - { string36, sp_setf, 0327, doc36 }, - { string37, sp_dolist, 0317, doc37 }, - { string38, sp_dotimes, 0317, doc38 }, - { string39, sp_trace, 0301, doc39 }, - { string40, sp_untrace, 0301, doc40 }, - { string41, sp_formillis, 0317, doc41 }, - { string42, sp_time, 0311, doc42 }, - { string43, sp_withoutputtostring, 0317, doc43 }, - { string44, sp_withserial, 0317, doc44 }, - { string45, sp_withi2c, 0317, doc45 }, - { string46, sp_withspi, 0317, doc46 }, - { string47, sp_withsdcard, 0327, doc47 }, - { string48, tf_progn, 0107, doc48 }, - { string49, tf_if, 0123, doc49 }, - { string50, tf_cond, 0107, doc50 }, - { string51, tf_when, 0117, doc51 }, - { string52, tf_unless, 0117, doc52 }, - { string53, tf_case, 0117, doc53 }, - { string54, tf_and, 0107, doc54 }, - { string55, fn_not, 0211, doc55 }, - { string56, fn_not, 0211, NULL }, - { string57, fn_cons, 0222, doc57 }, - { string58, fn_atom, 0211, doc58 }, - { string59, fn_listp, 0211, doc59 }, - { string60, fn_consp, 0211, doc60 }, - { string61, fn_symbolp, 0211, doc61 }, - { string62, fn_arrayp, 0211, doc62 }, - { string63, fn_boundp, 0211, doc63 }, - { string64, fn_keywordp, 0211, doc64 }, - { string65, fn_setfn, 0227, doc65 }, - { string66, fn_streamp, 0211, doc66 }, - { string67, fn_eq, 0222, doc67 }, - { string68, fn_equal, 0222, doc68 }, - { string69, fn_caar, 0211, doc69 }, - { string70, fn_cadr, 0211, doc70 }, - { string71, fn_cadr, 0211, NULL }, - { string72, fn_cdar, 0211, doc72 }, - { string73, fn_cddr, 0211, doc73 }, - { string74, fn_caaar, 0211, doc74 }, - { string75, fn_caadr, 0211, doc75 }, - { string76, fn_cadar, 0211, doc76 }, - { string77, fn_caddr, 0211, doc77 }, - { string78, fn_caddr, 0211, NULL }, - { string79, fn_cdaar, 0211, doc79 }, - { string80, fn_cdadr, 0211, doc80 }, - { string81, fn_cddar, 0211, doc81 }, - { string82, fn_cdddr, 0211, doc82 }, - { string83, fn_length, 0211, doc83 }, - { string84, fn_arraydimensions, 0211, doc84 }, - { string85, fn_list, 0207, doc85 }, - { string86, fn_makearray, 0215, doc86 }, - { string87, fn_reverse, 0211, doc87 }, - { string88, fn_assoc, 0222, doc88 }, - { string89, fn_member, 0222, doc89 }, - { string90, fn_apply, 0227, doc90 }, - { string91, fn_funcall, 0217, doc91 }, - { string92, fn_append, 0207, doc92 }, - { string93, fn_mapc, 0227, doc93 }, - { string94, fn_mapcar, 0227, doc94 }, - { string95, fn_mapcan, 0227, doc95 }, - { string96, fn_add, 0207, doc96 }, - { string97, fn_subtract, 0217, doc97 }, - { string98, fn_multiply, 0207, doc98 }, - { string99, fn_divide, 0217, doc99 }, - { string100, fn_mod, 0222, doc100 }, - { string101, fn_oneplus, 0211, doc101 }, - { string102, fn_oneminus, 0211, doc102 }, - { string103, fn_abs, 0211, doc103 }, - { string104, fn_random, 0211, doc104 }, - { string105, fn_maxfn, 0217, doc105 }, - { string106, fn_minfn, 0217, doc106 }, - { string107, fn_noteq, 0217, doc107 }, - { string108, fn_numeq, 0217, doc108 }, - { string109, fn_less, 0217, doc109 }, - { string110, fn_lesseq, 0217, doc110 }, - { string111, fn_greater, 0217, doc111 }, - { string112, fn_greatereq, 0217, doc112 }, - { string113, fn_plusp, 0211, doc113 }, - { string114, fn_minusp, 0211, doc114 }, - { string115, fn_zerop, 0211, doc115 }, - { string116, fn_oddp, 0211, doc116 }, - { string117, fn_evenp, 0211, doc117 }, - { string118, fn_integerp, 0211, doc118 }, - { string119, fn_numberp, 0211, doc119 }, - { string120, fn_floatfn, 0211, doc120 }, - { string121, fn_floatp, 0211, doc121 }, - { string122, fn_sin, 0211, doc122 }, - { string123, fn_cos, 0211, doc123 }, - { string124, fn_tan, 0211, doc124 }, - { string125, fn_asin, 0211, doc125 }, - { string126, fn_acos, 0211, doc126 }, - { string127, fn_atan, 0212, doc127 }, - { string128, fn_sinh, 0211, doc128 }, - { string129, fn_cosh, 0211, doc129 }, - { string130, fn_tanh, 0211, doc130 }, - { string131, fn_exp, 0211, doc131 }, - { string132, fn_sqrt, 0211, doc132 }, - { string133, fn_log, 0212, doc133 }, - { string134, fn_expt, 0222, doc134 }, - { string135, fn_ceiling, 0212, doc135 }, - { string136, fn_floor, 0212, doc136 }, - { string137, fn_truncate, 0212, doc137 }, - { string138, fn_round, 0212, doc138 }, - { string139, fn_char, 0222, doc139 }, - { string140, fn_charcode, 0211, doc140 }, - { string141, fn_codechar, 0211, doc141 }, - { string142, fn_characterp, 0211, doc142 }, - { string143, fn_stringp, 0211, doc143 }, - { string144, fn_stringeq, 0222, doc144 }, - { string145, fn_stringless, 0222, doc145 }, - { string146, fn_stringgreater, 0222, doc146 }, - { string147, fn_sort, 0222, doc147 }, - { string148, fn_concatenate, 0217, doc148 }, - { string149, fn_subseq, 0223, doc149 }, - { string150, fn_search, 0222, doc150 }, - { string151, fn_readfromstring, 0211, doc151 }, - { string152, fn_princtostring, 0211, doc152 }, - { string153, fn_prin1tostring, 0211, doc153 }, - { string154, fn_logand, 0207, doc154 }, - { string155, fn_logior, 0207, doc155 }, - { string156, fn_logxor, 0207, doc156 }, - { string157, fn_lognot, 0211, doc157 }, - { string158, fn_ash, 0222, doc158 }, - { string159, fn_logbitp, 0222, doc159 }, - { string160, fn_eval, 0211, doc160 }, - { string161, fn_globals, 0200, doc161 }, - { string162, fn_locals, 0200, doc162 }, - { string163, fn_makunbound, 0211, doc163 }, - { string164, fn_break, 0200, doc164 }, - { string165, fn_read, 0201, doc165 }, - { string166, fn_prin1, 0212, doc166 }, - { string167, fn_print, 0212, doc167 }, - { string168, fn_princ, 0212, doc168 }, - { string169, fn_terpri, 0201, doc169 }, - { string170, fn_readbyte, 0202, doc170 }, - { string171, fn_readline, 0201, doc171 }, - { string172, fn_writebyte, 0212, doc172 }, - { string173, fn_writestring, 0212, doc173 }, - { string174, fn_writeline, 0212, doc174 }, - { string175, fn_restarti2c, 0212, doc175 }, - { string176, fn_gc, 0200, doc176 }, - { string177, fn_room, 0200, doc177 }, - { string180, fn_cls, 0200, doc180 }, - { string181, fn_digitalread, 0211, doc181 }, - { string182, fn_analogreadresolution, 0211, doc182 }, - { string183, fn_analogwrite, 0222, doc183 }, - { string184, fn_delay, 0211, doc184 }, - { string185, fn_millis, 0200, doc185 }, - { string186, fn_sleep, 0201, doc186 }, - { string187, fn_note, 0203, doc187 }, - { string188, fn_edit, 0211, doc188 }, - { string189, fn_pprint, 0212, doc189 }, - { string190, fn_pprintall, 0201, doc190 }, - { string191, fn_require, 0211, doc191 }, - { string192, fn_listlibrary, 0200, doc192 }, - { string193, sp_help, 0311, doc193 }, - { string194, fn_documentation, 0212, doc194 }, - { string195, fn_apropos, 0211, doc195 }, - { string196, fn_aproposlist, 0211, doc196 }, - { string197, sp_unwindprotect, 0307, doc197 }, - { string198, sp_ignoreerrors, 0307, doc198 }, - { string199, sp_error, 0317, doc199 }, - { string200, sp_withclient, 0312, doc200 }, - { string201, fn_available, 0211, doc201 }, - { string202, fn_wifiserver, 0200, doc202 }, - { string203, fn_wifisoftap, 0204, doc203 }, - { string204, fn_connected, 0211, doc204 }, - { string205, fn_wifilocalip, 0200, doc205 }, - { string206, fn_wificonnect, 0203, doc206 }, - { string207, sp_withgfx, 0317, doc207 }, - { string208, fn_drawpixel, 0223, doc208 }, - { string209, fn_drawline, 0245, doc209 }, - { string210, fn_drawrect, 0245, doc210 }, - { string211, fn_fillrect, 0245, doc211 }, - { string212, fn_drawcircle, 0234, doc212 }, - { string213, fn_fillcircle, 0234, doc213 }, - { string214, fn_drawroundrect, 0256, doc214 }, - { string215, fn_fillroundrect, 0256, doc215 }, - { string216, fn_drawtriangle, 0267, doc216 }, - { string217, fn_filltriangle, 0267, doc217 }, - { string218, fn_drawchar, 0236, doc218 }, - { string219, fn_setcursor, 0222, doc219 }, - { string220, fn_settextcolor, 0212, doc220 }, - { string221, fn_settextsize, 0211, doc221 }, - { string222, fn_settextwrap, 0211, doc222 }, - { string223, fn_fillscreen, 0201, doc223 }, - { string224, fn_setrotation, 0211, doc224 }, - { string225, fn_invertdisplay, 0211, doc225 }, + { string0, NULL, MINMAX(OTHER_FORMS, 0, 0), doc0 }, + { string1, NULL, MINMAX(OTHER_FORMS, 0, 0), doc1 }, + { string2, NULL, MINMAX(OTHER_FORMS, 0, 0), doc2 }, + { string3, NULL, MINMAX(OTHER_FORMS, 0, 0), doc3 }, + { string4, NULL, MINMAX(OTHER_FORMS, 0, 0), NULL }, + { string5, NULL, MINMAX(OTHER_FORMS, 0, 0), NULL }, + { string6, NULL, MINMAX(OTHER_FORMS, 0, 0), NULL }, + { string7, NULL, MINMAX(OTHER_FORMS, 0, 0), doc7 }, + { string8, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), doc8 }, + { string9, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), doc9 }, + { string10, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), doc10 }, + { string11, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), NULL }, + { string12, NULL, MINMAX(OTHER_FORMS, 0, UNLIMITED), NULL }, + { string13, sp_quote, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, + { string14, sp_defun, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc14 }, + { string15, sp_defvar, MINMAX(SPECIAL_FORMS, 1, 3), doc15 }, + { string16, fn_car, MINMAX(FUNCTIONS, 1, 1), doc16 }, + { string17, fn_car, MINMAX(FUNCTIONS, 1, 1), NULL }, + { string18, fn_cdr, MINMAX(FUNCTIONS, 1, 1), doc18 }, + { string19, fn_cdr, MINMAX(FUNCTIONS, 1, 1), NULL }, + { string20, fn_nth, MINMAX(FUNCTIONS, 2, 2), doc20 }, + { string21, fn_aref, MINMAX(FUNCTIONS, 2, UNLIMITED), doc21 }, + { string22, fn_stringfn, MINMAX(FUNCTIONS, 1, 1), doc22 }, + { string23, fn_pinmode, MINMAX(FUNCTIONS, 2, 2), doc23 }, + { string24, fn_digitalwrite, MINMAX(FUNCTIONS, 2, 2), doc24 }, + { string25, fn_analogread, MINMAX(FUNCTIONS, 1, 1), doc25 }, + { string26, fn_register, MINMAX(FUNCTIONS, 1, 2), doc26 }, + { string27, fn_format, MINMAX(FUNCTIONS, 2, UNLIMITED), doc27 }, + { string28, sp_or, MINMAX(SPECIAL_FORMS, 0, UNLIMITED), doc28 }, + { string29, sp_setq, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc29 }, + { string30, sp_loop, MINMAX(SPECIAL_FORMS, 0, UNLIMITED), doc30 }, + { string31, sp_return, MINMAX(SPECIAL_FORMS, 0, UNLIMITED), doc31 }, + { string32, sp_push, MINMAX(SPECIAL_FORMS, 2, 2), doc32 }, + { string33, sp_pop, MINMAX(SPECIAL_FORMS, 1, 1), doc33 }, + { string34, sp_incf, MINMAX(SPECIAL_FORMS, 1, 2), doc34 }, + { string35, sp_decf, MINMAX(SPECIAL_FORMS, 1, 2), doc35 }, + { string36, sp_setf, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc36 }, + { string37, sp_dolist, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc37 }, + { string38, sp_dotimes, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc38 }, + { string39, sp_trace, MINMAX(SPECIAL_FORMS, 0, 1), doc39 }, + { string40, sp_untrace, MINMAX(SPECIAL_FORMS, 0, 1), doc40 }, + { string41, sp_formillis, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc41 }, + { string42, sp_time, MINMAX(SPECIAL_FORMS, 1, 1), doc42 }, + { string43, sp_withoutputtostring, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc43 }, + { string44, sp_withserial, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc44 }, + { string45, sp_withi2c, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc45 }, + { string46, sp_withspi, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc46 }, + { string47, sp_withsdcard, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc47 }, + { string48, tf_progn, MINMAX(TAIL_FORMS, 0, UNLIMITED), doc48 }, + { string49, tf_if, MINMAX(TAIL_FORMS, 2, 3), doc49 }, + { string50, tf_cond, MINMAX(TAIL_FORMS, 0, UNLIMITED), doc50 }, + { string51, tf_when, MINMAX(TAIL_FORMS, 1, UNLIMITED), doc51 }, + { string52, tf_unless, MINMAX(TAIL_FORMS, 1, UNLIMITED), doc52 }, + { string53, tf_case, MINMAX(TAIL_FORMS, 1, UNLIMITED), doc53 }, + { string54, tf_and, MINMAX(TAIL_FORMS, 0, UNLIMITED), doc54 }, + { string55, fn_not, MINMAX(FUNCTIONS, 1, 1), doc55 }, + { string56, fn_not, MINMAX(FUNCTIONS, 1, 1), NULL }, + { string57, fn_cons, MINMAX(FUNCTIONS, 2, 2), doc57 }, + { string58, fn_atom, MINMAX(FUNCTIONS, 1, 1), doc58 }, + { string59, fn_listp, MINMAX(FUNCTIONS, 1, 1), doc59 }, + { string60, fn_consp, MINMAX(FUNCTIONS, 1, 1), doc60 }, + { string61, fn_symbolp, MINMAX(FUNCTIONS, 1, 1), doc61 }, + { string62, fn_arrayp, MINMAX(FUNCTIONS, 1, 1), doc62 }, + { string63, fn_boundp, MINMAX(FUNCTIONS, 1, 1), doc63 }, + { string64, fn_keywordp, MINMAX(FUNCTIONS, 1, 1), doc64 }, + { string65, fn_setfn, MINMAX(FUNCTIONS, 2, UNLIMITED), doc65 }, + { string66, fn_streamp, MINMAX(FUNCTIONS, 1, 1), doc66 }, + { string67, fn_eq, MINMAX(FUNCTIONS, 2, 2), doc67 }, + { string68, fn_equal, MINMAX(FUNCTIONS, 2, 2), doc68 }, + { string69, fn_caar, MINMAX(FUNCTIONS, 1, 1), doc69 }, + { string70, fn_cadr, MINMAX(FUNCTIONS, 1, 1), doc70 }, + { string71, fn_cadr, MINMAX(FUNCTIONS, 1, 1), NULL }, + { string72, fn_cdar, MINMAX(FUNCTIONS, 1, 1), doc72 }, + { string73, fn_cddr, MINMAX(FUNCTIONS, 1, 1), doc73 }, + { string74, fn_caaar, MINMAX(FUNCTIONS, 1, 1), doc74 }, + { string75, fn_caadr, MINMAX(FUNCTIONS, 1, 1), doc75 }, + { string76, fn_cadar, MINMAX(FUNCTIONS, 1, 1), doc76 }, + { string77, fn_caddr, MINMAX(FUNCTIONS, 1, 1), doc77 }, + { string78, fn_caddr, MINMAX(FUNCTIONS, 1, 1), NULL }, + { string79, fn_cdaar, MINMAX(FUNCTIONS, 1, 1), doc79 }, + { string80, fn_cdadr, MINMAX(FUNCTIONS, 1, 1), doc80 }, + { string81, fn_cddar, MINMAX(FUNCTIONS, 1, 1), doc81 }, + { string82, fn_cdddr, MINMAX(FUNCTIONS, 1, 1), doc82 }, + { string83, fn_length, MINMAX(FUNCTIONS, 1, 1), doc83 }, + { string84, fn_arraydimensions, MINMAX(FUNCTIONS, 1, 1), doc84 }, + { string85, fn_list, MINMAX(FUNCTIONS, 0, UNLIMITED), doc85 }, + { string86, fn_makearray, MINMAX(FUNCTIONS, 1, 5), doc86 }, + { string87, fn_reverse, MINMAX(FUNCTIONS, 1, 1), doc87 }, + { string88, fn_assoc, MINMAX(FUNCTIONS, 2, 2), doc88 }, + { string89, fn_member, MINMAX(FUNCTIONS, 2, 2), doc89 }, + { string90, fn_apply, MINMAX(FUNCTIONS, 2, UNLIMITED), doc90 }, + { string91, fn_funcall, MINMAX(FUNCTIONS, 1, UNLIMITED), doc91 }, + { string92, fn_append, MINMAX(FUNCTIONS, 0, UNLIMITED), doc92 }, + { string93, fn_mapc, MINMAX(FUNCTIONS, 2, UNLIMITED), doc93 }, + { string94, fn_mapcar, MINMAX(FUNCTIONS, 2, UNLIMITED), doc94 }, + { string95, fn_mapcan, MINMAX(FUNCTIONS, 2, UNLIMITED), doc95 }, + { string96, fn_add, MINMAX(FUNCTIONS, 0, UNLIMITED), doc96 }, + { string97, fn_subtract, MINMAX(FUNCTIONS, 1, UNLIMITED), doc97 }, + { string98, fn_multiply, MINMAX(FUNCTIONS, 0, UNLIMITED), doc98 }, + { string99, fn_divide, MINMAX(FUNCTIONS, 1, UNLIMITED), doc99 }, + { string100, fn_mod, MINMAX(FUNCTIONS, 2, 2), doc100 }, + { string101, fn_oneplus, MINMAX(FUNCTIONS, 1, 1), doc101 }, + { string102, fn_oneminus, MINMAX(FUNCTIONS, 1, 1), doc102 }, + { string103, fn_abs, MINMAX(FUNCTIONS, 1, 1), doc103 }, + { string104, fn_random, MINMAX(FUNCTIONS, 1, 1), doc104 }, + { string105, fn_maxfn, MINMAX(FUNCTIONS, 1, UNLIMITED), doc105 }, + { string106, fn_minfn, MINMAX(FUNCTIONS, 1, UNLIMITED), doc106 }, + { string107, fn_noteq, MINMAX(FUNCTIONS, 1, UNLIMITED), doc107 }, + { string108, fn_numeq, MINMAX(FUNCTIONS, 1, UNLIMITED), doc108 }, + { string109, fn_less, MINMAX(FUNCTIONS, 1, UNLIMITED), doc109 }, + { string110, fn_lesseq, MINMAX(FUNCTIONS, 1, UNLIMITED), doc110 }, + { string111, fn_greater, MINMAX(FUNCTIONS, 1, UNLIMITED), doc111 }, + { string112, fn_greatereq, MINMAX(FUNCTIONS, 1, UNLIMITED), doc112 }, + { string113, fn_plusp, MINMAX(FUNCTIONS, 1, 1), doc113 }, + { string114, fn_minusp, MINMAX(FUNCTIONS, 1, 1), doc114 }, + { string115, fn_zerop, MINMAX(FUNCTIONS, 1, 1), doc115 }, + { string116, fn_oddp, MINMAX(FUNCTIONS, 1, 1), doc116 }, + { string117, fn_evenp, MINMAX(FUNCTIONS, 1, 1), doc117 }, + { string118, fn_integerp, MINMAX(FUNCTIONS, 1, 1), doc118 }, + { string119, fn_numberp, MINMAX(FUNCTIONS, 1, 1), doc119 }, + { string120, fn_floatfn, MINMAX(FUNCTIONS, 1, 1), doc120 }, + { string121, fn_floatp, MINMAX(FUNCTIONS, 1, 1), doc121 }, + { string122, fn_sin, MINMAX(FUNCTIONS, 1, 1), doc122 }, + { string123, fn_cos, MINMAX(FUNCTIONS, 1, 1), doc123 }, + { string124, fn_tan, MINMAX(FUNCTIONS, 1, 1), doc124 }, + { string125, fn_asin, MINMAX(FUNCTIONS, 1, 1), doc125 }, + { string126, fn_acos, MINMAX(FUNCTIONS, 1, 1), doc126 }, + { string127, fn_atan, MINMAX(FUNCTIONS, 1, 2), doc127 }, + { string128, fn_sinh, MINMAX(FUNCTIONS, 1, 1), doc128 }, + { string129, fn_cosh, MINMAX(FUNCTIONS, 1, 1), doc129 }, + { string130, fn_tanh, MINMAX(FUNCTIONS, 1, 1), doc130 }, + { string131, fn_exp, MINMAX(FUNCTIONS, 1, 1), doc131 }, + { string132, fn_sqrt, MINMAX(FUNCTIONS, 1, 1), doc132 }, + { string133, fn_log, MINMAX(FUNCTIONS, 1, 2), doc133 }, + { string134, fn_expt, MINMAX(FUNCTIONS, 2, 2), doc134 }, + { string135, fn_ceiling, MINMAX(FUNCTIONS, 1, 2), doc135 }, + { string136, fn_floor, MINMAX(FUNCTIONS, 1, 2), doc136 }, + { string137, fn_truncate, MINMAX(FUNCTIONS, 1, 2), doc137 }, + { string138, fn_round, MINMAX(FUNCTIONS, 1, 2), doc138 }, + { string139, fn_char, MINMAX(FUNCTIONS, 2, 2), doc139 }, + { string140, fn_charcode, MINMAX(FUNCTIONS, 1, 1), doc140 }, + { string141, fn_codechar, MINMAX(FUNCTIONS, 1, 1), doc141 }, + { string142, fn_characterp, MINMAX(FUNCTIONS, 1, 1), doc142 }, + { string143, fn_stringp, MINMAX(FUNCTIONS, 1, 1), doc143 }, + { string144, fn_stringeq, MINMAX(FUNCTIONS, 2, 2), doc144 }, + { string145, fn_stringless, MINMAX(FUNCTIONS, 2, 2), doc145 }, + { string146, fn_stringgreater, MINMAX(FUNCTIONS, 2, 2), doc146 }, + { string147, fn_sort, MINMAX(FUNCTIONS, 2, 2), doc147 }, + { string148, fn_concatenate, MINMAX(FUNCTIONS, 1, UNLIMITED), doc148 }, + { string149, fn_subseq, MINMAX(FUNCTIONS, 2, 3), doc149 }, + { string150, fn_search, MINMAX(FUNCTIONS, 2, 2), doc150 }, + { string151, fn_readfromstring, MINMAX(FUNCTIONS, 1, 1), doc151 }, + { string152, fn_princtostring, MINMAX(FUNCTIONS, 1, 1), doc152 }, + { string153, fn_prin1tostring, MINMAX(FUNCTIONS, 1, 1), doc153 }, + { string154, fn_logand, MINMAX(FUNCTIONS, 0, UNLIMITED), doc154 }, + { string155, fn_logior, MINMAX(FUNCTIONS, 0, UNLIMITED), doc155 }, + { string156, fn_logxor, MINMAX(FUNCTIONS, 0, UNLIMITED), doc156 }, + { string157, fn_lognot, MINMAX(FUNCTIONS, 1, 1), doc157 }, + { string158, fn_ash, MINMAX(FUNCTIONS, 2, 2), doc158 }, + { string159, fn_logbitp, MINMAX(FUNCTIONS, 2, 2), doc159 }, + { string160, fn_eval, MINMAX(FUNCTIONS, 1, 1), doc160 }, + { string161, fn_globals, MINMAX(FUNCTIONS, 0, 0), doc161 }, + { string162, fn_locals, MINMAX(FUNCTIONS, 0, 0), doc162 }, + { string163, fn_makunbound, MINMAX(FUNCTIONS, 1, 1), doc163 }, + { string164, fn_break, MINMAX(FUNCTIONS, 0, 0), doc164 }, + { string165, fn_read, MINMAX(FUNCTIONS, 0, 1), doc165 }, + { string166, fn_prin1, MINMAX(FUNCTIONS, 1, 2), doc166 }, + { string167, fn_print, MINMAX(FUNCTIONS, 1, 2), doc167 }, + { string168, fn_princ, MINMAX(FUNCTIONS, 1, 2), doc168 }, + { string169, fn_terpri, MINMAX(FUNCTIONS, 0, 1), doc169 }, + { string170, fn_readbyte, MINMAX(FUNCTIONS, 0, 2), doc170 }, + { string171, fn_readline, MINMAX(FUNCTIONS, 0, 1), doc171 }, + { string172, fn_writebyte, MINMAX(FUNCTIONS, 1, 2), doc172 }, + { string173, fn_writestring, MINMAX(FUNCTIONS, 1, 2), doc173 }, + { string174, fn_writeline, MINMAX(FUNCTIONS, 1, 2), doc174 }, + { string175, fn_restarti2c, MINMAX(FUNCTIONS, 1, 2), doc175 }, + { string176, fn_gc, MINMAX(FUNCTIONS, 0, 0), doc176 }, + { string177, fn_room, MINMAX(FUNCTIONS, 0, 0), doc177 }, + { string180, fn_cls, MINMAX(FUNCTIONS, 0, 0), doc180 }, + { string181, fn_digitalread, MINMAX(FUNCTIONS, 1, 1), doc181 }, + { string182, fn_analogreadresolution, MINMAX(FUNCTIONS, 1, 1), doc182 }, + { string183, fn_analogwrite, MINMAX(FUNCTIONS, 2, 2), doc183 }, + { string184, fn_delay, MINMAX(FUNCTIONS, 1, 1), doc184 }, + { string185, fn_millis, MINMAX(FUNCTIONS, 0, 0), doc185 }, + { string186, fn_sleep, MINMAX(FUNCTIONS, 0, 1), doc186 }, + { string187, fn_note, MINMAX(FUNCTIONS, 0, 3), doc187 }, + { string188, fn_edit, MINMAX(FUNCTIONS, 1, 1), doc188 }, + { string189, fn_pprint, MINMAX(FUNCTIONS, 1, 2), doc189 }, + { string190, fn_pprintall, MINMAX(FUNCTIONS, 0, 1), doc190 }, + { string191, fn_require, MINMAX(FUNCTIONS, 1, 1), doc191 }, + { string192, fn_listlibrary, MINMAX(FUNCTIONS, 0, 0), doc192 }, + { string193, sp_help, MINMAX(SPECIAL_FORMS, 1, 1), doc193 }, + { string194, fn_documentation, MINMAX(FUNCTIONS, 1, 2), doc194 }, + { string195, fn_apropos, MINMAX(FUNCTIONS, 1, 1), doc195 }, + { string196, fn_aproposlist, MINMAX(FUNCTIONS, 1, 1), doc196 }, + { string197, sp_unwindprotect, MINMAX(SPECIAL_FORMS, 0, UNLIMITED), doc197 }, + { string198, sp_ignoreerrors, MINMAX(SPECIAL_FORMS, 0, UNLIMITED), doc198 }, + { string199, sp_error, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc199 }, + { string200, sp_withclient, MINMAX(SPECIAL_FORMS, 1, 2), doc200 }, + { string201, fn_available, MINMAX(FUNCTIONS, 1, 1), doc201 }, + { string202, fn_wifiserver, MINMAX(FUNCTIONS, 0, 0), doc202 }, + { string203, fn_wifisoftap, MINMAX(FUNCTIONS, 0, 4), doc203 }, + { string204, fn_connected, MINMAX(FUNCTIONS, 1, 1), doc204 }, + { string205, fn_wifilocalip, MINMAX(FUNCTIONS, 0, 0), doc205 }, + { string206, fn_wificonnect, MINMAX(FUNCTIONS, 0, 3), doc206 }, + { string207, sp_withgfx, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc207 }, + { string208, fn_drawpixel, MINMAX(FUNCTIONS, 2, 3), doc208 }, + { string209, fn_drawline, MINMAX(FUNCTIONS, 4, 5), doc209 }, + { string210, fn_drawrect, MINMAX(FUNCTIONS, 4, 5), doc210 }, + { string211, fn_fillrect, MINMAX(FUNCTIONS, 4, 5), doc211 }, + { string212, fn_drawcircle, MINMAX(FUNCTIONS, 3, 4), doc212 }, + { string213, fn_fillcircle, MINMAX(FUNCTIONS, 3, 4), doc213 }, + { string214, fn_drawroundrect, MINMAX(FUNCTIONS, 5, 6), doc214 }, + { string215, fn_fillroundrect, MINMAX(FUNCTIONS, 5, 6), doc215 }, + { string216, fn_drawtriangle, MINMAX(FUNCTIONS, 6, 7), doc216 }, + { string217, fn_filltriangle, MINMAX(FUNCTIONS, 6, 7), doc217 }, + { string218, fn_drawchar, MINMAX(FUNCTIONS, 3, 6), doc218 }, + { string219, fn_setcursor, MINMAX(FUNCTIONS, 2, 2), doc219 }, + { string220, fn_settextcolor, MINMAX(FUNCTIONS, 1, 2), doc220 }, + { string221, fn_settextsize, MINMAX(FUNCTIONS, 1, 1), doc221 }, + { string222, fn_settextwrap, MINMAX(FUNCTIONS, 1, 1), doc222 }, + { string223, fn_fillscreen, MINMAX(FUNCTIONS, 0, 1), doc223 }, + { string224, fn_setrotation, MINMAX(FUNCTIONS, 1, 1), doc224 }, + { string225, fn_invertdisplay, MINMAX(FUNCTIONS, 1, 1), doc225 }, { string226, (fn_ptr_type)LED_BUILTIN, 0, NULL }, { string227, (fn_ptr_type)HIGH, DIGITALWRITE, NULL }, { string228, (fn_ptr_type)LOW, DIGITALWRITE, NULL }, @@ -6396,10 +6405,10 @@ minmax_t getminmax (builtin_t name) { checkminmax - checks that the number of arguments nargs for name is within the range specified by minmax */ void checkminmax (builtin_t name, int nargs) { - if (!(name < ENDFUNCTIONS)) error2(PSTR("not a builtin")); + if (name >= ENDFUNCTIONS) error2(PSTR("internal error: not a builtin")); minmax_t minmax = getminmax(name); - if (nargs<((minmax >> 3) & 0x07)) error2(toofewargs); - if ((minmax & 0x07) != 0x07 && nargs>(minmax & 0x07)) error2(toomanyargs); + if (nargs < getminargs(minmax)) error2(toofewargs); + if (!unlimitedp(minmax) && nargs > getmaxargs(minmax)) error2(toomanyargs); } /* @@ -6515,20 +6524,20 @@ object* eval (object* form, object* env) { } return cons(bsymbol(CLOSURE), cons(envcopy,args)); } - uint8_t fntype = getminmax(name)>>6; + uint8_t ft = fntype(getminmax(name)); - if (fntype == SPECIAL_FORMS) { + if (ft == SPECIAL_FORMS) { Context = name; return ((fn_ptr_type)lookupfn(name))(args, env); } - if (fntype == TAIL_FORMS) { + if (ft == TAIL_FORMS) { Context = name; form = ((fn_ptr_type)lookupfn(name))(args, env); TC = 1; goto EVAL; } - if (fntype == OTHER_FORMS) error(PSTR("can't be used as a function"), function); + if (ft == OTHER_FORMS) error(PSTR("can't be used as a function"), function); } // Evaluate the parameters - result in head From d3b5bb420b61064743d877fc9f094abf9a03acf7 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 12:47:10 -0400 Subject: [PATCH 017/109] dup oops --- ulisp.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ulisp.hpp b/ulisp.hpp index 2e31a6e..76e8139 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -114,7 +114,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define fntype(x) (((uint8_t)(x))>>6) #define getminargs(x) ((((uint8_t)(x))>>3)&7) #define getmaxargs(x) (((uint8_t)(x))&7) -#define unlimitedp(x) (((uint8_t)(x))&7==UNLIMITED) +#define unlimitedp(x) (getmaxargs(x)==UNLIMITED) #define UNLIMITED 7 // let's hope the compiler can do constant folding!! From d61eb1fb681aeb1a7fe5ec96fc57b18895a224c9 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 16:48:29 -0400 Subject: [PATCH 018/109] better table stuff --- ulisp.hpp | 38 ++++++++++++-------------------------- 1 file changed, 12 insertions(+), 26 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 76e8139..93c620b 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -141,8 +141,8 @@ enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM // Typedefs typedef uint32_t symbol_t; - typedef uint8_t minmax_t; +typedef uint16_t builtin_t; typedef struct sobject { union { @@ -180,8 +180,6 @@ typedef struct { typedef int (*gfun_t)(); typedef void (*pfun_t)(char); -typedef uint16_t builtin_t; - enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, LET, LETSTAR, CLOSURE, PSTAR, QUOTE, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, ANALOGREAD, REGISTER, FORMAT, @@ -190,14 +188,13 @@ ANALOGREAD, REGISTER, FORMAT, // Global variables object Workspace[WORKSPACESIZE] WORDALIGNED; +mtbl_entry_t* Metatable; +size_t NumTables; jmp_buf toplevel_handler; jmp_buf *handler = &toplevel_handler; size_t Freespace = 0; object* Freelist; -unsigned int I2Ccount; -unsigned int TraceFn[TRACEMAX]; -unsigned int TraceDepth[TRACEMAX]; builtin_t Context; object* GlobalEnv; @@ -210,6 +207,10 @@ uint8_t BreakLevel = 0; char LastChar = 0; char LastPrint = 0; +unsigned int I2Ccount; +unsigned int TraceFn[TRACEMAX]; +unsigned int TraceDepth[TRACEMAX]; + // Flags enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, NOECHO, MUFFLEERRORS }; volatile uint8_t Flags = 0b00001; // PRINTREADABLY set by default @@ -1434,8 +1435,9 @@ object* apropos (object* arg, bool print) { globals = cdr(globals); } // Built-in? - int entries = tablesize(0) + tablesize(1); - for (int i = 0; i < entries; i++) { + int entries = 0, i; + for (i = 0; i < NumTables; i++) entries += tablesize(i); + for (i = 0; i < entries; i++) { if (findsubstring(part, (builtin_t)i)) { if (print) { uint8_t ft = fntype(getminmax(i)); @@ -6318,9 +6320,6 @@ const tbl_entry_t BuiltinTable[] PROGMEM = { // Metatable cross-reference functions -mtbl_entry_t* Metatable; -size_t NumTables; - const tbl_entry_t *table (int n) { return Metatable[n].table; } @@ -6343,26 +6342,13 @@ void addtable (const tbl_entry_t table) { Metatable[NumTables-1].size = arraysize(table); } -int whichtable (builtin_t x) { +tbl_entry_t* getentry(builtin_t x) { int t = 0; while (x >= tablesize(t)) { x -= tablesize(t); t++; } - return t; -} - -int tableindex (builtin_t x) { - int t = 0; - while (x >= tablesize(t)) { - x -= tablesize(t); - t++; - } - return x; -} - -tbl_entry_t* getentry(builtin_t name) { - return &table(whichtable(name))[tableindex(name)] + return &table(t)[x] } // Table lookup functions From e1d335ee4f26f05a25dc85e9a03966715e2a69bd Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 18:12:32 -0400 Subject: [PATCH 019/109] intern everything, make functions buffer safe, fix `fromradix40` this allows buffers with only one trailing null to be passed in and not look at garbage values after the buffer also fixed bug (#60) in fromradix40 using explicit string search --- ulisp.hpp | 114 ++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 76 insertions(+), 38 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 93c620b..8a5b73e 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -230,8 +230,8 @@ void psymbol (symbol_t, pfun_t); void printobject (object*, pfun_t); symbol_t sym (builtin_t); void indent (uint8_t, char, pfun_t); -object* intern (symbol_t); object* lispstring (char*); +uint32_t pack40 (char*); char* cstring (object*, char*, int); void pint (int, pfun_t); void pintbase (uint32_t, uint8_t, pfun_t); @@ -404,8 +404,13 @@ inline void myfree (object* obj) { /* number - make an integer object with value n and return it + or return the existing one with the same value */ object* number (int n) { + for (int i=0; itype == NUMBER && obj->integer == n) return obj; + } object* ptr = myalloc(); ptr->type = NUMBER; ptr->integer = n; @@ -414,8 +419,13 @@ object* number (int n) { /* makefloat - make a floating point object with value f and return it + or return the existing one with the same value */ object* makefloat (float f) { + for (int i=0; itype == FLOAT && obj->single_float == f) return obj; + } object* ptr = myalloc(); ptr->type = FLOAT; ptr->single_float = f; @@ -424,8 +434,13 @@ object* makefloat (float f) { /* character - make a character object with value c and return it + or return the existing one with the same value */ object* character (char c) { + for (int i=0; itype == CHARACTER && obj->chars == c) return obj; + } object* ptr = myalloc(); ptr->type = CHARACTER; ptr->chars = c; @@ -444,8 +459,13 @@ object* cons (object* arg1, object* arg2) { /* symbol - make a symbol object with value name and return it + or returns the existing one with the same value */ object* symbol (symbol_t name) { + for (int i=0; itype == SYMBOL && obj->name == name) return obj; + } object* ptr = myalloc(); ptr->type = SYMBOL; ptr->name = name; @@ -456,19 +476,7 @@ object* symbol (symbol_t name) { bsymbol - make a built-in symbol */ inline object* bsymbol (builtin_t name) { - return intern(twist(name+BUILTINS)); -} - -/* - intern - looks through the workspace for an existing occurrence of symbol name and returns it, - otherwise calls symbol(name) to create a new symbol. -*/ -object* intern (symbol_t name) { - for (int i=0; itype == SYMBOL && obj->name == name) return obj; - } - return symbol(name); + return symbol(twist(name+BUILTINS)); } /* @@ -478,10 +486,23 @@ bool eqsymbols (object* obj, char* buffer) { object* arg = cdr(obj); int i = 0; while (!(arg == NULL && buffer[i] == 0)) { - if (arg == NULL || buffer[i] == 0 || - arg->chars != (buffer[i]<<24 | buffer[i+1]<<16 | buffer[i+2]<<8 | buffer[i+3])) return false; + if (arg == NULL || buffer[i] == 0) return false; + int test = buffer[i]<<24; + i++; + if (buffer[i] != 0) { + test |= buffer[i]<<16; + i++; + if (buffer[i] != 0) { + test |= buffer[i]<<8; + i++; + if (buffer[i] != 0) { + test |= buffer[i]; + i++; + } + } + } + if (arg->chars != test) return false; arg = car(arg); - i = i + 4; } return true; } @@ -500,6 +521,15 @@ object* internlong (char* buffer) { return obj; } +/* + buftosymbol - checks the characters in buffer and calls intern() or internlong() to make it a symbol. +*/ +object* buftosymbol (char* b) { + int l = strlen(b); + if (i <= 6 && valid40(b)) return symbol(twist(pack40(b))); + else return internlong(b); +} + /* stream - makes a stream object defined by streamtype and address, and returns it */ @@ -694,21 +724,22 @@ builtin_t builtin (symbol_t name) { } /* - sym - converts a builtin to a symbol name + sym - converts a builtin to a symbol name */ symbol_t sym (builtin_t x) { return twist(x + BUILTINS); } +const char radix40alphabet[] PROGMEM = "\0000123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-*$" + /* toradix40 - returns a number from 0 to 39 if the character can be encoded, or -1 otherwise. */ int8_t toradix40 (char ch) { - if (ch == 0) return 0; - if (ch >= '0' && ch <= '9') return ch-'0'+1; - if (ch == '-') return 37; if (ch == '*') return 38; if (ch == '$') return 39; - ch = ch | 0x20; - if (ch >= 'a' && ch <= 'z') return ch-'a'+11; + ch = toupper(ch); + for (int8_t i=0; i<40; i++) { + if ((char)pgm_read_byte(&radix40alphabet[i]) == ch) return i; + } return -1; // Invalid } @@ -716,18 +747,22 @@ int8_t toradix40 (char ch) { fromradix40 - returns the character encoded by the number n. */ char fromradix40 (char n) { - if (n >= 1 && n <= 9) return '0'+n-1; - if (n >= 11 && n <= 36) return 'a'+n-11; - if (n == 37) return '-'; if (n == 38) return '*'; if (n == 39) return '$'; - return 0; + if (n < 0 || n >= 40) return 0; + return (char)pgm_read_byte(radix40alphabet + n); } /* pack40 - packs six radix40-encoded characters from buffer into a 32-bit number and returns it. */ uint32_t pack40 (char* buffer) { - int x = 0; - for (int i=0; i<6; i++) x = x * 40 + toradix40(buffer[i]); + int x = 0, gz = 0, c = 0; + for (int i=0; i<6; i++) { + if (gz) c = 0; + else c = buffer[i]; // Don't dereference the buffer if we reached the end of the string already + x *= 40; + if (c == 0) gz = 1; + else x += toradix40(c); + } return x; } @@ -735,8 +770,12 @@ uint32_t pack40 (char* buffer) { valid40 - returns true if the symbol in buffer can be encoded as six radix40-encoded characters. */ bool valid40 (char* buffer) { - if (toradix40(buffer[0]) < 11) return false; - for (int i=1; i<6; i++) if (toradix40(buffer[i]) < 0) return false; + int t = 11; + for (int i=0; i<6; i++){ + if (toradix40(buffer[i]) < t) return false; + if (buffer[i+1] == 0) break; + t = 0; + } return true; } @@ -772,7 +811,7 @@ int checkbitvalue (object* obj) { checkintfloat - check that obj is an integer or floating-point number and return the number */ float checkintfloat (object* obj){ - if (integerp(obj)) return obj->integer; + if (integerp(obj)) return (float)obj->integer; if (!floatp(obj)) error(notanumber, obj); return obj->single_float; } @@ -1906,13 +1945,17 @@ void checkanalogwrite (int pin) { // Note +#ifndef tone void tone (int pin, int note) { (void) pin, (void) note; } +#endif +#ifndef noTone void noTone (int pin) { (void) pin; } +#endif const int scale[] PROGMEM = {4186,4435,4699,4978,5274,5588,5920,6272,6645,7040,7459,7902}; @@ -7039,12 +7082,7 @@ object* nextitem (gfun_t gfun) { builtin_t x = lookupbuiltin(buffer); if (x == NIL) return nil; if (x != ENDFUNCTIONS) return bsymbol(x); - object* sym; - if ((index <= 6) && valid40(buffer)) sym = intern(twist(pack40(buffer))); - else { - buffer[index+1] = '\0'; buffer[index+2] = '\0'; buffer[index+3] = '\0'; // For internlong - sym = internlong(buffer); - } + object* sym = buftosymbol(buffer); if (buffer[0] == ':') { // Keywords quote themselves sym = quoteit(QUOTE, sym); } From 5d05a3d749281f4eafef4fee18e7418eae41d269 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 18:16:35 -0400 Subject: [PATCH 020/109] use lowercase --- ulisp.hpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 8a5b73e..ed98222 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -730,13 +730,13 @@ symbol_t sym (builtin_t x) { return twist(x + BUILTINS); } -const char radix40alphabet[] PROGMEM = "\0000123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-*$" +const char radix40alphabet[] PROGMEM = "\0000123456789abcdefghijklmnopqrstuvwxyz-*$" /* toradix40 - returns a number from 0 to 39 if the character can be encoded, or -1 otherwise. */ int8_t toradix40 (char ch) { - ch = toupper(ch); + ch = tolower(ch); for (int8_t i=0; i<40; i++) { if ((char)pgm_read_byte(&radix40alphabet[i]) == ch) return i; } From 7bd1e9f2aac2d10812238746384dd631575eb8c7 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 18:22:46 -0400 Subject: [PATCH 021/109] missed pgm_read_ptr on getentry --- ulisp.hpp | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index ed98222..09bc78a 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -6385,13 +6385,14 @@ void addtable (const tbl_entry_t table) { Metatable[NumTables-1].size = arraysize(table); } -tbl_entry_t* getentry(builtin_t x) { +#define getentry(x) pgm_read_ptr(__getentry(x)) +tbl_entry_t* __getentry (builtin_t x) { int t = 0; while (x >= tablesize(t)) { x -= tablesize(t); t++; } - return &table(t)[x] + return &table(t)[x]; } // Table lookup functions From 611c232650f0c6011da679acf0d3d689da17cc51 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 18:40:24 -0400 Subject: [PATCH 022/109] eliminate table functions --- ulisp.hpp | 23 +++++++---------------- 1 file changed, 7 insertions(+), 16 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 09bc78a..2c3631d 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -246,7 +246,6 @@ object* findvalue (object*, object*); char* lookupdoc (builtin_t); void printsymbol (object*, pfun_t); void psymbol (symbol_t, pfun_t); -size_t tablesize (int); bool findsubstring (char*, builtin_t); bool stringcompare (object*, bool, bool, bool); void pbuiltin (builtin_t, pfun_t); @@ -1475,7 +1474,7 @@ object* apropos (object* arg, bool print) { } // Built-in? int entries = 0, i; - for (i = 0; i < NumTables; i++) entries += tablesize(i); + for (i = 0; i < NumTables; i++) entries += Metatable[i].size; for (i = 0; i < entries; i++) { if (findsubstring(part, (builtin_t)i)) { if (print) { @@ -6363,14 +6362,6 @@ const tbl_entry_t BuiltinTable[] PROGMEM = { // Metatable cross-reference functions -const tbl_entry_t *table (int n) { - return Metatable[n].table; -} - -size_t tablesize (int n) { - return Metatable[n].size; -} - void inittables () { Metatable = (mtbl_entry_t*)calloc(1, sizeof(mtbl_entry_t)); NumTables = 1; @@ -6378,7 +6369,7 @@ void inittables () { Metatable[0].size = arraysize(BuiltinTable); } -void addtable (const tbl_entry_t table) { +void addtable (const tbl_entry_t[] table) { NumTables++; Metatable = (mtbl_entry_t*)realloc(Metatable, NumTables * sizeof(mtbl_entry_t)); Metatable[NumTables-1].table = table; @@ -6388,11 +6379,11 @@ void addtable (const tbl_entry_t table) { #define getentry(x) pgm_read_ptr(__getentry(x)) tbl_entry_t* __getentry (builtin_t x) { int t = 0; - while (x >= tablesize(t)) { - x -= tablesize(t); + while (x >= Metatable[t].size) { + x -= Metatable[t].size; t++; } - return &table(t)[x]; + return &Matatable[t].table[x]; } // Table lookup functions @@ -6405,10 +6396,10 @@ builtin_t lookupbuiltin (char* c) { unsigned int end = 0, start; for (int n=0; n Date: Mon, 27 Mar 2023 18:42:22 -0400 Subject: [PATCH 023/109] Update extensions.hpp --- extensions.hpp | 50 +++++++++++++++++++------------------------------- 1 file changed, 19 insertions(+), 31 deletions(-) diff --git a/extensions.hpp b/extensions.hpp index 89db803..1630300 100644 --- a/extensions.hpp +++ b/extensions.hpp @@ -7,23 +7,23 @@ // Definitions object* fn_now (object* args, object* env) { - (void) env; - static unsigned long Offset; - unsigned long now = millis()/1000; - int nargs = listlength(args); - - // Set time - if (nargs == 3) { - Offset = (unsigned long)((checkinteger(first(args))*60 + checkinteger(second(args)))*60 - + checkinteger(third(args)) - now); - } else if (nargs > 0) error2(PSTR("wrong number of arguments")); - - // Return time - unsigned long secs = Offset + now; - object* seconds = number(secs%60); - object* minutes = number((secs/60)%60); - object* hours = number((secs/3600)%24); - return cons(hours, cons(minutes, cons(seconds, NULL))); + (void) env; + static unsigned long Offset; + unsigned long now = millis()/1000; + int nargs = listlength(args); + + // Set time + if (nargs == 3) { + Offset = (unsigned long)((checkinteger(first(args))*60 + checkinteger(second(args)))*60 + + checkinteger(third(args)) - now); + } else if (nargs > 0) error2(PSTR("wrong number of arguments")); + + // Return time + unsigned long secs = Offset + now; + object* seconds = number(secs%60); + object* minutes = number((secs/60)%60); + object* hours = number((secs/3600)%24); + return cons(hours, cons(minutes, cons(seconds, nil))); } // Symbol names @@ -35,19 +35,7 @@ const char docnow[] PROGMEM = "(now [hh mm ss])\n" "as a list of three integers (hh mm ss)."; // Symbol lookup table -const tbl_entry_t lookup_table2[] PROGMEM = { - { stringnow, fn_now, 0203, docnow }, +const tbl_entry_t ExtensionsTable[] PROGMEM = { + { stringnow, fn_now, 0203, docnow }, }; -// Table cross-reference functions - -tbl_entry_t *tables[] = {lookup_table, lookup_table2}; -const unsigned int tablesizes[] = { arraysize(lookup_table), arraysize(lookup_table2) }; - -const tbl_entry_t *table (int n) { - return tables[n]; -} - -unsigned int tablesize (int n) { - return tablesizes[n]; -} From 2e7087107f769ec0cbc9c545d9154f4512578e9f Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 18:43:17 -0400 Subject: [PATCH 024/109] indenting bad --- extensions.hpp | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/extensions.hpp b/extensions.hpp index 1630300..afd4cfa 100644 --- a/extensions.hpp +++ b/extensions.hpp @@ -7,23 +7,23 @@ // Definitions object* fn_now (object* args, object* env) { - (void) env; - static unsigned long Offset; - unsigned long now = millis()/1000; - int nargs = listlength(args); + (void) env; + static unsigned long Offset; + unsigned long now = millis()/1000; + int nargs = listlength(args); - // Set time - if (nargs == 3) { - Offset = (unsigned long)((checkinteger(first(args))*60 + checkinteger(second(args)))*60 - + checkinteger(third(args)) - now); - } else if (nargs > 0) error2(PSTR("wrong number of arguments")); + // Set time + if (nargs == 3) { + Offset = (unsigned long)((checkinteger(first(args))*60 + checkinteger(second(args)))*60 + + checkinteger(third(args)) - now); + } else if (nargs > 0) error2(PSTR("wrong number of arguments")); - // Return time - unsigned long secs = Offset + now; - object* seconds = number(secs%60); - object* minutes = number((secs/60)%60); - object* hours = number((secs/3600)%24); - return cons(hours, cons(minutes, cons(seconds, nil))); + // Return time + unsigned long secs = Offset + now; + object* seconds = number(secs%60); + object* minutes = number((secs/60)%60); + object* hours = number((secs/3600)%24); + return cons(hours, cons(minutes, cons(seconds, nil))); } // Symbol names From 0e22a56c99233c069886e83bae0486e189e7791f Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 20:28:32 -0400 Subject: [PATCH 025/109] compiler warnings (and mark location of bug) --- .gitignore | 3 +++ ulisp-esp32.ino | 2 +- ulisp.hpp | 19 ++++++++++++------- 3 files changed, 16 insertions(+), 8 deletions(-) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..6f91529 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +debug_custom.json +debug.cfg +esp32.svd diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index ef08aff..831230b 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -18,7 +18,7 @@ setup - entry point from the Arduino IDE */ void setup () { - Serial.begin(9600); + Serial.begin(115200); int start = millis(); while ((millis() - start) < 5000) { if (Serial) break; } ulispinit(); diff --git a/ulisp.hpp b/ulisp.hpp index 2c3631d..3276288 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -122,7 +122,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); // Constants -#define TRACEMAX 3; // Number of traced functions +#define TRACEMAX 3 // Number of traced functions enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; // ARRAY STRING and PAIR must be last enum token { UNUSED, BRA, KET, QUO, DOT }; enum fntypes_t { OTHER_FORMS, TAIL_FORMS, FUNCTIONS, SPECIAL_FORMS }; @@ -173,7 +173,7 @@ typedef const struct { } tbl_entry_t; typedef struct { - tbl_entry_t** table; + tbl_entry_t* table; size_t size; } mtbl_entry_t; @@ -232,6 +232,7 @@ symbol_t sym (builtin_t); void indent (uint8_t, char, pfun_t); object* lispstring (char*); uint32_t pack40 (char*); +bool valid40 (char*); char* cstring (object*, char*, int); void pint (int, pfun_t); void pintbase (uint32_t, uint8_t, pfun_t); @@ -525,7 +526,7 @@ object* internlong (char* buffer) { */ object* buftosymbol (char* b) { int l = strlen(b); - if (i <= 6 && valid40(b)) return symbol(twist(pack40(b))); + if (l <= 6 && valid40(b)) return symbol(twist(pack40(b))); else return internlong(b); } @@ -729,7 +730,7 @@ symbol_t sym (builtin_t x) { return twist(x + BUILTINS); } -const char radix40alphabet[] PROGMEM = "\0000123456789abcdefghijklmnopqrstuvwxyz-*$" +const char radix40alphabet[] PROGMEM = "\0000123456789abcdefghijklmnopqrstuvwxyz-*$"; /* toradix40 - returns a number from 0 to 39 if the character can be encoded, or -1 otherwise. @@ -6369,21 +6370,24 @@ void inittables () { Metatable[0].size = arraysize(BuiltinTable); } -void addtable (const tbl_entry_t[] table) { +void addtable (const tbl_entry_t table[]) { NumTables++; Metatable = (mtbl_entry_t*)realloc(Metatable, NumTables * sizeof(mtbl_entry_t)); Metatable[NumTables-1].table = table; Metatable[NumTables-1].size = arraysize(table); } -#define getentry(x) pgm_read_ptr(__getentry(x)) +#define getentry(x) ((tbl_entry_t*)pgm_read_ptr(__getentry(x))) tbl_entry_t* __getentry (builtin_t x) { + Serial.printf("__getentry(%hu)", x); int t = 0; while (x >= Metatable[t].size) { x -= Metatable[t].size; t++; + // THE BUG IS IN THIS FUNCTION SOMEWHERE + if (t > NumTables) error2(PSTR("foobar")); } - return &Matatable[t].table[x]; + return &Metatable[t].table[x]; } // Table lookup functions @@ -7146,6 +7150,7 @@ void initgfx () { void ulispinit () { initworkspace(); + inittables(); initenv(); initsleep(); initgfx(); From 87ce9e6de33fdf99378399c0ec0f838044cc86d8 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 27 Mar 2023 21:21:02 -0400 Subject: [PATCH 026/109] found the bug --- ulisp.hpp | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 3276288..196a632 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -6377,15 +6377,12 @@ void addtable (const tbl_entry_t table[]) { Metatable[NumTables-1].size = arraysize(table); } -#define getentry(x) ((tbl_entry_t*)pgm_read_ptr(__getentry(x))) -tbl_entry_t* __getentry (builtin_t x) { - Serial.printf("__getentry(%hu)", x); +// #define getentry(x) ((tbl_entry_t*)pgm_read_ptr(__getentry(x))) +tbl_entry_t* getentry (builtin_t x) { int t = 0; while (x >= Metatable[t].size) { x -= Metatable[t].size; t++; - // THE BUG IS IN THIS FUNCTION SOMEWHERE - if (t > NumTables) error2(PSTR("foobar")); } return &Metatable[t].table[x]; } @@ -6415,7 +6412,7 @@ builtin_t lookupbuiltin (char* c) { lookupfn - looks up the entry for name in BuiltinTable[], and returns the function entry point */ intptr_t lookupfn (builtin_t name) { - return (intptr_t)pgm_read_ptr(getentry(name)->fptr); + return (intptr_t)pgm_read_ptr(&(getentry(name)->fptr)); } /* @@ -6423,7 +6420,7 @@ intptr_t lookupfn (builtin_t name) { and minimum and maximum number of arguments for name */ minmax_t getminmax (builtin_t name) { - return pgm_read_byte(getentry(name)->minmax); + return pgm_read_byte(&(getentry(name)->minmax)); } /* @@ -6440,14 +6437,14 @@ void checkminmax (builtin_t name, int nargs) { lookupdoc - looks up the documentation string for the built-in function name */ char* lookupdoc (builtin_t name) { - return (char*)pgm_read_ptr(getentry(name)->doc); + return (char*)pgm_read_ptr(&(getentry(name)->doc)); } /* findsubstring - tests whether a specified substring occurs in the name of a built-in function */ bool findsubstring (char* part, builtin_t name) { - PGM_P s = (char*)pgm_read_ptr(getentry(name)->string); + PGM_P s = (char*)pgm_read_ptr(&(getentry(name)->string)); int l = strlen_P(s); int m = strlen(part); for (int i = 0; i <= l-m; i++) { @@ -6471,7 +6468,7 @@ void testescape () { bool keywordp (object* obj) { if (!(symbolp(obj) && builtinp(obj->name))) return false; builtin_t name = builtin(obj->name); - PGM_P s = (char*)pgm_read_ptr(getentry(name)->string); + PGM_P s = (char*)pgm_read_ptr(&(getentry(name)->string)); char c = pgm_read_byte(&s[0]); return (c == ':'); } @@ -6707,7 +6704,7 @@ void printstring (object* form, pfun_t pfun) { */ void pbuiltin (builtin_t name, pfun_t pfun) { int p = 0; - PGM_P s = (char*)pgm_read_ptr(getentry(name)->string); + PGM_P s = (char*)pgm_read_ptr(&(getentry(name)->string)); while (1) { char c = pgm_read_byte(&s[p++]); if (c == 0) return; From da2ffaf72f1ce8ce74b2a7f47f6821a258911204 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Tue, 28 Mar 2023 08:12:08 -0400 Subject: [PATCH 027/109] add some const modifiers to allow passing in a string literal --- ulisp.hpp | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 196a632..b54b024 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -482,7 +482,7 @@ inline object* bsymbol (builtin_t name) { /* eqsymbols - compares the long string/symbol obj with the string in buffer. */ -bool eqsymbols (object* obj, char* buffer) { +bool eqsymbols (object* obj, const char* buffer) { object* arg = cdr(obj); int i = 0; while (!(arg == NULL && buffer[i] == 0)) { @@ -511,7 +511,7 @@ bool eqsymbols (object* obj, char* buffer) { internlong - looks through the workspace for an existing occurrence of the long symbol in buffer and returns it, otherwise calls lispstring(buffer) to create a new symbol. */ -object* internlong (char* buffer) { +object* internlong (const char* buffer) { for (int i=0; itype == SYMBOL && longsymbolp(obj) && eqsymbols(obj, buffer)) return obj; @@ -522,9 +522,9 @@ object* internlong (char* buffer) { } /* - buftosymbol - checks the characters in buffer and calls intern() or internlong() to make it a symbol. + buftosymbol - checks the characters in buffer and calls symbol() or internlong() to make it a symbol. */ -object* buftosymbol (char* b) { +object* buftosymbol (const char* b) { int l = strlen(b); if (l <= 6 && valid40(b)) return symbol(twist(pack40(b))); else return internlong(b); @@ -1387,7 +1387,7 @@ void pstr (char c) { /* lispstring - converts a C string to a Lisp string */ -object* lispstring (char* s) { +object* lispstring (const char* s) { object* obj = newstring(); object* tail = obj; while(1) { From e0d37e672a9c43af6ededd0670afd308de8ebcec Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Tue, 28 Mar 2023 08:19:47 -0400 Subject: [PATCH 028/109] extraneous forward references --- ulisp.hpp | 3 --- 1 file changed, 3 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index b54b024..ef3a0ee 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -246,7 +246,6 @@ object* findpair (object*, object*); object* findvalue (object*, object*); char* lookupdoc (builtin_t); void printsymbol (object*, pfun_t); -void psymbol (symbol_t, pfun_t); bool findsubstring (char*, builtin_t); bool stringcompare (object*, bool, bool, bool); void pbuiltin (builtin_t, pfun_t); @@ -259,8 +258,6 @@ object* eval (object*, object*); void repl (object*); void prin1object (object*, pfun_t); void plispstr (symbol_t, pfun_t); -void printstring (object*, pfun_t); -void psymbol (symbol_t, pfun_t); void testescape (); From a2024faec72391ace1ed8e0a0b1ac0f022133d01 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Tue, 28 Mar 2023 08:21:40 -0400 Subject: [PATCH 029/109] add gensym --- extensions.hpp | 30 +++++++++++++++++++++++++----- 1 file changed, 25 insertions(+), 5 deletions(-) diff --git a/extensions.hpp b/extensions.hpp index afd4cfa..6ceab50 100644 --- a/extensions.hpp +++ b/extensions.hpp @@ -2,7 +2,6 @@ User Extensions */ #include -#define extensions #include "ulisp.hpp" // Definitions @@ -26,16 +25,37 @@ object* fn_now (object* args, object* env) { return cons(hours, cons(minutes, cons(seconds, nil))); } -// Symbol names const char stringnow[] PROGMEM = "now"; - -// Documentation strings const char docnow[] PROGMEM = "(now [hh mm ss])\n" "Sets the current time, or with no arguments returns the current time\n" "as a list of three integers (hh mm ss)."; +object* fn_gensym (object* args, object* env) { + int counter = 0; + char* buffer[BUFFERSIZE]; + char* prefix[BUFFERSIZE]; + if (args != NULL) { + prefix = cstring(first(args), prefix, BUFFERSIZE); + } else { + prefix = "$gensym"; + } + object* result; + do { + snprintf(buffer, BUFFERSIZE, "%s%i", prefix, counter); + result = internlong(buffer); + counter++; + } while (boundp(result, env) || boundp(result, GlobalEnv)); + return result; +} + +const char stringgensym[] PROGMEM = "gensym"; +const char docgensym[] PROGMEM = "(gensym [prefix])\n" +"Returns a new symbol, optionally beginning with prefix (which must be a string).\n" +"The returned symbol is guaranteed to not conflict with any existing bound symbol."; + // Symbol lookup table const tbl_entry_t ExtensionsTable[] PROGMEM = { - { stringnow, fn_now, 0203, docnow }, + { stringnow, fn_now, MINMAX(FUNCTIONS, 0, 3), docnow }, + { stringgensym, fn_gensym, MINMAX(FUNCTIONS, 0, 1), docgensym }, }; From 298c6b42bf6a04cef071b261c203c604f9dd761d Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Tue, 28 Mar 2023 08:29:05 -0400 Subject: [PATCH 030/109] add intern --- extensions.hpp | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/extensions.hpp b/extensions.hpp index 6ceab50..710482d 100644 --- a/extensions.hpp +++ b/extensions.hpp @@ -1,5 +1,5 @@ /* - User Extensions + User Extensions */ #include #include "ulisp.hpp" @@ -35,14 +35,14 @@ object* fn_gensym (object* args, object* env) { char* buffer[BUFFERSIZE]; char* prefix[BUFFERSIZE]; if (args != NULL) { - prefix = cstring(first(args), prefix, BUFFERSIZE); + prefix = cstring(checkstring(first(args)), prefix, BUFFERSIZE); } else { prefix = "$gensym"; } object* result; do { snprintf(buffer, BUFFERSIZE, "%s%i", prefix, counter); - result = internlong(buffer); + result = buftosymbol(buffer); counter++; } while (boundp(result, env) || boundp(result, GlobalEnv)); return result; @@ -53,9 +53,21 @@ const char docgensym[] PROGMEM = "(gensym [prefix])\n" "Returns a new symbol, optionally beginning with prefix (which must be a string).\n" "The returned symbol is guaranteed to not conflict with any existing bound symbol."; +object* fn_intern (object* args, object* env) { + char* b[BUFFERSIZE]; + return buftosymbol(cstring(checkstring(first(args)), b, BUFFERSIZE)); +} + +const char stringintern[] PROGMEM = "intern"; +const char docintern[] PROGMEM = "(intern string)\n" +"Creates a symbol, with the same name as the string.\n" +"Unlike gensym, the returned symbol is not modified from the string in any way,\n" +"and so it may be bound."; + // Symbol lookup table const tbl_entry_t ExtensionsTable[] PROGMEM = { { stringnow, fn_now, MINMAX(FUNCTIONS, 0, 3), docnow }, { stringgensym, fn_gensym, MINMAX(FUNCTIONS, 0, 1), docgensym }, + { stringintern, fn_intern, MINMAX(FUNCTIONS, 1, 1), docintern }, }; From 67ebad29a00319b26c9fdfdd9954e7c541872854 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Tue, 28 Mar 2023 08:41:37 -0400 Subject: [PATCH 031/109] add sizeof --- extensions.hpp | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/extensions.hpp b/extensions.hpp index 710482d..2a4e92f 100644 --- a/extensions.hpp +++ b/extensions.hpp @@ -64,10 +64,28 @@ const char docintern[] PROGMEM = "(intern string)\n" "Unlike gensym, the returned symbol is not modified from the string in any way,\n" "and so it may be bound."; +object* fn_sizeof (object* args, object* env) { + int count = 0; + markobject(first(args)); + for (int i=0; i Date: Tue, 28 Mar 2023 09:24:23 -0400 Subject: [PATCH 032/109] document extensions --- README.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/README.md b/README.md index bdc565f..fa95ff8 100644 --- a/README.md +++ b/README.md @@ -15,3 +15,11 @@ Patches: * Added: Lisp `:keywords` that auto-quote themselves * Added: Ability to add multiple (more than one) extension tables (using `calloc()`) *may not be portable to other platforms* * + +Extensions (`extensinos.hpp`): + +* `now` (provided by David) +* `gensym` +* `intern` +* `sizeof` +* From bbcd5b3e05cc69d2dd86ad8673704f8cccd5b80f Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Tue, 28 Mar 2023 12:57:48 -0400 Subject: [PATCH 033/109] include the extensions --- ulisp-esp32.ino | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index 831230b..000c5b2 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -13,6 +13,7 @@ // Includes #include "ulisp.hpp" +#include "extensions.hpp" /* setup - entry point from the Arduino IDE @@ -22,6 +23,7 @@ void setup () { int start = millis(); while ((millis() - start) < 5000) { if (Serial) break; } ulispinit(); + addtable(ExtensionsTable); pfstring(PSTR("uLisp 4.4 "), pserial); pln(pserial); } From 81aef881500d0cf299bf18cb95c1a9ef8e9095a7 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Tue, 28 Mar 2023 20:04:05 -0400 Subject: [PATCH 034/109] compiler issues also a fix for technoblogy#61 --- extensions.hpp | 11 +++++------ ulisp.hpp | 26 ++++++++++++++++---------- 2 files changed, 21 insertions(+), 16 deletions(-) diff --git a/extensions.hpp b/extensions.hpp index 2a4e92f..6652ea0 100644 --- a/extensions.hpp +++ b/extensions.hpp @@ -32,12 +32,12 @@ const char docnow[] PROGMEM = "(now [hh mm ss])\n" object* fn_gensym (object* args, object* env) { int counter = 0; - char* buffer[BUFFERSIZE]; - char* prefix[BUFFERSIZE]; + char buffer[BUFFERSIZE]; + char prefix[BUFFERSIZE]; if (args != NULL) { - prefix = cstring(checkstring(first(args)), prefix, BUFFERSIZE); + cstring(checkstring(first(args)), prefix, BUFFERSIZE); } else { - prefix = "$gensym"; + strcpy(prefix, "$gensym"); } object* result; do { @@ -54,7 +54,7 @@ const char docgensym[] PROGMEM = "(gensym [prefix])\n" "The returned symbol is guaranteed to not conflict with any existing bound symbol."; object* fn_intern (object* args, object* env) { - char* b[BUFFERSIZE]; + char b[BUFFERSIZE]; return buftosymbol(cstring(checkstring(first(args)), b, BUFFERSIZE)); } @@ -88,4 +88,3 @@ const tbl_entry_t ExtensionsTable[] PROGMEM = { { stringintern, fn_intern, MINMAX(FUNCTIONS, 1, 1), docintern }, { stringsizeof, fn_sizeof, MINMAX(FUNCTIONS, 1, 1), docsizeof }, }; - diff --git a/ulisp.hpp b/ulisp.hpp index ef3a0ee..2b932d8 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -102,8 +102,6 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define issp(x) (x == ' ' || x == '\n' || x == '\r' || x == '\t') #define isbr(x) (x == ')' || x == '(' || x == '"' || x == '#') #define longsymbolp(x) (((x)->name & 0x03) == 0) -#define twist(x) ((uint32_t)((x)<<2) | (((x) & 0xC0000000)>>30)) -#define untwist(x) (((x)>>2 & 0x3FFFFFFF) | ((x) & 0x03)<<30) #define arraysize(x) (sizeof(x) / sizeof(x[0])) #define stringifyX(x) #x #define stringify(x) stringifyX(x) @@ -230,9 +228,9 @@ void psymbol (symbol_t, pfun_t); void printobject (object*, pfun_t); symbol_t sym (builtin_t); void indent (uint8_t, char, pfun_t); -object* lispstring (char*); -uint32_t pack40 (char*); -bool valid40 (char*); +object* lispstring (const char*); +uint32_t pack40 (const char*); +bool valid40 (const char*); char* cstring (object*, char*, int); void pint (int, pfun_t); void pintbase (uint32_t, uint8_t, pfun_t); @@ -260,6 +258,13 @@ void prin1object (object*, pfun_t); void plispstr (symbol_t, pfun_t); void testescape (); +inline uint32_t twist (uint32_t x) { + return (x<<2) | ((x & 0xC0000000)>>30); +} + +inline uint32_t untwist (uint32_t x) { + return (x>>2 & 0x3FFFFFFF) | ((x & 0x03)<<30); +} // Error handling @@ -751,7 +756,7 @@ char fromradix40 (char n) { /* pack40 - packs six radix40-encoded characters from buffer into a 32-bit number and returns it. */ -uint32_t pack40 (char* buffer) { +uint32_t pack40 (const char* buffer) { int x = 0, gz = 0, c = 0; for (int i=0; i<6; i++) { if (gz) c = 0; @@ -766,7 +771,7 @@ uint32_t pack40 (char* buffer) { /* valid40 - returns true if the symbol in buffer can be encoded as six radix40-encoded characters. */ -bool valid40 (char* buffer) { +bool valid40 (const char* buffer) { int t = 11; for (int i=0; i<6; i++){ if (toradix40(buffer[i]) < t) return false; @@ -6367,14 +6372,14 @@ void inittables () { Metatable[0].size = arraysize(BuiltinTable); } -void addtable (const tbl_entry_t table[]) { +#define addtable(x) __addtable(x, arraysize(x)) +void __addtable (const tbl_entry_t table[], size_t sz) { NumTables++; Metatable = (mtbl_entry_t*)realloc(Metatable, NumTables * sizeof(mtbl_entry_t)); Metatable[NumTables-1].table = table; - Metatable[NumTables-1].size = arraysize(table); + Metatable[NumTables-1].size = sz; } -// #define getentry(x) ((tbl_entry_t*)pgm_read_ptr(__getentry(x))) tbl_entry_t* getentry (builtin_t x) { int t = 0; while (x >= Metatable[t].size) { @@ -6495,6 +6500,7 @@ object* eval (object* form, object* env) { pair = value(name, GlobalEnv); if (pair != NULL) return cdr(pair); else if (builtinp(name)) return form; + Context = NIL; error(PSTR("undefined"), form); } From 13c3a2a2a3536b09ddd9619ae7a8b312e173e1fa Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Thu, 30 Mar 2023 09:38:42 -0400 Subject: [PATCH 035/109] *experimental* throw/catch support (untested as of now) --- ulisp.hpp | 94 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 94 insertions(+) diff --git a/ulisp.hpp b/ulisp.hpp index 2b932d8..9e97577 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -215,6 +215,7 @@ volatile uint8_t Flags = 0b00001; // PRINTREADABLY set by default // Forward references object* tee; +object* Thrown; bool keywordp (object*); void pfstring (PGM_P, pfun_t); char nthchar (object*, int); @@ -610,6 +611,7 @@ void gc (object* form, object* env) { static int GC_Count = 0; #endif markobject(tee); + markobject(Thrown); markobject(GlobalEnv); markobject(GCStack); markobject(form); @@ -5377,6 +5379,84 @@ object* fn_invertdisplay (object* args, object* env) { return nil; } +/////////////////////////////////////////////////////////// +// Experimental (catch) / (throw) support +// also see Thrown global variable and garbage collector + +/* + (catch 'tag form*) + Evaluates the forms, and of any of them call (throw) with the same + tag, returns the "thrown" value. If none throw, returns the value returned by the + last form. +*/ + +object* sp_catch (object* args, object* env) { + object* current_GCStack = GCStack; + + bool top = handler == &toplevel_handler; + jmp_buf dynamic_handler; + jmp_buf *previous_handler = handler; + handler = &dynamic_handler; + + object* tag = first(args); + object* forms = rest(args); + push(tag, GCStack); + tag = eval(tag, env); + car(GCStack) = tag; + push(forms, GCStack); + + object* result; + + if (!setjmp(dynamic_handler)) { + // First: run forms + result = eval(tf_progn(forms, env), env); + // If we get here nothing was thrown + pop(GCStack); + pop(GCStack); + handler = previous_handler; + return result; + } else { + // Something was thrown, check if it is the same tag + GCStack = current_GCStack; + handler = previous_handler; + if (Thrown == NULL || !eq(car(Thrown), tag)) { + // Nothing thrown + if (!top) { + GCStack = NULL; + longjmp(*handler, 1); + } else { + error(PSTR("no matching tag"), tag); + } + } else { + // Caught! + pop(GCStack); + pop(GCStack); + result = cdr(Thrown); + Thrown = NULL; + return result; + } + } +} + +/* + (throw 'tag [value]) + Exits the (catch) form opened with the same tag (using eq). + It is invalid to call (throw) with a tag that isn't + already registered with (catch) -- undefined behavior will result. +*/ +object* fn_throw (object* args, object* env) { + object* tag = first(args); + args = rest(args); + object* value = NULL; + if (args != NULL) value = first(args); + Thrown = cons(tag, value); + longjmp(*handler, 1); + // unreachable + return NULL; +} + +/////////////////////////////////////////////////////////// + // Built-in symbol names const char string0[] PROGMEM = "nil"; const char string1[] PROGMEM = "t"; @@ -5612,6 +5692,9 @@ const char string230[] PROGMEM = ":input-pullup"; const char string231[] PROGMEM = ":input-pulldown"; const char string232[] PROGMEM = ":output"; +const char stringcatch[] PROGMEM = "catch"; +const char stringthrow[] PROGMEM = "throw"; + // Documentation strings const char doc0[] PROGMEM = "nil\n" "A symbol equivalent to the empty list (). Also represents false."; @@ -6128,6 +6211,15 @@ const char doc224[] PROGMEM = "(set-rotation option)\n" const char doc225[] PROGMEM = "(invert-display boolean)\n" "Mirror-images the display."; +const char doccatch[] PROGMEM = "(catch 'tag form*)\n" +"Evaluates the forms, and of any of them call (throw) with the same\n" +"tag, returns the \"thrown\" value. If none throw, returns the value returned by the\n" +"last form."; +const char docthrow[] PROGMEM = "(throw 'tag [value])\n" +"Exits the (catch) form opened with the same tag (using eq).\n" +"It is invalid to call (throw) with a tag that isn't\n" +"already registered with (catch) -- undefined behavior will result."; + // Built-in symbol lookup table const tbl_entry_t BuiltinTable[] PROGMEM = { { string0, NULL, MINMAX(OTHER_FORMS, 0, 0), doc0 }, @@ -6361,6 +6453,8 @@ const tbl_entry_t BuiltinTable[] PROGMEM = { { string230, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, { string231, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, { string232, (fn_ptr_type)OUTPUT, PINMODE, NULL }, + { stringcatch, sp_catch, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doccatch }, + { stringthrow, fn_throw, MINMAX(FUNCTIONS, 1, 2), docthrow }, }; // Metatable cross-reference functions From 2ee0edb3a5f57e0cbaeb919d7d847d6fc158f654 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Thu, 30 Mar 2023 10:55:00 -0400 Subject: [PATCH 036/109] add `(load)` --- ulisp.hpp | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/ulisp.hpp b/ulisp.hpp index 9e97577..38077f8 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -21,7 +21,14 @@ // Lisp Library #ifndef LispLibrary -const char LispLibrary[] PROGMEM = ""; +const char LispLibrary[] PROGMEM = +"(defun load (filename)" + "(with-sd-card (f filename)" + "(loop" + "(let ((form (read f)))" + "(unless form (return))" + "(eval form)))))" +; #endif // Compile options From d47b0239054c803aa6fc7f2099c5f41f19c5c9f2 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Thu, 30 Mar 2023 10:57:04 -0400 Subject: [PATCH 037/109] undo --- ulisp.hpp | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 38077f8..9e97577 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -21,14 +21,7 @@ // Lisp Library #ifndef LispLibrary -const char LispLibrary[] PROGMEM = -"(defun load (filename)" - "(with-sd-card (f filename)" - "(loop" - "(let ((form (read f)))" - "(unless form (return))" - "(eval form)))))" -; +const char LispLibrary[] PROGMEM = ""; #endif // Compile options From ba01e5b1a7720ca4d793c4f9a3241d64d1078110 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Thu, 30 Mar 2023 11:10:47 -0400 Subject: [PATCH 038/109] add test sdmain using c++ lambda --- ulisp-esp32.ino | 36 +++++++++++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index 000c5b2..451e083 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -15,6 +15,39 @@ #include "ulisp.hpp" #include "extensions.hpp" +const char foo[] PROGMEM = +"(defun load (filename)" + "(with-sd-card (f filename)" + "(loop" + "(let ((form (read f)))" + "(unless form (return))" + "(eval form)))))" +"(load \"main.lisp\")" +; +const size_t foolen = arraylength(foo); + +/* + sdmain - Run main.lisp on startup +*/ +void sdmain () { + size_t i = 0; + auto fooread = [i=]() -> int { + if (i == foolen) return -1; + char c = (char)pgm_read_byte(&foo[i]); + i++; + return c; + }; + if (setjmp(toplevel_handler)) return; + object* fooform; + for(;;) { + fooform = read(fooread); + if (fooform == NULL) return; + push(fooform, GCstack); + eval(fooform, NULL); + pop(GCstack); + } +} + /* setup - entry point from the Arduino IDE */ @@ -24,7 +57,8 @@ void setup () { while ((millis() - start) < 5000) { if (Serial) break; } ulispinit(); addtable(ExtensionsTable); - pfstring(PSTR("uLisp 4.4 "), pserial); pln(pserial); + Serial.println(F("uLisp 4.4!")); + sdmain(); } /* From c6fd6bcd6742d36b7578e2b185c7aee5ba929323 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Thu, 30 Mar 2023 14:21:39 -0400 Subject: [PATCH 039/109] *experimental* quasiquote support (untested) --- ulisp-esp32.ino | 10 +-- ulisp.hpp | 157 +++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 130 insertions(+), 37 deletions(-) diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index 451e083..e4a8479 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -16,16 +16,12 @@ #include "extensions.hpp" const char foo[] PROGMEM = -"(defun load (filename)" - "(with-sd-card (f filename)" - "(loop" - "(let ((form (read f)))" - "(unless form (return))" - "(eval form)))))" +// "compressed" lisp code omits unnecessary spaces +"(defun load(filename)(with-sd-card(f filename)(loop(let((form(read f)))(unless form(return))(eval form)))))" "(load \"main.lisp\")" ; const size_t foolen = arraylength(foo); - + /* sdmain - Run main.lisp on startup */ diff --git a/ulisp.hpp b/ulisp.hpp index 9e97577..1e36be1 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -122,7 +122,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define TRACEMAX 3 // Number of traced functions enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; // ARRAY STRING and PAIR must be last -enum token { UNUSED, BRA, KET, QUO, DOT }; +enum token { UNUSED, OPEN_PAREN, CLOSE_PAREN, SINGLE_QUOTE, PERIOD }; enum fntypes_t { OTHER_FORMS, TAIL_FORMS, FUNCTIONS, SPECIAL_FORMS }; // Stream names used by printobject @@ -141,6 +141,7 @@ enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM typedef uint32_t symbol_t; typedef uint8_t minmax_t; typedef uint16_t builtin_t; +typedef uint16_t flags_t; typedef struct sobject { union { @@ -179,7 +180,7 @@ typedef int (*gfun_t)(); typedef void (*pfun_t)(char); enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, LET, LETSTAR, -CLOSURE, PSTAR, QUOTE, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, +CLOSURE, PSTAR, QUOTE, QUASIQUOTE, UNQUOTE, UNQUOTESPLICING, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, ANALOGREAD, REGISTER, FORMAT, }; @@ -199,6 +200,7 @@ object* GlobalEnv; object* GCStack = NULL; object* GlobalString; object* GlobalStringTail; +object* Thrown; int GlobalStringIndex = 0; uint8_t PrintCount = 0; uint8_t BreakLevel = 0; @@ -210,12 +212,11 @@ unsigned int TraceFn[TRACEMAX]; unsigned int TraceDepth[TRACEMAX]; // Flags -enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, NOECHO, MUFFLEERRORS }; -volatile uint8_t Flags = 0b00001; // PRINTREADABLY set by default +enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, NOECHO, MUFFLEERRORS, INCATCH }; +volatile flags_t Flags = 0b00001; // PRINTREADABLY set by default // Forward references object* tee; -object* Thrown; bool keywordp (object*); void pfstring (PGM_P, pfun_t); char nthchar (object*, int); @@ -4353,7 +4354,7 @@ object* fn_writestring (object* args, object* env) { (void) env; object* obj = first(args); pfun_t pfun = pstreamfun(cdr(args)); - char temp = Flags; + flags_t temp = Flags; clrflag(PRINTREADABLY); printstring(obj, pfun); Flags = temp; @@ -4368,7 +4369,7 @@ object* fn_writeline (object* args, object* env) { (void) env; object* obj = first(args); pfun_t pfun = pstreamfun(cdr(args)); - char temp = Flags; + flags_t temp = Flags; clrflag(PRINTREADABLY); printstring(obj, pfun); pln(pfun); @@ -4812,7 +4813,7 @@ object* sp_help (object* args, object* env) { if (args == NULL) error2(noargument); object* docstring = documentation(first(args), env); if (docstring) { - char temp = Flags; + flags_t temp = Flags; clrflag(PRINTREADABLY); printstring(docstring, pserial); Flags = temp; @@ -4922,7 +4923,7 @@ object* sp_ignoreerrors (object* args, object* env) { object* sp_error (object* args, object* env) { object* message = eval(cons(bsymbol(FORMAT), cons(nil, args)), env); if (!tstflag(MUFFLEERRORS)) { - char temp = Flags; + flags_t temp = Flags; clrflag(PRINTREADABLY); pfstring(PSTR("Error: "), pserial); printstring(message, pserial); Flags = temp; @@ -5393,11 +5394,13 @@ object* fn_invertdisplay (object* args, object* env) { object* sp_catch (object* args, object* env) { object* current_GCStack = GCStack; - bool top = handler == &toplevel_handler; jmp_buf dynamic_handler; jmp_buf *previous_handler = handler; handler = &dynamic_handler; + flags_t temp = Flags; + setflag(INCATCH); + object* tag = first(args); object* forms = rest(args); push(tag, GCStack); @@ -5414,17 +5417,21 @@ object* sp_catch (object* args, object* env) { pop(GCStack); pop(GCStack); handler = previous_handler; + Flags = temp; return result; } else { // Something was thrown, check if it is the same tag GCStack = current_GCStack; handler = previous_handler; + Flags = temp; if (Thrown == NULL || !eq(car(Thrown), tag)) { - // Nothing thrown - if (!top) { + // Nothing thrown or wrong tag + if (tstflag(INCATCH)) { + // Try next-in-line catch GCStack = NULL; longjmp(*handler, 1); } else { + // No upper catch error(PSTR("no matching tag"), tag); } } else { @@ -5441,10 +5448,11 @@ object* sp_catch (object* args, object* env) { /* (throw 'tag [value]) Exits the (catch) form opened with the same tag (using eq). - It is invalid to call (throw) with a tag that isn't - already registered with (catch) -- undefined behavior will result. + It is an error to call (throw) without first entering a (catch) with + the same tag. */ object* fn_throw (object* args, object* env) { + if (!tstflag(INCATCH)) error2(PSTR("not in a catch")); object* tag = first(args); args = rest(args); object* value = NULL; @@ -5457,6 +5465,89 @@ object* fn_throw (object* args, object* env) { /////////////////////////////////////////////////////////// +/////////////////////////////////////////////////////////// +// Experimental QUASIQUOTE support + +#define nope ((object*)-3) + +// From https://github.com/kanaka/mal/issues/103#issuecomment-159047401 +object* unquote (object* arg, object* env, int level) { + if (arg == NULL || atom(arg)) return cons(bsymbol(QUOTE), cons(arg, NULL)); + object* what = first(arg); + object* result; + object* result2; + if (what->type == SYMBOL) { + switch (builtin(what->name)) { + case QUASIQUOTE: + push(second(arg), GCStack); + result = unquote(second(arg), env, level + 1); + pop(GCStack); + return cons(cons(bsymbol(QUASIQUOTE), result), NULL); + case UNQUOTE: + if (level == 1) { + push(second(arg), GCStack); + result = unquote(second(arg), env, level); + car(GCStack) = result; + result = eval(car(result), env); + pop(GCStack); + return cons(result, NULL); + } else { + push(second(arg), GCStack); + result = unquote(second(arg), env, level - 1); + pop(GCStack); + return cons(cons(bsymbol(UNQUOTE), result), NULL); + } + case UNQUOTESPLICING: + if (level == 1) { + push(second(arg), GCStack); + result = unquote(second(arg), env, level); + car(GCStack) = result; + result = eval(car(result), env); + pop(GCStack); + if (result == NULL) return nope; + else return result; + } else { + push(second(arg), GCStack); + result = unquote(second(arg), env, level - 1); + pop(GCStack); + return cons(cons(bsymbol(UNQUOTESPLICING), result), NULL); + } + default: + goto notspecial; + } + } else { + notspecial: + for (object* x = arg; x != NULL, x = cdr(x)) { + push(car(x), GCStack); + object* foo = unquote(car(x), env, level); + pop(GCStack); + if (foo != nope) push(foo, result); + } + // Reverse and flatten + for (object* y = result; y != NULL, y = cdr(y)) { + if (atom(car(y))) push(car(y), result2); + else for (object* z = car(y), z != NULL, z = cdr(c)) push(car(z), result2); + } + return cons(result2, NULL); + } +} + +object* sp_quasiquote (object* args, object* env) { + push(first(args), GCStack); + object* result = unquote(first(args), env, 1); + pop(GCStack); + return result; +} + +object* sp_unquote_invalid (object* args, object* env) { + (void)args, (void)env; + error2(PSTR("not valid outside quasiquote")); + // unreachable + return NULL; +} + +/////////////////////////////////////////////////////////// + // Built-in symbol names const char string0[] PROGMEM = "nil"; const char string1[] PROGMEM = "t"; @@ -5472,6 +5563,9 @@ const char string10[] PROGMEM = "let*"; const char string11[] PROGMEM = "closure"; const char string12[] PROGMEM = "*pc*"; const char string13[] PROGMEM = "quote"; +const char stringquasiquote[] PROGMEM = "quasiquote"; +const char stringunquote[] PROGMEM = "unquote"; +const char stringuqsplicing[] PROGMEM = "unquote-splicing"; const char string14[] PROGMEM = "defun"; const char string15[] PROGMEM = "defvar"; const char string16[] PROGMEM = "car"; @@ -6217,8 +6311,8 @@ const char doccatch[] PROGMEM = "(catch 'tag form*)\n" "last form."; const char docthrow[] PROGMEM = "(throw 'tag [value])\n" "Exits the (catch) form opened with the same tag (using eq).\n" -"It is invalid to call (throw) with a tag that isn't\n" -"already registered with (catch) -- undefined behavior will result."; +"It is an error to call (throw) without first entering a (catch) with\n" +"the same tag."; // Built-in symbol lookup table const tbl_entry_t BuiltinTable[] PROGMEM = { @@ -6236,6 +6330,9 @@ const tbl_entry_t BuiltinTable[] PROGMEM = { { string11, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), NULL }, { string12, NULL, MINMAX(OTHER_FORMS, 0, UNLIMITED), NULL }, { string13, sp_quote, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, + { stringquasiquote, sp_quasiquote, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, + { stringunquote, sp_uq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, + { stringuqsplicing, sp_uq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, { string14, sp_defun, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc14 }, { string15, sp_defvar, MINMAX(SPECIAL_FORMS, 1, 3), doc15 }, { string16, fn_car, MINMAX(FUNCTIONS, 1, 1), doc16 }, @@ -6996,7 +7093,7 @@ void printobject (object* form, pfun_t pfun) { prin1object - prints any Lisp object to the specified stream escaping special characters */ void prin1object (object* form, pfun_t pfun) { - char temp = Flags; + char flags_t = Flags; clrflag(PRINTREADABLY); printobject(form, pfun); Flags = temp; @@ -7060,9 +7157,9 @@ object* nextitem (gfun_t gfun) { } if (ch == '\n') ch = gfun(); if (ch == -1) return nil; - if (ch == ')') return (object*)KET; - if (ch == '(') return (object*)BRA; - if (ch == '\'') return (object*)QUO; + if (ch == ')') return (object*)CLOSE_PAREN; + if (ch == '(') return (object*)OPEN_PAREN; + if (ch == '\'') return (object*)SINGLE_QUOTE; // Parse string if (ch == '"') return readstring('"', gfun); @@ -7085,7 +7182,7 @@ object* nextitem (gfun_t gfun) { } else if (ch == '.') { buffer[index++] = ch; ch = gfun(); - if (ch == ' ') return (object*)DOT; + if (ch == ' ') return (object*)PERIOD; isfloat = true; } @@ -7187,12 +7284,12 @@ object* readrest (gfun_t gfun) { object* head = NULL; object* tail = NULL; - while (item != (object*)KET) { - if (item == (object*)BRA) { + while (item != (object*)CLOSE_PAREN) { + if (item == (object*)OPEN_PAREN) { item = readrest(gfun); - } else if (item == (object*)QUO) { + } else if (item == (object*)SINGLE_QUOTE) { item = cons(bsymbol(QUOTE), cons(read(gfun), NULL)); - } else if (item == (object*)DOT) { + } else if (item == (object*)PERIOD) { tail->cdr = read(gfun); if (readrest(gfun) != NULL) error2(PSTR("malformed list")); return head; @@ -7212,10 +7309,10 @@ object* readrest (gfun_t gfun) { */ object* read (gfun_t gfun) { object* item = nextitem(gfun); - if (item == (object*)KET) error2(PSTR("incomplete list")); - if (item == (object*)BRA) return readrest(gfun); - if (item == (object*)DOT) return read(gfun); - if (item == (object*)QUO) return cons(bsymbol(QUOTE), cons(read(gfun), NULL)); + if (item == (object*)CLOSE_PAREN) error2(PSTR("incomplete list")); + if (item == (object*)OPEN_PAREN) return readrest(gfun); + if (item == (object*)PERIOD) return read(gfun); + if (item == (object*)SINGLE_QUOTE) return cons(bsymbol(QUOTE), cons(read(gfun), NULL)); return item; } @@ -7270,7 +7367,7 @@ void repl (object* env) { Context = 0; object* line = read(gserial); if (BreakLevel && line == nil) { pln(pserial); return; } - if (line == (object*)KET) error2(PSTR("unmatched right bracket")); + if (line == (object*)CLOSE_PAREN) error2(PSTR("unmatched right bracket")); push(line, GCStack); pfl(pserial); line = eval(line, env); From 45cb2b426dc4d3e76fd91d2b1acafb325dd15765 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Thu, 30 Mar 2023 14:30:48 -0400 Subject: [PATCH 040/109] typo --- ulisp.hpp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 1e36be1..7b376f6 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -5539,7 +5539,7 @@ object* sp_quasiquote (object* args, object* env) { return result; } -object* sp_unquote_invalid (object* args, object* env) { +object* qq_invalid (object* args, object* env) { (void)args, (void)env; error2(PSTR("not valid outside quasiquote")); // unreachable @@ -6331,8 +6331,8 @@ const tbl_entry_t BuiltinTable[] PROGMEM = { { string12, NULL, MINMAX(OTHER_FORMS, 0, UNLIMITED), NULL }, { string13, sp_quote, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, { stringquasiquote, sp_quasiquote, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, - { stringunquote, sp_uq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, - { stringuqsplicing, sp_uq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, + { stringunquote, qq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, + { stringuqsplicing, qq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, { string14, sp_defun, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc14 }, { string15, sp_defvar, MINMAX(SPECIAL_FORMS, 1, 3), doc15 }, { string16, fn_car, MINMAX(FUNCTIONS, 1, 1), doc16 }, From 70368948fcfa9ff7463a8fbf49a91c6d749fcd3d Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Thu, 30 Mar 2023 21:59:25 -0400 Subject: [PATCH 041/109] Fix throw, catch, bugs (technoblogy#62) --- .gitignore | 1 + README.md | 7 +++++- ulisp-esp32.ino | 42 +++++++++++++++++++++++------------- ulisp.hpp | 57 +++++++++++++++++++++++++++---------------------- 4 files changed, 66 insertions(+), 41 deletions(-) diff --git a/.gitignore b/.gitignore index 6f91529..7e82a15 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ debug_custom.json debug.cfg esp32.svd +debug.svd diff --git a/README.md b/README.md index fa95ff8..dcdd1ed 100644 --- a/README.md +++ b/README.md @@ -14,7 +14,12 @@ Patches: * Deleted: line-editor support (you can just use `rlwrap` if you have it) * Added: Lisp `:keywords` that auto-quote themselves * Added: Ability to add multiple (more than one) extension tables (using `calloc()`) *may not be portable to other platforms* -* +* Added: Lisp `(throw)` and `(catch)` +* Added: ***EXPERIMENTAL, BUGGY, AND PROBABLY INCORRECT*** quasiquote/unquote/unquote-splicing (no reader support yet) +* Added: Auto-run contents of `main.lisp` (on microSD card) at startup +* Modified: SD-card functions now include filename in error messages +* Fixed: various malformed-input panics (technoblogy#62) +* Fixed: special forms don't need to call `checkargs()` because it is automatically called Extensions (`extensinos.hpp`): diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index e4a8479..ed99fc2 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -3,6 +3,12 @@ Licensed under the MIT license: https://opensource.org/licenses/MIT */ + +#include +#include +#include +#include + // Compile options #define printfreespace @@ -10,37 +16,43 @@ #define sdcardsupport // #define gfxsupport // #define lisplibrary +#define toneimplemented // Includes #include "ulisp.hpp" #include "extensions.hpp" const char foo[] PROGMEM = -// "compressed" lisp code omits unnecessary spaces -"(defun load(filename)(with-sd-card(f filename)(loop(let((form(read f)))(unless form(return))(eval form)))))" -"(load \"main.lisp\")" +"(defun load (filename) (with-sd-card (f filename) (loop (let ((form (read f))) (unless form (return)) (eval form)))))\n" +"(load \"main.lisp\")\n" ; -const size_t foolen = arraylength(foo); +const size_t foolen = arraysize(foo); +size_t fooi = 0; +int getfoo() { + if (LastChar) { + char temp = LastChar; + LastChar = 0; + return temp; + } + if (fooi == foolen) return -1; + char c = (char)pgm_read_byte(&foo[fooi]); + fooi++; + return c; +} /* sdmain - Run main.lisp on startup */ void sdmain () { - size_t i = 0; - auto fooread = [i=]() -> int { - if (i == foolen) return -1; - char c = (char)pgm_read_byte(&foo[i]); - i++; - return c; - }; + SD.begin(); if (setjmp(toplevel_handler)) return; object* fooform; for(;;) { - fooform = read(fooread); + fooform = read(getfoo); if (fooform == NULL) return; - push(fooform, GCstack); + push(fooform, GCStack); eval(fooform, NULL); - pop(GCstack); + pop(GCStack); } } @@ -53,7 +65,7 @@ void setup () { while ((millis() - start) < 5000) { if (Serial) break; } ulispinit(); addtable(ExtensionsTable); - Serial.println(F("uLisp 4.4!")); + Serial.println(F("\n\n\nuLisp 4.4!")); sdmain(); } diff --git a/ulisp.hpp b/ulisp.hpp index 7b376f6..0ccd4c9 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -386,7 +386,10 @@ void initworkspace () { myalloc - returns the first object from the linked list of free objects */ object* myalloc () { - if (Freespace == 0) error2(PSTR("no room")); + if (Freespace == 0) { + Context = NIL; + error2(PSTR("out of memory")); + } object* temp = Freelist; Freelist = cdr(Freelist); Freespace--; @@ -1950,13 +1953,11 @@ void checkanalogwrite (int pin) { // Note -#ifndef tone +#ifndef toneimplemented void tone (int pin, int note) { (void) pin, (void) note; } -#endif -#ifndef noTone void noTone (int pin) { (void) pin; } @@ -2089,7 +2090,6 @@ object* edit (object* fun) { object* sp_quote (object* args, object* env) { (void) env; - checkargs(args); return first(args); } @@ -2112,7 +2112,6 @@ object* sp_or (object* args, object* env) { */ object* sp_defun (object* args, object* env) { (void) env; - checkargs(args); object* var = first(args); if (!symbolp(var)) error(notasymbol, var); object* val = cons(bsymbol(LAMBDA), cdr(args)); @@ -2127,7 +2126,6 @@ object* sp_defun (object* args, object* env) { Defines a global variable. */ object* sp_defvar (object* args, object* env) { - checkargs(args); object* var = first(args); if (!symbolp(var)) error(notasymbol, var); object* val = NULL; @@ -2194,7 +2192,6 @@ object* sp_return (object* args, object* env) { */ object* sp_push (object* args, object* env) { int bit; - checkargs(args); object* item = eval(first(args), env); object** loc = place(second(args), env, &bit); push(item, *loc); @@ -2207,7 +2204,6 @@ object* sp_push (object* args, object* env) { */ object* sp_pop (object* args, object* env) { int bit; - checkargs(args); object** loc = place(first(args), env, &bit); object* result = car(*loc); pop(*loc); @@ -2223,7 +2219,6 @@ object* sp_pop (object* args, object* env) { */ object* sp_incf (object* args, object* env) { int bit; - checkargs(args); object** loc = place(first(args), env, &bit); args = cdr(args); @@ -2271,7 +2266,6 @@ object* sp_incf (object* args, object* env) { */ object* sp_decf (object* args, object* env) { int bit; - checkargs(args); object** loc = place(first(args), env, &bit); args = cdr(args); @@ -2457,7 +2451,10 @@ object* sp_formillis (object* args, object* env) { object* param = first(args); unsigned long start = millis(); unsigned long now, total = 0; - if (param != NULL) total = checkinteger(eval(first(param), env)); + if (param != NULL) { + if (atom(param)) error(notalist, param); + total = checkinteger(eval(first(param), env)); + } eval(tf_progn(cdr(args),env), env); do { now = millis() - start; @@ -2498,6 +2495,7 @@ object* sp_withoutputtostring (object* args, object* env) { if (args == NULL) error2(noargument); object* params = first(args); if (params == NULL) error2(nostream); + if (atom(params)) error(notalist, params); object* var = first(params); object* pair = cons(var, stream(STRINGSTREAM, 0)); push(pair,env); @@ -2517,6 +2515,7 @@ object* sp_withoutputtostring (object* args, object* env) { object* sp_withserial (object* args, object* env) { object* params = first(args); if (params == NULL) error2(nostream); + if (atom(params)) error(notalist, params); object* var = first(params); int address = checkinteger(eval(second(params), env)); params = cddr(params); @@ -2540,6 +2539,7 @@ object* sp_withserial (object* args, object* env) { object* sp_withi2c (object* args, object* env) { object* params = first(args); if (params == NULL) error2(nostream); + if (atom(params)) error(notalist, params); object* var = first(params); int address = checkinteger(eval(second(params), env)); params = cddr(params); @@ -2569,6 +2569,7 @@ object* sp_withi2c (object* args, object* env) { object* sp_withspi (object* args, object* env) { object* params = first(args); if (params == NULL) error2(nostream); + if (atom(params)) error(notalist, params); object* var = first(params); params = cdr(params); if (params == NULL) error2(nostream); @@ -2611,6 +2612,7 @@ object* sp_withsdcard (object* args, object* env) { #if defined(sdcardsupport) object* params = first(args); if (params == NULL) error2(nostream); + if (atom(params)) error(notalist, params); object* var = first(params); params = cdr(params); if (params == NULL) error2(PSTR("no filename specified")); @@ -2624,11 +2626,11 @@ object* sp_withsdcard (object* args, object* env) { if (mode >= 1) { char buffer[BUFFERSIZE]; SDpfile = SD.open(MakeFilename(filename, buffer), oflag); - if (!SDpfile) error2(PSTR("problem writing to SD card or invalid filename")); + if (!SDpfile) error(PSTR("problem writing to SD card or invalid filename"), filename); } else { char buffer[BUFFERSIZE]; SDgfile = SD.open(MakeFilename(filename, buffer), oflag); - if (!SDgfile) error2(PSTR("problem reading from SD card or invalid filename")); + if (!SDgfile) error(PSTR("problem reading from SD card or invalid filename"), filename); } object* pair = cons(var, stream(SDSTREAM, 1)); push(pair,env); @@ -5399,6 +5401,7 @@ object* sp_catch (object* args, object* env) { handler = &dynamic_handler; flags_t temp = Flags; + builtin_t catchcon = Context; setflag(INCATCH); object* tag = first(args); @@ -5414,8 +5417,7 @@ object* sp_catch (object* args, object* env) { // First: run forms result = eval(tf_progn(forms, env), env); // If we get here nothing was thrown - pop(GCStack); - pop(GCStack); + GCStack = current_GCStack; handler = previous_handler; Flags = temp; return result; @@ -5424,20 +5426,23 @@ object* sp_catch (object* args, object* env) { GCStack = current_GCStack; handler = previous_handler; Flags = temp; - if (Thrown == NULL || !eq(car(Thrown), tag)) { - // Nothing thrown or wrong tag + if (Thrown == NULL) { + // Not a (throw) --> propagate the error + longjmp(*handler, 1); + } + else if (!eq(car(Thrown), tag)) { + // Wrong tag if (tstflag(INCATCH)) { // Try next-in-line catch GCStack = NULL; longjmp(*handler, 1); } else { // No upper catch - error(PSTR("no matching tag"), tag); + Context = catchcon; + error(PSTR("no matching tag"), car(Thrown)); } } else { // Caught! - pop(GCStack); - pop(GCStack); result = cdr(Thrown); Thrown = NULL; return result; @@ -5517,22 +5522,23 @@ object* unquote (object* arg, object* env, int level) { } } else { notspecial: - for (object* x = arg; x != NULL, x = cdr(x)) { + for (object* x = arg; x != NULL; x = cdr(x)) { push(car(x), GCStack); object* foo = unquote(car(x), env, level); pop(GCStack); if (foo != nope) push(foo, result); } // Reverse and flatten - for (object* y = result; y != NULL, y = cdr(y)) { + for (object* y = result; y != NULL; y = cdr(y)) { if (atom(car(y))) push(car(y), result2); - else for (object* z = car(y), z != NULL, z = cdr(c)) push(car(z), result2); + else for (object* z = car(y); z != NULL; z = cdr(z)) push(car(z), result2); } return cons(result2, NULL); } } object* sp_quasiquote (object* args, object* env) { + checkargs(args); push(first(args), GCStack); object* result = unquote(first(args), env, 1); pop(GCStack); @@ -6744,6 +6750,7 @@ object* eval (object* form, object* env) { if (ft == SPECIAL_FORMS) { Context = name; + checkargs(args); return ((fn_ptr_type)lookupfn(name))(args, env); } @@ -7093,7 +7100,7 @@ void printobject (object* form, pfun_t pfun) { prin1object - prints any Lisp object to the specified stream escaping special characters */ void prin1object (object* form, pfun_t pfun) { - char flags_t = Flags; + flags_t temp = Flags; clrflag(PRINTREADABLY); printobject(form, pfun); Flags = temp; From b47e69a07d0ac8ad36a72d828c54e0c284b8dd0c Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 31 Mar 2023 11:18:37 -0400 Subject: [PATCH 042/109] optimize --- ulisp.hpp | 39 ++++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 0ccd4c9..56db815 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -81,6 +81,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define push(x, y) ((y) = cons((x), (y))) #define pop(y) ((y) = cdr(y)) +#define popandfree(y) do { object* temp__ = (y); pop(y); myfree(temp__); } while(0) #define integerp(x) ((x) != NULL && (x)->type == NUMBER) #define floatp(x) ((x) != NULL && (x)->type == FLOAT) @@ -1788,7 +1789,7 @@ object* mapcarcan (object* args, object* env, mapfun_t fun) { while (lists != NULL) { object* list = car(lists); if (list == NULL) { - pop(GCStack); pop(GCStack); + popandfree(GCStack); popandfree(GCStack); return cdr(head); } if (improperp(list)) error(notproper, list); @@ -2349,7 +2350,7 @@ object* sp_dolist (object* args, object* env) { object* result = eval(car(forms), env); if (tstflag(RETURNFLAG)) { clrflag(RETURNFLAG); - pop(GCStack); + popandfree(GCStack); return result; } forms = cdr(forms); @@ -2357,7 +2358,7 @@ object* sp_dolist (object* args, object* env) { list = cdr(list); } cdr(pair) = nil; - pop(GCStack); + popandfree(GCStack); if (params == NULL) return nil; return eval(car(params), env); } @@ -2503,7 +2504,7 @@ object* sp_withoutputtostring (object* args, object* env) { push(string, GCStack); object* forms = cdr(args); eval(tf_progn(forms,env), env); - pop(GCStack); + popandfree(GCStack); return string; } @@ -3217,7 +3218,7 @@ object* fn_mapc (object* args, object* env) { while (lists != NULL) { object* list = car(lists); if (list == NULL) { - pop(GCStack); pop(GCStack); + popandfree(GCStack); popandfree(GCStack); return result; } if (improperp(list)) error(notproper, list); @@ -3962,7 +3963,7 @@ object* fn_sort (object* args, object* env) { cdr(go) = obj; } else ptr = cdr(ptr); } - pop(GCStack); pop(GCStack); + popandfree(GCStack); popandfree(GCStack); return cdr(list); } @@ -5486,7 +5487,7 @@ object* unquote (object* arg, object* env, int level) { case QUASIQUOTE: push(second(arg), GCStack); result = unquote(second(arg), env, level + 1); - pop(GCStack); + popandfree(GCStack); return cons(cons(bsymbol(QUASIQUOTE), result), NULL); case UNQUOTE: if (level == 1) { @@ -5494,12 +5495,12 @@ object* unquote (object* arg, object* env, int level) { result = unquote(second(arg), env, level); car(GCStack) = result; result = eval(car(result), env); - pop(GCStack); + popandfree(GCStack); return cons(result, NULL); } else { push(second(arg), GCStack); result = unquote(second(arg), env, level - 1); - pop(GCStack); + popandfree(GCStack); return cons(cons(bsymbol(UNQUOTE), result), NULL); } case UNQUOTESPLICING: @@ -5508,13 +5509,13 @@ object* unquote (object* arg, object* env, int level) { result = unquote(second(arg), env, level); car(GCStack) = result; result = eval(car(result), env); - pop(GCStack); + popandfree(GCStack); if (result == NULL) return nope; else return result; } else { push(second(arg), GCStack); result = unquote(second(arg), env, level - 1); - pop(GCStack); + popandfree(GCStack); return cons(cons(bsymbol(UNQUOTESPLICING), result), NULL); } default: @@ -5525,7 +5526,7 @@ object* unquote (object* arg, object* env, int level) { for (object* x = arg; x != NULL; x = cdr(x)) { push(car(x), GCStack); object* foo = unquote(car(x), env, level); - pop(GCStack); + popandfree(GCStack); if (foo != nope) push(foo, result); } // Reverse and flatten @@ -5541,7 +5542,7 @@ object* sp_quasiquote (object* args, object* env) { checkargs(args); push(first(args), GCStack); object* result = unquote(first(args), env, 1); - pop(GCStack); + popandfree(GCStack); return result; } @@ -6730,7 +6731,7 @@ object* eval (object* form, object* env) { assigns = cdr(assigns); } env = newenv; - pop(GCStack); + popandfree(GCStack); form = tf_progn(forms,env); TC = TCstart; goto EVAL; @@ -6789,7 +6790,7 @@ object* eval (object* form, object* env) { Context = bname; checkminmax(bname, nargs); object* result = ((fn_ptr_type)lookupfn(bname))(args, env); - pop(GCStack); + popandfree(GCStack); return result; } @@ -6799,7 +6800,7 @@ object* eval (object* form, object* env) { if (isbuiltin(car(function), LAMBDA)) { form = closure(TCstart, name, function, args, &env); - pop(GCStack); + popandfree(GCStack); int trace = tracing(fname->name); if (trace) { object* result = eval(form, env); @@ -6818,7 +6819,7 @@ object* eval (object* form, object* env) { if (isbuiltin(car(function), CLOSURE)) { function = cdr(function); form = closure(TCstart, name, function, args, &env); - pop(GCStack); + popandfree(GCStack); TC = 1; goto EVAL; } @@ -7130,7 +7131,7 @@ void loadfromlibrary (object* env) { while (line != NULL) { push(line, GCStack); eval(line, env); - pop(GCStack); + popandfree(GCStack); line = read(glibrary); } } @@ -7380,7 +7381,7 @@ void repl (object* env) { line = eval(line, env); pfl(pserial); printobject(line, pserial); - pop(GCStack); + popandfree(GCStack); pfl(pserial); pln(pserial); } From 6d5f2a81ba07a69a3d3a334017ea3415632f3dbd Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 31 Mar 2023 18:11:00 -0400 Subject: [PATCH 043/109] add test term.py it does not work at all --- term.py | 166 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 166 insertions(+) create mode 100755 term.py diff --git a/term.py b/term.py new file mode 100755 index 0000000..3adb0f1 --- /dev/null +++ b/term.py @@ -0,0 +1,166 @@ +#! /usr/bin/env python3 +from sys import exit +from serial import Serial, SerialException +from argparse import ArgumentParser +from prompt_toolkit import PromptSession, Application +from prompt_toolkit.layout import VSplit, HSplit, BufferControl, Window +from prompt_toolkit.buffer import Buffer +from prompt_toolkit.widgets import TextArea, Button, VerticalLine +from prompt_toolkit.layout import Layout, ScrollablePane +from prompt_toolkit.history import FileHistory +from prompt_toolkit.auto_suggest import AutoSuggestFromHistory +from prompt_toolkit.validation import Validator, ValidationError +from prompt_toolkit.lexers import PygmentsLexer +from prompt_toolkit.formatted_text import HTML +from prompt_toolkit.patch_stdout import patch_stdout +from prompt_toolkit.shortcuts import set_title +from pygments.lexers.lisp import CommonLispLexer +import re +import os.path + + +WORKSPACESIZE = 9216 - 172 +HEADER_RE = re.compile(r"uLisp (\d+)", re.M) +PROMPT_RE = re.compile(r"(\d+)> ", re.M) + + +class LispValidator(Validator): + def validate(self, document): + nesting = 0 + stringmode = False + for c in document.text: + if c == '"': + stringmode = not stringmode + elif c == "(" and not stringmode: + nesting += 1 + elif c == ")" and not stringmode: + nesting -= 1 + if nesting > 0: + raise ValidationError(len(document.text), "Unbalanced parens") + elif stringmode: + raise ValidationError(len(document.text), "Unclosed string") + + +def parse_prompt(prompt: str) -> int: + return int(PROMPT_RE.match(prompt) or "0") + + +def mem_usage_indicator(num_used: int, ps: PromptSession): + width = ps.output.get_size().columns + usage_percent = num_used / WORKSPACESIZE + s = f"{num_used}/{WORKSPACESIZE} ({usage_percent * 100})% [" + e = "]" + if usage_percent > 0.75: + color = "ansired" + elif usage_percent > 0.5: + color = "ansiyellow" + else: + color = "ansiblue" + bw = width - len(s) - len(e) + nb = round(bw * usage_percent) + bar = "#" * nb + " " * (bw - nb) + return HTML(f"""""") + + +def get_lisp_input(prompt: str, ps: PromptSession) -> str: + num_used = parse_prompt(prompt) + try: + string = ps.prompt( + "uLisp> ", + multiline=True, + lexer=PygmentsLexer(CommonLispLexer), + auto_suggest=AutoSuggestFromHistory(), + bottom_toolbar=lambda: mem_usage_indicator(num_used, ps)) + except EOFError: + print("^D") + exit(0) + return string + + +def passthrough_until_prompt(port: Serial) -> str: + out = "" + while True: + line = port.read_until(b"\n").decode() + if line: + out += line + if PROMPT_RE.search(out) is not None: + return out + print(line, end="", flush=True) + + +def startup(port: Serial) -> str: + set_title(f"uLisp on {port.port}") + port.reset_input_buffer() + port.dtr = False + port.dtr = True + header = passthrough_until_prompt(port) + if m := HEADER_RE.match(header): + ver = " " + m.group(1) + else: + ver = "" + set_title(f"uLisp{ver} on {port.port}") + return header.rsplit("\n", 1)[-1] + + +async def repl(port: Serial, ps: PromptSession): + with patch_stdout(): + prompt = startup(port) + while True: + send = get_lisp_input(prompt, ps) + port.write(send.encode()) + port.write(b"\n") + port.flush() + prompt = passthrough_until_prompt(port).rsplit("\n", 1)[-1] + + +def main(): + a = ArgumentParser("term.py") + a.add_argument("-p", "--port", default="/dev/ttyUSB0") + a.add_argument("-b", "--baud", default=115200) + a.add_argument("-r", "--histfile", default="~/.ulisp_history") + x = a.parse_args() + try: + port = Serial(x.port, x.baud, timeout=0.1, exclusive=True) + except SerialException as e: + exit(repr(e)) + x.histfile = os.path.expanduser(x.histfile) + if not os.path.exists(x.histfile): + with open(x.histfile, "w"): + pass + + lispbuffer = TextArea( + multiline=True, + lexer=PygmentsLexer(CommonLispLexer), + history=FileHistory(x.histfile), + focus_on_click=True, + auto_suggest=AutoSuggestFromHistory(), + + scrollbar=True, + validator=LispValidator(), + ) + terminal = TextArea( + read_only=True, + scrollbar=True, + wrap_lines=False, + ) + terminal.text = "foofoo" + app = Application(Layout(HSplit([ + VSplit([ + Button(text="Quit", handler=lambda: app.exit(), + left_symbol="[", right_symbol="]"), + Button(text="Break", handler=lambda: port.write(b"~"), + left_symbol="[", right_symbol="]"), + Button(text="Reboot", handler=None, + left_symbol="[", right_symbol="]") + ]), + VSplit([ + lispbuffer, + VerticalLine(), + terminal + ]), + ])), mouse_support=True, full_screen=True) + app.run() + + +if __name__ == '__main__': + main() From 680d740997b8fdf6e61cae33e60e14fe87584bfe Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 31 Mar 2023 18:26:21 -0400 Subject: [PATCH 044/109] basic asyncio loop --- term.py | 85 ++++++++++++++++++++++++++------------------------------- 1 file changed, 39 insertions(+), 46 deletions(-) diff --git a/term.py b/term.py index 3adb0f1..14174e0 100755 --- a/term.py +++ b/term.py @@ -1,6 +1,6 @@ #! /usr/bin/env python3 from sys import exit -from serial import Serial, SerialException +from serial import Serial from argparse import ArgumentParser from prompt_toolkit import PromptSession, Application from prompt_toolkit.layout import VSplit, HSplit, BufferControl, Window @@ -17,6 +17,7 @@ from pygments.lexers.lisp import CommonLispLexer import re import os.path +import asyncio WORKSPACESIZE = 9216 - 172 @@ -41,8 +42,37 @@ def validate(self, document): raise ValidationError(len(document.text), "Unclosed string") +lispbuffer = TextArea( + multiline=True, + lexer=PygmentsLexer(CommonLispLexer), + focus_on_click=True, + scrollbar=True, + validator=LispValidator(), +) +terminal = TextArea( + read_only=True, + scrollbar=True, + wrap_lines=False, +) +app = Application(Layout(HSplit([ + VSplit([ + Button(text="Quit", handler=lambda: app.exit(), + left_symbol="[", right_symbol="]"), + Button(text="Break", handler=lambda: port.write(b"~"), + left_symbol="[", right_symbol="]"), + Button(text="Reboot", handler=None, + left_symbol="[", right_symbol="]") + ]), + VSplit([ + lispbuffer, + VerticalLine(), + terminal + ]), +])), mouse_support=True, full_screen=True) + + def parse_prompt(prompt: str) -> int: - return int(PROMPT_RE.match(prompt) or "0") + return int(PROMPT_RE.search(prompt) or "0") def mem_usage_indicator(num_used: int, ps: PromptSession): @@ -113,54 +143,17 @@ async def repl(port: Serial, ps: PromptSession): prompt = passthrough_until_prompt(port).rsplit("\n", 1)[-1] -def main(): +async def main(): a = ArgumentParser("term.py") a.add_argument("-p", "--port", default="/dev/ttyUSB0") a.add_argument("-b", "--baud", default=115200) - a.add_argument("-r", "--histfile", default="~/.ulisp_history") x = a.parse_args() - try: - port = Serial(x.port, x.baud, timeout=0.1, exclusive=True) - except SerialException as e: - exit(repr(e)) - x.histfile = os.path.expanduser(x.histfile) - if not os.path.exists(x.histfile): - with open(x.histfile, "w"): - pass - - lispbuffer = TextArea( - multiline=True, - lexer=PygmentsLexer(CommonLispLexer), - history=FileHistory(x.histfile), - focus_on_click=True, - auto_suggest=AutoSuggestFromHistory(), - - scrollbar=True, - validator=LispValidator(), - ) - terminal = TextArea( - read_only=True, - scrollbar=True, - wrap_lines=False, - ) - terminal.text = "foofoo" - app = Application(Layout(HSplit([ - VSplit([ - Button(text="Quit", handler=lambda: app.exit(), - left_symbol="[", right_symbol="]"), - Button(text="Break", handler=lambda: port.write(b"~"), - left_symbol="[", right_symbol="]"), - Button(text="Reboot", handler=None, - left_symbol="[", right_symbol="]") - ]), - VSplit([ - lispbuffer, - VerticalLine(), - terminal - ]), - ])), mouse_support=True, full_screen=True) - app.run() + port = Serial(x.port, x.baud, timeout=0.1, exclusive=True) + + tasks = [] + tasks.append(app.run_async()) + await asyncio.gather(*tasks) if __name__ == '__main__': - main() + asyncio.run(main()) From 90796e49423963466a624307960649eeab8d1488 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 1 Apr 2023 12:50:47 -0400 Subject: [PATCH 045/109] kinda works --- term.py | 116 ++++++++++++++++++++++++++++++++------------------------ 1 file changed, 67 insertions(+), 49 deletions(-) diff --git a/term.py b/term.py index 14174e0..5211f4f 100755 --- a/term.py +++ b/term.py @@ -1,11 +1,11 @@ #! /usr/bin/env python3 from sys import exit -from serial import Serial +from serial import Serial, SerialException from argparse import ArgumentParser from prompt_toolkit import PromptSession, Application from prompt_toolkit.layout import VSplit, HSplit, BufferControl, Window from prompt_toolkit.buffer import Buffer -from prompt_toolkit.widgets import TextArea, Button, VerticalLine +from prompt_toolkit.widgets import TextArea, Label, VerticalLine from prompt_toolkit.layout import Layout, ScrollablePane from prompt_toolkit.history import FileHistory from prompt_toolkit.auto_suggest import AutoSuggestFromHistory @@ -21,7 +21,11 @@ WORKSPACESIZE = 9216 - 172 -HEADER_RE = re.compile(r"uLisp (\d+)", re.M) +FREE = WORKSPACESIZE + +input_queue = asyncio.Queue() + +HEADER_RE = re.compile(r"uLisp ([\d.ab]+)", re.M) PROMPT_RE = re.compile(r"(\d+)> ", re.M) @@ -42,6 +46,28 @@ def validate(self, document): raise ValidationError(len(document.text), "Unclosed string") +def submit_box(b: Buffer): + input_queue.put_nowait(b.document.text) + return False + + +def mem_usage_indicator(): + width = app.output.get_size().columns + usage_percent = 1 - FREE / WORKSPACESIZE + s = f"{FREE} free ({round(usage_percent * 100, 2)}%) [" + e = "]" + if usage_percent > 0.75: + color = "#600" + elif usage_percent > 0.5: + color = "#630" + else: + color = "#040" + bw = width - len(s) - len(e) + nb = round(bw * usage_percent) + bar = "#" * nb + " " * (bw - nb) + return HTML(f"""""") + + lispbuffer = TextArea( multiline=True, lexer=PygmentsLexer(CommonLispLexer), @@ -52,59 +78,43 @@ def validate(self, document): terminal = TextArea( read_only=True, scrollbar=True, +) +cmdarea = TextArea( + scrollbar=False, wrap_lines=False, + lexer=PygmentsLexer(CommonLispLexer), + height=1, + focus_on_click=True, + validator=LispValidator(), + accept_handler=submit_box, + multiline=False, ) app = Application(Layout(HSplit([ - VSplit([ - Button(text="Quit", handler=lambda: app.exit(), - left_symbol="[", right_symbol="]"), - Button(text="Break", handler=lambda: port.write(b"~"), - left_symbol="[", right_symbol="]"), - Button(text="Reboot", handler=None, - left_symbol="[", right_symbol="]") - ]), VSplit([ lispbuffer, VerticalLine(), terminal ]), + VSplit([ + Label(text="cmd> ", dont_extend_width=True, dont_extend_height=True), + cmdarea, + ]), + Label(text=mem_usage_indicator, dont_extend_height=True) ])), mouse_support=True, full_screen=True) -def parse_prompt(prompt: str) -> int: - return int(PROMPT_RE.search(prompt) or "0") - - -def mem_usage_indicator(num_used: int, ps: PromptSession): - width = ps.output.get_size().columns - usage_percent = num_used / WORKSPACESIZE - s = f"{num_used}/{WORKSPACESIZE} ({usage_percent * 100})% [" - e = "]" - if usage_percent > 0.75: - color = "ansired" - elif usage_percent > 0.5: - color = "ansiyellow" - else: - color = "ansiblue" - bw = width - len(s) - len(e) - nb = round(bw * usage_percent) - bar = "#" * nb + " " * (bw - nb) - return HTML(f"""""") +def output(s: str): + if not s: + return + terminal.text += s.replace("\r\n", "\n") + for _ in range(s.count("\n")): + terminal.control.move_cursor_down() -def get_lisp_input(prompt: str, ps: PromptSession) -> str: - num_used = parse_prompt(prompt) - try: - string = ps.prompt( - "uLisp> ", - multiline=True, - lexer=PygmentsLexer(CommonLispLexer), - auto_suggest=AutoSuggestFromHistory(), - bottom_toolbar=lambda: mem_usage_indicator(num_used, ps)) - except EOFError: - print("^D") - exit(0) - return string +def parse_prompt(prompt: str) -> int: + if m := PROMPT_RE.search(prompt): + return int(m.group(1)) + return 0 def passthrough_until_prompt(port: Serial) -> str: @@ -115,7 +125,7 @@ def passthrough_until_prompt(port: Serial) -> str: out += line if PROMPT_RE.search(out) is not None: return out - print(line, end="", flush=True) + output(line) def startup(port: Serial) -> str: @@ -124,7 +134,7 @@ def startup(port: Serial) -> str: port.dtr = False port.dtr = True header = passthrough_until_prompt(port) - if m := HEADER_RE.match(header): + if m := HEADER_RE.search(header): ver = " " + m.group(1) else: ver = "" @@ -132,11 +142,13 @@ def startup(port: Serial) -> str: return header.rsplit("\n", 1)[-1] -async def repl(port: Serial, ps: PromptSession): +async def repl(port: Serial): + global FREE with patch_stdout(): prompt = startup(port) while True: - send = get_lisp_input(prompt, ps) + FREE = parse_prompt(prompt) + send = await input_queue.get() port.write(send.encode()) port.write(b"\n") port.flush() @@ -148,11 +160,17 @@ async def main(): a.add_argument("-p", "--port", default="/dev/ttyUSB0") a.add_argument("-b", "--baud", default=115200) x = a.parse_args() - port = Serial(x.port, x.baud, timeout=0.1, exclusive=True) + try: + port = Serial(x.port, x.baud, timeout=0.1, exclusive=True) + except SerialException: + exit(f"error: could not open {x.port}\n" + "- device plugged in?\n" + "- wrong port? (specify with -p PORT)\n") tasks = [] tasks.append(app.run_async()) - await asyncio.gather(*tasks) + tasks.append(repl(port)) + await asyncio.gather(*tasks, return_exceptions=True) if __name__ == '__main__': From 195e52199a5f7f4e5982b3ea6590593dc64a322c Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 3 Apr 2023 12:05:09 -0400 Subject: [PATCH 046/109] finish add term.py --- README.md | 59 ++++++++++- term.py | 256 +++++++++++++++++++++++++++++++----------------- ulisp-esp32.ino | 12 +-- ulisp.hpp | 117 ++++++++++------------ 4 files changed, 279 insertions(+), 165 deletions(-) diff --git a/README.md b/README.md index dcdd1ed..6f3c707 100644 --- a/README.md +++ b/README.md @@ -4,27 +4,76 @@ A (patched) version of the Lisp programming language for ESP32-based boards. Heavily customized to fit my use case but most of the original remains. For more about the original ulisp-esp see -This is based off of uLisp 4.4. For the old patches (some of which don't work) for +This is based off of uLisp 4.4b. For the old patches (some of which don't work) for uLisp 4.3a please see the [4.3a-old](https://github.com/dragoncoder047/ulisp-esp32/tree/4.3a-old) branch. Patches: * Deleted: load/save/autorunimage support * Modified: garbage collect message -* Deleted: line-editor support (you can just use `rlwrap` if you have it) +* Deleted: line-editor support * Added: Lisp `:keywords` that auto-quote themselves * Added: Ability to add multiple (more than one) extension tables (using `calloc()`) *may not be portable to other platforms* * Added: Lisp `(throw)` and `(catch)` * Added: ***EXPERIMENTAL, BUGGY, AND PROBABLY INCORRECT*** quasiquote/unquote/unquote-splicing (no reader support yet) * Added: Auto-run contents of `main.lisp` (on microSD card) at startup * Modified: SD-card functions now include filename in error messages -* Fixed: various malformed-input panics (technoblogy#62) * Fixed: special forms don't need to call `checkargs()` because it is automatically called -Extensions (`extensinos.hpp`): +Extensions (`extensions.hpp`): * `now` (provided by David) * `gensym` * `intern` * `sizeof` -* + +## `term.py` -- enhanced uLisp interface + +This provides a cleaner interface to use uLisp in compared to the stupid Arduino serial monitor. + +Dependencies: + +* A VT100-compliant terminal +* Python 3 +* [pyserial](https://pypi.org/project/pyserial/) (to communicate with your microcontroller) +* [prompt_toolkit](https://pypi.org/project/prompt-toolkit/) (to draw the interface) +* [Pygments](https://pypi.org/project/Pygments/) (for syntax highliting) + +To run: + +```bash +# use default port and baud (/dev/ttyUSB0 and 115200) +python3 term.py +# specify port and baud +python3 term.py -p COM3 -b 9600 +``` + +UI Overview: + +```txt +---------------------------------------------------- +| ^| ^| +| | | +| LISP | SERIAL | +| BUFFER | MONITOR | +| | | +| | | +| v| v| +|--------------------------------------------------| +|cmd> COMMAND AREA | +|--------------------------------------------------| +| STATUS BAR RIGHT STATUS | +| MEMORY USAGE LAST GC INFO | +---------------------------------------------------- +``` + +* Lisp Buffer: You can type Lisp code in here. +* Serial Monitor: This shows the output from the serial port. +* Command Area: You can type one-line Lisp commands in here, or you can type "special" commands (press ENTER to run them): + * `.reset`: Trips the RTS line of the serial port, to reset your microcontroller if it locks up and `~` doesn't work. + * `.run`: Sends the contents of the Lisp Buffer to the serial port, and then empty the Lisp Buffer. + * `.quit`: Closes the serial port, and exits from the application. +* Status Bar: Shows whether the program is running, waiting for input at the REPL, crashed because of an error, etc. +* Right Status: Doesn't do anything on its own, but if your program prints out something of the form `$!rs=foo!$`, it will hide that string in the Serial Monitor, and put `foo` in the Right Status area. This is useful if you want to monitor the state of a pin in a loop, and you don't want to overload the Serial Monitor with a barrage of text. +* Memory Usage: Shows the percentage of memory used by your program in a couple of different ways and also changes color depending on how much memory is used. +* Last GC Info: Shows how many garbage collections have been done since the start of the program, and how much was freed on the most recent GC. diff --git a/term.py b/term.py index 5211f4f..ec49837 100755 --- a/term.py +++ b/term.py @@ -1,33 +1,25 @@ #! /usr/bin/env python3 -from sys import exit from serial import Serial, SerialException from argparse import ArgumentParser -from prompt_toolkit import PromptSession, Application -from prompt_toolkit.layout import VSplit, HSplit, BufferControl, Window +from prompt_toolkit import Application +from prompt_toolkit.layout import VSplit, HSplit from prompt_toolkit.buffer import Buffer -from prompt_toolkit.widgets import TextArea, Label, VerticalLine -from prompt_toolkit.layout import Layout, ScrollablePane -from prompt_toolkit.history import FileHistory +from prompt_toolkit.widgets import ( + TextArea, Label, VerticalLine, HorizontalLine) +from prompt_toolkit.layout import Layout +from prompt_toolkit.history import InMemoryHistory from prompt_toolkit.auto_suggest import AutoSuggestFromHistory from prompt_toolkit.validation import Validator, ValidationError from prompt_toolkit.lexers import PygmentsLexer from prompt_toolkit.formatted_text import HTML -from prompt_toolkit.patch_stdout import patch_stdout from prompt_toolkit.shortcuts import set_title from pygments.lexers.lisp import CommonLispLexer import re -import os.path import asyncio -WORKSPACESIZE = 9216 - 172 -FREE = WORKSPACESIZE - input_queue = asyncio.Queue() -HEADER_RE = re.compile(r"uLisp ([\d.ab]+)", re.M) -PROMPT_RE = re.compile(r"(\d+)> ", re.M) - class LispValidator(Validator): def validate(self, document): @@ -46,26 +38,112 @@ def validate(self, document): raise ValidationError(len(document.text), "Unclosed string") -def submit_box(b: Buffer): - input_queue.put_nowait(b.document.text) - return False +class Watcher: + all_watchers = [] + + def __init__(self, regex): + self.regex = re.compile(regex, re.M) + Watcher.all_watchers.append(self) + + def __call__(self, fun): + self.fun = fun + + def run(self, content: str) -> str: + if m := self.regex.search(content): + if self.fun(m): + content = content.replace(m.group(0), "", 1) + return content + + +def run_watchers(content: str) -> str: + changed = True + while changed: + changed = False + for w in Watcher.all_watchers: + old = content + content = w.run(content) + if content != old: + changed = True + return content + + +WORKSPACESIZE = 1 +FREE = 0 +FREED = 0 +GC_COUNTER = 0 +LAST_ERROR = "" +STATUS = "Loading..." +RIGHT_STATUS = "" + + +@Watcher(r"\{GC#(\d+):(\d+),(\d+)/(\d+)\}") +def mem_usage_watcher(m: re.Match): + global GC_COUNTER + global FREED + global FREE + global WORKSPACESIZE + GC_COUNTER = int(m.group(1)) + FREED = int(m.group(2)) + FREE = int(m.group(3)) + WORKSPACESIZE = int(m.group(4)) + return True + + +@Watcher(r"\[Ready.\]\n") +def ready_watcher(m: re.Match): + global STATUS + if "error" not in STATUS.lower(): + STATUS = "Ready." + return True + + +@Watcher(r"\$!rs=(.*)!\$\n?") +def right_status_watcher(m: re.Match): + global RIGHT_STATUS + RIGHT_STATUS = m.group(1) + return True + + +@Watcher(r"waiting for download") +def bootloader_watcher(m: re.Match): + raise SerialException("Device is in bootloader mode") + + +@Watcher(r"(Error: [^\n]+)\n") +def error_watcher(m: re.Match): + global STATUS + STATUS = m.group(1) + return True -def mem_usage_indicator(): +def memory_usage_bar(): width = app.output.get_size().columns usage_percent = 1 - FREE / WORKSPACESIZE - s = f"{FREE} free ({round(usage_percent * 100, 2)}%) [" - e = "]" + s = f"{FREE}/{WORKSPACESIZE} free ({round(usage_percent * 100, 2)}%) [" + e = f"] (GC #{GC_COUNTER} freed {FREED})" if usage_percent > 0.75: - color = "#600" + color = "#F78" elif usage_percent > 0.5: - color = "#630" + color = "#E90" else: - color = "#040" + color = "#0B3" bw = width - len(s) - len(e) nb = round(bw * usage_percent) bar = "#" * nb + " " * (bw - nb) - return HTML(f"""""") + return HTML(f"""""") + + +def status_bar(): + width = app.output.get_size().columns + left = STATUS + right = RIGHT_STATUS + spaces = width - len(right) - len(left) + return HTML((left + " " * spaces + right).rstrip("\r\n")) + + +def submit_box(b: Buffer): + input_queue.put_nowait(b.document.text) + return False lispbuffer = TextArea( @@ -74,103 +152,105 @@ def mem_usage_indicator(): focus_on_click=True, scrollbar=True, validator=LispValidator(), -) + history=InMemoryHistory(), + auto_suggest=AutoSuggestFromHistory()) + terminal = TextArea( read_only=True, - scrollbar=True, -) -cmdarea = TextArea( + scrollbar=True) + +command_bar = TextArea( scrollbar=False, wrap_lines=False, lexer=PygmentsLexer(CommonLispLexer), - height=1, + height=2, focus_on_click=True, validator=LispValidator(), accept_handler=submit_box, multiline=False, -) + history=InMemoryHistory(), + auto_suggest=AutoSuggestFromHistory()) + app = Application(Layout(HSplit([ VSplit([ lispbuffer, VerticalLine(), terminal ]), + HorizontalLine(), VSplit([ Label(text="cmd> ", dont_extend_width=True, dont_extend_height=True), - cmdarea, + command_bar, ]), - Label(text=mem_usage_indicator, dont_extend_height=True) + HorizontalLine(), + Label(text=status_bar, dont_extend_height=True), + Label(text=memory_usage_bar, dont_extend_height=True) ])), mouse_support=True, full_screen=True) -def output(s: str): - if not s: - return - terminal.text += s.replace("\r\n", "\n") - for _ in range(s.count("\n")): - terminal.control.move_cursor_down() - - -def parse_prompt(prompt: str) -> int: - if m := PROMPT_RE.search(prompt): - return int(m.group(1)) - return 0 - - -def passthrough_until_prompt(port: Serial) -> str: - out = "" - while True: - line = port.read_until(b"\n").decode() - if line: - out += line - if PROMPT_RE.search(out) is not None: - return out - output(line) +def output(s: str = ""): + terminal.text += s + terminal.text = terminal.text.replace("\r\n", "\n") + terminal.buffer.cursor_position = len(terminal.text) def startup(port: Serial) -> str: - set_title(f"uLisp on {port.port}") + set_title(f"uLisp on {port.port} ({port.name})") port.reset_input_buffer() port.dtr = False port.dtr = True - header = passthrough_until_prompt(port) - if m := HEADER_RE.search(header): - ver = " " + m.group(1) - else: - ver = "" - set_title(f"uLisp{ver} on {port.port}") - return header.rsplit("\n", 1)[-1] + output("\n---MCU RESET---\n") -async def repl(port: Serial): - global FREE - with patch_stdout(): - prompt = startup(port) - while True: - FREE = parse_prompt(prompt) +async def repl_task(port: Serial): + global STATUS + startup(port) + await asyncio.sleep(0.1) + while True: + # allow other tasks to run + await asyncio.sleep(0.1) + if not input_queue.empty(): send = await input_queue.get() - port.write(send.encode()) - port.write(b"\n") - port.flush() - prompt = passthrough_until_prompt(port).rsplit("\n", 1)[-1] + match send: + case ".reset": + startup(port) + send = None + case ".quit": + app.exit() + return + case ".run": + send = lispbuffer.text + lispbuffer.buffer.append_to_history() + lispbuffer.text = "" + case _: + pass + if send is not None and send.strip(): + STATUS = "Running..." + port.write(send.encode()) + port.write(b"\n") + port.flush() + input_queue.task_done() + if port.in_waiting > 0: + terminal.text += port.read_all().decode() + terminal.text = run_watchers(terminal.text) + output() async def main(): - a = ArgumentParser("term.py") - a.add_argument("-p", "--port", default="/dev/ttyUSB0") - a.add_argument("-b", "--baud", default=115200) - x = a.parse_args() - try: - port = Serial(x.port, x.baud, timeout=0.1, exclusive=True) - except SerialException: - exit(f"error: could not open {x.port}\n" - "- device plugged in?\n" - "- wrong port? (specify with -p PORT)\n") - - tasks = [] - tasks.append(app.run_async()) - tasks.append(repl(port)) - await asyncio.gather(*tasks, return_exceptions=True) + argp = ArgumentParser("term.py") + argp.add_argument("-p", "--port", default="/dev/ttyUSB0") + argp.add_argument("-b", "--baud", default=115200) + foo = argp.parse_args() + port = Serial(foo.port, foo.baud, timeout=0.1, exclusive=True) + + @Watcher(r"uLisp ([\d.a-z]+)") + def version_watcher(m: re.Match): + nonlocal port + set_title(f"uLisp {m.group(1)} on {port.port} ({port.name})") + + await asyncio.gather( + app.run_async(), + repl_task(port)) if __name__ == '__main__': diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index ed99fc2..a979af6 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -1,7 +1,7 @@ -/* uLisp ESP Release 4.4 - www.ulisp.com - David Johnson-Davies - www.technoblogy.com - 21st March 2023 +/* uLisp ESP Release 4.4b - www.ulisp.com + David Johnson-Davies - www.technoblogy.com - 31st March 2023 - Licensed under the MIT license: https://opensource.org/licenses/MIT + Licensed under the MIT license: https://opensource.org/licenses/MIT */ #include @@ -23,8 +23,8 @@ #include "extensions.hpp" const char foo[] PROGMEM = -"(defun load (filename) (with-sd-card (f filename) (loop (let ((form (read f))) (unless form (return)) (eval form)))))\n" -"(load \"main.lisp\")\n" +"(defun load(filename)(with-sd-card(f filename)(loop(let((form(read f)))(unless form(return))(eval form)))))" +"(load \"main.lisp\")" ; const size_t foolen = arraysize(foo); size_t fooi = 0; @@ -65,7 +65,7 @@ void setup () { while ((millis() - start) < 5000) { if (Serial) break; } ulispinit(); addtable(ExtensionsTable); - Serial.println(F("\n\n\nuLisp 4.4!")); + Serial.println(F("\n\n\nuLisp 4.4b!")); sdmain(); } diff --git a/ulisp.hpp b/ulisp.hpp index 56db815..6c4ded6 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -1,7 +1,7 @@ -/* uLisp ESP Release 4.4 - www.ulisp.com - David Johnson-Davies - www.technoblogy.com - 21st March 2023 +/* uLisp ESP Release 4.4b - www.ulisp.com + David Johnson-Davies - www.technoblogy.com - 31st March 2023 - Licensed under the MIT license: https://opensource.org/licenses/MIT + Licensed under the MIT license: https://opensource.org/licenses/MIT */ #ifndef ULISP_HPP @@ -495,19 +495,11 @@ bool eqsymbols (object* obj, const char* buffer) { int i = 0; while (!(arg == NULL && buffer[i] == 0)) { if (arg == NULL || buffer[i] == 0) return false; - int test = buffer[i]<<24; - i++; - if (buffer[i] != 0) { - test |= buffer[i]<<16; - i++; - if (buffer[i] != 0) { - test |= buffer[i]<<8; - i++; - if (buffer[i] != 0) { - test |= buffer[i]; - i++; - } - } + int test = 0, shift = 24; + for (int j=0; j<4; j++, i++) { + if (buffer[i] == 0) break; + test |= buffer[i]<chars != test) return false; arg = car(arg); @@ -517,7 +509,7 @@ bool eqsymbols (object* obj, const char* buffer) { /* internlong - looks through the workspace for an existing occurrence of the long symbol in buffer and returns it, - otherwise calls lispstring(buffer) to create a new symbol. + otherwise calls lispstring(buffer) and coerces it to symbol. */ object* internlong (const char* buffer) { for (int i=0; i=0; i--) { object* obj = &Workspace[i]; - if (!marked(obj)) myfree(obj); else unmark(obj); + if (marked(obj)) unmark(obj); else myfree(obj); } } @@ -625,15 +617,19 @@ void gc (object* form, object* env) { #if defined(printgcs) GC_Count++; pfl(pserial); - pfstring(PSTR("{GC #"), pserial); + pfstring(PSTR("{GC#"), pserial); pint(GC_Count, pserial); - pfstring(PSTR(": "), pserial); + pserial(':'); pint(Freespace - start, pserial); - pfstring(PSTR(" freed}"), pserial); + pserial(','); + pint(Freespace, pserial); + pserial('/'); + pint(WORKSPACESIZE, pserial); + pserial('}'); #endif } -char *MakeFilename (object *arg, char *buffer) { +char *MakeFilename (object* arg, char *buffer) { int max = BUFFERSIZE-1; buffer[0]='/'; int i = 1; @@ -780,9 +776,9 @@ uint32_t pack40 (const char* buffer) { */ bool valid40 (const char* buffer) { int t = 11; - for (int i=0; i<6; i++){ + for (int i=0; i<6; i++) { if (toradix40(buffer[i]) < t) return false; - if (buffer[i+1] == 0) break; + if (buffer[i] == 0) break; t = 0; } return true; @@ -907,6 +903,20 @@ int listlength (object* list) { return length; } +/* + checkarguments - checks the arguments list in a special form such as with-xxx, + dolist, or dotimes. +*/ +object* checkarguments (object* args, int min, int max) { + if (args == NULL) error2(noargument); + args = first(args); + if (!listp(args)) error(notalist, args); + int length = listlength(args); + if (length < min) error(toofewargs, args); + if (length > max) error(toomanyargs, args); + return args; +} + // Mathematical helper functions /* @@ -1940,7 +1950,7 @@ pfun_t pstreamfun (object* args) { // Check pins void checkanalogread (int pin) { - + // if (!(pin==0 || pin==2 || pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) // error(PSTR("invalid pin"), number(pin)); (void)pin; @@ -2333,8 +2343,7 @@ object* sp_setf (object* args, object* env) { It then returns result, or nil if result is omitted. */ object* sp_dolist (object* args, object* env) { - if (args == NULL || listlength(first(args)) < 2) error2(noargument); - object* params = first(args); + object* params = checkarguments(args, 2, 3); object* var = first(params); object* list = eval(second(params), env); push(list, GCStack); // Don't GC the list @@ -2448,14 +2457,10 @@ object* sp_untrace (object* args, object* env) { Returns the total number of milliseconds taken. */ object* sp_formillis (object* args, object* env) { - if (args == NULL) error2(noargument); - object* param = first(args); + object* param = checkarguments(args, 0, 1); unsigned long start = millis(); unsigned long now, total = 0; - if (param != NULL) { - if (atom(param)) error(notalist, param); - total = checkinteger(eval(first(param), env)); - } + if (param != NULL) total = checkinteger(eval(first(param), env)); eval(tf_progn(cdr(args),env), env); do { now = millis() - start; @@ -2493,10 +2498,8 @@ object* sp_time (object* args, object* env) { Returns a string containing the output to the stream variable str. */ object* sp_withoutputtostring (object* args, object* env) { - if (args == NULL) error2(noargument); - object* params = first(args); + object* params = checkarguments(args, 1, 1); if (params == NULL) error2(nostream); - if (atom(params)) error(notalist, params); object* var = first(params); object* pair = cons(var, stream(STRINGSTREAM, 0)); push(pair,env); @@ -2514,9 +2517,7 @@ object* sp_withoutputtostring (object* args, object* env) { The optional baud gives the baud rate divided by 100, default 96. */ object* sp_withserial (object* args, object* env) { - object* params = first(args); - if (params == NULL) error2(nostream); - if (atom(params)) error(notalist, params); + object* params = checkarguments(args, 2, 3); object* var = first(params); int address = checkinteger(eval(second(params), env)); params = cddr(params); @@ -2538,9 +2539,7 @@ object* sp_withserial (object* args, object* env) { to be read from the stream. The port if specified is ignored. */ object* sp_withi2c (object* args, object* env) { - object* params = first(args); - if (params == NULL) error2(nostream); - if (atom(params)) error(notalist, params); + object* params = checkarguments(args, 2, 4); object* var = first(params); int address = checkinteger(eval(second(params), env)); params = cddr(params); @@ -2568,9 +2567,7 @@ object* sp_withi2c (object* args, object* env) { bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0). */ object* sp_withspi (object* args, object* env) { - object* params = first(args); - if (params == NULL) error2(nostream); - if (atom(params)) error(notalist, params); + object* params = checkarguments(args, 2, 6); object* var = first(params); params = cdr(params); if (params == NULL) error2(nostream); @@ -2611,9 +2608,7 @@ object* sp_withspi (object* args, object* env) { */ object* sp_withsdcard (object* args, object* env) { #if defined(sdcardsupport) - object* params = first(args); - if (params == NULL) error2(nostream); - if (atom(params)) error(notalist, params); + object* params = checkarguments(args, 2, 3); object* var = first(params); params = cdr(params); if (params == NULL) error2(PSTR("no filename specified")); @@ -4159,8 +4154,8 @@ object* fn_logxor (object* args, object* env) { } /* - (lognot number) - Returns the bitwise inverse of the number. + (lognot value) + Returns the bitwise logical NOT of the value. */ object* fn_lognot (object* args, object* env) { (void) env; @@ -5062,7 +5057,7 @@ object* fn_wificonnect (object* args, object* env) { */ object* sp_withgfx (object* args, object* env) { #if defined(gfxsupport) - object* params = first(args); + object* params = checkarguments(args, 1, 1); object* var = first(params); object* pair = cons(var, stream(GFXSTREAM, 1)); push(pair,env); @@ -5383,9 +5378,6 @@ object* fn_invertdisplay (object* args, object* env) { return nil; } -/////////////////////////////////////////////////////////// -// Experimental (catch) / (throw) support -// also see Thrown global variable and garbage collector /* (catch 'tag form*) @@ -5393,7 +5385,6 @@ object* fn_invertdisplay (object* args, object* env) { tag, returns the "thrown" value. If none throw, returns the value returned by the last form. */ - object* sp_catch (object* args, object* env) { object* current_GCStack = GCStack; @@ -5469,14 +5460,11 @@ object* fn_throw (object* args, object* env) { return NULL; } -/////////////////////////////////////////////////////////// - /////////////////////////////////////////////////////////// // Experimental QUASIQUOTE support #define nope ((object*)-3) -// From https://github.com/kanaka/mal/issues/103#issuecomment-159047401 object* unquote (object* arg, object* env, int level) { if (arg == NULL || atom(arg)) return cons(bsymbol(QUOTE), cons(arg, NULL)); object* what = first(arg); @@ -6147,8 +6135,8 @@ const char doc155[] PROGMEM = "(logior [value*])\n" "Returns the bitwise | of the values."; const char doc156[] PROGMEM = "(logxor [value*])\n" "Returns the bitwise ^ of the values."; -const char doc157[] PROGMEM = "(lognot number)\n" -"Returns the bitwise inverse of the number."; +const char doc157[] PROGMEM = "(lognot value)\n" +"Returns the bitwise logical NOT of the value."; const char doc158[] PROGMEM = "(ash value shift)\n" "Returns the result of bitwise shifting value by shift bits. If shift is positive, value is shifted to the left."; const char doc159[] PROGMEM = "(logbitp bit value)\n" @@ -6835,7 +6823,7 @@ object* eval (object* form, object* env) { */ void pserial (char c) { LastPrint = c; - if (c == '\n') Serial.write('\r'); + //if (c == '\n') Serial.write('\r'); Serial.write(c); } @@ -7364,15 +7352,12 @@ void repl (object* env) { for (;;) { randomSeed(micros()); gc(NULL, env); - #if defined(printfreespace) - pint(Freespace, pserial); - #endif if (BreakLevel) { pfstring(PSTR(" : "), pserial); pint(BreakLevel, pserial); } - pserial('>'); pserial(' '); - Context = 0; + pfstring(PSTR("[Ready.]\n"), pserial); + Context = NIL; object* line = read(gserial); if (BreakLevel && line == nil) { pln(pserial); return; } if (line == (object*)CLOSE_PAREN) error2(PSTR("unmatched right bracket")); From 6c6a838ee0edf7c2aa88acc4dcbae4ef1829cdc3 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 3 Apr 2023 14:48:21 -0400 Subject: [PATCH 047/109] add bell --- README.md | 2 +- term.py | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 6f3c707..609a251 100644 --- a/README.md +++ b/README.md @@ -75,5 +75,5 @@ UI Overview: * `.quit`: Closes the serial port, and exits from the application. * Status Bar: Shows whether the program is running, waiting for input at the REPL, crashed because of an error, etc. * Right Status: Doesn't do anything on its own, but if your program prints out something of the form `$!rs=foo!$`, it will hide that string in the Serial Monitor, and put `foo` in the Right Status area. This is useful if you want to monitor the state of a pin in a loop, and you don't want to overload the Serial Monitor with a barrage of text. -* Memory Usage: Shows the percentage of memory used by your program in a couple of different ways and also changes color depending on how much memory is used. +* Memory Usage: Shows the percentage of memory used by your program in a couple of different ways and also changes color depending on how much memory is used. This is updated after every garbage collection. * Last GC Info: Shows how many garbage collections have been done since the start of the program, and how much was freed on the most recent GC. diff --git a/term.py b/term.py index ec49837..c48f3db 100755 --- a/term.py +++ b/term.py @@ -116,6 +116,12 @@ def error_watcher(m: re.Match): return True +@Watcher(r"\a") +def bell_watcher(m: re.Match): + app.output.bell() + return True + + def memory_usage_bar(): width = app.output.get_size().columns usage_percent = 1 - FREE / WORKSPACESIZE @@ -154,10 +160,12 @@ def submit_box(b: Buffer): validator=LispValidator(), history=InMemoryHistory(), auto_suggest=AutoSuggestFromHistory()) +lispbuffer.allow_scroll_beyond_bottom = True terminal = TextArea( read_only=True, scrollbar=True) +terminal.allow_scroll_beyond_bottom = True command_bar = TextArea( scrollbar=False, From 5634435074bd8f7f6d078b166421b4fd157a8edd Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 3 Apr 2023 17:00:38 -0400 Subject: [PATCH 048/109] add reader support for quasiquote etc. --- README.md | 2 +- ulisp.hpp | 45 ++++++++++++++++++++++++++++----------------- 2 files changed, 29 insertions(+), 18 deletions(-) diff --git a/README.md b/README.md index 609a251..8800081 100644 --- a/README.md +++ b/README.md @@ -15,7 +15,7 @@ Patches: * Added: Lisp `:keywords` that auto-quote themselves * Added: Ability to add multiple (more than one) extension tables (using `calloc()`) *may not be portable to other platforms* * Added: Lisp `(throw)` and `(catch)` -* Added: ***EXPERIMENTAL, BUGGY, AND PROBABLY INCORRECT*** quasiquote/unquote/unquote-splicing (no reader support yet) +* Added: ***EXPERIMENTAL, BUGGY, AND PROBABLY INCORRECT*** quasiquote/unquote/unquote-splicing * Added: Auto-run contents of `main.lisp` (on microSD card) at startup * Modified: SD-card functions now include filename in error messages * Fixed: special forms don't need to call `checkargs()` because it is automatically called diff --git a/ulisp.hpp b/ulisp.hpp index 6c4ded6..098ec0d 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -123,7 +123,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define TRACEMAX 3 // Number of traced functions enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; // ARRAY STRING and PAIR must be last -enum token { UNUSED, OPEN_PAREN, CLOSE_PAREN, SINGLE_QUOTE, PERIOD }; +enum token { UNUSED, OPEN_PAREN, CLOSE_PAREN, SINGLE_QUOTE, PERIOD, BACKQUOTE, COMMA, COMMA_AT }; enum fntypes_t { OTHER_FORMS, TAIL_FORMS, FUNCTIONS, SPECIAL_FORMS }; // Stream names used by printobject @@ -1303,11 +1303,11 @@ void buildstring (char ch, object** tail) { if (cdr(*tail) == NULL) { cell = myalloc(); cdr(*tail) = cell; } else if (((*tail)->chars & 0xFFFFFF) == 0) { - (*tail)->chars = (*tail)->chars | ch<<16; return; + (*tail)->chars |= ch<<16; return; } else if (((*tail)->chars & 0xFFFF) == 0) { - (*tail)->chars = (*tail)->chars | ch<<8; return; + (*tail)->chars |= ch<<8; return; } else if (((*tail)->chars & 0xFF) == 0) { - (*tail)->chars = (*tail)->chars | ch; return; + (*tail)->chars |= ch; return; } else { cell = myalloc(); car(*tail) = cell; } @@ -6680,6 +6680,7 @@ object* eval (object* form, object* env) { if (form->type >= NUMBER && form->type <= STRING) return form; if (symbolp(form)) { + if (nthchar(princtostring(form), 0) == ':') return form; // Keyword symbol_t name = form->name; object* pair = value(name, env); if (pair != NULL) return cdr(pair); @@ -7156,6 +7157,16 @@ object* nextitem (gfun_t gfun) { if (ch == ')') return (object*)CLOSE_PAREN; if (ch == '(') return (object*)OPEN_PAREN; if (ch == '\'') return (object*)SINGLE_QUOTE; + if (ch == '`') return (object*)BACKQUOTE; + if (ch == '@') return (object*)COMMA_AT; // maintain compatibility with old Dave Astels code + if (ch == ',') { + ch = gfun(); + if (ch == '@') return (object *)COMMA_AT; + else { + LastChar = ch; + return (object *)COMMA; + } + } // Parse string if (ch == '"') return readstring('"', gfun); @@ -7265,11 +7276,7 @@ object* nextitem (gfun_t gfun) { builtin_t x = lookupbuiltin(buffer); if (x == NIL) return nil; if (x != ENDFUNCTIONS) return bsymbol(x); - object* sym = buftosymbol(buffer); - if (buffer[0] == ':') { // Keywords quote themselves - sym = quoteit(QUOTE, sym); - } - return sym; + return buftosymbol(buffer); } /* @@ -7281,13 +7288,14 @@ object* readrest (gfun_t gfun) { object* tail = NULL; while (item != (object*)CLOSE_PAREN) { - if (item == (object*)OPEN_PAREN) { - item = readrest(gfun); - } else if (item == (object*)SINGLE_QUOTE) { - item = cons(bsymbol(QUOTE), cons(read(gfun), NULL)); - } else if (item == (object*)PERIOD) { + if (item == (object*)OPEN_PAREN) item = readrest(gfun); + else if (item == (object*)SINGLE_QUOTE) item = quoteit(QUOTE, read(gfun)); + else if (item == (object*)BACKQUOTE) item = quoteit(QUASIQUOTE, read(gfun)); + else if (item == (object*)COMMA) item = quoteit(UNQUOTE, read(gfun)); + else if (item == (object*)COMMA_AT) item = quoteit(UNQUOTE_SPLICING, read(gfun)); + else if (item == (object*)PERIOD) { tail->cdr = read(gfun); - if (readrest(gfun) != NULL) error2(PSTR("malformed list")); + if (readrest(gfun) != NULL) error2(PSTR("only one form allowed after reader dot")); return head; } else { object* cell = cons(item, NULL); @@ -7305,10 +7313,13 @@ object* readrest (gfun_t gfun) { */ object* read (gfun_t gfun) { object* item = nextitem(gfun); - if (item == (object*)CLOSE_PAREN) error2(PSTR("incomplete list")); + if (item == (object*)CLOSE_PAREN) error2(PSTR("unexpected close paren")); if (item == (object*)OPEN_PAREN) return readrest(gfun); if (item == (object*)PERIOD) return read(gfun); - if (item == (object*)SINGLE_QUOTE) return cons(bsymbol(QUOTE), cons(read(gfun), NULL)); + if (item == (object*)SINGLE_QUOTE) return quoteit(QUOTE, read(gfun)); + if (item == (object*)BACKQUOTE) return quoteit(QUASIQUOTE, read(gfun)); + if (item == (object*)COMMA) return quoteit(UNQUOTE, read(gfun)); + if (item == (object*)COMMA_AT) return quoteit(UNQUOTE_SPLICING, read(gfun)); return item; } From 69d9e65bf2be94d79b3e45676ec4a94a4817b717 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 8 Apr 2023 09:51:20 -0400 Subject: [PATCH 049/109] bugs and bugs --- term.py | 9 ++------- ulisp.hpp | 9 +++++---- 2 files changed, 7 insertions(+), 11 deletions(-) diff --git a/term.py b/term.py index c48f3db..bbf3797 100755 --- a/term.py +++ b/term.py @@ -50,8 +50,8 @@ def __call__(self, fun): def run(self, content: str) -> str: if m := self.regex.search(content): - if self.fun(m): - content = content.replace(m.group(0), "", 1) + self.fun(m) + content = content.replace(m.group(0), "", 1) return content @@ -86,7 +86,6 @@ def mem_usage_watcher(m: re.Match): FREED = int(m.group(2)) FREE = int(m.group(3)) WORKSPACESIZE = int(m.group(4)) - return True @Watcher(r"\[Ready.\]\n") @@ -94,14 +93,12 @@ def ready_watcher(m: re.Match): global STATUS if "error" not in STATUS.lower(): STATUS = "Ready." - return True @Watcher(r"\$!rs=(.*)!\$\n?") def right_status_watcher(m: re.Match): global RIGHT_STATUS RIGHT_STATUS = m.group(1) - return True @Watcher(r"waiting for download") @@ -113,13 +110,11 @@ def bootloader_watcher(m: re.Match): def error_watcher(m: re.Match): global STATUS STATUS = m.group(1) - return True @Watcher(r"\a") def bell_watcher(m: re.Match): app.output.bell() - return True def memory_usage_bar(): diff --git a/ulisp.hpp b/ulisp.hpp index 098ec0d..20aa6dd 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -181,7 +181,7 @@ typedef int (*gfun_t)(); typedef void (*pfun_t)(char); enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, LET, LETSTAR, -CLOSURE, PSTAR, QUOTE, QUASIQUOTE, UNQUOTE, UNQUOTESPLICING, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, +CLOSURE, PSTAR, QUOTE, QUASIQUOTE, UNQUOTE, UNQUOTE_SPLICING, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, ANALOGREAD, REGISTER, FORMAT, }; @@ -5491,7 +5491,7 @@ object* unquote (object* arg, object* env, int level) { popandfree(GCStack); return cons(cons(bsymbol(UNQUOTE), result), NULL); } - case UNQUOTESPLICING: + case UNQUOTE_SPLICING: if (level == 1) { push(second(arg), GCStack); result = unquote(second(arg), env, level); @@ -5504,7 +5504,7 @@ object* unquote (object* arg, object* env, int level) { push(second(arg), GCStack); result = unquote(second(arg), env, level - 1); popandfree(GCStack); - return cons(cons(bsymbol(UNQUOTESPLICING), result), NULL); + return cons(cons(bsymbol(UNQUOTE_SPLICING), result), NULL); } default: goto notspecial; @@ -6695,7 +6695,7 @@ object* eval (object* form, object* env) { object* function = car(form); object* args = cdr(form); - if (function == NULL) error(PSTR("illegal function"), nil); + if (function == NULL) error2(PSTR("can't call nil")); if (!listp(args)) error(PSTR("can't evaluate a dotted pair"), args); // List starts with a builtin symbol? @@ -6746,6 +6746,7 @@ object* eval (object* form, object* env) { if (ft == TAIL_FORMS) { Context = name; + checkargs(args); form = ((fn_ptr_type)lookupfn(name))(args, env); TC = 1; goto EVAL; From 1807c5553f94c851f60ff37b019324272fc2d0ba Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Wed, 12 Apr 2023 14:09:47 -0400 Subject: [PATCH 050/109] add bignums extension --- README.md | 1 + bignums.hpp | 561 ++++++++++++++++++++++++++++++++++++++++++++++++ ulisp-esp32.ino | 2 + 3 files changed, 564 insertions(+) create mode 100644 bignums.hpp diff --git a/README.md b/README.md index 8800081..f5a48e3 100644 --- a/README.md +++ b/README.md @@ -26,6 +26,7 @@ Extensions (`extensions.hpp`): * `gensym` * `intern` * `sizeof` +* Everything from the [ulisp-bignums](https://github.com/technoblogy/ulisp-bignums) extension ## `term.py` -- enhanced uLisp interface diff --git a/bignums.hpp b/bignums.hpp new file mode 100644 index 0000000..0ba6737 --- /dev/null +++ b/bignums.hpp @@ -0,0 +1,561 @@ +/* + Arbitrary Precision uLisp Extension - Version 1 - 11th April 2023 + See http://forum.ulisp.com/t/a-ulisp-extension-for-arbitrary-precision-arithmetic/1183 +*/ +#include +#include "ulisp.hpp" + +#define MAX_VAL ((uint64_t)0xFFFFFFFF) +#define int_to_bignum(x) (cons(number(x), NULL)) +enum { SMALLER = -1, EQUAL = 0, LARGER = 1 }; + +// Internal utility functions + +/* + maybe_gc - Does a garbage collection if less than 1/16 workspace remains. +*/ +void maybe_gc(object *arg, object *env) { + if (Freespace <= WORKSPACESIZE>>4) gc(arg, env); +} + +/* + checkbignum - checks argument is cons. + It makes the other routines simpler if we don't allow a null list. +*/ +object *checkbignum (object *b) { + if (!consp(b)) error(PSTR("argument is not a bignum"), b); + return b; +} + +/* + bignum_zerop - Tests whether a bignum is zero, allowing for possible trailing zeros. +*/ +bool bignum_zerop (object *bignum) { + while (bignum != NULL) { + if (checkinteger(car(bignum)) != 0) return false; + bignum = cdr(bignum); + } + return true; +} + +/* + bignum_normalise - Destructively removes trailing zeros. +*/ +object *bignum_normalise (object *bignum) { + object *result = bignum; + object *last = bignum; + while (bignum != NULL) { + if (checkinteger(car(bignum)) != 0) last = bignum; + bignum = cdr(bignum); + } + cdr(last) = NULL; + return result; +} + +/* + copylist - Returns a copy of a list. +*/ +object *copylist (object *arg) { + object *result = cons(NULL, NULL); + object *ptr = result; + while (arg != NULL) { + cdr(ptr) = cons(car(arg), NULL); + ptr = cdr(ptr); arg = cdr(arg); + } + return cdr(result); +} + +/* + upshift_bit - Destructively shifts a bignum up one bit; ie multiplies by 2. +*/ +void upshift_bit (object *bignum) { + uint32_t now = (uint32_t)checkinteger(car(bignum)); + car(bignum) = number(now << 1); + while (cdr(bignum) != NULL) { + uint32_t next = (uint32_t)checkinteger(car(cdr(bignum))); + car(cdr(bignum)) = number((next << 1) | (now >> 31)); + now = next; bignum = cdr(bignum); + } + if (now >> 31 != 0) cdr(bignum) = cons(number(now >> 31), NULL); +} + +/* + downshift_bit - Destructively shifts a bignum down one bit; ie divides by 2. +*/ +void downshift_bit (object *bignum) { + uint32_t now = (uint32_t)checkinteger(car(bignum)); + while (cdr(bignum) != NULL) { + uint32_t next = (uint32_t)checkinteger(car(cdr(bignum))); + car(bignum) = number((now >> 1) | (next << 31)); + now = next; bignum = cdr(bignum); + } + car(bignum) = number(now >> 1); +} + +/* + bignum_from_int - Converts a 64-bit integer to a bignum and returns it. +*/ +object *bignum_from_int (uint64_t n) { + uint32_t high = n>>32; + if (high == 0) return cons(number(n), NULL); + return cons(number(n), cons(number(high), NULL)); +} + +/* + bignum_add - Performs bignum1 + bignum2. +*/ +object *bignum_add (object *bignum1, object *bignum2) { + object *result = cons(NULL, NULL); + object *ptr = result; + int carry = 0; + while (!(bignum1 == NULL && bignum2 == NULL)) { + uint64_t tmp1 = 0, tmp2 = 0, tmp; + if (bignum1 != NULL) { + tmp1 = (uint64_t)(uint32_t)checkinteger(first(bignum1)); + bignum1 = cdr(bignum1); + } + if (bignum2 != NULL) { + tmp2 = (uint64_t)(uint32_t)checkinteger(first(bignum2)); + bignum2 = cdr(bignum2); + } + tmp = tmp1 + tmp2 + carry; + carry = (tmp > MAX_VAL); + cdr(ptr) = cons(number(tmp & MAX_VAL), NULL); + ptr = cdr(ptr); + } + if (carry != 0) { + cdr(ptr) = cons(number(carry), NULL); + } + return cdr(result); +} + +/* + bignum_sub - Performs bignum1 = bignum1 - bignum2. +*/ + object *bignum_sub (object *bignum1, object *bignum2) { + object *result = cons(NULL, NULL); + object *ptr = result; + int borrow = 0; + while (!(bignum1 == NULL && bignum2 == NULL)) { + uint64_t tmp1, tmp2, res; + if (bignum1 != NULL) { + tmp1 = (uint64_t)(uint32_t)checkinteger(first(bignum1)) + (MAX_VAL + 1); + bignum1 = cdr(bignum1); + } else tmp1 = (MAX_VAL + 1); + if (bignum2 != NULL) { + tmp2 = (uint64_t)(uint32_t)checkinteger(first(bignum2)) + borrow; + bignum2 = cdr(bignum2); + } else tmp2 = borrow; + res = tmp1 - tmp2; + borrow = (res <= MAX_VAL); + cdr(ptr) = cons(number(res & MAX_VAL), NULL); + ptr = cdr(ptr); + } + return cdr(result); +} + +/* + bignum_mul - Performs bignum1 * bignum2. +*/ +object *bignum_mul (object *bignum1, object *bignum2, object *env) { + object *result = int_to_bignum(0); + object *arg2 = bignum2; + int i = 0, j; + while (bignum1 != NULL) { + bignum2 = arg2; j = 0; + while (bignum2 != NULL) { + uint64_t n = (uint64_t)(uint32_t)checkinteger(first(bignum1)) * + (uint64_t)(uint32_t)checkinteger(first(bignum2)); + object *tmp; + if (n > MAX_VAL) tmp = cons(number(n), cons(number(n>>(uint64_t)32), NULL)); + else tmp = cons(number(n), NULL); + for (int m = i + j; m > 0; m--) push(number(0), tmp); // upshift i+j words + result = bignum_add(result, tmp); + bignum2 = cdr(bignum2); j++; + maybe_gc(result, env); + } + bignum1 = cdr(bignum1); i++; + } + return result; +} + +/* + bignum_div - Performs bignum1 / bignum2 and returns the list (quotient remainder). + First we normalise the denominator, and then do bitwise subtraction. + We need to do gcs in the main loops, while preserving the temporary lists on the GCStack. +*/ +object *bignum_div (object *bignum1, object *bignum2, object *env) { + object *current = int_to_bignum(1); + object *denom = copylist(bignum2); + while (bignum_cmp(denom, bignum1) != LARGER) { + push(number(0), current); push(number(0), denom); // upshift current and denom 1 word + push(current, GCStack); + maybe_gc(denom, env); + pop(GCStack); + } + + object *result = int_to_bignum(0); + object *remainder = copylist(bignum1); + while (!bignum_zerop(current)) { + if (bignum_cmp(remainder, denom) != SMALLER) { + remainder = bignum_sub(remainder, denom); + result = do_operator(result, current, op_ior); + } + downshift_bit(current); downshift_bit(denom); + push(current, GCStack); push(remainder, GCStack); push(denom, GCStack); + maybe_gc(result, env); + pop(GCStack); pop(GCStack); pop(GCStack); + } + return cons(result, cons(remainder, NULL)); +} + +/* + bignum_cmp - Compares two bignums and returns LARGER (b1>b2), EQUAL (b1=b2), or SMALLER (b1 b2) state = LARGER; else if (b1 < b2) state = SMALLER; + } + return state; +} + +uint32_t op_and (uint32_t a, uint32_t b) { return a & b; }; +uint32_t op_ior (uint32_t a, uint32_t b) { return a | b; }; +uint32_t op_xor (uint32_t a, uint32_t b) { return a ^ b; }; + +/* + do_operator - Returns the result of performing a logical operation on two bignums. +*/ +object *do_operator (object *bignum1, object *bignum2, uint32_t (*op)(uint32_t, uint32_t)) { + object *result = cons(NULL, NULL); + object *ptr = result; + uint32_t tmp1 = 0, tmp2 = 0; + while (!(bignum1 == NULL && bignum2 == NULL)) { + if (bignum1 != NULL) { + tmp1 = (uint32_t)checkinteger(first(bignum1)); + bignum1 = cdr(bignum1); + } + if (bignum2 != NULL) { + tmp2 = (uint32_t)checkinteger(first(bignum2)); + bignum2 = cdr(bignum2); + } + cdr(ptr) = cons(number(op(tmp1, tmp2)), NULL); + ptr = cdr(ptr); + } + return cdr(result); +} + +// Lisp functions + +/* + ($bignum int) + Converts an integer to a bignum and returns it. +*/ +object *fn_Sbignum (object *args, object *env) { + (void) env; + return int_to_bignum(checkinteger(first(args))); +} + +/* + ($integer bignum) + Converts a bignum to an integer and returns it. +*/ +object *fn_Sinteger (object *args, object *env) { + (void) env; + object *bignum = checkbignum(first(args)); + bignum = bignum_normalise(bignum); + uint32_t i = checkinteger(first(bignum)); + if (cdr(bignum) != NULL || i > 0x7FFFFFFF) error2(PSTR("bignum too large to convert to an integer")); + return number(i); +} + +/* + ($bignum-string bignum [base]) + Converts a bignum to a string in base 10 (default) or 16 and returns it. + Base 16 is trivial. For base 10 we get remainders mod 1000000000 and then print those. +*/ +object *fn_Sbignumstring (object *args, object *env) { + (void) env; + object *bignum = copylist(checkbignum(first(args))); + int b = 10; uint32_t p; + args = cdr(args); + if (args != NULL) b = checkinteger(car(args)); + object *list = NULL; + if (b == 16) { + p = 0x10000000; + while (bignum != NULL) { + push(car(bignum), list); + bignum = cdr(bignum); + } + } else if (b == 10) { + p = 100000000; + object *base = cons(number(p*10), NULL); + while(!bignum_zerop(bignum)) { + push(bignum, GCStack); push(base, GCStack); push(list, GCStack); + object *result = bignum_div(bignum, base, env); + pop(GCStack); pop(GCStack); pop(GCStack); + object *remainder = car(second(result)); + bignum = first(result); + push(remainder, list); + } + } else error2(PSTR("only base 10 or 16 supported")); + bool lead = false; + object *obj = newstring(); + object *tail = obj; + while (list != NULL) { + uint32_t i = car(list)->integer; + for (uint32_t d=p; d>0; d=d/b) { + uint32_t j = i/d; + if (j!=0 || lead || d==1) { + char ch = (j<10) ? j+'0' : j+'W'; + lead=true; + buildstring(ch, &tail); + } + i = i - j*d; + } + list = cdr(list); + } + return obj; +} + +/* + ($string-bignum string [base]) + Converts a string in the specified base, 10 (default) or 16, to a bignum and returns it. +*/ +object *fn_Sstringbignum (object *args, object *env) { + (void) env; + object *string = first(args); + if (!stringp(string)) error(notastring, string); + int b = 10; + args = cdr(args); + if (args != NULL) b = checkinteger(car(args)); + if (b != 10 && b != 16) error2(PSTR("only base 10 or 16 supported")); + object *base = int_to_bignum(b); + object *result = int_to_bignum(0); + object *form = (object *)string->name; + while (form != NULL) { + int chars = form->chars; + for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { + char ch = chars>>i & 0xFF; + if (!ch) break; + int d = digitvalue(ch); + if (d >= b) error(PSTR("illegal character in bignum"), character(ch)); + push(result, GCStack); push(base, GCStack); + result = bignum_mul(result, base, env); + pop(GCStack); pop(GCStack); + result = bignum_add(result, cons(number(d), NULL)); + } + form = car(form); + } + return result; +} + +/* + ($zerop bignum) + Tests whether a bignum is zero, allowing for trailing zeros. +*/ +object *fn_Szerop (object *args, object *env) { + (void) env; + return bignum_zerop(checkbignum(first(args))) ? tee : nil; +} + +/* + ($+ bignum1 bignum2) + Adds two bignums and returns the sum as a new bignum. +*/ +object *fn_Sadd (object *args, object *env) { + (void) env; + return bignum_add(checkbignum(first(args)), checkbignum(second(args))); +} + +/* + ($- bignum1 bignum2) + Subtracts two bignums and returns the difference as a new bignum. +*/ +object *fn_Ssub (object *args, object *env) { + (void) env; + return bignum_sub(checkbignum(first(args)), checkbignum(second(args))); +} + +/* + ($* bignum1 bignum2) + Multiplies two bignums and returns the product as a new bignum. +*/ +object *fn_Smul (object *args, object *env) { + return bignum_mul(checkbignum(first(args)), checkbignum(second(args)), env); +} + +/* + ($/ bignum1 bignum2) + Divides two bignums and returns the quotient as a new bignum. +*/ +object *fn_Sdiv (object *args, object *env) { + return first(bignum_div(checkbignum(first(args)), checkbignum(second(args)), env)); +} + +/* + ($mod bignum1 bignum2) + Divides two bignums and returns the remainder as a new bignum. +*/ +object *fn_Smod (object *args, object *env) { + return second(bignum_div(checkbignum(first(args)), checkbignum(second(args)), env)); +} + +// Comparisons +/* + ($= bignum1 bignum2) + Returns t if the two bignums are equal. +*/ +object *fn_Sequal (object *args, object *env) { + (void) env; + return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == EQUAL) ? tee : nil; +} + +/* + ($< bignum1 bignum2) + Returns t if bignum1 is less than bignum2. +*/ +object *fn_Sless (object *args, object *env) { + (void) env; + return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == SMALLER) ? tee : nil; +} + +/* + ($> bignum1 bignum2) + Returns t if bignum1 is greater than bignum2. +*/ +object *fn_Sgreater (object *args, object *env) { + (void) env; + return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == LARGER) ? tee : nil; +} + +// Bitwise logical operations + +/* + ($logand bignum1 bignum2) + Returns the logical AND of two bignums. +*/ +object *fn_Slogand (object *args, object *env) { + (void) env; + return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_and)); +} + +/* + ($logior bignum1 bignum2) + Returns the logical inclusive OR of two bignums. +*/ +object *fn_Slogior (object *args, object *env) { + (void) env; + return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_ior)); +} + +/* + ($logxor bignum1 bignum2) + Returns the logical exclusive OR of two bignums. +*/ +object *fn_Slogxor (object *args, object *env) { + (void) env; + return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_xor)); +} + +/* + ($ash bignum shift) + Returns bignum shifted by shift bits; positive means left. +*/ +object *fn_Sash (object *args, object *env) { + (void) env; + object *bignum = copylist(checkbignum(first(args))); + int shift = checkinteger(second(args)); + for (int i = 0; i < shift; i++) upshift_bit(bignum); + for (int i = 0; i < -shift; i++) downshift_bit(bignum); + return bignum_normalise(bignum); +} + +// Symbol names +const char stringSbignum[] PROGMEM = "$bignum"; +const char stringSinteger[] PROGMEM = "$integer"; +const char stringSbignumstring[] PROGMEM = "$bignum-string"; +const char stringSstringbignum[] PROGMEM = "$string-bignum"; +const char stringSzerop[] PROGMEM = "$zerop"; +const char stringSdecf[] PROGMEM = "$decf"; +const char stringSincf[] PROGMEM = "$incf"; +const char stringSadd[] PROGMEM = "$+"; +const char stringSsub[] PROGMEM = "$-"; +const char stringSmul[] PROGMEM = "$*"; +const char stringSdiv[] PROGMEM = "$/"; +const char stringSmod[] PROGMEM = "$mod"; +const char stringSequal[] PROGMEM = "$="; +const char stringSless[] PROGMEM = "$<"; +const char stringSgreater[] PROGMEM = "$>"; +const char stringSlogand[] PROGMEM = "$logand"; +const char stringSlogior[] PROGMEM = "$logior"; +const char stringSlogxor[] PROGMEM = "$logxor"; +const char stringSash[] PROGMEM = "$ash"; + +// Documentation strings +const char docSbignum[] PROGMEM = "($bignum int)\n" +"Converts an integer to a bignum and returns it."; +const char docSinteger[] PROGMEM = "($integer bignum)\n" +"Converts a bignum to an integer and returns it."; +const char docSbignumstring[] PROGMEM = "($bignum-string bignum [base])\n" +"Converts a bignum to a string in base 10 (default) or 16 and returns it."; +const char docSstringbignum[] PROGMEM = "($string-bignum bignum [base])\n" +"Converts a bignum to a string in the specified base (default 10) and returns it."; +const char docSzerop[] PROGMEM = "($zerop bignum)\n" +"Tests whether a bignum is zero, allowing for trailing zeros."; +const char docSadd[] PROGMEM = "($+ bignum1 bignum2)\n" +"Adds two bignums and returns the sum as a new bignum."; +const char docSsub[] PROGMEM = "($- bignum1 bignum2)\n" +"Subtracts two bignums and returns the difference as a new bignum."; +const char docSmul[] PROGMEM = "($* bignum1 bignum2)\n" +"Multiplies two bignums and returns the product as a new bignum."; +const char docSdiv[] PROGMEM = "($/ bignum1 bignum2)\n" +"Divides two bignums and returns the quotient as a new bignum."; +const char docSmod[] PROGMEM = "($mod bignum1 bignum2)\n" +"Divides two bignums and returns the remainder as a new bignum."; +const char docSequal[] PROGMEM = "($= bignum1 bignum2)\n" +"Returns t if the two bignums are equal."; +const char docSless[] PROGMEM = "($< bignum1 bignum2)\n" +"Returns t if bignum1 is less than bignum2."; +const char docSgreater[] PROGMEM = "($> bignum1 bignum2)\n" +"Returns t if bignum1 is greater than bignum2."; +const char docSlogand[] PROGMEM = "($logand bignum bignum)\n" +"Returns the logical AND of two bignums."; +const char docSlogior[] PROGMEM = "($logior bignum bignum)\n" +"Returns the logical inclusive OR of two bignums."; +const char docSlogxor[] PROGMEM = "($logxor bignum bignum)\n" +"Returns the logical exclusive OR of two bignums."; +const char docSash[] PROGMEM = "($ash bignum shift)\n" +"Returns bignum shifted by shift bits; positive means left."; + +// Symbol lookup table +const tbl_entry_t BignumsTable[] PROGMEM = { + { stringSbignum, fn_Sbignum, 0211, docSbignum }, + { stringSinteger, fn_Sinteger, 0211, docSinteger }, + { stringSbignumstring, fn_Sbignumstring, 0212, docSbignumstring }, + { stringSstringbignum, fn_Sstringbignum, 0212, docSstringbignum }, + { stringSzerop, fn_Szerop, 0211, docSzerop }, + { stringSadd, fn_Sadd, 0222, docSadd }, + { stringSsub, fn_Ssub, 0222, docSsub }, + { stringSmul, fn_Smul, 0222, docSmul }, + { stringSdiv, fn_Sdiv, 0222, docSdiv }, + { stringSmod, fn_Smod, 0222, docSmod }, + { stringSequal, fn_Sequal, 0222, docSequal }, + { stringSless, fn_Sless, 0222, docSless }, + { stringSgreater, fn_Sgreater, 0222, docSgreater }, + { stringSlogand, fn_Slogand, 0222, docSlogand }, + { stringSlogior, fn_Slogior, 0222, docSlogior }, + { stringSlogxor, fn_Slogxor, 0222, docSlogxor }, + { stringSash, fn_Sash, 0222, docSash }, +}; diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index a979af6..1f00d2a 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -21,6 +21,7 @@ // Includes #include "ulisp.hpp" #include "extensions.hpp" +#include "bignums.hpp" const char foo[] PROGMEM = "(defun load(filename)(with-sd-card(f filename)(loop(let((form(read f)))(unless form(return))(eval form)))))" @@ -65,6 +66,7 @@ void setup () { while ((millis() - start) < 5000) { if (Serial) break; } ulispinit(); addtable(ExtensionsTable); + addtable(BignumsTable); Serial.println(F("\n\n\nuLisp 4.4b!")); sdmain(); } From 2990eafee155167b27eaea5d620e2c10cf56f9ca Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 14 Apr 2023 09:12:07 -0400 Subject: [PATCH 051/109] immediately free the memory for GCstack --- bignums.hpp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/bignums.hpp b/bignums.hpp index 0ba6737..03ed987 100644 --- a/bignums.hpp +++ b/bignums.hpp @@ -191,7 +191,7 @@ object *bignum_div (object *bignum1, object *bignum2, object *env) { push(number(0), current); push(number(0), denom); // upshift current and denom 1 word push(current, GCStack); maybe_gc(denom, env); - pop(GCStack); + popandfree(GCStack); } object *result = int_to_bignum(0); @@ -204,7 +204,7 @@ object *bignum_div (object *bignum1, object *bignum2, object *env) { downshift_bit(current); downshift_bit(denom); push(current, GCStack); push(remainder, GCStack); push(denom, GCStack); maybe_gc(result, env); - pop(GCStack); pop(GCStack); pop(GCStack); + popandfree(GCStack); popandfree(GCStack); popandfree(GCStack); } return cons(result, cons(remainder, NULL)); } @@ -304,7 +304,7 @@ object *fn_Sbignumstring (object *args, object *env) { while(!bignum_zerop(bignum)) { push(bignum, GCStack); push(base, GCStack); push(list, GCStack); object *result = bignum_div(bignum, base, env); - pop(GCStack); pop(GCStack); pop(GCStack); + popandfree(GCStack); popandfree(GCStack); popandfree(GCStack); object *remainder = car(second(result)); bignum = first(result); push(remainder, list); @@ -353,7 +353,7 @@ object *fn_Sstringbignum (object *args, object *env) { if (d >= b) error(PSTR("illegal character in bignum"), character(ch)); push(result, GCStack); push(base, GCStack); result = bignum_mul(result, base, env); - pop(GCStack); pop(GCStack); + popandfree(GCStack); popandfree(GCStack); result = bignum_add(result, cons(number(d), NULL)); } form = car(form); From 1d133e93c2dec2c98a5808f1bc51f7d11da58744 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 14 Apr 2023 09:16:06 -0400 Subject: [PATCH 052/109] Update ulisp-esp32.ino --- ulisp-esp32.ino | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index 1f00d2a..531db3a 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -53,7 +53,7 @@ void sdmain () { if (fooform == NULL) return; push(fooform, GCStack); eval(fooform, NULL); - pop(GCStack); + popandfree(GCStack); } } From 8a1c80d84b1ceab89e92b4e96e03e828807098b7 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 14 Apr 2023 10:20:20 -0400 Subject: [PATCH 053/109] some fixes --- bignums.hpp | 16 ++++----- term.py | 10 +++--- ulisp-esp32.ino | 4 +-- ulisp.hpp | 86 +++++++++++++++++++++++++------------------------ 4 files changed, 60 insertions(+), 56 deletions(-) diff --git a/bignums.hpp b/bignums.hpp index 03ed987..d811ec4 100644 --- a/bignums.hpp +++ b/bignums.hpp @@ -189,9 +189,9 @@ object *bignum_div (object *bignum1, object *bignum2, object *env) { object *denom = copylist(bignum2); while (bignum_cmp(denom, bignum1) != LARGER) { push(number(0), current); push(number(0), denom); // upshift current and denom 1 word - push(current, GCStack); + protect(current); maybe_gc(denom, env); - popandfree(GCStack); + unprotect(); } object *result = int_to_bignum(0); @@ -202,9 +202,9 @@ object *bignum_div (object *bignum1, object *bignum2, object *env) { result = do_operator(result, current, op_ior); } downshift_bit(current); downshift_bit(denom); - push(current, GCStack); push(remainder, GCStack); push(denom, GCStack); + protect(current); protect(remainder); protect(denom); maybe_gc(result, env); - popandfree(GCStack); popandfree(GCStack); popandfree(GCStack); + unprotect(); unprotect(); unprotect(); } return cons(result, cons(remainder, NULL)); } @@ -302,9 +302,9 @@ object *fn_Sbignumstring (object *args, object *env) { p = 100000000; object *base = cons(number(p*10), NULL); while(!bignum_zerop(bignum)) { - push(bignum, GCStack); push(base, GCStack); push(list, GCStack); + protect(bignum); protect(base); protect(list); object *result = bignum_div(bignum, base, env); - popandfree(GCStack); popandfree(GCStack); popandfree(GCStack); + unprotect(); unprotect(); unprotect(); object *remainder = car(second(result)); bignum = first(result); push(remainder, list); @@ -351,9 +351,9 @@ object *fn_Sstringbignum (object *args, object *env) { if (!ch) break; int d = digitvalue(ch); if (d >= b) error(PSTR("illegal character in bignum"), character(ch)); - push(result, GCStack); push(base, GCStack); + protect(result); protect(base); result = bignum_mul(result, base, env); - popandfree(GCStack); popandfree(GCStack); + unprotect(); unprotect(); result = bignum_add(result, cons(number(d), NULL)); } form = car(form); diff --git a/term.py b/term.py index bbf3797..521d9cd 100755 --- a/term.py +++ b/term.py @@ -50,8 +50,8 @@ def __call__(self, fun): def run(self, content: str) -> str: if m := self.regex.search(content): - self.fun(m) - content = content.replace(m.group(0), "", 1) + foo = self.fun(m) or "" + content = content.replace(m.group(0), foo, 1) return content @@ -106,10 +106,11 @@ def bootloader_watcher(m: re.Match): raise SerialException("Device is in bootloader mode") -@Watcher(r"(Error: [^\n]+)\n") +@Watcher(r"(Error: ([^\n]+))\n") def error_watcher(m: re.Match): global STATUS STATUS = m.group(1) + return m.group(2) @Watcher(r"\a") @@ -230,7 +231,7 @@ async def repl_task(port: Serial): if send is not None and send.strip(): STATUS = "Running..." port.write(send.encode()) - port.write(b"\n") + port.write(b"\r\n") port.flush() input_queue.task_done() if port.in_waiting > 0: @@ -250,6 +251,7 @@ async def main(): def version_watcher(m: re.Match): nonlocal port set_title(f"uLisp {m.group(1)} on {port.port} ({port.name})") + return f"uLisp version {m.group(1)}" await asyncio.gather( app.run_async(), diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index 531db3a..0d4a450 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -51,9 +51,9 @@ void sdmain () { for(;;) { fooform = read(getfoo); if (fooform == NULL) return; - push(fooform, GCStack); + protect(fooform); eval(fooform, NULL); - popandfree(GCStack); + unprotect(); } } diff --git a/ulisp.hpp b/ulisp.hpp index 20aa6dd..3f722af 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -81,7 +81,9 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define push(x, y) ((y) = cons((x), (y))) #define pop(y) ((y) = cdr(y)) -#define popandfree(y) do { object* temp__ = (y); pop(y); myfree(temp__); } while(0) + +#define protect(y) push((y), GCStack) +#define unprotect() do { object* __old__GCStack = GCStack; pop(GCStack); myfree(__old__GCStack); } while(0) #define integerp(x) ((x) != NULL && (x)->type == NUMBER) #define floatp(x) ((x) != NULL && (x)->type == FLOAT) @@ -1788,9 +1790,9 @@ object* mapcarcan (object* args, object* env, mapfun_t fun) { object* function = first(args); args = cdr(args); object* params = cons(NULL, NULL); - push(params,GCStack); + protect(params); object* head = cons(NULL, NULL); - push(head,GCStack); + protect(head); object* tail = head; // Make parameters while (true) { @@ -1799,7 +1801,7 @@ object* mapcarcan (object* args, object* env, mapfun_t fun) { while (lists != NULL) { object* list = car(lists); if (list == NULL) { - popandfree(GCStack); popandfree(GCStack); + unprotect(); unprotect(); return cdr(head); } if (improperp(list)) error(notproper, list); @@ -2346,7 +2348,7 @@ object* sp_dolist (object* args, object* env) { object* params = checkarguments(args, 2, 3); object* var = first(params); object* list = eval(second(params), env); - push(list, GCStack); // Don't GC the list + protect(list); // Don't GC the list object* pair = cons(var,nil); push(pair,env); params = cdr(cdr(params)); @@ -2359,7 +2361,7 @@ object* sp_dolist (object* args, object* env) { object* result = eval(car(forms), env); if (tstflag(RETURNFLAG)) { clrflag(RETURNFLAG); - popandfree(GCStack); + unprotect(); return result; } forms = cdr(forms); @@ -2367,7 +2369,7 @@ object* sp_dolist (object* args, object* env) { list = cdr(list); } cdr(pair) = nil; - popandfree(GCStack); + unprotect(); if (params == NULL) return nil; return eval(car(params), env); } @@ -2504,10 +2506,10 @@ object* sp_withoutputtostring (object* args, object* env) { object* pair = cons(var, stream(STRINGSTREAM, 0)); push(pair,env); object* string = startstring(); - push(string, GCStack); + protect(string); object* forms = cdr(args); eval(tf_progn(forms,env), env); - popandfree(GCStack); + unprotect(); return string; } @@ -3203,9 +3205,9 @@ object* fn_mapc (object* args, object* env) { object* function = first(args); args = cdr(args); object* result = first(args); - push(result,GCStack); + protect(result); object* params = cons(NULL, NULL); - push(params,GCStack); + protect(params); // Make parameters while (true) { object* tailp = params; @@ -3213,7 +3215,7 @@ object* fn_mapc (object* args, object* env) { while (lists != NULL) { object* list = car(lists); if (list == NULL) { - popandfree(GCStack); popandfree(GCStack); + unprotect(); unprotect(); return result; } if (improperp(list)) error(notproper, list); @@ -3938,10 +3940,10 @@ object* fn_stringgreater (object* args, object* env) { object* fn_sort (object* args, object* env) { if (first(args) == NULL) return nil; object* list = cons(nil,first(args)); - push(list,GCStack); + protect(list); object* predicate = second(args); object* compare = cons(NULL, cons(NULL, NULL)); - push(compare,GCStack); + protect(compare); object* ptr = cdr(list); while (cdr(ptr) != NULL) { object* go = list; @@ -3958,7 +3960,7 @@ object* fn_sort (object* args, object* env) { cdr(go) = obj; } else ptr = cdr(ptr); } - popandfree(GCStack); popandfree(GCStack); + unprotect(); unprotect(); return cdr(list); } @@ -5398,10 +5400,10 @@ object* sp_catch (object* args, object* env) { object* tag = first(args); object* forms = rest(args); - push(tag, GCStack); + protect(tag); tag = eval(tag, env); car(GCStack) = tag; - push(forms, GCStack); + protect(forms); object* result; @@ -5473,37 +5475,37 @@ object* unquote (object* arg, object* env, int level) { if (what->type == SYMBOL) { switch (builtin(what->name)) { case QUASIQUOTE: - push(second(arg), GCStack); + protect(second(arg)); result = unquote(second(arg), env, level + 1); - popandfree(GCStack); + unprotect(); return cons(cons(bsymbol(QUASIQUOTE), result), NULL); case UNQUOTE: if (level == 1) { - push(second(arg), GCStack); + protect(second(arg)); result = unquote(second(arg), env, level); car(GCStack) = result; result = eval(car(result), env); - popandfree(GCStack); + unprotect(); return cons(result, NULL); } else { - push(second(arg), GCStack); + protect(second(arg)); result = unquote(second(arg), env, level - 1); - popandfree(GCStack); + unprotect(); return cons(cons(bsymbol(UNQUOTE), result), NULL); } case UNQUOTE_SPLICING: if (level == 1) { - push(second(arg), GCStack); + protect(second(arg)); result = unquote(second(arg), env, level); car(GCStack) = result; result = eval(car(result), env); - popandfree(GCStack); + unprotect(); if (result == NULL) return nope; else return result; } else { - push(second(arg), GCStack); + protect(second(arg)); result = unquote(second(arg), env, level - 1); - popandfree(GCStack); + unprotect(); return cons(cons(bsymbol(UNQUOTE_SPLICING), result), NULL); } default: @@ -5512,9 +5514,9 @@ object* unquote (object* arg, object* env, int level) { } else { notspecial: for (object* x = arg; x != NULL; x = cdr(x)) { - push(car(x), GCStack); + protect(car(x)); object* foo = unquote(car(x), env, level); - popandfree(GCStack); + unprotect(); if (foo != nope) push(foo, result); } // Reverse and flatten @@ -5528,9 +5530,9 @@ object* unquote (object* arg, object* env, int level) { object* sp_quasiquote (object* args, object* env) { checkargs(args); - push(first(args), GCStack); + protect(first(args)); object* result = unquote(first(args), env, 1); - popandfree(GCStack); + unprotect(); return result; } @@ -6709,7 +6711,7 @@ object* eval (object* form, object* env) { if (!listp(assigns)) error(notalist, assigns); object* forms = cdr(args); object* newenv = env; - push(newenv, GCStack); + protect(newenv); while (assigns != NULL) { object* assign = car(assigns); if (!consp(assign)) push(cons(assign,nil), newenv); @@ -6720,7 +6722,7 @@ object* eval (object* form, object* env) { assigns = cdr(assigns); } env = newenv; - popandfree(GCStack); + unprotect(); form = tf_progn(forms,env); TC = TCstart; goto EVAL; @@ -6758,7 +6760,7 @@ object* eval (object* form, object* env) { object* fname = car(form); int TCstart = TC; object* head = cons(eval(fname, env), NULL); - push(head, GCStack); // Don't GC the result list + protect(head); // Don't GC the result list object* tail = head; form = cdr(form); int nargs = 0; @@ -6780,7 +6782,7 @@ object* eval (object* form, object* env) { Context = bname; checkminmax(bname, nargs); object* result = ((fn_ptr_type)lookupfn(bname))(args, env); - popandfree(GCStack); + unprotect(); return result; } @@ -6790,7 +6792,7 @@ object* eval (object* form, object* env) { if (isbuiltin(car(function), LAMBDA)) { form = closure(TCstart, name, function, args, &env); - popandfree(GCStack); + unprotect(); int trace = tracing(fname->name); if (trace) { object* result = eval(form, env); @@ -6809,7 +6811,7 @@ object* eval (object* form, object* env) { if (isbuiltin(car(function), CLOSURE)) { function = cdr(function); form = closure(TCstart, name, function, args, &env); - popandfree(GCStack); + unprotect(); TC = 1; goto EVAL; } @@ -6825,7 +6827,7 @@ object* eval (object* form, object* env) { */ void pserial (char c) { LastPrint = c; - //if (c == '\n') Serial.write('\r'); + if (c == '\n') Serial.write('\r'); Serial.write(c); } @@ -7119,9 +7121,9 @@ void loadfromlibrary (object* env) { GlobalStringIndex = 0; object* line = read(glibrary); while (line != NULL) { - push(line, GCStack); + protect(line); eval(line, env); - popandfree(GCStack); + unprotect(); line = read(glibrary); } } @@ -7373,12 +7375,12 @@ void repl (object* env) { object* line = read(gserial); if (BreakLevel && line == nil) { pln(pserial); return; } if (line == (object*)CLOSE_PAREN) error2(PSTR("unmatched right bracket")); - push(line, GCStack); + protect(line); pfl(pserial); line = eval(line, env); pfl(pserial); printobject(line, pserial); - popandfree(GCStack); + unprotect(); pfl(pserial); pln(pserial); } From 3cc164afa70346c77bc509196f5aa4b8f27fd932 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 20 May 2023 16:50:40 -0400 Subject: [PATCH 054/109] fix some compiler warnings --- extensions.hpp | 8 ++++---- ulisp.hpp | 40 +++++++++++++++++++++++++++++----------- 2 files changed, 33 insertions(+), 15 deletions(-) diff --git a/extensions.hpp b/extensions.hpp index 6652ea0..108dd97 100644 --- a/extensions.hpp +++ b/extensions.hpp @@ -31,17 +31,17 @@ const char docnow[] PROGMEM = "(now [hh mm ss])\n" "as a list of three integers (hh mm ss)."; object* fn_gensym (object* args, object* env) { - int counter = 0; - char buffer[BUFFERSIZE]; + unsigned int counter = 0; + char buffer[BUFFERSIZE+10]; char prefix[BUFFERSIZE]; if (args != NULL) { - cstring(checkstring(first(args)), prefix, BUFFERSIZE); + cstring(checkstring(first(args)), prefix, sizeof(prefix)); } else { strcpy(prefix, "$gensym"); } object* result; do { - snprintf(buffer, BUFFERSIZE, "%s%i", prefix, counter); + snprintf(buffer, sizeof(buffer), "%s%u", prefix, counter); result = buftosymbol(buffer); counter++; } while (boundp(result, env) || boundp(result, GlobalEnv)); diff --git a/ulisp.hpp b/ulisp.hpp index 20aa6dd..76246dd 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -16,7 +16,6 @@ #include #include #include -#include #include // Lisp Library @@ -285,6 +284,9 @@ void errorsub (symbol_t fname, PGM_P string) { pfstring(string, pserial); } +#ifdef __cplusplus +[[noreturn]] +#endif void errorend () { GCStack = NULL; longjmp(*handler, 1); } /* @@ -292,6 +294,9 @@ void errorend () { GCStack = NULL; longjmp(*handler, 1); } Prints: "Error: 'fname' string: symbol", where fname is the name of the user Lisp function in which the error occurred, and symbol is the object generating the error. */ +#ifdef __cplusplus +[[noreturn]] +#endif void errorsym (symbol_t fname, PGM_P string, object* symbol) { if (!tstflag(MUFFLEERRORS)) { errorsub(fname, string); @@ -306,6 +311,9 @@ void errorsym (symbol_t fname, PGM_P string, object* symbol) { errorsym2 - prints an error message and reenters the REPL. Prints: "Error: 'fname' string", where fname is the name of the user Lisp function in which the error occurred. */ +#ifdef __cplusplus +[[noreturn]] +#endif void errorsym2 (symbol_t fname, PGM_P string) { if (!tstflag(MUFFLEERRORS)) { errorsub(fname, string); @@ -319,6 +327,9 @@ void errorsym2 (symbol_t fname, PGM_P string) { Prints: "Error: 'Context' string: symbol", where Context is the name of the built-in Lisp function in which the error occurred, and symbol is the object generating the error. */ +#ifdef __cplusplus +[[noreturn]] +#endif void error (PGM_P string, object* symbol) { errorsym(sym(Context), string, symbol); } @@ -327,6 +338,9 @@ void error (PGM_P string, object* symbol) { error2 - prints an error message and reenters the REPL. Prints: "Error: 'Context' string", where Context is the name of the built-in Lisp function in which the error occurred. */ +#ifdef __cplusplus +[[noreturn]] +#endif void error2 (PGM_P string) { errorsym2(sym(Context), string); } @@ -334,6 +348,9 @@ void error2 (PGM_P string) { /* formaterr - displays a format error with a ^ pointing to the error */ +#ifdef __cplusplus +[[noreturn]] +#endif void formaterr (object* formatstr, PGM_P string, uint8_t p) { pln(pserial); indent(4, ' ', pserial); printstring(formatstr, pserial); pln(pserial); indent(p+5, ' ', pserial); pserial('^'); @@ -1829,14 +1846,15 @@ void I2Cwrite (uint8_t data) { } bool I2Cstart (uint8_t address, uint8_t read) { - int ok = true; - if (read == 0) { - Wire.beginTransmission(address); - ok = (Wire.endTransmission(true) == 0); - Wire.beginTransmission(address); - } - else Wire.requestFrom(address, I2Ccount); - return ok; + int ok = true; + if (read == 0) { + Wire.setClock(10000); // Low speed mode (still pretty fast) + Wire.beginTransmission(address); + ok = (Wire.endTransmission(true) == 0); + Wire.beginTransmission(address); + } + else Wire.requestFrom(address, I2Ccount); + return ok; } bool I2Crestart (uint8_t address, uint8_t read) { @@ -5468,8 +5486,8 @@ object* fn_throw (object* args, object* env) { object* unquote (object* arg, object* env, int level) { if (arg == NULL || atom(arg)) return cons(bsymbol(QUOTE), cons(arg, NULL)); object* what = first(arg); - object* result; - object* result2; + object* result = NULL; + object* result2 = NULL; if (what->type == SYMBOL) { switch (builtin(what->name)) { case QUASIQUOTE: From 10821ab522920d5607122474c519bdc732e7412e Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 27 May 2023 21:20:15 -0400 Subject: [PATCH 055/109] fix forward references to compile --- bignums.hpp | 152 +++++++++++++++++++++++++++------------------------- 1 file changed, 79 insertions(+), 73 deletions(-) diff --git a/bignums.hpp b/bignums.hpp index d811ec4..8daea30 100644 --- a/bignums.hpp +++ b/bignums.hpp @@ -9,41 +9,47 @@ #define int_to_bignum(x) (cons(number(x), NULL)) enum { SMALLER = -1, EQUAL = 0, LARGER = 1 }; +// Forward references +object* do_operator (object* bignum1, object* bignum2, uint32_t (*op)(uint32_t, uint32_t)); +uint32_t op_ior (uint32_t, uint32_t); +int bignum_cmp (object* bignum1, object* bignum2); + + // Internal utility functions /* - maybe_gc - Does a garbage collection if less than 1/16 workspace remains. + maybe_gc - Does a garbage collection if less than 1/16 workspace remains. */ -void maybe_gc(object *arg, object *env) { - if (Freespace <= WORKSPACESIZE>>4) gc(arg, env); +void maybe_gc(object* arg, object* env) { + if (Freespace <= WORKSPACESIZE>>4) gc(arg, env); } /* - checkbignum - checks argument is cons. - It makes the other routines simpler if we don't allow a null list. + checkbignum - checks argument is cons. + It makes the other routines simpler if we don't allow a null list. */ -object *checkbignum (object *b) { - if (!consp(b)) error(PSTR("argument is not a bignum"), b); - return b; +object* checkbignum (object* b) { + if (!consp(b)) error(PSTR("argument is not a bignum"), b); + return b; } /* - bignum_zerop - Tests whether a bignum is zero, allowing for possible trailing zeros. + bignum_zerop - Tests whether a bignum is zero, allowing for possible trailing zeros. */ -bool bignum_zerop (object *bignum) { - while (bignum != NULL) { - if (checkinteger(car(bignum)) != 0) return false; - bignum = cdr(bignum); - } - return true; +bool bignum_zerop (object* bignum) { + while (bignum != NULL) { + if (checkinteger(car(bignum)) != 0) return false; + bignum = cdr(bignum); + } + return true; } /* bignum_normalise - Destructively removes trailing zeros. */ -object *bignum_normalise (object *bignum) { - object *result = bignum; - object *last = bignum; +object* bignum_normalise (object* bignum) { + object* result = bignum; + object* last = bignum; while (bignum != NULL) { if (checkinteger(car(bignum)) != 0) last = bignum; bignum = cdr(bignum); @@ -55,9 +61,9 @@ object *bignum_normalise (object *bignum) { /* copylist - Returns a copy of a list. */ -object *copylist (object *arg) { - object *result = cons(NULL, NULL); - object *ptr = result; +object* copylist (object* arg) { + object* result = cons(NULL, NULL); + object* ptr = result; while (arg != NULL) { cdr(ptr) = cons(car(arg), NULL); ptr = cdr(ptr); arg = cdr(arg); @@ -68,7 +74,7 @@ object *copylist (object *arg) { /* upshift_bit - Destructively shifts a bignum up one bit; ie multiplies by 2. */ -void upshift_bit (object *bignum) { +void upshift_bit (object* bignum) { uint32_t now = (uint32_t)checkinteger(car(bignum)); car(bignum) = number(now << 1); while (cdr(bignum) != NULL) { @@ -82,7 +88,7 @@ void upshift_bit (object *bignum) { /* downshift_bit - Destructively shifts a bignum down one bit; ie divides by 2. */ -void downshift_bit (object *bignum) { +void downshift_bit (object* bignum) { uint32_t now = (uint32_t)checkinteger(car(bignum)); while (cdr(bignum) != NULL) { uint32_t next = (uint32_t)checkinteger(car(cdr(bignum))); @@ -95,7 +101,7 @@ void downshift_bit (object *bignum) { /* bignum_from_int - Converts a 64-bit integer to a bignum and returns it. */ -object *bignum_from_int (uint64_t n) { +object* bignum_from_int (uint64_t n) { uint32_t high = n>>32; if (high == 0) return cons(number(n), NULL); return cons(number(n), cons(number(high), NULL)); @@ -104,9 +110,9 @@ object *bignum_from_int (uint64_t n) { /* bignum_add - Performs bignum1 + bignum2. */ -object *bignum_add (object *bignum1, object *bignum2) { - object *result = cons(NULL, NULL); - object *ptr = result; +object* bignum_add (object* bignum1, object* bignum2) { + object* result = cons(NULL, NULL); + object* ptr = result; int carry = 0; while (!(bignum1 == NULL && bignum2 == NULL)) { uint64_t tmp1 = 0, tmp2 = 0, tmp; @@ -132,9 +138,9 @@ object *bignum_add (object *bignum1, object *bignum2) { /* bignum_sub - Performs bignum1 = bignum1 - bignum2. */ - object *bignum_sub (object *bignum1, object *bignum2) { - object *result = cons(NULL, NULL); - object *ptr = result; + object* bignum_sub (object* bignum1, object* bignum2) { + object* result = cons(NULL, NULL); + object* ptr = result; int borrow = 0; while (!(bignum1 == NULL && bignum2 == NULL)) { uint64_t tmp1, tmp2, res; @@ -157,16 +163,16 @@ object *bignum_add (object *bignum1, object *bignum2) { /* bignum_mul - Performs bignum1 * bignum2. */ -object *bignum_mul (object *bignum1, object *bignum2, object *env) { - object *result = int_to_bignum(0); - object *arg2 = bignum2; +object* bignum_mul (object* bignum1, object* bignum2, object* env) { + object* result = int_to_bignum(0); + object* arg2 = bignum2; int i = 0, j; while (bignum1 != NULL) { bignum2 = arg2; j = 0; while (bignum2 != NULL) { uint64_t n = (uint64_t)(uint32_t)checkinteger(first(bignum1)) * (uint64_t)(uint32_t)checkinteger(first(bignum2)); - object *tmp; + object* tmp; if (n > MAX_VAL) tmp = cons(number(n), cons(number(n>>(uint64_t)32), NULL)); else tmp = cons(number(n), NULL); for (int m = i + j; m > 0; m--) push(number(0), tmp); // upshift i+j words @@ -184,9 +190,9 @@ object *bignum_mul (object *bignum1, object *bignum2, object *env) { First we normalise the denominator, and then do bitwise subtraction. We need to do gcs in the main loops, while preserving the temporary lists on the GCStack. */ -object *bignum_div (object *bignum1, object *bignum2, object *env) { - object *current = int_to_bignum(1); - object *denom = copylist(bignum2); +object* bignum_div (object* bignum1, object* bignum2, object* env) { + object* current = int_to_bignum(1); + object* denom = copylist(bignum2); while (bignum_cmp(denom, bignum1) != LARGER) { push(number(0), current); push(number(0), denom); // upshift current and denom 1 word protect(current); @@ -194,8 +200,8 @@ object *bignum_div (object *bignum1, object *bignum2, object *env) { unprotect(); } - object *result = int_to_bignum(0); - object *remainder = copylist(bignum1); + object* result = int_to_bignum(0); + object* remainder = copylist(bignum1); while (!bignum_zerop(current)) { if (bignum_cmp(remainder, denom) != SMALLER) { remainder = bignum_sub(remainder, denom); @@ -213,7 +219,7 @@ object *bignum_div (object *bignum1, object *bignum2, object *env) { bignum_cmp - Compares two bignums and returns LARGER (b1>b2), EQUAL (b1=b2), or SMALLER (b1 0x7FFFFFFF) error2(PSTR("bignum too large to convert to an integer")); @@ -285,13 +291,13 @@ object *fn_Sinteger (object *args, object *env) { Converts a bignum to a string in base 10 (default) or 16 and returns it. Base 16 is trivial. For base 10 we get remainders mod 1000000000 and then print those. */ -object *fn_Sbignumstring (object *args, object *env) { +object* fn_Sbignumstring (object* args, object* env) { (void) env; - object *bignum = copylist(checkbignum(first(args))); + object* bignum = copylist(checkbignum(first(args))); int b = 10; uint32_t p; args = cdr(args); if (args != NULL) b = checkinteger(car(args)); - object *list = NULL; + object* list = NULL; if (b == 16) { p = 0x10000000; while (bignum != NULL) { @@ -300,19 +306,19 @@ object *fn_Sbignumstring (object *args, object *env) { } } else if (b == 10) { p = 100000000; - object *base = cons(number(p*10), NULL); + object* base = cons(number(p*10), NULL); while(!bignum_zerop(bignum)) { protect(bignum); protect(base); protect(list); - object *result = bignum_div(bignum, base, env); + object* result = bignum_div(bignum, base, env); unprotect(); unprotect(); unprotect(); - object *remainder = car(second(result)); + object* remainder = car(second(result)); bignum = first(result); push(remainder, list); } } else error2(PSTR("only base 10 or 16 supported")); bool lead = false; - object *obj = newstring(); - object *tail = obj; + object* obj = newstring(); + object* tail = obj; while (list != NULL) { uint32_t i = car(list)->integer; for (uint32_t d=p; d>0; d=d/b) { @@ -333,17 +339,17 @@ object *fn_Sbignumstring (object *args, object *env) { ($string-bignum string [base]) Converts a string in the specified base, 10 (default) or 16, to a bignum and returns it. */ -object *fn_Sstringbignum (object *args, object *env) { +object* fn_Sstringbignum (object* args, object* env) { (void) env; - object *string = first(args); + object* string = first(args); if (!stringp(string)) error(notastring, string); int b = 10; args = cdr(args); if (args != NULL) b = checkinteger(car(args)); if (b != 10 && b != 16) error2(PSTR("only base 10 or 16 supported")); - object *base = int_to_bignum(b); - object *result = int_to_bignum(0); - object *form = (object *)string->name; + object* base = int_to_bignum(b); + object* result = int_to_bignum(0); + object* form = (object* )string->name; while (form != NULL) { int chars = form->chars; for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { @@ -365,7 +371,7 @@ object *fn_Sstringbignum (object *args, object *env) { ($zerop bignum) Tests whether a bignum is zero, allowing for trailing zeros. */ -object *fn_Szerop (object *args, object *env) { +object* fn_Szerop (object* args, object* env) { (void) env; return bignum_zerop(checkbignum(first(args))) ? tee : nil; } @@ -374,7 +380,7 @@ object *fn_Szerop (object *args, object *env) { ($+ bignum1 bignum2) Adds two bignums and returns the sum as a new bignum. */ -object *fn_Sadd (object *args, object *env) { +object* fn_Sadd (object* args, object* env) { (void) env; return bignum_add(checkbignum(first(args)), checkbignum(second(args))); } @@ -383,7 +389,7 @@ object *fn_Sadd (object *args, object *env) { ($- bignum1 bignum2) Subtracts two bignums and returns the difference as a new bignum. */ -object *fn_Ssub (object *args, object *env) { +object* fn_Ssub (object* args, object* env) { (void) env; return bignum_sub(checkbignum(first(args)), checkbignum(second(args))); } @@ -392,7 +398,7 @@ object *fn_Ssub (object *args, object *env) { ($* bignum1 bignum2) Multiplies two bignums and returns the product as a new bignum. */ -object *fn_Smul (object *args, object *env) { +object* fn_Smul (object* args, object* env) { return bignum_mul(checkbignum(first(args)), checkbignum(second(args)), env); } @@ -400,7 +406,7 @@ object *fn_Smul (object *args, object *env) { ($/ bignum1 bignum2) Divides two bignums and returns the quotient as a new bignum. */ -object *fn_Sdiv (object *args, object *env) { +object* fn_Sdiv (object* args, object* env) { return first(bignum_div(checkbignum(first(args)), checkbignum(second(args)), env)); } @@ -408,7 +414,7 @@ object *fn_Sdiv (object *args, object *env) { ($mod bignum1 bignum2) Divides two bignums and returns the remainder as a new bignum. */ -object *fn_Smod (object *args, object *env) { +object* fn_Smod (object* args, object* env) { return second(bignum_div(checkbignum(first(args)), checkbignum(second(args)), env)); } @@ -417,7 +423,7 @@ object *fn_Smod (object *args, object *env) { ($= bignum1 bignum2) Returns t if the two bignums are equal. */ -object *fn_Sequal (object *args, object *env) { +object* fn_Sequal (object* args, object* env) { (void) env; return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == EQUAL) ? tee : nil; } @@ -426,7 +432,7 @@ object *fn_Sequal (object *args, object *env) { ($< bignum1 bignum2) Returns t if bignum1 is less than bignum2. */ -object *fn_Sless (object *args, object *env) { +object* fn_Sless (object* args, object* env) { (void) env; return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == SMALLER) ? tee : nil; } @@ -435,7 +441,7 @@ object *fn_Sless (object *args, object *env) { ($> bignum1 bignum2) Returns t if bignum1 is greater than bignum2. */ -object *fn_Sgreater (object *args, object *env) { +object* fn_Sgreater (object* args, object* env) { (void) env; return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == LARGER) ? tee : nil; } @@ -446,7 +452,7 @@ object *fn_Sgreater (object *args, object *env) { ($logand bignum1 bignum2) Returns the logical AND of two bignums. */ -object *fn_Slogand (object *args, object *env) { +object* fn_Slogand (object* args, object* env) { (void) env; return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_and)); } @@ -455,7 +461,7 @@ object *fn_Slogand (object *args, object *env) { ($logior bignum1 bignum2) Returns the logical inclusive OR of two bignums. */ -object *fn_Slogior (object *args, object *env) { +object* fn_Slogior (object* args, object* env) { (void) env; return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_ior)); } @@ -464,7 +470,7 @@ object *fn_Slogior (object *args, object *env) { ($logxor bignum1 bignum2) Returns the logical exclusive OR of two bignums. */ -object *fn_Slogxor (object *args, object *env) { +object* fn_Slogxor (object* args, object* env) { (void) env; return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_xor)); } @@ -473,9 +479,9 @@ object *fn_Slogxor (object *args, object *env) { ($ash bignum shift) Returns bignum shifted by shift bits; positive means left. */ -object *fn_Sash (object *args, object *env) { +object* fn_Sash (object* args, object* env) { (void) env; - object *bignum = copylist(checkbignum(first(args))); + object* bignum = copylist(checkbignum(first(args))); int shift = checkinteger(second(args)); for (int i = 0; i < shift; i++) upshift_bit(bignum); for (int i = 0; i < -shift; i++) downshift_bit(bignum); From 7e80bf147cd222d17b60428ab604279570e328a8 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 5 Jun 2023 16:32:40 -0400 Subject: [PATCH 056/109] fix some bugs and some modifications * release i2c pins at end of (with-i2c) block * fix technoblogy#76 * formatting on bignums source code --- bignums.hpp | 764 ++++++++++++++++++++++++++-------------------------- term.py | 60 +++-- ulisp.hpp | 4 +- 3 files changed, 417 insertions(+), 411 deletions(-) diff --git a/bignums.hpp b/bignums.hpp index 8daea30..b7e9006 100644 --- a/bignums.hpp +++ b/bignums.hpp @@ -1,6 +1,6 @@ /* - Arbitrary Precision uLisp Extension - Version 1 - 11th April 2023 - See http://forum.ulisp.com/t/a-ulisp-extension-for-arbitrary-precision-arithmetic/1183 + Arbitrary Precision uLisp Extension - Version 1 - 11th April 2023 + See http://forum.ulisp.com/t/a-ulisp-extension-for-arbitrary-precision-arithmetic/1183 */ #include #include "ulisp.hpp" @@ -21,7 +21,7 @@ int bignum_cmp (object* bignum1, object* bignum2); maybe_gc - Does a garbage collection if less than 1/16 workspace remains. */ void maybe_gc(object* arg, object* env) { - if (Freespace <= WORKSPACESIZE>>4) gc(arg, env); + if (Freespace <= WORKSPACESIZE >> 4) gc(arg, env); } /* @@ -45,195 +45,195 @@ bool bignum_zerop (object* bignum) { } /* - bignum_normalise - Destructively removes trailing zeros. + bignum_normalise - Destructively removes trailing zeros. */ object* bignum_normalise (object* bignum) { - object* result = bignum; - object* last = bignum; - while (bignum != NULL) { - if (checkinteger(car(bignum)) != 0) last = bignum; - bignum = cdr(bignum); - } - cdr(last) = NULL; - return result; + object* result = bignum; + object* last = bignum; + while (bignum != NULL) { + if (checkinteger(car(bignum)) != 0) last = bignum; + bignum = cdr(bignum); + } + cdr(last) = NULL; + return result; } /* - copylist - Returns a copy of a list. + copylist - Returns a copy of a list. */ object* copylist (object* arg) { - object* result = cons(NULL, NULL); - object* ptr = result; - while (arg != NULL) { - cdr(ptr) = cons(car(arg), NULL); - ptr = cdr(ptr); arg = cdr(arg); - } - return cdr(result); + object* result = cons(NULL, NULL); + object* ptr = result; + while (arg != NULL) { + cdr(ptr) = cons(car(arg), NULL); + ptr = cdr(ptr); arg = cdr(arg); + } + return cdr(result); } /* - upshift_bit - Destructively shifts a bignum up one bit; ie multiplies by 2. + upshift_bit - Destructively shifts a bignum up one bit; ie multiplies by 2. */ void upshift_bit (object* bignum) { - uint32_t now = (uint32_t)checkinteger(car(bignum)); - car(bignum) = number(now << 1); - while (cdr(bignum) != NULL) { - uint32_t next = (uint32_t)checkinteger(car(cdr(bignum))); - car(cdr(bignum)) = number((next << 1) | (now >> 31)); - now = next; bignum = cdr(bignum); - } - if (now >> 31 != 0) cdr(bignum) = cons(number(now >> 31), NULL); + uint32_t now = (uint32_t)checkinteger(car(bignum)); + car(bignum) = number(now << 1); + while (cdr(bignum) != NULL) { + uint32_t next = (uint32_t)checkinteger(car(cdr(bignum))); + car(cdr(bignum)) = number((next << 1) | (now >> 31)); + now = next; bignum = cdr(bignum); + } + if (now >> 31 != 0) cdr(bignum) = cons(number(now >> 31), NULL); } /* - downshift_bit - Destructively shifts a bignum down one bit; ie divides by 2. + downshift_bit - Destructively shifts a bignum down one bit; ie divides by 2. */ void downshift_bit (object* bignum) { - uint32_t now = (uint32_t)checkinteger(car(bignum)); - while (cdr(bignum) != NULL) { - uint32_t next = (uint32_t)checkinteger(car(cdr(bignum))); - car(bignum) = number((now >> 1) | (next << 31)); - now = next; bignum = cdr(bignum); - } - car(bignum) = number(now >> 1); + uint32_t now = (uint32_t)checkinteger(car(bignum)); + while (cdr(bignum) != NULL) { + uint32_t next = (uint32_t)checkinteger(car(cdr(bignum))); + car(bignum) = number((now >> 1) | (next << 31)); + now = next; bignum = cdr(bignum); + } + car(bignum) = number(now >> 1); } /* - bignum_from_int - Converts a 64-bit integer to a bignum and returns it. + bignum_from_int - Converts a 64-bit integer to a bignum and returns it. */ object* bignum_from_int (uint64_t n) { - uint32_t high = n>>32; - if (high == 0) return cons(number(n), NULL); - return cons(number(n), cons(number(high), NULL)); + uint32_t high = n >> 32; + if (high == 0) return cons(number(n), NULL); + return cons(number(n), cons(number(high), NULL)); } /* - bignum_add - Performs bignum1 + bignum2. + bignum_add - Performs bignum1 + bignum2. */ object* bignum_add (object* bignum1, object* bignum2) { - object* result = cons(NULL, NULL); - object* ptr = result; - int carry = 0; - while (!(bignum1 == NULL && bignum2 == NULL)) { - uint64_t tmp1 = 0, tmp2 = 0, tmp; - if (bignum1 != NULL) { - tmp1 = (uint64_t)(uint32_t)checkinteger(first(bignum1)); - bignum1 = cdr(bignum1); + object* result = cons(NULL, NULL); + object* ptr = result; + int carry = 0; + while (!(bignum1 == NULL && bignum2 == NULL)) { + uint64_t tmp1 = 0, tmp2 = 0, tmp; + if (bignum1 != NULL) { + tmp1 = (uint64_t)(uint32_t)checkinteger(first(bignum1)); + bignum1 = cdr(bignum1); + } + if (bignum2 != NULL) { + tmp2 = (uint64_t)(uint32_t)checkinteger(first(bignum2)); + bignum2 = cdr(bignum2); + } + tmp = tmp1 + tmp2 + carry; + carry = (tmp > MAX_VAL); + cdr(ptr) = cons(number(tmp & MAX_VAL), NULL); + ptr = cdr(ptr); } - if (bignum2 != NULL) { - tmp2 = (uint64_t)(uint32_t)checkinteger(first(bignum2)); - bignum2 = cdr(bignum2); + if (carry != 0) { + cdr(ptr) = cons(number(carry), NULL); } - tmp = tmp1 + tmp2 + carry; - carry = (tmp > MAX_VAL); - cdr(ptr) = cons(number(tmp & MAX_VAL), NULL); - ptr = cdr(ptr); - } - if (carry != 0) { - cdr(ptr) = cons(number(carry), NULL); - } - return cdr(result); + return cdr(result); } /* - bignum_sub - Performs bignum1 = bignum1 - bignum2. -*/ - object* bignum_sub (object* bignum1, object* bignum2) { - object* result = cons(NULL, NULL); - object* ptr = result; - int borrow = 0; - while (!(bignum1 == NULL && bignum2 == NULL)) { - uint64_t tmp1, tmp2, res; - if (bignum1 != NULL) { - tmp1 = (uint64_t)(uint32_t)checkinteger(first(bignum1)) + (MAX_VAL + 1); - bignum1 = cdr(bignum1); - } else tmp1 = (MAX_VAL + 1); - if (bignum2 != NULL) { - tmp2 = (uint64_t)(uint32_t)checkinteger(first(bignum2)) + borrow; - bignum2 = cdr(bignum2); - } else tmp2 = borrow; - res = tmp1 - tmp2; - borrow = (res <= MAX_VAL); - cdr(ptr) = cons(number(res & MAX_VAL), NULL); - ptr = cdr(ptr); - } - return cdr(result); + bignum_sub - Performs bignum1 = bignum1 - bignum2. +*/ +object* bignum_sub (object* bignum1, object* bignum2) { + object* result = cons(NULL, NULL); + object* ptr = result; + int borrow = 0; + while (!(bignum1 == NULL && bignum2 == NULL)) { + uint64_t tmp1, tmp2, res; + if (bignum1 != NULL) { + tmp1 = (uint64_t)(uint32_t)checkinteger(first(bignum1)) + (MAX_VAL + 1); + bignum1 = cdr(bignum1); + } else tmp1 = (MAX_VAL + 1); + if (bignum2 != NULL) { + tmp2 = (uint64_t)(uint32_t)checkinteger(first(bignum2)) + borrow; + bignum2 = cdr(bignum2); + } else tmp2 = borrow; + res = tmp1 - tmp2; + borrow = (res <= MAX_VAL); + cdr(ptr) = cons(number(res & MAX_VAL), NULL); + ptr = cdr(ptr); + } + return cdr(result); } /* - bignum_mul - Performs bignum1 * bignum2. + bignum_mul - Performs bignum1 * bignum2. */ object* bignum_mul (object* bignum1, object* bignum2, object* env) { - object* result = int_to_bignum(0); - object* arg2 = bignum2; - int i = 0, j; - while (bignum1 != NULL) { - bignum2 = arg2; j = 0; - while (bignum2 != NULL) { - uint64_t n = (uint64_t)(uint32_t)checkinteger(first(bignum1)) * - (uint64_t)(uint32_t)checkinteger(first(bignum2)); - object* tmp; - if (n > MAX_VAL) tmp = cons(number(n), cons(number(n>>(uint64_t)32), NULL)); - else tmp = cons(number(n), NULL); - for (int m = i + j; m > 0; m--) push(number(0), tmp); // upshift i+j words - result = bignum_add(result, tmp); - bignum2 = cdr(bignum2); j++; - maybe_gc(result, env); + object* result = int_to_bignum(0); + object* arg2 = bignum2; + int i = 0, j; + while (bignum1 != NULL) { + bignum2 = arg2; j = 0; + while (bignum2 != NULL) { + uint64_t n = (uint64_t)(uint32_t)checkinteger(first(bignum1)) * + (uint64_t)(uint32_t)checkinteger(first(bignum2)); + object* tmp; + if (n > MAX_VAL) tmp = cons(number(n), cons(number(n >> (uint64_t)32), NULL)); + else tmp = cons(number(n), NULL); + for (int m = i + j; m > 0; m--) push(number(0), tmp); // upshift i+j words + result = bignum_add(result, tmp); + bignum2 = cdr(bignum2); j++; + maybe_gc(result, env); + } + bignum1 = cdr(bignum1); i++; } - bignum1 = cdr(bignum1); i++; - } - return result; + return result; } /* - bignum_div - Performs bignum1 / bignum2 and returns the list (quotient remainder). - First we normalise the denominator, and then do bitwise subtraction. - We need to do gcs in the main loops, while preserving the temporary lists on the GCStack. + bignum_div - Performs bignum1 / bignum2 and returns the list (quotient remainder). + First we normalise the denominator, and then do bitwise subtraction. + We need to do gcs in the main loops, while preserving the temporary lists on the GCStack. */ object* bignum_div (object* bignum1, object* bignum2, object* env) { - object* current = int_to_bignum(1); - object* denom = copylist(bignum2); - while (bignum_cmp(denom, bignum1) != LARGER) { - push(number(0), current); push(number(0), denom); // upshift current and denom 1 word - protect(current); - maybe_gc(denom, env); - unprotect(); - } - - object* result = int_to_bignum(0); - object* remainder = copylist(bignum1); - while (!bignum_zerop(current)) { - if (bignum_cmp(remainder, denom) != SMALLER) { - remainder = bignum_sub(remainder, denom); - result = do_operator(result, current, op_ior); + object* current = int_to_bignum(1); + object* denom = copylist(bignum2); + while (bignum_cmp(denom, bignum1) != LARGER) { + push(number(0), current); push(number(0), denom); // upshift current and denom 1 word + protect(current); + maybe_gc(denom, env); + unprotect(); } - downshift_bit(current); downshift_bit(denom); - protect(current); protect(remainder); protect(denom); - maybe_gc(result, env); - unprotect(); unprotect(); unprotect(); - } - return cons(result, cons(remainder, NULL)); + + object* result = int_to_bignum(0); + object* remainder = copylist(bignum1); + while (!bignum_zerop(current)) { + if (bignum_cmp(remainder, denom) != SMALLER) { + remainder = bignum_sub(remainder, denom); + result = do_operator(result, current, op_ior); + } + downshift_bit(current); downshift_bit(denom); + protect(current); protect(remainder); protect(denom); + maybe_gc(result, env); + unprotect(); unprotect(); unprotect(); + } + return cons(result, cons(remainder, NULL)); } /* - bignum_cmp - Compares two bignums and returns LARGER (b1>b2), EQUAL (b1=b2), or SMALLER (b1b2), EQUAL (b1=b2), or SMALLER (b1 b2) state = LARGER; else if (b1 < b2) state = SMALLER; - } - return state; + int state = EQUAL; + uint32_t b1, b2; + while (!(bignum1 == NULL && bignum2 == NULL)) { + if (bignum1 != NULL) { + b1 = checkinteger(car(bignum1)); + bignum1 = cdr(bignum1); + } else b1 = 0; + if (bignum2 != NULL) { + b2 = checkinteger(car(bignum2)); + bignum2 = cdr(bignum2); + } else b2 = 0; + if (b1 > b2) state = LARGER; else if (b1 < b2) state = SMALLER; + } + return state; } uint32_t op_and (uint32_t a, uint32_t b) { return a & b; }; @@ -241,327 +241,327 @@ uint32_t op_ior (uint32_t a, uint32_t b) { return a | b; }; uint32_t op_xor (uint32_t a, uint32_t b) { return a ^ b; }; /* - do_operator - Returns the result of performing a logical operation on two bignums. + do_operator - Returns the result of performing a logical operation on two bignums. */ object* do_operator (object* bignum1, object* bignum2, uint32_t (*op)(uint32_t, uint32_t)) { - object* result = cons(NULL, NULL); - object* ptr = result; - uint32_t tmp1 = 0, tmp2 = 0; - while (!(bignum1 == NULL && bignum2 == NULL)) { - if (bignum1 != NULL) { - tmp1 = (uint32_t)checkinteger(first(bignum1)); - bignum1 = cdr(bignum1); + object* result = cons(NULL, NULL); + object* ptr = result; + uint32_t tmp1 = 0, tmp2 = 0; + while (!(bignum1 == NULL && bignum2 == NULL)) { + if (bignum1 != NULL) { + tmp1 = (uint32_t)checkinteger(first(bignum1)); + bignum1 = cdr(bignum1); + } + if (bignum2 != NULL) { + tmp2 = (uint32_t)checkinteger(first(bignum2)); + bignum2 = cdr(bignum2); + } + cdr(ptr) = cons(number(op(tmp1, tmp2)), NULL); + ptr = cdr(ptr); } - if (bignum2 != NULL) { - tmp2 = (uint32_t)checkinteger(first(bignum2)); - bignum2 = cdr(bignum2); - } - cdr(ptr) = cons(number(op(tmp1, tmp2)), NULL); - ptr = cdr(ptr); - } - return cdr(result); + return cdr(result); } // Lisp functions /* - ($bignum int) - Converts an integer to a bignum and returns it. + ($bignum int) + Converts an integer to a bignum and returns it. */ -object* fn_Sbignum (object* args, object* env) { - (void) env; - return int_to_bignum(checkinteger(first(args))); +object* fn_BIGbignum (object* args, object* env) { + (void) env; + return int_to_bignum(checkinteger(first(args))); } /* - ($integer bignum) - Converts a bignum to an integer and returns it. + ($integer bignum) + Converts a bignum to an integer and returns it. */ -object* fn_Sinteger (object* args, object* env) { - (void) env; - object* bignum = checkbignum(first(args)); - bignum = bignum_normalise(bignum); - uint32_t i = checkinteger(first(bignum)); - if (cdr(bignum) != NULL || i > 0x7FFFFFFF) error2(PSTR("bignum too large to convert to an integer")); - return number(i); +object* fn_BIGinteger (object* args, object* env) { + (void) env; + object* bignum = checkbignum(first(args)); + bignum = bignum_normalise(bignum); + uint32_t i = checkinteger(first(bignum)); + if (cdr(bignum) != NULL || i > 0x7FFFFFFF) error2(PSTR("bignum too large to convert to an integer")); + return number(i); } /* - ($bignum-string bignum [base]) - Converts a bignum to a string in base 10 (default) or 16 and returns it. - Base 16 is trivial. For base 10 we get remainders mod 1000000000 and then print those. -*/ -object* fn_Sbignumstring (object* args, object* env) { - (void) env; - object* bignum = copylist(checkbignum(first(args))); - int b = 10; uint32_t p; - args = cdr(args); - if (args != NULL) b = checkinteger(car(args)); - object* list = NULL; - if (b == 16) { - p = 0x10000000; - while (bignum != NULL) { - push(car(bignum), list); - bignum = cdr(bignum); - } - } else if (b == 10) { - p = 100000000; - object* base = cons(number(p*10), NULL); - while(!bignum_zerop(bignum)) { - protect(bignum); protect(base); protect(list); - object* result = bignum_div(bignum, base, env); - unprotect(); unprotect(); unprotect(); - object* remainder = car(second(result)); - bignum = first(result); - push(remainder, list); - } - } else error2(PSTR("only base 10 or 16 supported")); - bool lead = false; - object* obj = newstring(); - object* tail = obj; - while (list != NULL) { - uint32_t i = car(list)->integer; - for (uint32_t d=p; d>0; d=d/b) { - uint32_t j = i/d; - if (j!=0 || lead || d==1) { - char ch = (j<10) ? j+'0' : j+'W'; - lead=true; - buildstring(ch, &tail); - } - i = i - j*d; + ($bignum-string bignum [base]) + Converts a bignum to a string in base 10 (default) or 16 and returns it. + Base 16 is trivial. For base 10 we get remainders mod 1000000000 and then print those. +*/ +object* fn_BIGbignumstring (object* args, object* env) { + (void) env; + object* bignum = copylist(checkbignum(first(args))); + int b = 10; uint32_t p; + args = cdr(args); + if (args != NULL) b = checkinteger(car(args)); + object* list = NULL; + if (b == 16) { + p = 0x10000000; + while (bignum != NULL) { + push(car(bignum), list); + bignum = cdr(bignum); + } + } else if (b == 10) { + p = 100000000; + object* base = cons(number(p * 10), NULL); + while (!bignum_zerop(bignum)) { + protect(bignum); protect(base); protect(list); + object* result = bignum_div(bignum, base, env); + unprotect(); unprotect(); unprotect(); + object* remainder = car(second(result)); + bignum = first(result); + push(remainder, list); + } + } else error2(PSTR("only base 10 or 16 supported")); + bool lead = false; + object* obj = newstring(); + object* tail = obj; + while (list != NULL) { + uint32_t i = car(list)->integer; + for (uint32_t d = p; d > 0; d = d / b) { + uint32_t j = i / d; + if (j != 0 || lead || d == 1) { + char ch = (j < 10) ? j + '0' : j + 'W'; + lead = true; + buildstring(ch, &tail); + } + i = i - j * d; + } + list = cdr(list); } - list = cdr(list); - } - return obj; + return obj; } /* - ($string-bignum string [base]) - Converts a string in the specified base, 10 (default) or 16, to a bignum and returns it. -*/ -object* fn_Sstringbignum (object* args, object* env) { - (void) env; - object* string = first(args); - if (!stringp(string)) error(notastring, string); - int b = 10; - args = cdr(args); - if (args != NULL) b = checkinteger(car(args)); - if (b != 10 && b != 16) error2(PSTR("only base 10 or 16 supported")); - object* base = int_to_bignum(b); - object* result = int_to_bignum(0); - object* form = (object* )string->name; - while (form != NULL) { - int chars = form->chars; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; - if (!ch) break; - int d = digitvalue(ch); - if (d >= b) error(PSTR("illegal character in bignum"), character(ch)); - protect(result); protect(base); - result = bignum_mul(result, base, env); - unprotect(); unprotect(); - result = bignum_add(result, cons(number(d), NULL)); + ($string-bignum string [base]) + Converts a string in the specified base, 10 (default) or 16, to a bignum and returns it. +*/ +object* fn_BIGstringbignum (object* args, object* env) { + (void) env; + object* string = first(args); + if (!stringp(string)) error(notastring, string); + int b = 10; + args = cdr(args); + if (args != NULL) b = checkinteger(car(args)); + if (b != 10 && b != 16) error2(PSTR("only base 10 or 16 supported")); + object* base = int_to_bignum(b); + object* result = int_to_bignum(0); + object* form = (object* )string->name; + while (form != NULL) { + int chars = form->chars; + for (int i = (sizeof(int) - 1) * 8; i >= 0; i = i - 8) { + char ch = chars >> i & 0xFF; + if (!ch) break; + int d = digitvalue(ch); + if (d >= b) error(PSTR("illegal character in bignum"), character(ch)); + protect(result); protect(base); + result = bignum_mul(result, base, env); + unprotect(); unprotect(); + result = bignum_add(result, cons(number(d), NULL)); + } + form = car(form); } - form = car(form); - } - return result; + return result; } /* - ($zerop bignum) - Tests whether a bignum is zero, allowing for trailing zeros. + ($zerop bignum) + Tests whether a bignum is zero, allowing for trailing zeros. */ -object* fn_Szerop (object* args, object* env) { - (void) env; - return bignum_zerop(checkbignum(first(args))) ? tee : nil; +object* fn_BIGzerop (object* args, object* env) { + (void) env; + return bignum_zerop(checkbignum(first(args))) ? tee : nil; } /* - ($+ bignum1 bignum2) - Adds two bignums and returns the sum as a new bignum. + ($+ bignum1 bignum2) + Adds two bignums and returns the sum as a new bignum. */ -object* fn_Sadd (object* args, object* env) { - (void) env; - return bignum_add(checkbignum(first(args)), checkbignum(second(args))); +object* fn_BIGadd (object* args, object* env) { + (void) env; + return bignum_add(checkbignum(first(args)), checkbignum(second(args))); } /* - ($- bignum1 bignum2) - Subtracts two bignums and returns the difference as a new bignum. + ($- bignum1 bignum2) + Subtracts two bignums and returns the difference as a new bignum. */ -object* fn_Ssub (object* args, object* env) { - (void) env; - return bignum_sub(checkbignum(first(args)), checkbignum(second(args))); +object* fn_BIGsub (object* args, object* env) { + (void) env; + return bignum_sub(checkbignum(first(args)), checkbignum(second(args))); } /* - ($* bignum1 bignum2) - Multiplies two bignums and returns the product as a new bignum. + ($* bignum1 bignum2) + Multiplies two bignums and returns the product as a new bignum. */ -object* fn_Smul (object* args, object* env) { - return bignum_mul(checkbignum(first(args)), checkbignum(second(args)), env); +object* fn_BIGmul (object* args, object* env) { + return bignum_mul(checkbignum(first(args)), checkbignum(second(args)), env); } /* - ($/ bignum1 bignum2) - Divides two bignums and returns the quotient as a new bignum. + ($/ bignum1 bignum2) + Divides two bignums and returns the quotient as a new bignum. */ -object* fn_Sdiv (object* args, object* env) { - return first(bignum_div(checkbignum(first(args)), checkbignum(second(args)), env)); +object* fn_BIGdiv (object* args, object* env) { + return first(bignum_div(checkbignum(first(args)), checkbignum(second(args)), env)); } /* - ($mod bignum1 bignum2) - Divides two bignums and returns the remainder as a new bignum. + ($mod bignum1 bignum2) + Divides two bignums and returns the remainder as a new bignum. */ -object* fn_Smod (object* args, object* env) { - return second(bignum_div(checkbignum(first(args)), checkbignum(second(args)), env)); +object* fn_BIGmod (object* args, object* env) { + return second(bignum_div(checkbignum(first(args)), checkbignum(second(args)), env)); } // Comparisons /* - ($= bignum1 bignum2) - Returns t if the two bignums are equal. + ($= bignum1 bignum2) + Returns t if the two bignums are equal. */ -object* fn_Sequal (object* args, object* env) { - (void) env; - return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == EQUAL) ? tee : nil; +object* fn_BIGequal (object* args, object* env) { + (void) env; + return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == EQUAL) ? tee : nil; } /* - ($< bignum1 bignum2) - Returns t if bignum1 is less than bignum2. + ($< bignum1 bignum2) + Returns t if bignum1 is less than bignum2. */ -object* fn_Sless (object* args, object* env) { - (void) env; - return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == SMALLER) ? tee : nil; +object* fn_BIGless (object* args, object* env) { + (void) env; + return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == SMALLER) ? tee : nil; } /* - ($> bignum1 bignum2) - Returns t if bignum1 is greater than bignum2. + ($> bignum1 bignum2) + Returns t if bignum1 is greater than bignum2. */ -object* fn_Sgreater (object* args, object* env) { - (void) env; - return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == LARGER) ? tee : nil; +object* fn_BIGgreater (object* args, object* env) { + (void) env; + return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == LARGER) ? tee : nil; } // Bitwise logical operations /* - ($logand bignum1 bignum2) - Returns the logical AND of two bignums. + ($logand bignum1 bignum2) + Returns the logical AND of two bignums. */ -object* fn_Slogand (object* args, object* env) { - (void) env; - return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_and)); +object* fn_BIGlogand (object* args, object* env) { + (void) env; + return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_and)); } /* - ($logior bignum1 bignum2) - Returns the logical inclusive OR of two bignums. + ($logior bignum1 bignum2) + Returns the logical inclusive OR of two bignums. */ -object* fn_Slogior (object* args, object* env) { - (void) env; - return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_ior)); +object* fn_BIGlogior (object* args, object* env) { + (void) env; + return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_ior)); } /* - ($logxor bignum1 bignum2) - Returns the logical exclusive OR of two bignums. + ($logxor bignum1 bignum2) + Returns the logical exclusive OR of two bignums. */ -object* fn_Slogxor (object* args, object* env) { - (void) env; - return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_xor)); +object* fn_BIGlogxor (object* args, object* env) { + (void) env; + return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_xor)); } /* - ($ash bignum shift) - Returns bignum shifted by shift bits; positive means left. + ($ash bignum shift) + Returns bignum shifted by shift bits; positive means left. */ -object* fn_Sash (object* args, object* env) { - (void) env; - object* bignum = copylist(checkbignum(first(args))); - int shift = checkinteger(second(args)); - for (int i = 0; i < shift; i++) upshift_bit(bignum); - for (int i = 0; i < -shift; i++) downshift_bit(bignum); - return bignum_normalise(bignum); +object* fn_BIGash (object* args, object* env) { + (void) env; + object* bignum = copylist(checkbignum(first(args))); + int shift = checkinteger(second(args)); + for (int i = 0; i < shift; i++) upshift_bit(bignum); + for (int i = 0; i < -shift; i++) downshift_bit(bignum); + return bignum_normalise(bignum); } // Symbol names -const char stringSbignum[] PROGMEM = "$bignum"; -const char stringSinteger[] PROGMEM = "$integer"; -const char stringSbignumstring[] PROGMEM = "$bignum-string"; -const char stringSstringbignum[] PROGMEM = "$string-bignum"; -const char stringSzerop[] PROGMEM = "$zerop"; -const char stringSdecf[] PROGMEM = "$decf"; -const char stringSincf[] PROGMEM = "$incf"; -const char stringSadd[] PROGMEM = "$+"; -const char stringSsub[] PROGMEM = "$-"; -const char stringSmul[] PROGMEM = "$*"; -const char stringSdiv[] PROGMEM = "$/"; -const char stringSmod[] PROGMEM = "$mod"; -const char stringSequal[] PROGMEM = "$="; -const char stringSless[] PROGMEM = "$<"; -const char stringSgreater[] PROGMEM = "$>"; -const char stringSlogand[] PROGMEM = "$logand"; -const char stringSlogior[] PROGMEM = "$logior"; -const char stringSlogxor[] PROGMEM = "$logxor"; -const char stringSash[] PROGMEM = "$ash"; +const char stringBIGbignum[] PROGMEM = "$bignum"; +const char stringBIGinteger[] PROGMEM = "$integer"; +const char stringBIGbignumstring[] PROGMEM = "$bignum-string"; +const char stringBIGstringbignum[] PROGMEM = "$string-bignum"; +const char stringBIGzerop[] PROGMEM = "$zerop"; +const char stringBIGdecf[] PROGMEM = "$decf"; +const char stringBIGincf[] PROGMEM = "$incf"; +const char stringBIGadd[] PROGMEM = "$+"; +const char stringBIGsub[] PROGMEM = "$-"; +const char stringBIGmul[] PROGMEM = "$*"; +const char stringBIGdiv[] PROGMEM = "$/"; +const char stringBIGmod[] PROGMEM = "$mod"; +const char stringBIGequal[] PROGMEM = "$="; +const char stringBIGless[] PROGMEM = "$<"; +const char stringBIGgreater[] PROGMEM = "$>"; +const char stringBIGlogand[] PROGMEM = "$logand"; +const char stringBIGlogior[] PROGMEM = "$logior"; +const char stringBIGlogxor[] PROGMEM = "$logxor"; +const char stringBIGash[] PROGMEM = "$ash"; // Documentation strings -const char docSbignum[] PROGMEM = "($bignum int)\n" -"Converts an integer to a bignum and returns it."; -const char docSinteger[] PROGMEM = "($integer bignum)\n" -"Converts a bignum to an integer and returns it."; -const char docSbignumstring[] PROGMEM = "($bignum-string bignum [base])\n" -"Converts a bignum to a string in base 10 (default) or 16 and returns it."; -const char docSstringbignum[] PROGMEM = "($string-bignum bignum [base])\n" -"Converts a bignum to a string in the specified base (default 10) and returns it."; -const char docSzerop[] PROGMEM = "($zerop bignum)\n" -"Tests whether a bignum is zero, allowing for trailing zeros."; -const char docSadd[] PROGMEM = "($+ bignum1 bignum2)\n" -"Adds two bignums and returns the sum as a new bignum."; -const char docSsub[] PROGMEM = "($- bignum1 bignum2)\n" -"Subtracts two bignums and returns the difference as a new bignum."; -const char docSmul[] PROGMEM = "($* bignum1 bignum2)\n" -"Multiplies two bignums and returns the product as a new bignum."; -const char docSdiv[] PROGMEM = "($/ bignum1 bignum2)\n" -"Divides two bignums and returns the quotient as a new bignum."; -const char docSmod[] PROGMEM = "($mod bignum1 bignum2)\n" -"Divides two bignums and returns the remainder as a new bignum."; -const char docSequal[] PROGMEM = "($= bignum1 bignum2)\n" -"Returns t if the two bignums are equal."; -const char docSless[] PROGMEM = "($< bignum1 bignum2)\n" -"Returns t if bignum1 is less than bignum2."; -const char docSgreater[] PROGMEM = "($> bignum1 bignum2)\n" -"Returns t if bignum1 is greater than bignum2."; -const char docSlogand[] PROGMEM = "($logand bignum bignum)\n" -"Returns the logical AND of two bignums."; -const char docSlogior[] PROGMEM = "($logior bignum bignum)\n" -"Returns the logical inclusive OR of two bignums."; -const char docSlogxor[] PROGMEM = "($logxor bignum bignum)\n" -"Returns the logical exclusive OR of two bignums."; -const char docSash[] PROGMEM = "($ash bignum shift)\n" -"Returns bignum shifted by shift bits; positive means left."; +const char docBIGbignum[] PROGMEM = "($bignum int)\n" + "Converts an integer to a bignum and returns it."; +const char docBIGinteger[] PROGMEM = "($integer bignum)\n" + "Converts a bignum to an integer and returns it."; +const char docBIGbignumstring[] PROGMEM = "($bignum-string bignum [base])\n" + "Converts a bignum to a string in base 10 (default) or 16 and returns it."; +const char docBIGstringbignum[] PROGMEM = "($string-bignum bignum [base])\n" + "Converts a bignum to a string in the specified base (default 10) and returns it."; +const char docBIGzerop[] PROGMEM = "($zerop bignum)\n" + "Tests whether a bignum is zero, allowing for trailing zeros."; +const char docBIGadd[] PROGMEM = "($+ bignum1 bignum2)\n" + "Adds two bignums and returns the sum as a new bignum."; +const char docBIGsub[] PROGMEM = "($- bignum1 bignum2)\n" + "Subtracts two bignums and returns the difference as a new bignum."; +const char docBIGmul[] PROGMEM = "($* bignum1 bignum2)\n" + "Multiplies two bignums and returns the product as a new bignum."; +const char docBIGdiv[] PROGMEM = "($/ bignum1 bignum2)\n" + "Divides two bignums and returns the quotient as a new bignum."; +const char docBIGmod[] PROGMEM = "($mod bignum1 bignum2)\n" + "Divides two bignums and returns the remainder as a new bignum."; +const char docBIGequal[] PROGMEM = "($= bignum1 bignum2)\n" + "Returns t if the two bignums are equal."; +const char docBIGless[] PROGMEM = "($< bignum1 bignum2)\n" + "Returns t if bignum1 is less than bignum2."; +const char docBIGgreater[] PROGMEM = "($> bignum1 bignum2)\n" + "Returns t if bignum1 is greater than bignum2."; +const char docBIGlogand[] PROGMEM = "($logand bignum bignum)\n" + "Returns the logical AND of two bignums."; +const char docBIGlogior[] PROGMEM = "($logior bignum bignum)\n" + "Returns the logical inclusive OR of two bignums."; +const char docBIGlogxor[] PROGMEM = "($logxor bignum bignum)\n" + "Returns the logical exclusive OR of two bignums."; +const char docBIGash[] PROGMEM = "($ash bignum shift)\n" + "Returns bignum shifted by shift bits; positive means left."; // Symbol lookup table const tbl_entry_t BignumsTable[] PROGMEM = { - { stringSbignum, fn_Sbignum, 0211, docSbignum }, - { stringSinteger, fn_Sinteger, 0211, docSinteger }, - { stringSbignumstring, fn_Sbignumstring, 0212, docSbignumstring }, - { stringSstringbignum, fn_Sstringbignum, 0212, docSstringbignum }, - { stringSzerop, fn_Szerop, 0211, docSzerop }, - { stringSadd, fn_Sadd, 0222, docSadd }, - { stringSsub, fn_Ssub, 0222, docSsub }, - { stringSmul, fn_Smul, 0222, docSmul }, - { stringSdiv, fn_Sdiv, 0222, docSdiv }, - { stringSmod, fn_Smod, 0222, docSmod }, - { stringSequal, fn_Sequal, 0222, docSequal }, - { stringSless, fn_Sless, 0222, docSless }, - { stringSgreater, fn_Sgreater, 0222, docSgreater }, - { stringSlogand, fn_Slogand, 0222, docSlogand }, - { stringSlogior, fn_Slogior, 0222, docSlogior }, - { stringSlogxor, fn_Slogxor, 0222, docSlogxor }, - { stringSash, fn_Sash, 0222, docSash }, + { stringBIGbignum, fn_BIGbignum, 0211, docBIGbignum }, + { stringBIGinteger, fn_BIGinteger, 0211, docBIGinteger }, + { stringBIGbignumstring, fn_BIGbignumstring, 0212, docBIGbignumstring }, + { stringBIGstringbignum, fn_BIGstringbignum, 0212, docBIGstringbignum }, + { stringBIGzerop, fn_BIGzerop, 0211, docBIGzerop }, + { stringBIGadd, fn_BIGadd, 0222, docBIGadd }, + { stringBIGsub, fn_BIGsub, 0222, docBIGsub }, + { stringBIGmul, fn_BIGmul, 0222, docBIGmul }, + { stringBIGdiv, fn_BIGdiv, 0222, docBIGdiv }, + { stringBIGmod, fn_BIGmod, 0222, docBIGmod }, + { stringBIGequal, fn_BIGequal, 0222, docBIGequal }, + { stringBIGless, fn_BIGless, 0222, docBIGless }, + { stringBIGgreater, fn_BIGgreater, 0222, docBIGgreater }, + { stringBIGlogand, fn_BIGlogand, 0222, docBIGlogand }, + { stringBIGlogior, fn_BIGlogior, 0222, docBIGlogior }, + { stringBIGlogxor, fn_BIGlogxor, 0222, docBIGlogxor }, + { stringBIGash, fn_BIGash, 0222, docBIGash }, }; diff --git a/term.py b/term.py index 521d9cd..76413e2 100755 --- a/term.py +++ b/term.py @@ -210,34 +210,38 @@ async def repl_task(port: Serial): global STATUS startup(port) await asyncio.sleep(0.1) - while True: - # allow other tasks to run - await asyncio.sleep(0.1) - if not input_queue.empty(): - send = await input_queue.get() - match send: - case ".reset": - startup(port) - send = None - case ".quit": - app.exit() - return - case ".run": - send = lispbuffer.text - lispbuffer.buffer.append_to_history() - lispbuffer.text = "" - case _: - pass - if send is not None and send.strip(): - STATUS = "Running..." - port.write(send.encode()) - port.write(b"\r\n") - port.flush() - input_queue.task_done() - if port.in_waiting > 0: - terminal.text += port.read_all().decode() - terminal.text = run_watchers(terminal.text) - output() + try: + while True: + # allow other tasks to run + await asyncio.sleep(0.1) + if not input_queue.empty(): + send = await input_queue.get() + match send: + case ".reset": + startup(port) + send = None + case ".quit": + app.exit() + return + case ".run": + send = lispbuffer.text + lispbuffer.buffer.append_to_history() + lispbuffer.text = "" + case _: + pass + if send is not None and send.strip(): + STATUS = "Running..." + port.write(send.encode()) + port.write(b"\r\n") + port.flush() + input_queue.task_done() + if port.in_waiting > 0: + terminal.text += port.read_all().decode() + terminal.text = run_watchers(terminal.text) + output() + except SerialException: + output("Communication error, closing serial port...\n") + port.close() async def main(): diff --git a/ulisp.hpp b/ulisp.hpp index 21358ef..187eb3f 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -1868,6 +1868,8 @@ bool I2Crestart (uint8_t address, uint8_t read) { void I2Cstop (uint8_t read) { if (read == 0) Wire.endTransmission(); // Check for error? + // Release pins + Wire.end(); } // Streams @@ -4403,7 +4405,7 @@ object* fn_writeline (object* args, object* env) { */ object* fn_restarti2c (object* args, object* env) { (void) env; - int stream = first(args)->integer; + int stream = isstream(first(args)); args = cdr(args); int read = 0; // Write I2Ccount = 0; From ede50c97cae8d70fed68cf4bce5ec59a7cbb55a4 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Wed, 14 Jun 2023 16:44:13 -0400 Subject: [PATCH 057/109] better loader kernel & remove low speed I2C mode since it works now at high speed --- ulisp-esp32.ino | 4 +++- ulisp.hpp | 3 +-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index 0d4a450..60beec2 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -24,8 +24,10 @@ #include "bignums.hpp" const char foo[] PROGMEM = -"(defun load(filename)(with-sd-card(f filename)(loop(let((form(read f)))(unless form(return))(eval form)))))" +"(defvar *loaded* nil)" +"(defun load(filename)(if(null(search(list filename)*loaded*))(with-sd-card(f filename)(push filename *loaded*)(loop(let((form(read f)))(unless form(return))(eval form))))))" "(load \"main.lisp\")" +"(princ \"main.lisp returned, entering REPL...\")" ; const size_t foolen = arraysize(foo); size_t fooi = 0; diff --git a/ulisp.hpp b/ulisp.hpp index 187eb3f..ff252f4 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -1567,7 +1567,7 @@ uint32_t ipstring (object* form) { for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { char ch = chars>>i & 0xFF; if (ch) { - if (ch == '.') { p++; if (p > 3) error2(PSTR("illegal IP address")); } + if (ch == '.') { p++; if (p > 3) error(PSTR("illegal IP address"), form); } else ipbytes[p] = (ipbytes[p] * 10) + ch - '0'; } } @@ -1850,7 +1850,6 @@ void I2Cwrite (uint8_t data) { bool I2Cstart (uint8_t address, uint8_t read) { int ok = true; if (read == 0) { - Wire.setClock(10000); // Low speed mode (still pretty fast) Wire.beginTransmission(address); ok = (Wire.endTransmission(true) == 0); Wire.beginTransmission(address); From c018a7be4c56604dc427c568e1f056795bf089d7 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 30 Jun 2023 17:32:36 -0400 Subject: [PATCH 058/109] add some 4.4d changes and improve quasiquoting using MAL --- ulisp-esp32.ino | 6 +- ulisp.hpp | 180 ++++++++++++++++++++++-------------------------- 2 files changed, 84 insertions(+), 102 deletions(-) diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index 60beec2..6f82867 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -1,5 +1,5 @@ -/* uLisp ESP Release 4.4b - www.ulisp.com - David Johnson-Davies - www.technoblogy.com - 31st March 2023 +/* uLisp ESP Release 4.4d - www.ulisp.com + David Johnson-Davies - www.technoblogy.com - 30th June 2023 Licensed under the MIT license: https://opensource.org/licenses/MIT */ @@ -69,7 +69,7 @@ void setup () { ulispinit(); addtable(ExtensionsTable); addtable(BignumsTable); - Serial.println(F("\n\n\nuLisp 4.4b!")); + Serial.println(F("\n\n\nuLisp 4.4d-mod!")); sdmain(); } diff --git a/ulisp.hpp b/ulisp.hpp index ff252f4..71df3a4 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -1,5 +1,5 @@ -/* uLisp ESP Release 4.4b - www.ulisp.com - David Johnson-Davies - www.technoblogy.com - 31st March 2023 +/* uLisp ESP Release 4.4d - www.ulisp.com + David Johnson-Davies - www.technoblogy.com - 30th June 2023 Licensed under the MIT license: https://opensource.org/licenses/MIT */ @@ -72,17 +72,17 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define car(x) (((object*)(x))->car) #define cdr(x) (((object*)(x))->cdr) -#define first(x) (car(x)) -#define rest(x) (cdr(x)) -#define second(x) (first(rest(x))) -#define cddr(x) (cdr(cdr(x))) -#define third(x) (first(cddr(x))) +#define first(x) car(x) +#define rest(x) cdr(x) +#define second(x) first(rest(x)) +#define cddr(x) cdr(cdr(x)) +#define third(x) first(cddr(x)) #define push(x, y) ((y) = cons((x), (y))) #define pop(y) ((y) = cdr(y)) #define protect(y) push((y), GCStack) -#define unprotect() do { object* __old__GCStack = GCStack; pop(GCStack); myfree(__old__GCStack); } while(0) +#define unprotect() pop(GCStack) #define integerp(x) ((x) != NULL && (x)->type == NUMBER) #define floatp(x) ((x) != NULL && (x)->type == FLOAT) @@ -182,7 +182,7 @@ typedef int (*gfun_t)(); typedef void (*pfun_t)(char); enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, LET, LETSTAR, -CLOSURE, PSTAR, QUOTE, QUASIQUOTE, UNQUOTE, UNQUOTE_SPLICING, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, +CLOSURE, PSTAR, QUOTE, QUASIQUOTE, UNQUOTE, UNQUOTE_SPLICING, CONS, APPEND, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, ANALOGREAD, REGISTER, FORMAT, }; @@ -734,7 +734,7 @@ bool listp (object* x) { quoteit - quote a symbol with the specified type of quote */ -object* quoteit (symbol_t q, object* it) { +object* quoteit (builtin_t q, object* it) { return cons(bsymbol(q), cons(it, nil)); } @@ -1007,14 +1007,6 @@ object* divide_floats (object* args, float fresult) { return makefloat(fresult); } -/* - myround - rounds - Returns t if the argument is a floating-point number. -*/ -int myround (float number) { - return (number >= 0) ? (int)(number + 0.5) : (int)(number - 0.5); -} - /* compare - a generic compare function Used to implement the other comparison functions. @@ -1354,13 +1346,13 @@ object* copystring (object* arg) { readstring - reads characters from an input stream up to delimiter delim and returns a Lisp string */ -object* readstring (char delim, gfun_t gfun) { +object* readstring (char delim, bool do_escape, gfun_t gfun) { object* obj = newstring(); object* tail = obj; int ch = gfun(); if (ch == -1) return nil; while ((ch != delim) && (ch != -1)) { - if (ch == '\\') ch = gfun(); + if (do_escape && ch == '\\') ch = gfun(); buildstring(ch, &tail); ch = gfun(); } @@ -1422,6 +1414,21 @@ void pstr (char c) { buildstring(c, &GlobalStringTail); } +/* + iptostring - converts an Arduino IPAddress into the string representation of it. + It assumes it is an IPv4 address and won't work for IPv6. +*/ +object* iptostring (IPAddress ip) { + union { uint32_t data2; uint8_t u8[4]; }; + object *obj = startstring(); + data2 = ip; + for (int i=0; i<4; i++) { + if (i) pstr('.'); + pintbase(u8[i], 10, pstr); + } + return obj; +} + /* lispstring - converts a C string to a Lisp string */ @@ -2633,7 +2640,10 @@ object* sp_withsdcard (object* args, object* env) { object* var = first(params); params = cdr(params); if (params == NULL) error2(PSTR("no filename specified")); - object* filename = eval(first(params), env); + builtin_t temp = Context; + object *filename = eval(first(params), env); + Context = temp; + if (!stringp(filename)) error(PSTR("filename is not a string"), filename); params = cdr(params); SD.begin(); int mode = 0; @@ -3867,8 +3877,8 @@ object* fn_round (object* args, object* env) { (void) env; object* arg = first(args); args = cdr(args); - if (args != NULL) return number(myround(checkintfloat(arg) / checkintfloat(first(args)))); - else return number(myround(checkintfloat(arg))); + if (args != NULL) return number(round(checkintfloat(arg) / checkintfloat(first(args)))); + else return number(round(checkintfloat(arg))); } // Characters @@ -4350,7 +4360,7 @@ object* fn_readbyte (object* args, object* env) { object* fn_readline (object* args, object* env) { (void) env; gfun_t gfun = gstreamfun(args); - return readstring('\n', gfun); + return readstring('\n', false, gfun); } /* @@ -5029,7 +5039,7 @@ object* fn_wifisoftap (object* args, object* env) { } WiFi.softAP(cstring(first, ssid, 33), cstring(second, pass, 65), channel, hidden); } - return lispstring((char*)WiFi.softAPIP().toString().c_str()); + return iptostring(WiFi.softAPIP()); } /* @@ -5048,7 +5058,7 @@ object* fn_connected (object* args, object* env) { */ object* fn_wifilocalip (object* args, object* env) { (void) args, (void) env; - return lispstring((char*)WiFi.localIP().toString().c_str()); + return iptostring(WiFi.localIP()); } /* @@ -5062,7 +5072,7 @@ object* fn_wificonnect (object* args, object* env) { if (cdr(args) == NULL) WiFi.begin(cstring(first(args), ssid, 33)); else WiFi.begin(cstring(first(args), ssid, 33), cstring(second(args), pass, 65)); int result = WiFi.waitForConnectResult(); - if (result == WL_CONNECTED) return lispstring((char*)WiFi.localIP().toString().c_str()); + if (result == WL_CONNECTED) return iptostring(WiFi.localIP()); else if (result == WL_NO_SSID_AVAIL) error2(PSTR("network not found")); else if (result == WL_CONNECT_FAILED) error2(PSTR("connection failed")); else error2(PSTR("unable to connect")); @@ -5483,75 +5493,47 @@ object* fn_throw (object* args, object* env) { /////////////////////////////////////////////////////////// // Experimental QUASIQUOTE support +// see https://github.com/kanaka/mal/blob/master/process/guide.md#step-7-quoting -#define nope ((object*)-3) +object* reverse (object* what) { + object* result = NULL; + for (; what != NULL; what = cdr(what)) { + push(car(what), result); + } + return result; +} -object* unquote (object* arg, object* env, int level) { - if (arg == NULL || atom(arg)) return cons(bsymbol(QUOTE), cons(arg, NULL)); - object* what = first(arg); +object* process_quasiquote (object* arg) { + // "If ast is a map or a symbol, return a list containing: the "quote" symbol, then ast." + if (arg == NULL || atom(arg)) return quoteit(QUOTE, arg); + // "If ast is a list starting with the "unquote" symbol, return its second element." + if (listp(arg) && symbolp(first(arg)) && builtin(first(arg)->name) == UNQUOTE) return second(arg); + // "If ast is a list failing previous test, the result will be a list populated by the following process." + // "The result is initially an empty list. Iterate over each element elt of ast in reverse order:" object* result = NULL; - object* result2 = NULL; - if (what->type == SYMBOL) { - switch (builtin(what->name)) { - case QUASIQUOTE: - protect(second(arg)); - result = unquote(second(arg), env, level + 1); - unprotect(); - return cons(cons(bsymbol(QUASIQUOTE), result), NULL); - case UNQUOTE: - if (level == 1) { - protect(second(arg)); - result = unquote(second(arg), env, level); - car(GCStack) = result; - result = eval(car(result), env); - unprotect(); - return cons(result, NULL); - } else { - protect(second(arg)); - result = unquote(second(arg), env, level - 1); - unprotect(); - return cons(cons(bsymbol(UNQUOTE), result), NULL); - } - case UNQUOTE_SPLICING: - if (level == 1) { - protect(second(arg)); - result = unquote(second(arg), env, level); - car(GCStack) = result; - result = eval(car(result), env); - unprotect(); - if (result == NULL) return nope; - else return result; - } else { - protect(second(arg)); - result = unquote(second(arg), env, level - 1); - unprotect(); - return cons(cons(bsymbol(UNQUOTE_SPLICING), result), NULL); - } - default: - goto notspecial; - } - } else { - notspecial: - for (object* x = arg; x != NULL; x = cdr(x)) { - protect(car(x)); - object* foo = unquote(car(x), env, level); - unprotect(); - if (foo != nope) push(foo, result); - } - // Reverse and flatten - for (object* y = result; y != NULL; y = cdr(y)) { - if (atom(car(y))) push(car(y), result2); - else for (object* z = car(y); z != NULL; z = cdr(z)) push(car(z), result2); - } - return cons(result2, NULL); + object* rev_arg = reverse(arg); + for (; rev_arg != NULL; rev_arg = cdr(rev_arg)) { + object* element = car(rev_arg); + // "If elt is a list starting with the "splice-unquote" symbol, + // replace the current result with a list containing: the "concat" symbol, + // the second element of elt, then the previous result." + if (listp(element) && symbolp(first(element)) && builtin(first(element)->name) == UNQUOTE_SPLICING) + result = cons(bsymbol(APPEND), cons(second(element), cons(result, nil))); + // "Else replace the current result with a list containing: + // the "cons" symbol, the result of calling quasiquote with + // elt as argument, then the previous result." + else result = cons(bsymbol(CONS), cons(process_quasiquote(element), cons(result, nil))); } + return result; } -object* sp_quasiquote (object* args, object* env) { - checkargs(args); - protect(first(args)); - object* result = unquote(first(args), env, 1); - unprotect(); +// "Add the quasiquote special form. This form does the same than quasiquoteexpand, +// but evaluates the result in the current environment before returning it, either by +// recursively calling EVAL with the result and env, or by assigning ast with the result +// and continuing execution at the top of the loop (TCO)." +object* tf_quasiquote (object* args, object* env) { + object* result = process_quasiquote(first(args)); + // Tail call return result; } @@ -5582,6 +5564,8 @@ const char string13[] PROGMEM = "quote"; const char stringquasiquote[] PROGMEM = "quasiquote"; const char stringunquote[] PROGMEM = "unquote"; const char stringuqsplicing[] PROGMEM = "unquote-splicing"; +const char string57[] PROGMEM = "cons"; +const char string92[] PROGMEM = "append"; const char string14[] PROGMEM = "defun"; const char string15[] PROGMEM = "defvar"; const char string16[] PROGMEM = "car"; @@ -5625,7 +5609,6 @@ const char string53[] PROGMEM = "case"; const char string54[] PROGMEM = "and"; const char string55[] PROGMEM = "not"; const char string56[] PROGMEM = "null"; -const char string57[] PROGMEM = "cons"; const char string58[] PROGMEM = "atom"; const char string59[] PROGMEM = "listp"; const char string60[] PROGMEM = "consp"; @@ -5660,7 +5643,6 @@ const char string88[] PROGMEM = "assoc"; const char string89[] PROGMEM = "member"; const char string90[] PROGMEM = "apply"; const char string91[] PROGMEM = "funcall"; -const char string92[] PROGMEM = "append"; const char string93[] PROGMEM = "mapc"; const char string94[] PROGMEM = "mapcar"; const char string95[] PROGMEM = "mapcan"; @@ -5826,6 +5808,9 @@ const char doc9[] PROGMEM = "(let ((var value) ... ) forms*)\n" const char doc10[] PROGMEM = "(let* ((var value) ... ) forms*)\n" "Declares local variables with values, and evaluates the forms with those local variables.\n" "Each declaration can refer to local variables that have been defined earlier in the let*."; +const char doc57[] PROGMEM = "(cons item item)\n" +"If the second argument is a list, cons returns a new list with item added to the front of the list.\n" +"If the second argument isn't a list cons returns a dotted pair."; const char doc14[] PROGMEM = "(defun name (parameters) form*)\n" "Defines a function."; const char doc15[] PROGMEM = "(defvar variable form)\n" @@ -5930,9 +5915,6 @@ const char doc54[] PROGMEM = "(and item*)\n" "Evaluates its arguments until one returns nil, and returns the last value."; const char doc55[] PROGMEM = "(not item)\n" "Returns t if its argument is nil, or nil otherwise. Equivalent to null."; -const char doc57[] PROGMEM = "(cons item item)\n" -"If the second argument is a list, cons returns a new list with item added to the front of the list.\n" -"If the second argument isn't a list cons returns a dotted pair."; const char doc58[] PROGMEM = "(atom item)\n" "Returns t if its argument is a single number, symbol, or nil."; const char doc59[] PROGMEM = "(listp item)\n" @@ -6346,9 +6328,11 @@ const tbl_entry_t BuiltinTable[] PROGMEM = { { string11, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), NULL }, { string12, NULL, MINMAX(OTHER_FORMS, 0, UNLIMITED), NULL }, { string13, sp_quote, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, - { stringquasiquote, sp_quasiquote, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, + { stringquasiquote, tf_quasiquote, MINMAX(TAIL_FORMS, 1, 1), NULL }, { stringunquote, qq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, { stringuqsplicing, qq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, + { string57, fn_cons, MINMAX(FUNCTIONS, 2, 2), doc57 }, + { string92, fn_append, MINMAX(FUNCTIONS, 0, UNLIMITED), doc92 }, { string14, sp_defun, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc14 }, { string15, sp_defvar, MINMAX(SPECIAL_FORMS, 1, 3), doc15 }, { string16, fn_car, MINMAX(FUNCTIONS, 1, 1), doc16 }, @@ -6392,7 +6376,6 @@ const tbl_entry_t BuiltinTable[] PROGMEM = { { string54, tf_and, MINMAX(TAIL_FORMS, 0, UNLIMITED), doc54 }, { string55, fn_not, MINMAX(FUNCTIONS, 1, 1), doc55 }, { string56, fn_not, MINMAX(FUNCTIONS, 1, 1), NULL }, - { string57, fn_cons, MINMAX(FUNCTIONS, 2, 2), doc57 }, { string58, fn_atom, MINMAX(FUNCTIONS, 1, 1), doc58 }, { string59, fn_listp, MINMAX(FUNCTIONS, 1, 1), doc59 }, { string60, fn_consp, MINMAX(FUNCTIONS, 1, 1), doc60 }, @@ -6427,7 +6410,6 @@ const tbl_entry_t BuiltinTable[] PROGMEM = { { string89, fn_member, MINMAX(FUNCTIONS, 2, 2), doc89 }, { string90, fn_apply, MINMAX(FUNCTIONS, 2, UNLIMITED), doc90 }, { string91, fn_funcall, MINMAX(FUNCTIONS, 1, UNLIMITED), doc91 }, - { string92, fn_append, MINMAX(FUNCTIONS, 0, UNLIMITED), doc92 }, { string93, fn_mapc, MINMAX(FUNCTIONS, 2, UNLIMITED), doc93 }, { string94, fn_mapcar, MINMAX(FUNCTIONS, 2, UNLIMITED), doc94 }, { string95, fn_mapcan, MINMAX(FUNCTIONS, 2, UNLIMITED), doc95 }, @@ -7191,7 +7173,7 @@ object* nextitem (gfun_t gfun) { } // Parse string - if (ch == '"') return readstring('"', gfun); + if (ch == '"') return readstring('"', true, gfun); // Parse symbol, character, or number int index = 0, base = 10, sign = 1; From 5908b1ac6780909beaaee01dfe5d54b467309749 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 30 Jun 2023 17:40:28 -0400 Subject: [PATCH 059/109] use MINMAX macro in bignums for forward compatibility --- bignums.hpp | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/bignums.hpp b/bignums.hpp index b7e9006..3b15014 100644 --- a/bignums.hpp +++ b/bignums.hpp @@ -547,21 +547,21 @@ const char docBIGash[] PROGMEM = "($ash bignum shift)\n" // Symbol lookup table const tbl_entry_t BignumsTable[] PROGMEM = { - { stringBIGbignum, fn_BIGbignum, 0211, docBIGbignum }, - { stringBIGinteger, fn_BIGinteger, 0211, docBIGinteger }, - { stringBIGbignumstring, fn_BIGbignumstring, 0212, docBIGbignumstring }, - { stringBIGstringbignum, fn_BIGstringbignum, 0212, docBIGstringbignum }, - { stringBIGzerop, fn_BIGzerop, 0211, docBIGzerop }, - { stringBIGadd, fn_BIGadd, 0222, docBIGadd }, - { stringBIGsub, fn_BIGsub, 0222, docBIGsub }, - { stringBIGmul, fn_BIGmul, 0222, docBIGmul }, - { stringBIGdiv, fn_BIGdiv, 0222, docBIGdiv }, - { stringBIGmod, fn_BIGmod, 0222, docBIGmod }, - { stringBIGequal, fn_BIGequal, 0222, docBIGequal }, - { stringBIGless, fn_BIGless, 0222, docBIGless }, - { stringBIGgreater, fn_BIGgreater, 0222, docBIGgreater }, - { stringBIGlogand, fn_BIGlogand, 0222, docBIGlogand }, - { stringBIGlogior, fn_BIGlogior, 0222, docBIGlogior }, - { stringBIGlogxor, fn_BIGlogxor, 0222, docBIGlogxor }, - { stringBIGash, fn_BIGash, 0222, docBIGash }, + { stringBIGbignum, fn_BIGbignum, MINMAX(FUNCTIONS, 1, 1), docBIGbignum }, + { stringBIGinteger, fn_BIGinteger, MINMAX(FUNCTIONS, 1, 1), docBIGinteger }, + { stringBIGbignumstring, fn_BIGbignumstring, MINMAX(FUNCTIONS, 1, 2), docBIGbignumstring }, + { stringBIGstringbignum, fn_BIGstringbignum, MINMAX(FUNCTIONS, 1, 2), docBIGstringbignum }, + { stringBIGzerop, fn_BIGzerop, MINMAX(FUNCTIONS, 1, 1), docBIGzerop }, + { stringBIGadd, fn_BIGadd, MINMAX(FUNCTIONS, 2, 2), docBIGadd }, + { stringBIGsub, fn_BIGsub, MINMAX(FUNCTIONS, 2, 2), docBIGsub }, + { stringBIGmul, fn_BIGmul, MINMAX(FUNCTIONS, 2, 2), docBIGmul }, + { stringBIGdiv, fn_BIGdiv, MINMAX(FUNCTIONS, 2, 2), docBIGdiv }, + { stringBIGmod, fn_BIGmod, MINMAX(FUNCTIONS, 2, 2), docBIGmod }, + { stringBIGequal, fn_BIGequal, MINMAX(FUNCTIONS, 2, 2), docBIGequal }, + { stringBIGless, fn_BIGless, MINMAX(FUNCTIONS, 2, 2), docBIGless }, + { stringBIGgreater, fn_BIGgreater, MINMAX(FUNCTIONS, 2, 2), docBIGgreater }, + { stringBIGlogand, fn_BIGlogand, MINMAX(FUNCTIONS, 2, 2), docBIGlogand }, + { stringBIGlogior, fn_BIGlogior, MINMAX(FUNCTIONS, 2, 2), docBIGlogior }, + { stringBIGlogxor, fn_BIGlogxor, MINMAX(FUNCTIONS, 2, 2), docBIGlogxor }, + { stringBIGash, fn_BIGash, MINMAX(FUNCTIONS, 2, 2), docBIGash }, }; From 9a3d85353256f6c57bfbec4722e8136463dafd26 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 30 Jun 2023 20:59:00 -0400 Subject: [PATCH 060/109] quasiquote works now as expected --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index f5a48e3..d44ce70 100644 --- a/README.md +++ b/README.md @@ -15,7 +15,7 @@ Patches: * Added: Lisp `:keywords` that auto-quote themselves * Added: Ability to add multiple (more than one) extension tables (using `calloc()`) *may not be portable to other platforms* * Added: Lisp `(throw)` and `(catch)` -* Added: ***EXPERIMENTAL, BUGGY, AND PROBABLY INCORRECT*** quasiquote/unquote/unquote-splicing +* Added: quasiquote/unquote/unquote-splicing * Added: Auto-run contents of `main.lisp` (on microSD card) at startup * Modified: SD-card functions now include filename in error messages * Fixed: special forms don't need to call `checkargs()` because it is automatically called From dc5da825b97b9018577d0f6dcdfa55fcf1b25dd2 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 1 Jul 2023 09:17:03 -0400 Subject: [PATCH 061/109] move docstring so all 3 are in order --- ulisp.hpp | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 71df3a4..2b0a519 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -5491,8 +5491,7 @@ object* fn_throw (object* args, object* env) { return NULL; } -/////////////////////////////////////////////////////////// -// Experimental QUASIQUOTE support +// QUASIQUOTE support // see https://github.com/kanaka/mal/blob/master/process/guide.md#step-7-quoting object* reverse (object* what) { @@ -5811,6 +5810,8 @@ const char doc10[] PROGMEM = "(let* ((var value) ... ) forms*)\n" const char doc57[] PROGMEM = "(cons item item)\n" "If the second argument is a list, cons returns a new list with item added to the front of the list.\n" "If the second argument isn't a list cons returns a dotted pair."; +const char doc92[] PROGMEM = "(append list*)\n" +"Joins its arguments, which should be lists, into a single list."; const char doc14[] PROGMEM = "(defun name (parameters) form*)\n" "Defines a function."; const char doc15[] PROGMEM = "(defvar variable form)\n" @@ -5983,8 +5984,6 @@ const char doc90[] PROGMEM = "(apply function list)\n" "Returns the result of evaluating function, with the list of arguments specified by the second parameter."; const char doc91[] PROGMEM = "(funcall function argument*)\n" "Evaluates function with the specified arguments."; -const char doc92[] PROGMEM = "(append list*)\n" -"Joins its arguments, which should be lists, into a single list."; const char doc93[] PROGMEM = "(mapc function list1 [list]*)\n" "Applies the function to each element in one or more lists, ignoring the results.\n" "It returns the first list argument."; From c33f649c4170860258d857385dd7a98c1b2083ee Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 1 Jul 2023 21:15:58 -0400 Subject: [PATCH 062/109] add recursive quasiquote support pending test suite (#3) it looks to work okay --- ulisp.hpp | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 2b0a519..df34770 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -5493,6 +5493,7 @@ object* fn_throw (object* args, object* env) { // QUASIQUOTE support // see https://github.com/kanaka/mal/blob/master/process/guide.md#step-7-quoting +// and https://github.com/kanaka/mal/issues/103#issuecomment-159047401 object* reverse (object* what) { object* result = NULL; @@ -5502,11 +5503,17 @@ object* reverse (object* what) { return result; } -object* process_quasiquote (object* arg) { +object* process_quasiquote (object* arg, size_t level = 0) { // "If ast is a map or a symbol, return a list containing: the "quote" symbol, then ast." if (arg == NULL || atom(arg)) return quoteit(QUOTE, arg); // "If ast is a list starting with the "unquote" symbol, return its second element." - if (listp(arg) && symbolp(first(arg)) && builtin(first(arg)->name) == UNQUOTE) return second(arg); + if (listp(arg) && symbolp(first(arg))) { + switch (builtin(first(arg)->name)) { + case QUASIQUOTE: return process_quasiquote(second(arg), level + 1); + case UNQUOTE: return level == 0 ? second(arg) : process_quasiquote(second(arg), level - 1); + default: break; + } + } // "If ast is a list failing previous test, the result will be a list populated by the following process." // "The result is initially an empty list. Iterate over each element elt of ast in reverse order:" object* result = NULL; @@ -5516,12 +5523,15 @@ object* process_quasiquote (object* arg) { // "If elt is a list starting with the "splice-unquote" symbol, // replace the current result with a list containing: the "concat" symbol, // the second element of elt, then the previous result." - if (listp(element) && symbolp(first(element)) && builtin(first(element)->name) == UNQUOTE_SPLICING) - result = cons(bsymbol(APPEND), cons(second(element), cons(result, nil))); + if (listp(element) && symbolp(first(element)) && builtin(first(element)->name) == UNQUOTE_SPLICING) { + object* x = second(element); + if (level > 0) x = process_quasiquote(x, level - 1); + result = cons(bsymbol(APPEND), cons(x, cons(result, nil))); + } // "Else replace the current result with a list containing: // the "cons" symbol, the result of calling quasiquote with // elt as argument, then the previous result." - else result = cons(bsymbol(CONS), cons(process_quasiquote(element), cons(result, nil))); + else result = cons(bsymbol(CONS), cons(process_quasiquote(element, level), cons(result, nil))); } return result; } From 8f995c2ee2b82848bcbffda7eb27797988a0c52a Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sun, 2 Jul 2023 18:54:36 -0400 Subject: [PATCH 063/109] rename quasiquote -> backquote ref: https://github.com/dragoncoder047/ulisp-esp32/issues/3#issuecomment-1616466879 --- README.md | 2 +- ulisp.hpp | 28 ++++++++++++++-------------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/README.md b/README.md index d44ce70..ef89e3f 100644 --- a/README.md +++ b/README.md @@ -15,7 +15,7 @@ Patches: * Added: Lisp `:keywords` that auto-quote themselves * Added: Ability to add multiple (more than one) extension tables (using `calloc()`) *may not be portable to other platforms* * Added: Lisp `(throw)` and `(catch)` -* Added: quasiquote/unquote/unquote-splicing +* Added: backquote/unquote/unquote-splicing * Added: Auto-run contents of `main.lisp` (on microSD card) at startup * Modified: SD-card functions now include filename in error messages * Fixed: special forms don't need to call `checkargs()` because it is automatically called diff --git a/ulisp.hpp b/ulisp.hpp index df34770..7a2edbf 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -182,7 +182,7 @@ typedef int (*gfun_t)(); typedef void (*pfun_t)(char); enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, LET, LETSTAR, -CLOSURE, PSTAR, QUOTE, QUASIQUOTE, UNQUOTE, UNQUOTE_SPLICING, CONS, APPEND, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, +CLOSURE, PSTAR, QUOTE, BACKQUOTE, UNQUOTE, UNQUOTE_SPLICING, CONS, APPEND, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, ANALOGREAD, REGISTER, FORMAT, }; @@ -5491,7 +5491,7 @@ object* fn_throw (object* args, object* env) { return NULL; } -// QUASIQUOTE support +// BACKQUOTE support // see https://github.com/kanaka/mal/blob/master/process/guide.md#step-7-quoting // and https://github.com/kanaka/mal/issues/103#issuecomment-159047401 @@ -5503,14 +5503,14 @@ object* reverse (object* what) { return result; } -object* process_quasiquote (object* arg, size_t level = 0) { +object* process_backquote (object* arg, size_t level = 0) { // "If ast is a map or a symbol, return a list containing: the "quote" symbol, then ast." if (arg == NULL || atom(arg)) return quoteit(QUOTE, arg); // "If ast is a list starting with the "unquote" symbol, return its second element." if (listp(arg) && symbolp(first(arg))) { switch (builtin(first(arg)->name)) { - case QUASIQUOTE: return process_quasiquote(second(arg), level + 1); - case UNQUOTE: return level == 0 ? second(arg) : process_quasiquote(second(arg), level - 1); + case BACKQUOTE: return process_backquote(second(arg), level + 1); + case UNQUOTE: return level == 0 ? second(arg) : process_backquote(second(arg), level - 1); default: break; } } @@ -5525,13 +5525,13 @@ object* process_quasiquote (object* arg, size_t level = 0) { // the second element of elt, then the previous result." if (listp(element) && symbolp(first(element)) && builtin(first(element)->name) == UNQUOTE_SPLICING) { object* x = second(element); - if (level > 0) x = process_quasiquote(x, level - 1); + if (level > 0) x = process_backquote(x, level - 1); result = cons(bsymbol(APPEND), cons(x, cons(result, nil))); } // "Else replace the current result with a list containing: // the "cons" symbol, the result of calling quasiquote with // elt as argument, then the previous result." - else result = cons(bsymbol(CONS), cons(process_quasiquote(element, level), cons(result, nil))); + else result = cons(bsymbol(CONS), cons(process_backquote(element, level), cons(result, nil))); } return result; } @@ -5540,15 +5540,15 @@ object* process_quasiquote (object* arg, size_t level = 0) { // but evaluates the result in the current environment before returning it, either by // recursively calling EVAL with the result and env, or by assigning ast with the result // and continuing execution at the top of the loop (TCO)." -object* tf_quasiquote (object* args, object* env) { - object* result = process_quasiquote(first(args)); +object* tf_backquote (object* args, object* env) { + object* result = process_backquote(first(args)); // Tail call return result; } object* qq_invalid (object* args, object* env) { (void)args, (void)env; - error2(PSTR("not valid outside quasiquote")); + error2(PSTR("not valid outside backquote")); // unreachable return NULL; } @@ -5570,7 +5570,7 @@ const char string10[] PROGMEM = "let*"; const char string11[] PROGMEM = "closure"; const char string12[] PROGMEM = "*pc*"; const char string13[] PROGMEM = "quote"; -const char stringquasiquote[] PROGMEM = "quasiquote"; +const char stringbackquote[] PROGMEM = "backquote"; const char stringunquote[] PROGMEM = "unquote"; const char stringuqsplicing[] PROGMEM = "unquote-splicing"; const char string57[] PROGMEM = "cons"; @@ -6337,7 +6337,7 @@ const tbl_entry_t BuiltinTable[] PROGMEM = { { string11, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), NULL }, { string12, NULL, MINMAX(OTHER_FORMS, 0, UNLIMITED), NULL }, { string13, sp_quote, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, - { stringquasiquote, tf_quasiquote, MINMAX(TAIL_FORMS, 1, 1), NULL }, + { stringbackquote, tf_backquote, MINMAX(TAIL_FORMS, 1, 1), NULL }, { stringunquote, qq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, { stringuqsplicing, qq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, { string57, fn_cons, MINMAX(FUNCTIONS, 2, 2), doc57 }, @@ -7303,7 +7303,7 @@ object* readrest (gfun_t gfun) { while (item != (object*)CLOSE_PAREN) { if (item == (object*)OPEN_PAREN) item = readrest(gfun); else if (item == (object*)SINGLE_QUOTE) item = quoteit(QUOTE, read(gfun)); - else if (item == (object*)BACKQUOTE) item = quoteit(QUASIQUOTE, read(gfun)); + else if (item == (object*)BACKQUOTE) item = quoteit(BACKQUOTE, read(gfun)); else if (item == (object*)COMMA) item = quoteit(UNQUOTE, read(gfun)); else if (item == (object*)COMMA_AT) item = quoteit(UNQUOTE_SPLICING, read(gfun)); else if (item == (object*)PERIOD) { @@ -7330,7 +7330,7 @@ object* read (gfun_t gfun) { if (item == (object*)OPEN_PAREN) return readrest(gfun); if (item == (object*)PERIOD) return read(gfun); if (item == (object*)SINGLE_QUOTE) return quoteit(QUOTE, read(gfun)); - if (item == (object*)BACKQUOTE) return quoteit(QUASIQUOTE, read(gfun)); + if (item == (object*)BACKQUOTE) return quoteit(BACKQUOTE, read(gfun)); if (item == (object*)COMMA) return quoteit(UNQUOTE, read(gfun)); if (item == (object*)COMMA_AT) return quoteit(UNQUOTE_SPLICING, read(gfun)); return item; From edaf64a8b7559854d0843f720375bb5fa76010f1 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sun, 2 Jul 2023 19:05:37 -0400 Subject: [PATCH 064/109] pretty print backquotes --- ulisp.hpp | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 7a2edbf..522f0b7 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -2049,13 +2049,16 @@ uint8_t basewidth (object* obj, uint8_t base) { return PrintCount; } -bool quoted (object* obj) { - return (consp(obj) && car(obj) != NULL && car(obj)->name == sym(QUOTE) && consp(cdr(obj)) && cddr(obj) == NULL); +bool quoted (object* obj, builtin_t which) { + return (consp(obj) && car(obj) != NULL && car(obj)->name == sym(which) && consp(cdr(obj)) && cddr(obj) == NULL); } int subwidth (object* obj, int w) { if (atom(obj)) return w - atomwidth(obj); - if (quoted(obj)) obj = car(cdr(obj)); + if (quoted(obj, QUOTE) || quoted(obj, BACKQUOTE) || quoted(obj, UNQUOTE) || quoted(obj, UNQUOTE_SPLICING)) { + if (builtin(car(obj)->name) == UNQUOTE_SPLICING) w--; // unquote splicing is 2 chars + obj = car(cdr(obj)); + } return subwidthlist(obj, w - 1); } @@ -2076,7 +2079,10 @@ void superprint (object* form, int lm, pfun_t pfun) { if (symbolp(form) && form->name == sym(NOTHING)) printsymbol(form, pfun); else printobject(form, pfun); } - else if (quoted(form)) { pfun('\''); superprint(car(cdr(form)), lm + 1, pfun); } + else if (quoted(form, QUOTE)) { pfun('\''); superprint(car(cdr(form)), lm + 1, pfun); } + else if (quoted(form, BACKQUOTE)) { pfun('`'); superprint(car(cdr(form)), lm + 1, pfun); } + else if (quoted(form, UNQUOTE)) { pfun(','); superprint(car(cdr(form)), lm + 1, pfun); } + else if (quoted(form, UNQUOTE_SPLICING)) { pfun(','); pfun('@'); superprint(car(cdr(form)), lm + 2, pfun); } else if (subwidth(form, ppwidth - lm) >= 0) supersub(form, lm + PPINDENT, 0, pfun); else supersub(form, lm + PPINDENT, 1, pfun); } From e3d9bbb40d216768ae6f7c4886f220bfdd813515 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 3 Jul 2023 10:02:42 -0400 Subject: [PATCH 065/109] very old typo --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index ef89e3f..3640bf7 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ A (patched) version of the Lisp programming language for ESP32-based boards. Heavily customized to fit my use case but most of the original remains. For more about the original ulisp-esp see -This is based off of uLisp 4.4b. For the old patches (some of which don't work) for +This is based off of uLisp 4.4d. For the old patches (some of which don't work) for uLisp 4.3a please see the [4.3a-old](https://github.com/dragoncoder047/ulisp-esp32/tree/4.3a-old) branch. Patches: From 798d6533c09a5e942dd3957c1bf4144347326326 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 3 Jul 2023 17:00:20 -0400 Subject: [PATCH 066/109] add experimental macros --- README.md | 1 + ulisp.hpp | 88 +++++++++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 83 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index 3640bf7..cde0d2a 100644 --- a/README.md +++ b/README.md @@ -16,6 +16,7 @@ Patches: * Added: Ability to add multiple (more than one) extension tables (using `calloc()`) *may not be portable to other platforms* * Added: Lisp `(throw)` and `(catch)` * Added: backquote/unquote/unquote-splicing +* Added: **EXPERIMENTAL** macros/defmacro/macroexpand *no support for destructuring lambda lists yet* * Added: Auto-run contents of `main.lisp` (on microSD card) at startup * Modified: SD-card functions now include filename in error messages * Fixed: special forms don't need to call `checkargs()` because it is automatically called diff --git a/ulisp.hpp b/ulisp.hpp index 522f0b7..b1ef5b6 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -181,8 +181,8 @@ typedef struct { typedef int (*gfun_t)(); typedef void (*pfun_t)(char); -enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, LET, LETSTAR, -CLOSURE, PSTAR, QUOTE, BACKQUOTE, UNQUOTE, UNQUOTE_SPLICING, CONS, APPEND, DEFUN, DEFVAR, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, +enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, MACRO, LET, LETSTAR, +CLOSURE, PSTAR, QUOTE, BACKQUOTE, UNQUOTE, UNQUOTE_SPLICING, CONS, APPEND, DEFUN, DEFVAR, DEFMACRO, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, ANALOGREAD, REGISTER, FORMAT, }; @@ -2182,6 +2182,21 @@ object* sp_defvar (object* args, object* env) { return var; } +/* + (defmacro name (parameters) form*) + Defines a syntactic macro. +*/ +object* sp_defmacro (object* args, object* env) { + (void) env; + object* var = first(args); + if (!symbolp(var)) error(notasymbol, var); + object* val = cons(bsymbol(MACRO), cdr(args)); + object* pair = value(var->name, GlobalEnv); + if (pair != NULL) cdr(pair) = val; + else push(cons(var, val), GlobalEnv); + return var; +} + /* (setq symbol value [symbol value]*) For each pair of arguments assigns the value of the second argument @@ -5552,13 +5567,44 @@ object* tf_backquote (object* args, object* env) { return result; } -object* qq_invalid (object* args, object* env) { +object* bq_invalid (object* args, object* env) { (void)args, (void)env; error2(PSTR("not valid outside backquote")); // unreachable return NULL; } +//////////////////////////////////////////////////////////////////////// +// MACRO support + +bool is_macro_call (object* form) { + if (!consp(form)) return false; + object* lambda = first(form); + if (!consp(lambda)) return false; + return isbuiltin(first(lambda), MACRO); +} + +object* macroexpand1 (object* form, object* env, bool* done) { + if (symbolp(car(form))) form = cons(eval(car(form), env), cdr(form)); // Look up variable but DON'T mutate form + if (!is_macro_call(form)) { + *done = true; + return form; + } + form = closure(0, sym(NIL), car(form), cdr(form), &env); + return eval(form, env); +} + +object* fn_macroexpand1 (object* form, object* env) { + bool dummy; + return macroexpand1(form, env, &dummy); +} + +object* macroexpand (object* form, object* env) { + bool done = false; + while (!done) form = macroexpand1(form, env, &done); + return form; +} + /////////////////////////////////////////////////////////// // Built-in symbol names @@ -5571,6 +5617,7 @@ const char string5[] PROGMEM = ":element-type"; const char string6[] PROGMEM = "bit"; const char string7[] PROGMEM = "&rest"; const char string8[] PROGMEM = "lambda"; +const char stringmacro[] PROGMEM = "macro"; const char string9[] PROGMEM = "let"; const char string10[] PROGMEM = "let*"; const char string11[] PROGMEM = "closure"; @@ -5583,6 +5630,7 @@ const char string57[] PROGMEM = "cons"; const char string92[] PROGMEM = "append"; const char string14[] PROGMEM = "defun"; const char string15[] PROGMEM = "defvar"; +const char stringdefmacro[] PROGMEM = "defmacro"; const char string16[] PROGMEM = "car"; const char string17[] PROGMEM = "first"; const char string18[] PROGMEM = "cdr"; @@ -5801,6 +5849,8 @@ const char string232[] PROGMEM = ":output"; const char stringcatch[] PROGMEM = "catch"; const char stringthrow[] PROGMEM = "throw"; +const char stringmacroexpand1[] PROGMEM = "macroexpand-1"; +const char stringmacroexpand[] PROGMEM = "macroexpand"; // Documentation strings const char doc0[] PROGMEM = "nil\n" @@ -5818,11 +5868,22 @@ const char doc7[] PROGMEM = "&rest\n" const char doc8[] PROGMEM = "(lambda (parameter*) form*)\n" "Creates an unnamed function with parameters. The body is evaluated with the parameters as local variables\n" "whose initial values are defined by the values of the forms after the lambda form."; +const char docmacro[] PROGMEM = "(macro (parameter*) form*)\n" +"Creates an unnamed lambda-macro with parameters. The body is evaluated with the parameters as local variables\n" +"whose initial values are defined by the values of the forms after the macro form;\n" +"the resultant Lisp code returned is then evaluated again, this time in the scope of where the macro was called."; const char doc9[] PROGMEM = "(let ((var value) ... ) forms*)\n" "Declares local variables with values, and evaluates the forms with those local variables."; const char doc10[] PROGMEM = "(let* ((var value) ... ) forms*)\n" "Declares local variables with values, and evaluates the forms with those local variables.\n" "Each declaration can refer to local variables that have been defined earlier in the let*."; +const char docbackquote[] PROGMEM = "(backquote form) or `form\n" +"Expands the unquotes present in the form as a syntactic template. Most commonly used in macros."; +const char docunquote[] PROGMEM = "(unquote form) or ,form\n" +"Marks a form to be evaluated and the value inserted when (backquote) expands the template."; +const char docunquotesplicing[] PROGMEM = "(unquote-splicing form) or ,@form\n" +"Marks a form to be evaluated and the value spliced in when (backquote) expands the template.\n" +"If the value returned when evaluating form is not a proper list (backquote) will bork very badly."; const char doc57[] PROGMEM = "(cons item item)\n" "If the second argument is a list, cons returns a new list with item added to the front of the list.\n" "If the second argument isn't a list cons returns a dotted pair."; @@ -5832,6 +5893,8 @@ const char doc14[] PROGMEM = "(defun name (parameters) form*)\n" "Defines a function."; const char doc15[] PROGMEM = "(defvar variable form)\n" "Defines a global variable."; +const char docdefmacro[] PROGMEM = "(defmacro name (parameters) form*)\n" +"Defines a syntactic macro."; const char doc16[] PROGMEM = "(car list)\n" "Returns the first item in a list."; const char doc18[] PROGMEM = "(cdr list)\n" @@ -6327,6 +6390,12 @@ const char docthrow[] PROGMEM = "(throw 'tag [value])\n" "It is an error to call (throw) without first entering a (catch) with\n" "the same tag."; +const char docmacroexpand1[] PROGMEM = "(macroexpand-1 'form)\n" +"If the form represents a call to a macro, expands the macro once and returns the expanded code."; +const char docmacroexpand[] PROGMEM = "(macroexpand 'form)\n" +"Repeatedly applies (macroexpand) until the form no longer represents a call to a macro,\n" +"then returns the new form."; + // Built-in symbol lookup table const tbl_entry_t BuiltinTable[] PROGMEM = { { string0, NULL, MINMAX(OTHER_FORMS, 0, 0), doc0 }, @@ -6338,18 +6407,20 @@ const tbl_entry_t BuiltinTable[] PROGMEM = { { string6, NULL, MINMAX(OTHER_FORMS, 0, 0), NULL }, { string7, NULL, MINMAX(OTHER_FORMS, 0, 0), doc7 }, { string8, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), doc8 }, + { stringmacro, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), docmacro }, { string9, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), doc9 }, { string10, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), doc10 }, { string11, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), NULL }, { string12, NULL, MINMAX(OTHER_FORMS, 0, UNLIMITED), NULL }, { string13, sp_quote, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, - { stringbackquote, tf_backquote, MINMAX(TAIL_FORMS, 1, 1), NULL }, - { stringunquote, qq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, - { stringuqsplicing, qq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, + { stringbackquote, tf_backquote, MINMAX(TAIL_FORMS, 1, 1), docbackquote }, + { stringunquote, bq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), docunquote }, + { stringuqsplicing, bq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), docunquotesplicing }, { string57, fn_cons, MINMAX(FUNCTIONS, 2, 2), doc57 }, { string92, fn_append, MINMAX(FUNCTIONS, 0, UNLIMITED), doc92 }, { string14, sp_defun, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc14 }, { string15, sp_defvar, MINMAX(SPECIAL_FORMS, 1, 3), doc15 }, + { stringdefmacro, sp_defmacro, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), docdefmacro }, { string16, fn_car, MINMAX(FUNCTIONS, 1, 1), doc16 }, { string17, fn_car, MINMAX(FUNCTIONS, 1, 1), NULL }, { string18, fn_cdr, MINMAX(FUNCTIONS, 1, 1), doc18 }, @@ -6565,6 +6636,8 @@ const tbl_entry_t BuiltinTable[] PROGMEM = { { string232, (fn_ptr_type)OUTPUT, PINMODE, NULL }, { stringcatch, sp_catch, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doccatch }, { stringthrow, fn_throw, MINMAX(FUNCTIONS, 1, 2), docthrow }, + { stringmacroexpand1, fn_macroexpand1, MINMAX(FUNCTIONS, 1, 1), docmacroexpand1 }, + { stringmacroexpand, macroexpand, MINMAX(FUNCTIONS, 1, 1), docmacroexpand }, }; // Metatable cross-reference functions @@ -6708,6 +6781,8 @@ object* eval (object* form, object* env) { Context = NIL; error(PSTR("undefined"), form); } + // Expand macros + form = macroexpand(form); // It's a list object* function = car(form); @@ -6744,6 +6819,7 @@ object* eval (object* form, object* env) { goto EVAL; } + // MACRO does not do closures. if (name == LAMBDA) { if (env == NULL) return form; object* envcopy = NULL; From 0539758a705df1f7585634b27e5cdb3cc7290960 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Tue, 4 Jul 2023 16:29:31 -0400 Subject: [PATCH 067/109] Add limit to number of chained macros Hard constant but it could be made a variable *macro-limit* ? --- ulisp.hpp | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/ulisp.hpp b/ulisp.hpp index b1ef5b6..30f812d 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -5601,7 +5601,12 @@ object* fn_macroexpand1 (object* form, object* env) { object* macroexpand (object* form, object* env) { bool done = false; - while (!done) form = macroexpand1(form, env, &done); + int limit = 10000; + while (!done) { + form = macroexpand1(form, env, &done); + limit--; + if (limit == 0 && !done) error2(PSTR("too many macros")); + } return form; } From 6eb4288fdca739f81dbd628e863368710b9f20b9 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Tue, 4 Jul 2023 16:32:20 -0400 Subject: [PATCH 068/109] Allow macros to be used in `setf` expressions That way a macro can dynamically expand to a car-cdr chain depending on the value of the expression --- ulisp.hpp | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ulisp.hpp b/ulisp.hpp index 30f812d..66a87d0 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -261,6 +261,7 @@ void repl (object*); void prin1object (object*, pfun_t); void plispstr (symbol_t, pfun_t); void testescape (); +bool is_macro_call (object*); inline uint32_t twist (uint32_t x) { return (x<<2) | ((x & 0xC0000000)>>30); @@ -1716,6 +1717,7 @@ object* apply (object* function, object* args, object* env) { in-place operation such as setf. bit is used to indicate the bit position in a bit array */ object** place (object* args, object* env, int *bit) { + PLACE: *bit = -1; if (atom(args)) return &cdr(findvalue(args, env)); object* function = first(args); @@ -1748,6 +1750,10 @@ object** place (object* args, object* env, int *bit) { return getarray(array, cddr(args), env, bit); } } + else if (is_macro_call(function)) { + function = eval(function, env); + goto PLACE; + } error2(PSTR("illegal place")); return nil; } From b2e8dce3e4c724c7bd092c0b42246ecf9913601d Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Wed, 5 Jul 2023 17:12:05 -0400 Subject: [PATCH 069/109] rename token so it won't conflict with builtin enum value --- ulisp.hpp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 66a87d0..78d0e1a 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -124,7 +124,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define TRACEMAX 3 // Number of traced functions enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; // ARRAY STRING and PAIR must be last -enum token { UNUSED, OPEN_PAREN, CLOSE_PAREN, SINGLE_QUOTE, PERIOD, BACKQUOTE, COMMA, COMMA_AT }; +enum token { UNUSED, OPEN_PAREN, CLOSE_PAREN, SINGLE_QUOTE, PERIOD, BACKTICK, COMMA, COMMA_AT }; enum fntypes_t { OTHER_FORMS, TAIL_FORMS, FUNCTIONS, SPECIAL_FORMS }; // Stream names used by printobject @@ -7263,7 +7263,7 @@ object* nextitem (gfun_t gfun) { if (ch == ')') return (object*)CLOSE_PAREN; if (ch == '(') return (object*)OPEN_PAREN; if (ch == '\'') return (object*)SINGLE_QUOTE; - if (ch == '`') return (object*)BACKQUOTE; + if (ch == '`') return (object*)BACKTICK; if (ch == '@') return (object*)COMMA_AT; // maintain compatibility with old Dave Astels code if (ch == ',') { ch = gfun(); @@ -7396,7 +7396,7 @@ object* readrest (gfun_t gfun) { while (item != (object*)CLOSE_PAREN) { if (item == (object*)OPEN_PAREN) item = readrest(gfun); else if (item == (object*)SINGLE_QUOTE) item = quoteit(QUOTE, read(gfun)); - else if (item == (object*)BACKQUOTE) item = quoteit(BACKQUOTE, read(gfun)); + else if (item == (object*)BACKTICK) item = quoteit(BACKQUOTE, read(gfun)); else if (item == (object*)COMMA) item = quoteit(UNQUOTE, read(gfun)); else if (item == (object*)COMMA_AT) item = quoteit(UNQUOTE_SPLICING, read(gfun)); else if (item == (object*)PERIOD) { @@ -7423,7 +7423,7 @@ object* read (gfun_t gfun) { if (item == (object*)OPEN_PAREN) return readrest(gfun); if (item == (object*)PERIOD) return read(gfun); if (item == (object*)SINGLE_QUOTE) return quoteit(QUOTE, read(gfun)); - if (item == (object*)BACKQUOTE) return quoteit(BACKQUOTE, read(gfun)); + if (item == (object*)BACKTICK) return quoteit(BACKQUOTE, read(gfun)); if (item == (object*)COMMA) return quoteit(UNQUOTE, read(gfun)); if (item == (object*)COMMA_AT) return quoteit(UNQUOTE_SPLICING, read(gfun)); return item; From 652fd30232fcffaedf626673435cf2997046eaf4 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 17 Jul 2023 08:45:08 -0400 Subject: [PATCH 070/109] make it compile (macros still don't work) --- ulisp.hpp | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 78d0e1a..0365221 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -261,7 +261,7 @@ void repl (object*); void prin1object (object*, pfun_t); void plispstr (symbol_t, pfun_t); void testescape (); -bool is_macro_call (object*); +bool is_macro_call (object*, object*); inline uint32_t twist (uint32_t x) { return (x<<2) | ((x & 0xC0000000)>>30); @@ -1750,7 +1750,7 @@ object** place (object* args, object* env, int *bit) { return getarray(array, cddr(args), env, bit); } } - else if (is_macro_call(function)) { + else if (is_macro_call(function, env)) { function = eval(function, env); goto PLACE; } @@ -5583,7 +5583,14 @@ object* bq_invalid (object* args, object* env) { //////////////////////////////////////////////////////////////////////// // MACRO support -bool is_macro_call (object* form) { +bool is_macro_call (object* form, object* env) { + CHECK: + if (symbolp(form)) { + object* pair = findpair(form, env); + if (pair == NULL) return false; + form = cdr(pair); + goto CHECK; + } if (!consp(form)) return false; object* lambda = first(form); if (!consp(lambda)) return false; @@ -5591,8 +5598,7 @@ bool is_macro_call (object* form) { } object* macroexpand1 (object* form, object* env, bool* done) { - if (symbolp(car(form))) form = cons(eval(car(form), env), cdr(form)); // Look up variable but DON'T mutate form - if (!is_macro_call(form)) { + if (!is_macro_call(form, env)) { *done = true; return form; } @@ -6793,7 +6799,7 @@ object* eval (object* form, object* env) { error(PSTR("undefined"), form); } // Expand macros - form = macroexpand(form); + form = macroexpand(form, env); // It's a list object* function = car(form); From 664dc1ba56559307afdfbb7a9d8e2e250d1da314 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 2 Dec 2023 19:33:43 -0500 Subject: [PATCH 071/109] boundp already checks GlobalEnv --- extensions.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extensions.hpp b/extensions.hpp index 108dd97..2a238a4 100644 --- a/extensions.hpp +++ b/extensions.hpp @@ -44,7 +44,7 @@ object* fn_gensym (object* args, object* env) { snprintf(buffer, sizeof(buffer), "%s%u", prefix, counter); result = buftosymbol(buffer); counter++; - } while (boundp(result, env) || boundp(result, GlobalEnv)); + } while (boundp(result, env)); return result; } From f5dc52a47161a4ab3370d53b589a02280315c063 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 2 Dec 2023 19:58:24 -0500 Subject: [PATCH 072/109] macros now appear to work --- ulisp.hpp | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 0365221..003d9d8 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -5585,10 +5585,11 @@ object* bq_invalid (object* args, object* env) { bool is_macro_call (object* form, object* env) { CHECK: - if (symbolp(form)) { - object* pair = findpair(form, env); + if (form == nil) return false; + if (symbolp(car(form))) { + object* pair = findpair(car(form), env); if (pair == NULL) return false; - form = cdr(pair); + form = cons(cdr(pair), cdr(form)); goto CHECK; } if (!consp(form)) return false; @@ -5602,7 +5603,19 @@ object* macroexpand1 (object* form, object* env, bool* done) { *done = true; return form; } - form = closure(0, sym(NIL), car(form), cdr(form), &env); + Serial.print("***in macroexpand1() form="); + printobject(form, pserial); + Serial.println(); + symbol_t name = sym(NIL); + if (symbolp(car(form))) { + Serial.println("is a named macro, name="); + printsymbol(car(form), pserial); + do form = cons(cdr(findvalue(car(form), env)), cdr(form)); while (symbolp(car(form))); + Serial.print(" new value="); + printobject(car(form), pserial); + Serial.println(); + } + form = closure(0, name, car(form), cdr(form), &env); return eval(form, env); } @@ -5617,7 +5630,7 @@ object* macroexpand (object* form, object* env) { while (!done) { form = macroexpand1(form, env, &done); limit--; - if (limit == 0 && !done) error2(PSTR("too many macros")); + if (limit == 0 && !done) error2(PSTR("too many nested macros")); } return form; } From dd0f3f8da2c57a6ab2e8c7a2ade4c77188269e3c Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sun, 3 Dec 2023 20:19:24 -0500 Subject: [PATCH 073/109] fixed some error edge cases in macroexpand --- ulisp.hpp | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 003d9d8..f3b6353 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -5603,38 +5603,40 @@ object* macroexpand1 (object* form, object* env, bool* done) { *done = true; return form; } - Serial.print("***in macroexpand1() form="); - printobject(form, pserial); - Serial.println(); symbol_t name = sym(NIL); if (symbolp(car(form))) { - Serial.println("is a named macro, name="); - printsymbol(car(form), pserial); do form = cons(cdr(findvalue(car(form), env)), cdr(form)); while (symbolp(car(form))); - Serial.print(" new value="); - printobject(car(form), pserial); - Serial.println(); } + protect(form); form = closure(0, name, car(form), cdr(form), &env); - return eval(form, env); + object* result = eval(form, env); + unprotect(); + return result; } -object* fn_macroexpand1 (object* form, object* env) { +object* fn_macroexpand1 (object* args, object* env) { bool dummy; - return macroexpand1(form, env, &dummy); + return macroexpand1(first(args), env, &dummy); } object* macroexpand (object* form, object* env) { + static object* prev_form = NULL; + if (equal(prev_form, form)) error2(PSTR("infinitely recursive macro detected")); + prev_form = form; bool done = false; - int limit = 10000; + protect(form); while (!done) { form = macroexpand1(form, env, &done); - limit--; - if (limit == 0 && !done) error2(PSTR("too many nested macros")); + car(GCStack) = form; } + unprotect(); return form; } +object* fn_macroexpand (object* args, object* env) { + return macroexpand(first(args), env); +} + /////////////////////////////////////////////////////////// // Built-in symbol names @@ -6423,7 +6425,7 @@ const char docthrow[] PROGMEM = "(throw 'tag [value])\n" const char docmacroexpand1[] PROGMEM = "(macroexpand-1 'form)\n" "If the form represents a call to a macro, expands the macro once and returns the expanded code."; const char docmacroexpand[] PROGMEM = "(macroexpand 'form)\n" -"Repeatedly applies (macroexpand) until the form no longer represents a call to a macro,\n" +"Repeatedly applies (macroexpand-1) until the form no longer represents a call to a macro,\n" "then returns the new form."; // Built-in symbol lookup table @@ -6667,7 +6669,7 @@ const tbl_entry_t BuiltinTable[] PROGMEM = { { stringcatch, sp_catch, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doccatch }, { stringthrow, fn_throw, MINMAX(FUNCTIONS, 1, 2), docthrow }, { stringmacroexpand1, fn_macroexpand1, MINMAX(FUNCTIONS, 1, 1), docmacroexpand1 }, - { stringmacroexpand, macroexpand, MINMAX(FUNCTIONS, 1, 1), docmacroexpand }, + { stringmacroexpand, fn_macroexpand, MINMAX(FUNCTIONS, 1, 1), docmacroexpand }, }; // Metatable cross-reference functions From d0d124d81c0ea5e9e1c449a5b7e30d5acd06920e Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Mon, 4 Dec 2023 08:20:46 -0500 Subject: [PATCH 074/109] add proper stack overflow detection --- ulisp.hpp | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index f3b6353..9f70da0 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -65,6 +65,8 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define LED_BUILTIN 13 #endif +#define MAX_STACK 1000 + // C Macros @@ -213,6 +215,8 @@ unsigned int I2Ccount; unsigned int TraceFn[TRACEMAX]; unsigned int TraceDepth[TRACEMAX]; +void* StackBottom; + // Flags enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, NOECHO, MUFFLEERRORS, INCATCH }; volatile flags_t Flags = 0b00001; // PRINTREADABLY set by default @@ -5603,12 +5607,9 @@ object* macroexpand1 (object* form, object* env, bool* done) { *done = true; return form; } - symbol_t name = sym(NIL); - if (symbolp(car(form))) { - do form = cons(cdr(findvalue(car(form), env)), cdr(form)); while (symbolp(car(form))); - } + while (symbolp(car(form))) form = cons(cdr(findvalue(car(form), env)), cdr(form)); protect(form); - form = closure(0, name, car(form), cdr(form), &env); + form = closure(0, sym(NIL), car(form), cdr(form), &env); object* result = eval(form, env); unprotect(); return result; @@ -5620,9 +5621,6 @@ object* fn_macroexpand1 (object* args, object* env) { } object* macroexpand (object* form, object* env) { - static object* prev_form = NULL; - if (equal(prev_form, form)) error2(PSTR("infinitely recursive macro detected")); - prev_form = form; bool done = false; protect(form); while (!done) { @@ -6797,6 +6795,8 @@ object* eval (object* form, object* env) { // Escape if (tstflag(ESCAPE)) { clrflag(ESCAPE); error2(PSTR("escape!"));} if (!tstflag(NOESC)) testescape(); + // Stack overflow check + if (abs(static_cast(StackBottom) - &TC) > MAX_STACK) error(PSTR("C stack overflow"), form); if (form == NULL) return nil; @@ -7474,6 +7474,8 @@ void initgfx () { } void ulispinit () { + int foo = 0; + StackBottom = &foo; initworkspace(); inittables(); initenv(); From c70a8dbc7b524a675810fd9b9c67e47b8213f717 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 22 Dec 2023 10:39:05 -0500 Subject: [PATCH 075/109] make setf work properly with macros --- ulisp.hpp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 9f70da0..26df53e 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -1151,7 +1151,7 @@ object** arrayref (object* array, int index, int size) { getarray - gets a pointer to an element in a multi-dimensional array, given a list of the subscripts subs If the first subscript is negative it's a bit array and bit is set to the bit number */ -object** getarray (object* array, object* subs, object* env, int *bit) { +object** getarray (object* array, object* subs, object* env, int* bit) { int index = 0, size = 1, s; *bit = -1; bool bitp = false; @@ -1720,7 +1720,7 @@ object* apply (object* function, object* args, object* env) { place - returns a pointer to an object referenced in the second argument of an in-place operation such as setf. bit is used to indicate the bit position in a bit array */ -object** place (object* args, object* env, int *bit) { +object** place (object* args, object* env, int* bit) { PLACE: *bit = -1; if (atom(args)) return &cdr(findvalue(args, env)); @@ -1754,7 +1754,7 @@ object** place (object* args, object* env, int *bit) { return getarray(array, cddr(args), env, bit); } } - else if (is_macro_call(function, env)) { + else if (is_macro_call(args, env)) { function = eval(function, env); goto PLACE; } @@ -5588,8 +5588,8 @@ object* bq_invalid (object* args, object* env) { // MACRO support bool is_macro_call (object* form, object* env) { - CHECK: if (form == nil) return false; + CHECK: if (symbolp(car(form))) { object* pair = findpair(car(form), env); if (pair == NULL) return false; From 71047844a3bfe294ead0b0e0b0000bdd8d005353 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 22 Dec 2023 16:46:19 -0500 Subject: [PATCH 076/109] some tweaks --- ulisp.hpp | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 26df53e..b95e103 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -65,7 +65,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define LED_BUILTIN 13 #endif -#define MAX_STACK 1000 +#define MAX_STACK 4000 // C Macros @@ -279,15 +279,15 @@ inline uint32_t untwist (uint32_t x) { /* errorsub - used by all the error routines. - Prints: "Error: 'fname' string", where fname is the name of the Lisp function in which the error occurred. + Prints: "Error in fname: string", where fname is the name of the Lisp function in which the error occurred. */ void errorsub (symbol_t fname, PGM_P string) { - pfl(pserial); pfstring(PSTR("Error: "), pserial); + pfl(pserial); pfstring(PSTR("Error"), pserial); if (fname != sym(NIL)) { - pserial('\''); + pfstring(PSTR(" in "), pserial); psymbol(fname, pserial); - pserial('\''); pserial(' '); } + pserial(':'); pserial(' '); pfstring(string, pserial); } @@ -1951,7 +1951,7 @@ inline void spiwrite (char c) { SPI.transfer(c); } inline void serial1write (char c) { Serial1.write(c); } inline void WiFiwrite (char c) { client.write(c); } #if defined(sdcardsupport) -inline void SDwrite (char c) { SDpfile.write(c); } +inline void SDwrite (char c) { int w = SDpfile.write(c); if (w != 1) { Context = NIL; error2(PSTR("failed to write to file")); } } #endif #if defined(gfxsupport) inline void gfxwrite (char c) { tft.write(c); } @@ -2600,7 +2600,8 @@ object* sp_withserial (object* args, object* env) { object* sp_withi2c (object* args, object* env) { object* params = checkarguments(args, 2, 4); object* var = first(params); - int address = checkinteger(eval(second(params), env)); + object* addr = eval(second(params), env); + int address = checkinteger(addr); params = cddr(params); if (address == 0 && params != NULL) params = cdr(params); // Ignore port int read = 0; // Write From 1942d983053100957ed8746d40402d95aba8d4ea Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Wed, 28 Feb 2024 08:25:11 -0500 Subject: [PATCH 077/109] Update README.md --- README.md | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index f46114d..deaa0e2 100644 --- a/README.md +++ b/README.md @@ -14,13 +14,16 @@ Patches: * Deleted: line-editor support * Added: Lisp `:keywords` that auto-quote themselves * Added: Ability to add multiple (more than one) extension tables (using `calloc()`) *may not be portable to other platforms* -* Added: Lisp `(throw)` and `(catch)` -* Added: backquote/unquote/unquote-splicing -* Added: **EXPERIMENTAL** macros/defmacro/macroexpand *no support for destructuring lambda lists yet* +* Added: Lisp `(throw)` and `(catch)` (\*) +* Added: backquote/unquote/unquote-splicing (\*) +* Added: macros/defmacro/macroexpand *no support for destructuring lambda lists yet* (\*) * Added: Auto-run contents of `main.lisp` (on microSD card) at startup * Modified: SD-card functions now include filename in error messages * Fixed: special forms don't need to call `checkargs()` because it is automatically called +> [!CAUTION] +> If you are looking to use this patched bersion as a guide for adding any of the 3 starred (\*) features listed above, please use [this guide I prepared](https://dragoncoder047.github.io/pages/ulisp_howto.html) instead. There are many subtle changes in my patched version that are understandable to me, but will no doubt cause confusion for someone who is just copy-pasting my code. The aforementioned document is structured and designed to allow copy-asting into vanilla uLisp without major problems arising. + Extensions (`extensions.hpp`): * `now` (provided by David) From 6beb5101bcc353efa5bbcaa3c7441e299a72135c Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 22 Mar 2024 15:46:14 -0400 Subject: [PATCH 078/109] Typos --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index deaa0e2..7cd1a85 100644 --- a/README.md +++ b/README.md @@ -22,7 +22,7 @@ Patches: * Fixed: special forms don't need to call `checkargs()` because it is automatically called > [!CAUTION] -> If you are looking to use this patched bersion as a guide for adding any of the 3 starred (\*) features listed above, please use [this guide I prepared](https://dragoncoder047.github.io/pages/ulisp_howto.html) instead. There are many subtle changes in my patched version that are understandable to me, but will no doubt cause confusion for someone who is just copy-pasting my code. The aforementioned document is structured and designed to allow copy-asting into vanilla uLisp without major problems arising. +> If you are looking to use this patched version as a guide for adding any of the 3 starred (\*) features listed above, please use [this guide I prepared](https://dragoncoder047.github.io/pages/ulisp_howto.html) instead. There are many subtle changes in my patched version that are understandable to me, but will no doubt cause confusion for someone who is just copy-pasting my code. The aforementioned document is structured and designed to allow copy-pasting into vanilla uLisp without major problems arising. Extensions (`extensions.hpp`): From 1e3aad35db38ebc2f560253301dea6b588ada358 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Thu, 6 Jun 2024 16:01:45 -0400 Subject: [PATCH 079/109] add better keywordp and fix behavior of Lisp keywordp on non-builtin symbols --- ulisp.hpp | 65 +++++++++++++++++++++++++++++++++---------------------- 1 file changed, 39 insertions(+), 26 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index b95e103..cff18e9 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -223,6 +223,7 @@ volatile flags_t Flags = 0b00001; // PRINTREADABLY set by default // Forward references object* tee; +bool builtin_keywordp (object*); bool keywordp (object*); void pfstring (PGM_P, pfun_t); char nthchar (object*, int); @@ -875,7 +876,7 @@ bool builtinp (symbol_t name) { } int checkkeyword (object* obj) { - if (!keywordp(obj)) error(PSTR("argument is not a keyword"), obj); + if (!builtin_keywordp(obj)) error(PSTR("argument is not a keyword"), obj); builtin_t kname = builtin(obj->name); minmax_t context = getminmax(kname); if (context != 0 && context != (minmax_t)Context) error(invalidkey, obj); @@ -1628,7 +1629,7 @@ object* findvalue (object* var, object* env) { // Handling closures -object* closure (int tc, symbol_t name, object* function, object* args, object** env) { +object* closure (bool tc, symbol_t name, object* function, object* args, object** env) { object* state = car(function); function = cdr(function); int trace = 0; @@ -1702,12 +1703,12 @@ object* apply (object* function, object* args, object* env) { } else function = eval(function, env); } if (consp(function) && isbuiltin(car(function), LAMBDA)) { - object* result = closure(0, sym(NIL), function, args, &env); + object* result = closure(false, sym(NIL), function, args, &env); return eval(result, env); } if (consp(function) && isbuiltin(car(function), CLOSURE)) { function = cdr(function); - object* result = closure(0, sym(NIL), function, args, &env); + object* result = closure(false, sym(NIL), function, args, &env); return eval(result, env); } error(PSTR("illegal function"), function); @@ -6773,14 +6774,24 @@ void testescape () { } /* - keywordp - check that obj is a keyword + builtin_keywordp - check that obj is a built-in keyword */ -bool keywordp (object* obj) { +bool builtin_keywordp (object* obj) { if (!(symbolp(obj) && builtinp(obj->name))) return false; builtin_t name = builtin(obj->name); PGM_P s = (char*)pgm_read_ptr(&(getentry(name)->string)); char c = pgm_read_byte(&s[0]); - return (c == ':'); + return c == ':'; +} + +bool keywordp (object* obj) { + if (obj == nil) return false; + if (builtin_keywordp(obj)) return true; + symbol_t name = obj->name; + if ((name & 3) != 0) return false; // Packed symbols are never keywords + object* first_chunk = (object*)name; + if (!first_chunk) return false; + return (((first_chunk->chars) >> ((sizeof(int) - 1) * 8)) & 255) == ':'; } // Main evaluator @@ -6789,7 +6800,7 @@ bool keywordp (object* obj) { eval - the main Lisp evaluator */ object* eval (object* form, object* env) { - int TC=0; + bool tailcall = false; EVAL: // Enough space? if (Freespace <= WORKSPACESIZE>>4) gc(form, env); @@ -6797,14 +6808,14 @@ object* eval (object* form, object* env) { if (tstflag(ESCAPE)) { clrflag(ESCAPE); error2(PSTR("escape!"));} if (!tstflag(NOESC)) testescape(); // Stack overflow check - if (abs(static_cast(StackBottom) - &TC) > MAX_STACK) error(PSTR("C stack overflow"), form); + if (abs(static_cast(StackBottom) - &tailcall) > MAX_STACK) error(PSTR("C stack overflow"), form); if (form == NULL) return nil; - if (form->type >= NUMBER && form->type <= STRING) return form; + if (form->type >= NUMBER && form->type <= STRING) return form; // Literal if (symbolp(form)) { - if (nthchar(princtostring(form), 0) == ':') return form; // Keyword + if (keywordp(form)) return form; // Keyword symbol_t name = form->name; object* pair = value(name, env); if (pair != NULL) return cdr(pair); @@ -6829,7 +6840,7 @@ object* eval (object* form, object* env) { builtin_t name = builtin(function->name); if ((name == LET) || (name == LETSTAR)) { - int TCstart = TC; + bool old_tailcall = tailcall; if (args == NULL) error2(noargument); object* assigns = first(args); if (!listp(assigns)) error(notalist, assigns); @@ -6838,9 +6849,9 @@ object* eval (object* form, object* env) { protect(newenv); while (assigns != NULL) { object* assign = car(assigns); - if (!consp(assign)) push(cons(assign,nil), newenv); - else if (cdr(assign) == NULL) push(cons(first(assign),nil), newenv); - else push(cons(first(assign),eval(second(assign),env)), newenv); + if (!consp(assign)) push(cons(assign, nil), newenv); + else if (cdr(assign) == NULL) push(cons(first(assign), nil), newenv); + else push(cons(first(assign), eval(second(assign), env)), newenv); car(GCStack) = newenv; if (name == LETSTAR) env = newenv; assigns = cdr(assigns); @@ -6848,7 +6859,7 @@ object* eval (object* form, object* env) { env = newenv; unprotect(); form = tf_progn(forms,env); - TC = TCstart; + tailcall = old_tailcall; goto EVAL; } @@ -6861,7 +6872,7 @@ object* eval (object* form, object* env) { if (pair != NULL) push(pair, envcopy); env = cdr(env); } - return cons(bsymbol(CLOSURE), cons(envcopy,args)); + return cons(bsymbol(CLOSURE), cons(envcopy, args)); } uint8_t ft = fntype(getminmax(name)); @@ -6875,7 +6886,7 @@ object* eval (object* form, object* env) { Context = name; checkargs(args); form = ((fn_ptr_type)lookupfn(name))(args, env); - TC = 1; + tailcall = true; goto EVAL; } if (ft == OTHER_FORMS) error(PSTR("can't be used as a function"), function); @@ -6883,7 +6894,7 @@ object* eval (object* form, object* env) { // Evaluate the parameters - result in head object* fname = car(form); - int TCstart = TC; + bool old_tailcall = tailcall; object* head = cons(eval(fname, env), NULL); protect(head); // Don't GC the result list object* tail = head; @@ -6891,7 +6902,7 @@ object* eval (object* form, object* env) { int nargs = 0; while (form != NULL){ - object* obj = cons(eval(car(form),env),NULL); + object* obj = cons(eval(car(form), env), NULL); cdr(tail) = obj; tail = obj; form = cdr(form); @@ -6903,7 +6914,7 @@ object* eval (object* form, object* env) { if (symbolp(function)) { builtin_t bname = builtin(function->name); - if (!builtinp(function->name)) error(PSTR("not valid here"), fname); + if (!builtinp(function->name)) error(PSTR("can't call a symbol"), fname); Context = bname; checkminmax(bname, nargs); object* result = ((fn_ptr_type)lookupfn(bname))(args, env); @@ -6916,7 +6927,7 @@ object* eval (object* form, object* env) { if (!listp(fname)) name = fname->name; if (isbuiltin(car(function), LAMBDA)) { - form = closure(TCstart, name, function, args, &env); + form = closure(old_tailcall, name, function, args, &env); unprotect(); int trace = tracing(fname->name); if (trace) { @@ -6928,21 +6939,23 @@ object* eval (object* form, object* env) { printobject(result, pserial); pln(pserial); return result; } else { - TC = 1; + tailcall = true; goto EVAL; } } if (isbuiltin(car(function), CLOSURE)) { function = cdr(function); - form = closure(TCstart, name, function, args, &env); + form = closure(old_tailcall, name, function, args, &env); unprotect(); - TC = 1; + tailcall = true; goto EVAL; } } - error(PSTR("illegal function"), fname); return nil; + error(PSTR("illegal function"), fname); + // unreachable + return nil; } // Print functions From 5f3a1b988e4d7954642a4337cd7cb001161bcbd9 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 7 Jun 2024 17:37:06 -0400 Subject: [PATCH 080/109] added destructuring-bind ref: http://forum.ulisp.com/t/destructuring-bind/1425?u=dragoncoder047 --- extensions.hpp | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/extensions.hpp b/extensions.hpp index 2a238a4..56d884d 100644 --- a/extensions.hpp +++ b/extensions.hpp @@ -81,10 +81,41 @@ const char stringsizeof[] PROGMEM = "sizeof"; const char docsizeof[] PROGMEM = "(sizeof obj)\n" "Returns the number of Lisp cells the object occupies in memory."; +void destructure (object* structure, object* data, object** env) { + if (structure == nil) return; + if (symbolp(structure)) push(cons(structure, data), *env); + else if (consp(structure)) { + if (!consp(data)) error(canttakecar, data); + destructure(car(structure), car(data), env); + destructure(cdr(structure), cdr(data), env); + } + else error(invalidarg, structure); +} + +object* sp_destructuring_bind (object* args, object* env) { + object* structure = first(args); + object* data_expr = second(args); + protect(data_expr); + object* data = eval(data_expr, env); + unprotect(); + object* body = cddr(args); + destructure(structure, data, &env); + protect(body); + object* result = eval(tf_progn(body, env), env); + unprotect(); + return result; +} + +const char stringdestructuringbind[] PROGMEM = "destructuring-bind"; +const char docdestructuringbind[] PROGMEM = "(destructuring-bind structure data [forms*])\n\n" +"Recursively assigns the datums of `data` to the symbols named in `structure`,\n" +"and then evaluates forms in that new environment."; + // Symbol lookup table const tbl_entry_t ExtensionsTable[] PROGMEM = { { stringnow, fn_now, MINMAX(FUNCTIONS, 0, 3), docnow }, { stringgensym, fn_gensym, MINMAX(FUNCTIONS, 0, 1), docgensym }, { stringintern, fn_intern, MINMAX(FUNCTIONS, 1, 1), docintern }, { stringsizeof, fn_sizeof, MINMAX(FUNCTIONS, 1, 1), docsizeof }, + { stringdestructuringbind, sp_destructuring_bind, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), docdestructuringbind }, }; From c9a612fa0811c34b7d1f02291e3628599ce821ce Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 7 Jun 2024 21:09:29 -0400 Subject: [PATCH 081/109] Update README.md --- README.md | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/README.md b/README.md index 7cd1a85..4382932 100644 --- a/README.md +++ b/README.md @@ -7,16 +7,24 @@ For more about the original ulisp-esp see [!CAUTION] > If you are looking to use this patched version as a guide for adding any of the 3 starred (\*) features listed above, please use [this guide I prepared](https://dragoncoder047.github.io/pages/ulisp_howto.html) instead. There are many subtle changes in my patched version that are understandable to me, but will no doubt cause confusion for someone who is just copy-pasting my code. The aforementioned document is structured and designed to allow copy-pasting into vanilla uLisp without major problems arising. -Extensions (`extensions.hpp`): - -* `now` (provided by David) -* `gensym` -* `intern` -* `sizeof` -* Everything from the [ulisp-bignums](https://github.com/technoblogy/ulisp-bignums) extension - ## `term.py` -- enhanced uLisp interface This provides a cleaner interface to use uLisp in compared to the stupid Arduino serial monitor. From 31b65cabd487ce623815fd9a9b2f733e3c9c3ad1 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sun, 9 Jun 2024 16:33:18 -0400 Subject: [PATCH 082/109] type safety on twist() and untwist() --- ulisp.hpp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index cff18e9..9193eba 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -144,7 +144,7 @@ enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM typedef uint32_t symbol_t; typedef uint8_t minmax_t; -typedef uint16_t builtin_t; +typedef uint32_t builtin_t; typedef uint16_t flags_t; typedef struct sobject { @@ -268,11 +268,11 @@ void plispstr (symbol_t, pfun_t); void testescape (); bool is_macro_call (object*, object*); -inline uint32_t twist (uint32_t x) { +inline symbol_t twist (builtin_t x) { return (x<<2) | ((x & 0xC0000000)>>30); } -inline uint32_t untwist (uint32_t x) { +inline builtin_t untwist (symbol_t x) { return (x>>2 & 0x3FFFFFFF) | ((x & 0x03)<<30); } From f4cd15cb2231267f92c9229eadfc80eb0ed7790b Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sun, 9 Jun 2024 17:48:20 -0400 Subject: [PATCH 083/109] add (defun (setf foo) (val arg) ...) support ref: http://forum.ulisp.com/t/defun-setf-foo-val-arg/1401?u=dragoncoder047 --- ulisp.hpp | 38 ++++++++++++++++++++++++++++++++++---- 1 file changed, 34 insertions(+), 4 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 9193eba..aad7654 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -184,7 +184,7 @@ typedef int (*gfun_t)(); typedef void (*pfun_t)(char); enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, MACRO, LET, LETSTAR, -CLOSURE, PSTAR, QUOTE, BACKQUOTE, UNQUOTE, UNQUOTE_SPLICING, CONS, APPEND, DEFUN, DEFVAR, DEFMACRO, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, +CLOSURE, PSTAR, QUOTE, BACKQUOTE, UNQUOTE, UNQUOTE_SPLICING, CONS, APPEND, DEFUN, SETF, DEFVAR, DEFMACRO, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, ANALOGREAD, REGISTER, FORMAT, }; @@ -2162,6 +2162,16 @@ object* sp_or (object* args, object* env) { return nil; } +// Need to do manual search because findvalue() uses eq() but we need equal() for this. +object* find_setf_func (object* whatenv, object* funcname) { + object* what = cons(bsymbol(SETF), cons(funcname, nil)); + for (object* z = whatenv; z != nil; z = cdr(z)) { + object* pair = car(z); + if (equal(what, car(pair))) return pair; + } + return nil; +} + /* (defun name (parameters) form*) Defines a function. @@ -2169,9 +2179,14 @@ object* sp_or (object* args, object* env) { object* sp_defun (object* args, object* env) { (void) env; object* var = first(args); - if (!symbolp(var)) error(notasymbol, var); + if (!symbolp(var)) { + // Check for (setf foo) forms + if (consp(var) && listlength(var) == 2 && eq(first(var), bsymbol(SETF))) /* do nothing */; + else error(notasymbol, var); + } object* val = cons(bsymbol(LAMBDA), cdr(args)); object* pair = value(var->name, GlobalEnv); + if (consp(var) && !pair) pair = find_setf_func(GlobalEnv, second(var)); if (pair != NULL) cdr(pair) = val; else push(cons(var, val), GlobalEnv); return var; @@ -2384,12 +2399,27 @@ object* sp_decf (object* args, object* env) { object* sp_setf (object* args, object* env) { int bit; object* arg = nil; + object* placeform = nil; + object** loc; while (args != NULL) { if (cdr(args) == NULL) error2(oddargs); - object** loc = place(first(args), env, &bit); + placeform = first(args); + // Check for special defsetf forms first before calling place() + if (consp(placeform)) { + object* funcname = first(placeform); + object* userdef = find_setf_func(env, funcname); + if (!userdef) userdef = find_setf_func(GlobalEnv, funcname); + if (userdef) { + // usercode should be a lambda + arg = eval(cons(cdr(userdef), cons(second(args), rest(placeform))), env); + goto next; + } + } arg = eval(second(args), env); + loc = place(placeform, env, &bit); if (bit == -1) *loc = arg; else *loc = number((checkinteger(*loc) & ~(1< Date: Fri, 14 Jun 2024 08:34:52 -0400 Subject: [PATCH 084/109] formatting --- ulisp.hpp | 46 +++++++++++++++++++++++++++++++++++----------- 1 file changed, 35 insertions(+), 11 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 570cb99..33b113b 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -1489,9 +1489,9 @@ object* iptostring (uint32_t ip) { object* lispstring (const char* s) { object* obj = newstring(); object* tail = obj; - while(1) { + for (;;) { char ch = *s++; - if (ch == 0) break; + if (ch == '\0') break; if (ch == '\\') ch = *s++; buildstring(ch, &tail); } @@ -1511,18 +1511,42 @@ int stringcompare (object* args, bool lt, bool gt, bool eq) { object* arg2 = checkstring(second(args)); arg1 = cdr(arg1); arg2 = cdr(arg2); - int m = 0; chars_t a = 0, b = 0; - while ((arg1 != NULL) || (arg2 != NULL)) { - if (arg1 == NULL) return lt ? m : -1; - if (arg2 == NULL) return gt ? m : -1; + int m = 0; + chars_t a = 0, b = 0; + while (arg1 || arg2) { + if (!arg1) return lt ? m : -1; + if (!arg2) return gt ? m : -1; a = arg1->chars; b = arg2->chars; - if (a < b) { if (lt) { m = m + sizeof(int); while (a != b) { m--; a = a >> 8; b = b >> 8; } return m; } else return -1; } - if (a > b) { if (gt) { m = m + sizeof(int); while (a != b) { m--; a = a >> 8; b = b >> 8; } return m; } else return -1; } - arg1 = car(arg1); arg2 = car(arg2); - m = m + sizeof(int); + if (a < b) { + if (lt) { + m += sizeof(int); + while (a != b) { + m--; + a = a >> 8; + b = b >> 8; + } + return m; + } + else return -1; + } + if (a > b) { + if (gt) { + m += sizeof(int); + while (a != b) { + m--; + a = a >> 8; + b = b >> 8; + } + return m; + } + else return -1; + } + arg1 = car(arg1); + arg2 = car(arg2); + m += sizeof(int); } if (eq) { - m = m - sizeof(int); + m -= sizeof(int); while (a != 0) { m++; a = a << 8; From efa583165a6109c093dfc63660587b9c479f5633 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 14 Jun 2024 08:43:25 -0400 Subject: [PATCH 085/109] fix for https://github.com/technoblogy/ulisp/issues/65 --- ulisp.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ulisp.hpp b/ulisp.hpp index 33b113b..7bfc563 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -1616,7 +1616,7 @@ object* apropos (object* arg, bool print) { uint8_t ft = fntype(getminmax(i)); pbuiltin((builtin_t)i, pserial); pserial(' '); pserial('('); if (ft == FUNCTIONS) pfstring("function", pserial); - else if (ft == SPECIAL_FORMS) pfstring("special form", pserial); + else if (ft == SPECIAL_FORMS || ft == TAIL_FORMS) pfstring("special form", pserial); else pfstring("symbol/keyword", pserial); pserial(')'); pln(pserial); } else { From a17719abd3596f4e7036639902921d3d746b36ca Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 15 Jun 2024 09:01:20 -0400 Subject: [PATCH 086/109] switch ENDFUNCTIONS for the value on the symbols page for 32-bit platforms --- ulisp.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ulisp.hpp b/ulisp.hpp index 7bfc563..a9c6614 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -112,7 +112,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define stringify(x) stringifyX(x) #define PACKEDS 0x43238000 #define BUILTINS 0xF4240000 -#define ENDFUNCTIONS 1536 +#define ENDFUNCTIONS 0x0BDC0000 #define fntype(x) (((uint8_t)(x))>>6) #define getminargs(x) ((((uint8_t)(x))>>3)&7) From 769869db6227f934a4e3b5d6ee8b54541904a4b8 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 15 Jun 2024 09:07:42 -0400 Subject: [PATCH 087/109] remove PROGMEM from extension files --- bignums.hpp | 74 +++++++++++++++++++++++++------------------------- extensions.hpp | 22 +++++++-------- 2 files changed, 48 insertions(+), 48 deletions(-) diff --git a/bignums.hpp b/bignums.hpp index 3b15014..8c19463 100644 --- a/bignums.hpp +++ b/bignums.hpp @@ -489,64 +489,64 @@ object* fn_BIGash (object* args, object* env) { } // Symbol names -const char stringBIGbignum[] PROGMEM = "$bignum"; -const char stringBIGinteger[] PROGMEM = "$integer"; -const char stringBIGbignumstring[] PROGMEM = "$bignum-string"; -const char stringBIGstringbignum[] PROGMEM = "$string-bignum"; -const char stringBIGzerop[] PROGMEM = "$zerop"; -const char stringBIGdecf[] PROGMEM = "$decf"; -const char stringBIGincf[] PROGMEM = "$incf"; -const char stringBIGadd[] PROGMEM = "$+"; -const char stringBIGsub[] PROGMEM = "$-"; -const char stringBIGmul[] PROGMEM = "$*"; -const char stringBIGdiv[] PROGMEM = "$/"; -const char stringBIGmod[] PROGMEM = "$mod"; -const char stringBIGequal[] PROGMEM = "$="; -const char stringBIGless[] PROGMEM = "$<"; -const char stringBIGgreater[] PROGMEM = "$>"; -const char stringBIGlogand[] PROGMEM = "$logand"; -const char stringBIGlogior[] PROGMEM = "$logior"; -const char stringBIGlogxor[] PROGMEM = "$logxor"; -const char stringBIGash[] PROGMEM = "$ash"; +const char stringBIGbignum[] = "$bignum"; +const char stringBIGinteger[] = "$integer"; +const char stringBIGbignumstring[] = "$bignum-string"; +const char stringBIGstringbignum[] = "$string-bignum"; +const char stringBIGzerop[] = "$zerop"; +const char stringBIGdecf[] = "$decf"; +const char stringBIGincf[] = "$incf"; +const char stringBIGadd[] = "$+"; +const char stringBIGsub[] = "$-"; +const char stringBIGmul[] = "$*"; +const char stringBIGdiv[] = "$/"; +const char stringBIGmod[] = "$mod"; +const char stringBIGequal[] = "$="; +const char stringBIGless[] = "$<"; +const char stringBIGgreater[] = "$>"; +const char stringBIGlogand[] = "$logand"; +const char stringBIGlogior[] = "$logior"; +const char stringBIGlogxor[] = "$logxor"; +const char stringBIGash[] = "$ash"; // Documentation strings -const char docBIGbignum[] PROGMEM = "($bignum int)\n" +const char docBIGbignum[] = "($bignum int)\n" "Converts an integer to a bignum and returns it."; -const char docBIGinteger[] PROGMEM = "($integer bignum)\n" +const char docBIGinteger[] = "($integer bignum)\n" "Converts a bignum to an integer and returns it."; -const char docBIGbignumstring[] PROGMEM = "($bignum-string bignum [base])\n" +const char docBIGbignumstring[] = "($bignum-string bignum [base])\n" "Converts a bignum to a string in base 10 (default) or 16 and returns it."; -const char docBIGstringbignum[] PROGMEM = "($string-bignum bignum [base])\n" +const char docBIGstringbignum[] = "($string-bignum bignum [base])\n" "Converts a bignum to a string in the specified base (default 10) and returns it."; -const char docBIGzerop[] PROGMEM = "($zerop bignum)\n" +const char docBIGzerop[] = "($zerop bignum)\n" "Tests whether a bignum is zero, allowing for trailing zeros."; -const char docBIGadd[] PROGMEM = "($+ bignum1 bignum2)\n" +const char docBIGadd[] = "($+ bignum1 bignum2)\n" "Adds two bignums and returns the sum as a new bignum."; -const char docBIGsub[] PROGMEM = "($- bignum1 bignum2)\n" +const char docBIGsub[] = "($- bignum1 bignum2)\n" "Subtracts two bignums and returns the difference as a new bignum."; -const char docBIGmul[] PROGMEM = "($* bignum1 bignum2)\n" +const char docBIGmul[] = "($* bignum1 bignum2)\n" "Multiplies two bignums and returns the product as a new bignum."; -const char docBIGdiv[] PROGMEM = "($/ bignum1 bignum2)\n" +const char docBIGdiv[] = "($/ bignum1 bignum2)\n" "Divides two bignums and returns the quotient as a new bignum."; -const char docBIGmod[] PROGMEM = "($mod bignum1 bignum2)\n" +const char docBIGmod[] = "($mod bignum1 bignum2)\n" "Divides two bignums and returns the remainder as a new bignum."; -const char docBIGequal[] PROGMEM = "($= bignum1 bignum2)\n" +const char docBIGequal[] = "($= bignum1 bignum2)\n" "Returns t if the two bignums are equal."; -const char docBIGless[] PROGMEM = "($< bignum1 bignum2)\n" +const char docBIGless[] = "($< bignum1 bignum2)\n" "Returns t if bignum1 is less than bignum2."; -const char docBIGgreater[] PROGMEM = "($> bignum1 bignum2)\n" +const char docBIGgreater[] = "($> bignum1 bignum2)\n" "Returns t if bignum1 is greater than bignum2."; -const char docBIGlogand[] PROGMEM = "($logand bignum bignum)\n" +const char docBIGlogand[] = "($logand bignum bignum)\n" "Returns the logical AND of two bignums."; -const char docBIGlogior[] PROGMEM = "($logior bignum bignum)\n" +const char docBIGlogior[] = "($logior bignum bignum)\n" "Returns the logical inclusive OR of two bignums."; -const char docBIGlogxor[] PROGMEM = "($logxor bignum bignum)\n" +const char docBIGlogxor[] = "($logxor bignum bignum)\n" "Returns the logical exclusive OR of two bignums."; -const char docBIGash[] PROGMEM = "($ash bignum shift)\n" +const char docBIGash[] = "($ash bignum shift)\n" "Returns bignum shifted by shift bits; positive means left."; // Symbol lookup table -const tbl_entry_t BignumsTable[] PROGMEM = { +const tbl_entry_t BignumsTable[] = { { stringBIGbignum, fn_BIGbignum, MINMAX(FUNCTIONS, 1, 1), docBIGbignum }, { stringBIGinteger, fn_BIGinteger, MINMAX(FUNCTIONS, 1, 1), docBIGinteger }, { stringBIGbignumstring, fn_BIGbignumstring, MINMAX(FUNCTIONS, 1, 2), docBIGbignumstring }, diff --git a/extensions.hpp b/extensions.hpp index 56d884d..e0885db 100644 --- a/extensions.hpp +++ b/extensions.hpp @@ -25,8 +25,8 @@ object* fn_now (object* args, object* env) { return cons(hours, cons(minutes, cons(seconds, nil))); } -const char stringnow[] PROGMEM = "now"; -const char docnow[] PROGMEM = "(now [hh mm ss])\n" +const char stringnow[] = "now"; +const char docnow[] = "(now [hh mm ss])\n" "Sets the current time, or with no arguments returns the current time\n" "as a list of three integers (hh mm ss)."; @@ -48,8 +48,8 @@ object* fn_gensym (object* args, object* env) { return result; } -const char stringgensym[] PROGMEM = "gensym"; -const char docgensym[] PROGMEM = "(gensym [prefix])\n" +const char stringgensym[] = "gensym"; +const char docgensym[] = "(gensym [prefix])\n" "Returns a new symbol, optionally beginning with prefix (which must be a string).\n" "The returned symbol is guaranteed to not conflict with any existing bound symbol."; @@ -58,8 +58,8 @@ object* fn_intern (object* args, object* env) { return buftosymbol(cstring(checkstring(first(args)), b, BUFFERSIZE)); } -const char stringintern[] PROGMEM = "intern"; -const char docintern[] PROGMEM = "(intern string)\n" +const char stringintern[] = "intern"; +const char docintern[] = "(intern string)\n" "Creates a symbol, with the same name as the string.\n" "Unlike gensym, the returned symbol is not modified from the string in any way,\n" "and so it may be bound."; @@ -77,8 +77,8 @@ object* fn_sizeof (object* args, object* env) { return number(count); } -const char stringsizeof[] PROGMEM = "sizeof"; -const char docsizeof[] PROGMEM = "(sizeof obj)\n" +const char stringsizeof[] = "sizeof"; +const char docsizeof[] = "(sizeof obj)\n" "Returns the number of Lisp cells the object occupies in memory."; void destructure (object* structure, object* data, object** env) { @@ -106,13 +106,13 @@ object* sp_destructuring_bind (object* args, object* env) { return result; } -const char stringdestructuringbind[] PROGMEM = "destructuring-bind"; -const char docdestructuringbind[] PROGMEM = "(destructuring-bind structure data [forms*])\n\n" +const char stringdestructuringbind[] = "destructuring-bind"; +const char docdestructuringbind[] = "(destructuring-bind structure data [forms*])\n\n" "Recursively assigns the datums of `data` to the symbols named in `structure`,\n" "and then evaluates forms in that new environment."; // Symbol lookup table -const tbl_entry_t ExtensionsTable[] PROGMEM = { +const tbl_entry_t ExtensionsTable[] = { { stringnow, fn_now, MINMAX(FUNCTIONS, 0, 3), docnow }, { stringgensym, fn_gensym, MINMAX(FUNCTIONS, 0, 1), docgensym }, { stringintern, fn_intern, MINMAX(FUNCTIONS, 1, 1), docintern }, From 67188e47a6e8b10b6b2b0f6801562cfa74bb7cf1 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 15 Jun 2024 12:17:24 -0400 Subject: [PATCH 088/109] TAIL_FORMS -> TAILCALL flag / SPECIAL_SYMBOLS fntype_t --- extensions.hpp | 2 +- ulisp.hpp | 145 +++++++++++++++++++++++++++++-------------------- 2 files changed, 87 insertions(+), 60 deletions(-) diff --git a/extensions.hpp b/extensions.hpp index e0885db..2beac02 100644 --- a/extensions.hpp +++ b/extensions.hpp @@ -101,7 +101,7 @@ object* sp_destructuring_bind (object* args, object* env) { object* body = cddr(args); destructure(structure, data, &env); protect(body); - object* result = eval(tf_progn(body, env), env); + object* result = progn_no_tc(body, env); unprotect(); return result; } diff --git a/ulisp.hpp b/ulisp.hpp index a9c6614..fe3d1e6 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -128,7 +128,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define TRACEMAX 3 // Number of traced functions enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; // ARRAY STRING and PAIR must be last enum token { UNUSED, OPEN_PAREN, CLOSE_PAREN, SINGLE_QUOTE, PERIOD, BACKTICK, COMMA, COMMA_AT }; -enum fntypes_t { OTHER_FORMS, TAIL_FORMS, FUNCTIONS, SPECIAL_FORMS }; +enum fntypes_t { OTHER_FORMS, SPECIAL_FORMS, FUNCTIONS, SPECIAL_SYMBOLS }; // Stream names used by printobject const char serialstream[] = "serial"; @@ -219,8 +219,8 @@ unsigned int TraceDepth[TRACEMAX]; void* StackBottom; // Flags -enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, NOECHO, MUFFLEERRORS, INCATCH }; -volatile flags_t Flags = 0b00001; // PRINTREADABLY set by default +enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, NOECHO, MUFFLEERRORS, TAILCALL, INCATCH }; +volatile flags_t Flags = 1; // PRINTREADABLY set by default // Forward references object* tee; @@ -259,7 +259,8 @@ int stringcompare (object*, bool, bool, bool); void pbuiltin (builtin_t, pfun_t); object* value (symbol_t, object*); void supersub (object*, int, int, pfun_t); -object* tf_progn (object*, object*); +object* sp_progn (object*, object*); +object* progn_no_tc (object*, object*); object* fn_princtostring (object*, object*); object* read (gfun_t); object* eval (object*, object*); @@ -586,9 +587,11 @@ const char wifi[] = ":wi-fi"; const char gfx[] = ":gfx"; /* - features - create a list of features symbols from const strings. + *features* - create a list of features symbols from const strings. */ -object* features () { +object* ss_features (object* args, object* env) { + (void)env; + if (args) error2("*features* is read only"); object* result = NULL; #ifdef gfxsupport push(internlong(gfx), result); @@ -1616,7 +1619,8 @@ object* apropos (object* arg, bool print) { uint8_t ft = fntype(getminmax(i)); pbuiltin((builtin_t)i, pserial); pserial(' '); pserial('('); if (ft == FUNCTIONS) pfstring("function", pserial); - else if (ft == SPECIAL_FORMS || ft == TAIL_FORMS) pfstring("special form", pserial); + else if (ft == SPECIAL_FORMS) pfstring("special form", pserial); + else if (ft == SPECIAL_SYMBOLS) pfstring("special symbol", pserial); else pfstring("symbol/keyword", pserial); pserial(')'); pln(pserial); } else { @@ -1774,7 +1778,7 @@ object* closure (bool tc, symbol_t name, object* function, object* args, object* if (trace) { pserial(')'); pln(pserial); } // Do an implicit progn if (tc) push(nil, *env); - return tf_progn(function, *env); + return sp_progn(function, *env); } object* apply (object* function, object* args, object* env) { @@ -2045,7 +2049,7 @@ object* dobody (object* args, object* env, bool star) { } } unprotect(); - return eval(tf_progn(results, env), env); + return progn_no_tc(results, env); } // I2C interface for up to two ports, using Arduino Wire @@ -2367,7 +2371,7 @@ void supersub (object* form, int lm, int super, pfun_t pfun) { if (symbolp(arg) && builtinp(arg->name)) { minmax_t minmax = getminmax(builtin(arg->name)); if (minmax == MINMAX(SPECIAL_FORMS, 2, UNLIMITED) || minmax == MINMAX(SPECIAL_FORMS, 1, 3)) special = 2; // defun, setq, setf, defvar - else if (minmax == MINMAX(SPECIAL_FORMS, 1, UNLIMITED) || minmax == MINMAX(OTHER_FORMS, 1, UNLIMITED) || minmax == MINMAX(TAIL_FORMS, 1, UNLIMITED) || minmax == MINMAX(TAIL_FORMS, 2, 3)) special = 1; + else if (minmax == MINMAX(SPECIAL_FORMS, 1, UNLIMITED) || minmax == MINMAX(OTHER_FORMS, 1, UNLIMITED) || minmax == MINMAX(SPECIAL_FORMS, 2, 3)) special = 1; } while (form != NULL) { if (atom(form)) { pfstring(" . ", pfun); printobject(form, pfun); pfun(')'); return; } @@ -2526,7 +2530,7 @@ object* sp_loop (object* args, object* env) { Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value. */ object* sp_return (object* args, object* env) { - object* result = eval(tf_progn(args,env), env); + object* result = progn_no_tc(args, env); setflag(RETURNFLAG); return result; } @@ -2837,7 +2841,7 @@ object* sp_formillis (object* args, object* env) { unsigned long start = millis(); unsigned long now, total = 0; if (param != NULL) total = checkinteger(eval(first(param), env)); - eval(tf_progn(cdr(args),env), env); + progn_no_tc(cdr(args), env); do { now = millis() - start; testescape(); @@ -2882,7 +2886,7 @@ object* sp_withoutputtostring (object* args, object* env) { object* string = startstring(); protect(string); object* forms = cdr(args); - eval(tf_progn(forms,env), env); + progn_no_tc(forms, env); unprotect(); return string; } @@ -2903,7 +2907,7 @@ object* sp_withserial (object* args, object* env) { push(pair,env); serialbegin(address, baud); object* forms = cdr(args); - object* result = eval(tf_progn(forms,env), env); + object* result = progn_no_tc(forms, env); serialend(address); return result; } @@ -2940,7 +2944,7 @@ object* sp_withi2c (object* args, object* env) { object* pair = cons(var, (I2Cstart(port, address & 0x7F, read)) ? stream(I2CSTREAM, address) : nil); push(pair, env); object* forms = cdr(args); - object* result = eval(tf_progn(forms,env), env); + object* result = progn_no_tc(forms, env); I2Cstop(port, read); return result; } @@ -2980,7 +2984,7 @@ object* sp_withspi (object* args, object* env) { SPI.beginTransaction(SPISettings(((unsigned long)clock * 1000), bitorder, mode)); digitalWrite(pin, LOW); object* forms = cdr(args); - object* result = eval(tf_progn(forms,env), env); + object* result = progn_no_tc(forms, env); digitalWrite(pin, HIGH); SPI.endTransaction(); return result; @@ -3019,7 +3023,7 @@ object* sp_withsdcard (object* args, object* env) { object* pair = cons(var, stream(SDSTREAM, 1)); push(pair,env); object* forms = cdr(args); - object* result = eval(tf_progn(forms,env), env); + object* result = progn_no_tc(forms, env); if (mode >= 1) SDpfile.close(); else SDgfile.close(); return result; #else @@ -3035,28 +3039,45 @@ object* sp_withsdcard (object* args, object* env) { (progn form*) Evaluates several forms grouped together into a block, and returns the result of evaluating the last form. */ -object* tf_progn (object* args, object* env) { +object* sp_progn (object* args, object* env) { if (args == NULL) return nil; object* more = cdr(args); while (more != NULL) { object* result = eval(car(args),env); - if (tstflag(RETURNFLAG)) return quoteit(QUOTE, result); // kludge to keep value from getting eval'ed again because this is a tail form + if (tstflag(RETURNFLAG)) return result; args = more; more = cdr(args); } + setflag(TAILCALL); return car(args); } +object* progn_no_tc (object* args, object* env) { + object* value = sp_progn(args, env); + if (tstflag(TAILCALL)) { + clrflag(TAILCALL); + value = eval(value, env); + } + return value; +} + /* (if test then [else]) Evaluates test. If it's non-nil the form then is evaluated and returned; otherwise the form else is evaluated and returned. */ -object* tf_if (object* args, object* env) { +object* sp_if (object* args, object* env) { if (args == NULL || cdr(args) == NULL) error2(toofewargs); - if (eval(first(args), env) != nil) return second(args); + if (eval(first(args), env) != nil) { + setflag(TAILCALL); + return second(args); + } args = cddr(args); - return (args != NULL) ? first(args) : nil; + if (args) { + setflag(TAILCALL); + return first(args); + } + return nil; } /* @@ -3065,14 +3086,15 @@ object* tf_if (object* args, object* env) { If the test evaluates to non-nil the forms are evaluated, and the last value is returned as the result of the cond. If the test evaluates to nil, none of the forms are evaluated, and the next argument is processed in the same way. */ -object* tf_cond (object* args, object* env) { +object* sp_cond (object* args, object* env) { while (args != NULL) { object* clause = first(args); if (!consp(clause)) error(illegalclause, clause); object* test = eval(first(clause), env); object* forms = cdr(clause); if (test != nil) { - if (forms == NULL) return quoteit(QUOTE, test); else return tf_progn(forms, env); + if (forms == NULL) return test; + else return sp_progn(forms, env); } args = cdr(args); } @@ -3083,9 +3105,9 @@ object* tf_cond (object* args, object* env) { (when test form*) Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned. */ -object* tf_when (object* args, object* env) { +object* sp_when (object* args, object* env) { if (args == NULL) error2(noargument); - if (eval(first(args), env) != nil) return tf_progn(cdr(args),env); + if (eval(first(args), env) != nil) return sp_progn(cdr(args), env); else return nil; } @@ -3093,10 +3115,10 @@ object* tf_when (object* args, object* env) { (unless test form*) Evaluates the test. If it's nil the forms are evaluated and the last value is returned. */ -object* tf_unless (object* args, object* env) { +object* sp_unless (object* args, object* env) { if (args == NULL) error2(noargument); if (eval(first(args), env) != nil) return nil; - else return tf_progn(cdr(args),env); + else return sp_progn(cdr(args), env); } /* @@ -3104,7 +3126,7 @@ object* tf_unless (object* args, object* env) { Evaluates a keyform to produce a test key, and then tests this against a series of arguments, each of which is a list containing a key optionally followed by one or more forms. */ -object* tf_case (object* args, object* env) { +object* sp_case (object* args, object* env) { object* test = eval(first(args), env); args = cdr(args); while (args != NULL) { @@ -3114,10 +3136,10 @@ object* tf_case (object* args, object* env) { object* forms = cdr(clause); if (consp(key)) { while (key != NULL) { - if (eq(test,car(key))) return tf_progn(forms, env); + if (eq(test,car(key))) return sp_progn(forms, env); key = cdr(key); } - } else if (eq(test,key) || eq(key,tee)) return tf_progn(forms, env); + } else if (eq(test, key) || eq(key, tee)) return sp_progn(forms, env); args = cdr(args); } return nil; @@ -3127,7 +3149,7 @@ object* tf_case (object* args, object* env) { (and item*) Evaluates its arguments until one returns nil, and returns the last value. */ -object* tf_and (object* args, object* env) { +object* sp_and (object* args, object* env) { if (args == NULL) return tee; object* more = cdr(args); while (more != NULL) { @@ -3135,6 +3157,7 @@ object* tf_and (object* args, object* env) { args = more; more = cdr(args); } + setflag(TAILCALL); return car(args); } @@ -5437,7 +5460,7 @@ object* sp_withclient (object* args, object* env) { object* pair = cons(var, stream(WIFISTREAM, n)); push(pair,env); object* forms = cdr(args); - object* result = eval(tf_progn(forms,env), env); + object* result = progn_no_tc(forms, env); client.stop(); return result; } @@ -5539,7 +5562,7 @@ object* sp_withgfx (object* args, object* env) { object* pair = cons(var, stream(GFXSTREAM, 1)); push(pair,env); object* forms = cdr(args); - object* result = eval(tf_progn(forms,env), env); + object* result = progn_no_tc(forms, env); return result; #else (void) args, (void) env; @@ -5884,7 +5907,7 @@ object* sp_catch (object* args, object* env) { if (!setjmp(dynamic_handler)) { // First: run forms - result = eval(tf_progn(forms, env), env); + result = progn_no_tc(forms, env); // If we get here nothing was thrown GCStack = current_GCStack; handler = previous_handler; @@ -5986,9 +6009,9 @@ object* process_backquote (object* arg, size_t level = 0) { // but evaluates the result in the current environment before returning it, either by // recursively calling EVAL with the result and env, or by assigning ast with the result // and continuing execution at the top of the loop (TCO)." -object* tf_backquote (object* args, object* env) { +object* sp_backquote (object* args, object* env) { object* result = process_backquote(first(args)); - // Tail call + setflag(TAILCALL); return result; } @@ -6892,7 +6915,7 @@ const tbl_entry_t BuiltinTable[] = { { string1, NULL, MINMAX(OTHER_FORMS, 0, 0), doc1 }, { string2, NULL, MINMAX(OTHER_FORMS, 0, 0), doc2 }, { string3, NULL, MINMAX(OTHER_FORMS, 0, 0), doc3 }, - { stringfeatures, NULL, MINMAX(OTHER_FORMS, 0, 0), docfeatures }, + { stringfeatures, ss_features, MINMAX(SPECIAL_SYMBOLS, 0, 0), docfeatures }, { string4, NULL, MINMAX(OTHER_FORMS, 0, 0), NULL }, { string5, NULL, MINMAX(OTHER_FORMS, 0, 0), NULL }, { stringtest, NULL, MINMAX(OTHER_FORMS, 0, 0), NULL }, @@ -6906,7 +6929,7 @@ const tbl_entry_t BuiltinTable[] = { { string11, NULL, MINMAX(OTHER_FORMS, 1, UNLIMITED), NULL }, { string12, NULL, MINMAX(OTHER_FORMS, 0, UNLIMITED), NULL }, { string13, sp_quote, MINMAX(SPECIAL_FORMS, 1, 1), NULL }, - { stringbackquote, tf_backquote, MINMAX(TAIL_FORMS, 1, 1), docbackquote }, + { stringbackquote, sp_backquote, MINMAX(SPECIAL_FORMS, 1, 1), docbackquote }, { stringunquote, bq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), docunquote }, { stringuqsplicing, bq_invalid, MINMAX(SPECIAL_FORMS, 1, 1), docunquotesplicing }, { string57, fn_cons, MINMAX(FUNCTIONS, 2, 2), doc57 }, @@ -6949,13 +6972,13 @@ const tbl_entry_t BuiltinTable[] = { { string45, sp_withi2c, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc45 }, { string46, sp_withspi, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc46 }, { string47, sp_withsdcard, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc47 }, - { string48, tf_progn, MINMAX(TAIL_FORMS, 0, UNLIMITED), doc48 }, - { string49, tf_if, MINMAX(TAIL_FORMS, 2, 3), doc49 }, - { string50, tf_cond, MINMAX(TAIL_FORMS, 0, UNLIMITED), doc50 }, - { string51, tf_when, MINMAX(TAIL_FORMS, 1, UNLIMITED), doc51 }, - { string52, tf_unless, MINMAX(TAIL_FORMS, 1, UNLIMITED), doc52 }, - { string53, tf_case, MINMAX(TAIL_FORMS, 1, UNLIMITED), doc53 }, - { string54, tf_and, MINMAX(TAIL_FORMS, 0, UNLIMITED), doc54 }, + { string48, sp_progn, MINMAX(SPECIAL_FORMS, 0, UNLIMITED), doc48 }, + { string49, sp_if, MINMAX(SPECIAL_FORMS, 2, 3), doc49 }, + { string50, sp_cond, MINMAX(SPECIAL_FORMS, 0, UNLIMITED), doc50 }, + { string51, sp_when, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc51 }, + { string52, sp_unless, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc52 }, + { string53, sp_case, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc53 }, + { string54, sp_and, MINMAX(SPECIAL_FORMS, 0, UNLIMITED), doc54 }, { string55, fn_not, MINMAX(FUNCTIONS, 1, 1), doc55 }, { string56, fn_not, MINMAX(FUNCTIONS, 1, 1), NULL }, { string58, fn_atom, MINMAX(FUNCTIONS, 1, 1), doc58 }, @@ -7279,9 +7302,10 @@ object* eval (object* form, object* env) { if (pair != NULL) return cdr(pair); pair = value(name, GlobalEnv); if (pair != NULL) return cdr(pair); - // special symbol macro kludge + // special symbol macro handling else if (builtinp(name)) { - if (builtin(name) == FEATURES) return features(); + builtin_t bname = builtin(name); + if (fntype(getminmax(bname)) == SPECIAL_SYMBOLS) return ((fn_ptr_type)lookupfn(bname))(NULL, env); return form; } Context = NIL; @@ -7320,9 +7344,14 @@ object* eval (object* form, object* env) { } env = newenv; unprotect(); - form = tf_progn(forms,env); - tailcall = old_tailcall; - goto EVAL; + clrflag(TAILCALL); + form = sp_progn(forms, env); + if (tstflag(TAILCALL)) { + clrflag(TAILCALL); + tailcall = old_tailcall; + goto EVAL; + } + return form; } // MACRO does not do closures. @@ -7339,17 +7368,15 @@ object* eval (object* form, object* env) { uint8_t ft = fntype(getminmax(name)); if (ft == SPECIAL_FORMS) { - Context = name; - checkargs(args); - return ((fn_ptr_type)lookupfn(name))(args, env); - } - - if (ft == TAIL_FORMS) { Context = name; checkargs(args); form = ((fn_ptr_type)lookupfn(name))(args, env); - tailcall = true; - goto EVAL; + if (tstflag(TAILCALL)) { + tailcall = true; + clrflag(TAILCALL); + goto EVAL; + } + return form; } if (ft == OTHER_FORMS) error("can't be used as a function", function); } From 5abc6efab2218b63fa0fafeafe21b8186be7c4a2 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 15 Jun 2024 12:20:32 -0400 Subject: [PATCH 089/109] remove saving of old_tailcall in the enclosed code, there was nothing that branched on, accessed, or modified tailcall or old_tailcall, so saving/restoring it was rather pointless --- ulisp.hpp | 2 -- 1 file changed, 2 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index fe3d1e6..1639c7e 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -7326,7 +7326,6 @@ object* eval (object* form, object* env) { builtin_t name = builtin(function->name); if ((name == LET) || (name == LETSTAR)) { - bool old_tailcall = tailcall; if (args == NULL) error2(noargument); object* assigns = first(args); if (!listp(assigns)) error(notalist, assigns); @@ -7348,7 +7347,6 @@ object* eval (object* form, object* env) { form = sp_progn(forms, env); if (tstflag(TAILCALL)) { clrflag(TAILCALL); - tailcall = old_tailcall; goto EVAL; } return form; From 277d7531afb3e77f8c99f92d4ba030239f6ae503 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sun, 16 Jun 2024 08:33:03 -0400 Subject: [PATCH 090/109] add note about ESP32Servo library, add __has_include magic --- README.md | 3 +++ ulisp-esp32.ino | 1 - ulisp.hpp | 48 +++++++++++++++++++++++++++++++----------------- 3 files changed, 34 insertions(+), 18 deletions(-) diff --git a/README.md b/README.md index 9425762..055bea8 100644 --- a/README.md +++ b/README.md @@ -7,6 +7,9 @@ For more about the original ulisp-esp see [!NOTE] +> This version includes (requires?) the [ESP32Servo](https://www.arduino.cc/reference/en/libraries/esp32servo/) library to get the analogWrite() and tone() functioning correctly. If you don't have it installed uLisp will compile but you won't have analogWrite() and tone(). + New features, some care in editing required: * Lisp `:keywords` that auto-quote themselves * Ability to add multiple (more than one) extension tables (using `calloc()`) *may not be portable to other platforms* diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index 95da532..d7ca4ef 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -16,7 +16,6 @@ #define sdcardsupport // #define gfxsupport // #define lisplibrary -#define toneimplemented // Includes #include "ulisp.hpp" diff --git a/ulisp.hpp b/ulisp.hpp index 1639c7e..10fd1b9 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -44,6 +44,16 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #endif #endif +#ifdef __has_include +#if __has_include() +#include +#include +#include +#include +#define toneimplemented +#endif +#endif + #include #define SDSIZE 172 @@ -57,10 +67,6 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #include "FS.h" #include -#ifndef analogWrite -#define analogWrite(x,y) dacWrite((x),(y)) -#endif - #ifndef LED_BUILTIN #define LED_BUILTIN 13 #endif @@ -2224,33 +2230,36 @@ void checkanalogread (int pin) { } void checkanalogwrite (int pin) { -// if (!(pin>=25 && pin<=26)) error("invalid pin", number(pin)); - (void)pin; + #ifdef toneimplemented + // ERROR PWM channel unavailable on pin requested! 1 + // PWM available on: 2,4,5,12-19,21-23,25-27,32-33 + if (!(pin==2 || pin==4 || pin==5 || (pin>=12 && pin<=19) || (pin>=21 && pin<=23) || (pin>=25 && pin<=27) || pin==32 || pin==33)) error("not a PWM-capable pin", number(pin)); + #else + if (!(pin>=25 && pin<=26)) error("not a DAC pin", number(pin)); + #endif } // Note -#ifndef toneimplemented -void tone (int pin, int note) { - (void) pin, (void) note; -} - -void noTone (int pin) { - (void) pin; -} -#endif - const int scale[] = {4186,4435,4699,4978,5274,5588,5920,6272,6645,7040,7459,7902}; void playnote (int pin, int note, int octave) { + #ifdef toneimplemented int oct = octave + note/12; int prescaler = 8 - oct; if (prescaler<0 || prescaler>8) error("octave out of range", number(prescaler)); tone(pin, scale[note%12]>>prescaler); + #else + error2("not available"); + #endif } void nonote (int pin) { + #ifdef toneimplemented noTone(pin); + #else + error2("not available"); + #endif } // Sleep @@ -5027,7 +5036,12 @@ object* fn_analogwrite (object* args, object* env) { else pin = checkinteger(arg); checkanalogwrite(pin); object* value = second(args); - analogWrite(pin, checkinteger(value)); + #ifdef toneimplemented + analogWrite + #else + dacWrite + #endif + (pin, checkinteger(value)); return value; } From d6190e443f7bb2701d268197e3bea1ea9957d3ed Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sun, 16 Jun 2024 20:31:58 -0400 Subject: [PATCH 091/109] remove doubled compile options "why was printgcs still on when I comment it out in ulisp-esp32.ino?" --- ulisp.hpp | 8 -------- 1 file changed, 8 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 10fd1b9..4a56f1e 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -23,14 +23,6 @@ const char LispLibrary[] = ""; #endif -// Compile options - -#define printfreespace -#define printgcs -#define sdcardsupport -// #define gfxsupport -// #define lisplibrary - #if defined(gfxsupport) #define COLOR_WHITE ST77XX_WHITE #define COLOR_BLACK ST77XX_BLACK From 6ff151216f4e13793a6bb2f8f511a1923f18dc31 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Tue, 18 Jun 2024 18:22:48 -0400 Subject: [PATCH 092/109] remove old code and reorganize --- ulisp.hpp | 29 +++-------------------------- 1 file changed, 3 insertions(+), 26 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 4a56f1e..8b5df41 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -137,7 +137,7 @@ const char wifistream[] = "wifi"; const char stringstream[] = "string"; const char gfxstream[] = "gfx"; const char* const streamname[] = {serialstream, i2cstream, spistream, sdstream, wifistream, stringstream, gfxstream}; -enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM}; +enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM}; // Typedefs @@ -199,6 +199,7 @@ size_t Freespace = 0; object* Freelist; builtin_t Context; +object* tee; object* GlobalEnv; object* GCStack = NULL; object* GlobalString; @@ -221,7 +222,6 @@ enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, volatile flags_t Flags = 1; // PRINTREADABLY set by default // Forward references -object* tee; bool builtin_keywordp (object*); bool keywordp (object*); void pfstring (const char*, pfun_t); @@ -898,7 +898,7 @@ int isbuiltin (object* obj, builtin_t n) { return symbolp(obj) && obj->name == sym(n); } -bool builtinp (symbol_t name) { +inline bool builtinp (symbol_t name) { return (untwist(name) >= BUILTINS); } @@ -2363,29 +2363,6 @@ void superprint (object* form, int lm, pfun_t pfun) { } } -/* - supersub - subroutine used by pprint -*/ -void supersub (object* form, int lm, int super, pfun_t pfun) { - int special = 0, separate = 1; - object* arg = car(form); - if (symbolp(arg) && builtinp(arg->name)) { - minmax_t minmax = getminmax(builtin(arg->name)); - if (minmax == MINMAX(SPECIAL_FORMS, 2, UNLIMITED) || minmax == MINMAX(SPECIAL_FORMS, 1, 3)) special = 2; // defun, setq, setf, defvar - else if (minmax == MINMAX(SPECIAL_FORMS, 1, UNLIMITED) || minmax == MINMAX(OTHER_FORMS, 1, UNLIMITED) || minmax == MINMAX(SPECIAL_FORMS, 2, 3)) special = 1; - } - while (form != NULL) { - if (atom(form)) { pfstring(" . ", pfun); printobject(form, pfun); pfun(')'); return; } - else if (separate) { pfun('('); separate = 0; } - else if (special) { pfun(' '); special--; } - else if (!super) pfun(' '); - else { pln(pfun); indent(lm, ' ', pfun); } - superprint(car(form), lm, pfun); - form = cdr(form); - } - pfun(')'); return; -} - /* edit - the Lisp tree editor Steps through a function definition, editing it a bit at a time, using single-key editing commands. From d2b2fc437f677ca9b845f882ee1d93c33913e304 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Tue, 18 Jun 2024 18:23:45 -0400 Subject: [PATCH 093/109] Add fix for `('print 'foo)` bug no fix yet for `('progn 'foo)` evaluating the form twice --- ulisp.hpp | 40 +++++++++++++++++++++++++++++++++++----- 1 file changed, 35 insertions(+), 5 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 8b5df41..1bc63d7 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -87,6 +87,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define integerp(x) ((x) != NULL && (x)->type == NUMBER) #define floatp(x) ((x) != NULL && (x)->type == FLOAT) #define symbolp(x) ((x) != NULL && (x)->type == SYMBOL) +#define bfunctionp(x) ((x) != NULL && (x)->type == BFUNCTION) #define stringp(x) ((x) != NULL && (x)->type == STRING) #define characterp(x) ((x) != NULL && (x)->type == CHARACTER) #define arrayp(x) ((x) != NULL && (x)->type == ARRAY) @@ -124,7 +125,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); // Constants #define TRACEMAX 3 // Number of traced functions -enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; // ARRAY STRING and PAIR must be last +enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, BFUNCTION=8, STREAM=10, CHARACTER=12, FLOAT=14, ARRAY=16, STRING=18, PAIR=20 }; // ARRAY, STRING, and PAIR must be last enum token { UNUSED, OPEN_PAREN, CLOSE_PAREN, SINGLE_QUOTE, PERIOD, BACKTICK, COMMA, COMMA_AT }; enum fntypes_t { OTHER_FORMS, SPECIAL_FORMS, FUNCTIONS, SPECIAL_SYMBOLS }; @@ -223,6 +224,7 @@ volatile flags_t Flags = 1; // PRINTREADABLY set by default // Forward references bool builtin_keywordp (object*); +inline bool builtinp (symbol_t name); bool keywordp (object*); void pfstring (const char*, pfun_t); char nthchar (object*, int); @@ -505,6 +507,19 @@ object* symbol (symbol_t name) { return ptr; } +object* bfunction_from_symbol (object* symbol) { + if (!(symbolp(symbol) && builtinp(symbol->name))) return nil; + symbol_t nm = symbol->name; + for (int i=0; itype == BFUNCTION && obj->name == nm) return obj; + } + object* ptr = myalloc(); + ptr->type = BFUNCTION; + ptr->name = nm; + return ptr; +} + /* bsymbol - make a built-in symbol */ @@ -7279,6 +7294,7 @@ object* eval (object* form, object* env) { if (form->type >= NUMBER && form->type <= STRING) return form; // Literal if (symbolp(form)) { + if (form == tee) return form; if (keywordp(form)) return form; // Keyword symbol_t name = form->name; object* pair = value(name, env); @@ -7289,7 +7305,7 @@ object* eval (object* form, object* env) { else if (builtinp(name)) { builtin_t bname = builtin(name); if (fntype(getminmax(bname)) == SPECIAL_SYMBOLS) return ((fn_ptr_type)lookupfn(bname))(NULL, env); - return form; + return bfunction_from_symbol(form); } Context = NIL; error("undefined", form); @@ -7304,7 +7320,7 @@ object* eval (object* form, object* env) { if (function == NULL) error2("can't call nil"); if (!listp(args)) error("can't evaluate a dotted pair", args); - // List starts with a builtin symbol? + // List starts with a builtin special form? if (symbolp(function) && builtinp(function->name)) { builtin_t name = builtin(function->name); @@ -7381,10 +7397,15 @@ object* eval (object* form, object* env) { function = car(head); args = cdr(head); - + + // fail early on calling a symbol if (symbolp(function)) { + Context = NIL; + error("can't call a symbol", function); + } + if (bfunctionp(function)) { builtin_t bname = builtin(function->name); - if (!builtinp(function->name)) error("can't call a symbol", fname); + if (!builtinp(function->name)) error("can't call a symbol", function); Context = bname; checkminmax(bname, nargs); object* result = ((fn_ptr_type)lookupfn(bname))(args, env); @@ -7688,6 +7709,15 @@ void printobject (object* form, pfun_t pfun) { else if (integerp(form)) pint(form->integer, pfun); else if (floatp(form)) pfloat(form->single_float, pfun); else if (symbolp(form)) { if (form->name != sym(NOTHING)) printsymbol(form, pfun); } + else if (bfunctionp(form)) { + pfstring("name)))) { + case FUNCTIONS: pfstring("function ", pfun); break; + case SPECIAL_FORMS: pfstring("special form ", pfun); break; + } + printsymbol(form, pfun); + pfun('>'); + } else if (characterp(form)) pcharacter(form->chars, pfun); else if (stringp(form)) printstring(form, pfun); else if (arrayp(form)) printarray(form, pfun); From 64dfd89e013816001137f803902f7b244ef5e192 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Tue, 18 Jun 2024 18:25:05 -0400 Subject: [PATCH 094/109] add fix for https://github.com/technoblogy/ulisp/issues/67 --- ulisp.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ulisp.hpp b/ulisp.hpp index 1bc63d7..c9ad6ca 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -103,7 +103,7 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #define tstflag(x) (Flags & 1<<(x)) #define issp(x) (x == ' ' || x == '\n' || x == '\r' || x == '\t') -#define isbr(x) (x == ')' || x == '(' || x == '"' || x == '#') +#define isbr(x) (x == ')' || x == '(' || x == '"' || x == '#' || x == '\'') #define longsymbolp(x) longnamep((x)->name) #define longnamep(x) (((x) & 0x03) == 0) #define arraysize(x) (sizeof(x) / sizeof(x[0])) From cfcc504c5f8e8fd88ab8c9cb7758a50dd2bc0235 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Thu, 20 Jun 2024 15:27:29 -0400 Subject: [PATCH 095/109] sticky tail call bugs with user-defined closures --- ulisp.hpp | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/ulisp.hpp b/ulisp.hpp index c9ad6ca..843d1d3 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -1805,11 +1805,13 @@ object* apply (object* function, object* args, object* env) { } if (consp(function) && isbuiltin(car(function), LAMBDA)) { object* result = closure(false, sym(NIL), function, args, &env); + clrflag(TAILCALL); return eval(result, env); } if (consp(function) && isbuiltin(car(function), CLOSURE)) { function = cdr(function); object* result = closure(false, sym(NIL), function, args, &env); + clrflag(TAILCALL); return eval(result, env); } error("illegal function", function); @@ -6045,7 +6047,8 @@ object* macroexpand1 (object* form, object* env, bool* done) { } while (symbolp(car(form))) form = cons(cdr(findvalue(car(form), env)), cdr(form)); protect(form); - form = closure(0, sym(NIL), car(form), cdr(form), &env); + form = closure(false, sym(NIL), car(form), cdr(form), &env); + clrflag(TAILCALL); object* result = eval(form, env); unprotect(); return result; @@ -7419,6 +7422,7 @@ object* eval (object* form, object* env) { if (isbuiltin(car(function), LAMBDA)) { form = closure(old_tailcall, name, function, args, &env); + clrflag(TAILCALL); unprotect(); int trace = tracing(fname->name); if (trace) { @@ -7439,6 +7443,7 @@ object* eval (object* form, object* env) { function = cdr(function); form = closure(old_tailcall, name, function, args, &env); unprotect(); + clrflag(TAILCALL); tailcall = true; goto EVAL; } From 6205ce4dbf92413f09bfb06bc31bc85e53e67fb1 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Thu, 20 Jun 2024 21:41:08 -0400 Subject: [PATCH 096/109] fix crashes on `(pinmode 32 :output)` didn't crash on pin 31 or 33. Why? Little importance now. --- ulisp.hpp | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 843d1d3..63bc5c3 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -4934,11 +4934,11 @@ object* fn_cls (object* args, object* env) { object* fn_pinmode (object* args, object* env) { (void) env; int pin; object* arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); + if (builtin_keywordp(arg)) pin = checkkeyword(arg); else pin = checkinteger(first(args)); int pm = INPUT; arg = second(args); - if (keywordp(arg)) pm = checkkeyword(arg); + if (builtin_keywordp(arg)) pm = checkkeyword(arg); else if (integerp(arg)) { int mode = arg->integer; if (mode == 1) pm = OUTPUT; else if (mode == 2) pm = INPUT_PULLUP; @@ -4958,7 +4958,7 @@ object* fn_digitalread (object* args, object* env) { (void) env; int pin; object* arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); + if (builtin_keywordp(arg)) pin = checkkeyword(arg); else pin = checkinteger(arg); if (digitalRead(pin) != 0) return tee; else return nil; } @@ -4971,11 +4971,11 @@ object* fn_digitalwrite (object* args, object* env) { (void) env; int pin; object* arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); + if (builtin_keywordp(arg)) pin = checkkeyword(arg); else pin = checkinteger(arg); arg = second(args); int mode; - if (keywordp(arg)) mode = checkkeyword(arg); + if (builtin_keywordp(arg)) mode = checkkeyword(arg); else if (integerp(arg)) mode = arg->integer ? HIGH : LOW; else mode = (arg != nil) ? HIGH : LOW; digitalWrite(pin, mode); @@ -4990,7 +4990,7 @@ object* fn_analogread (object* args, object* env) { (void) env; int pin; object* arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); + if (builtin_keywordp(arg)) pin = checkkeyword(arg); else { pin = checkinteger(arg); checkanalogread(pin); @@ -5018,7 +5018,7 @@ object* fn_analogwrite (object* args, object* env) { (void) env; int pin; object* arg = first(args); - if (keywordp(arg)) pin = checkkeyword(arg); + if (builtin_keywordp(arg)) pin = checkkeyword(arg); else pin = checkinteger(arg); checkanalogwrite(pin); object* value = second(args); @@ -5098,7 +5098,7 @@ object* fn_register (object* args, object* env) { (void) env; object* arg = first(args); int addr; - if (keywordp(arg)) addr = checkkeyword(arg); + if (builtin_keywordp(arg)) addr = checkkeyword(arg); else addr = checkinteger(first(args)); if (cdr(args) == NULL) return number(*(uint32_t *)addr); (*(uint32_t *)addr) = checkinteger(second(args)); From 0b22144fac2f05acd920496aa591e0d6f04667d4 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 29 Jun 2024 09:29:57 -0400 Subject: [PATCH 097/109] change sp_return -> fn_return (missed on 4.6 update) --- ulisp.hpp | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 63bc5c3..116cd36 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -2524,10 +2524,9 @@ object* sp_loop (object* args, object* env) { (return [value]) Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value. */ -object* sp_return (object* args, object* env) { - object* result = progn_no_tc(args, env); +object* fn_return (object* args, object* env) { setflag(RETURNFLAG); - return result; + return args ? first(args) : nil; } /* @@ -6955,7 +6954,7 @@ const tbl_entry_t BuiltinTable[] = { { string28, sp_or, MINMAX(SPECIAL_FORMS, 0, UNLIMITED), doc28 }, { string29, sp_setq, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc29 }, { string30, sp_loop, MINMAX(SPECIAL_FORMS, 0, UNLIMITED), doc30 }, - { string31, sp_return, MINMAX(SPECIAL_FORMS, 0, UNLIMITED), doc31 }, + { string31, fn_return, MINMAX(FUNCTIONS, 0, 1), doc31 }, { string32, sp_push, MINMAX(SPECIAL_FORMS, 2, 2), doc32 }, { string33, sp_pop, MINMAX(SPECIAL_FORMS, 1, 1), doc33 }, { string34, sp_incf, MINMAX(SPECIAL_FORMS, 1, 2), doc34 }, From 1c3aaf06f46622846a606f9fa8fca8fa92537712 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 29 Jun 2024 09:30:41 -0400 Subject: [PATCH 098/109] remove redefinition of fn_return --- ulisp.hpp | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 116cd36..3239993 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -4671,16 +4671,6 @@ object* fn_eval (object* args, object* env) { return eval(first(args), env); } -/* - (return [value]) - Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value. -*/ -object *fn_return (object *args, object *env) { - (void) env; - setflag(RETURNFLAG); - if (args == NULL) return nil; else return first(args); -} - /* (globals) Returns a list of global variables. From 8be07374630d8daeaeeb42ae8efa9cb7ee719891 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 29 Jun 2024 10:05:12 -0400 Subject: [PATCH 099/109] Create autotest.py --- autotest.py | 808 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 808 insertions(+) create mode 100644 autotest.py diff --git a/autotest.py b/autotest.py new file mode 100644 index 0000000..f1fdce4 --- /dev/null +++ b/autotest.py @@ -0,0 +1,808 @@ +import serial +import time +import sys + +# copied from ulisp-builder cause I can't run Lisp + +TESTS = r""" + +(defvar ers 0) + +(defun aeq (tst x y) (unless (or (and (floatp x) (floatp y) (< (abs (- x y)) 0.000005)) (equal x y)) (incf ers) (format t "~a=~a/~a~%" tst x y))) + +#| Symbols |# + +(aeq 'let 123 (let ((cat 123)) cat)) +(aeq 'let 79 (let ((ca% 79)) ca%)) +(aeq 'let 83 (let ((1- 83)) 1-)) +(aeq 'let 13 (let ((12a 13)) 12a)) +(aeq 'let 17 (let ((-1- 17)) -1-)) +(aeq 'let 66 (let ((abcdef 66)) abcdef)) +(aeq 'let 77 (let ((abcdefg 77)) abcdefg)) +(aeq 'let 88 (let ((abcdefgh 88)) abcdefgh)) +(aeq 'let 99 (let ((abcdefghi 99)) abcdefghi)) +(aeq 'let 1010 (let ((abcdefghij 1010)) abcdefghij)) +(aeq 'let "ab9" (princ-to-string 'ab9)) +(aeq 'let t (eq 'me 'me)) +(aeq 'let t (eq 'fishcake 'fishcake)) +(aeq 'let nil (eq 'fishcak 'fishca)) + +#| Arithmetic |# + +(aeq '* 9 (* -3 -3)) +(aeq '* 32580 (* 180 181)) +(aeq '* 1 (*)) +(aeq '+ 32767 (+ 32765 1 1)) +(aeq '+ 0 (+)) +(aeq '+ -2 (+ -1 -1)) +(aeq '- -4 (- 4)) +(aeq '- 0 (- 4 2 1 1)) +(aeq '/ 2 (/ 60 10 3)) +(aeq '1+ 2 (1+ 1)) +(aeq '1+ 0 (1+ -1)) +(aeq '1- 0 (1- 1)) + +#| Comparisons |# + +(aeq '< t (< -32768 32767)) +(aeq '< t (< -1 0)) +(aeq '< t (< 1 2 3 4)) +(aeq '< nil (< 1 2 2 4)) +(aeq '< t (<= 1 2 2 4)) +(aeq '< nil (<= 1 3 2 4)) +(aeq '< t (> 4 3 2 1)) +(aeq '< nil (> 4 2 2 1)) +(aeq '< t (>= 4 2 2 1)) +(aeq '< nil (>= 4 2 3 1)) +(aeq '< t (< 1)) +(aeq '< nil (< 1 3 2)) +(aeq '< nil (< -1 -2)) +(aeq '< nil (< 10 10)) +(aeq '<= t (<= 10 10)) +(aeq '= t (= 32767 32767)) +(aeq '>= t (>= 10 10)) +(aeq '>= nil (>= 9 10)) +(aeq '/= t (/= 1)) +(aeq '/= nil (/= 1 2 1)) +(aeq '/= nil (/= 1 2 3 1)) +(aeq '/= t (/= 1 2 3 4)) +(aeq 'plusp t (plusp 1)) +(aeq 'plusp nil (plusp 0)) +(aeq 'plusp nil (plusp -1)) +(aeq 'minusp nil (minusp 1)) +(aeq 'minusp nil (minusp 0)) +(aeq 'minusp t (minusp -1)) +(aeq 'zerop nil (zerop 1)) +(aeq 'zerop t (zerop 0)) +(aeq 'zerop nil (zerop -1)) +(aeq 'evenp nil (evenp 1)) +(aeq 'evenp t (evenp 0)) +(aeq 'evenp nil (evenp -1)) +(aeq 'oddp t (oddp 1)) +(aeq 'oddp nil (oddp 0)) +(aeq 'oddp t (oddp -1)) + +#| Maths functions |# + +(aeq 'abs 10 (abs 10)) +(aeq 'abs 10 (abs -10)) +(aeq 'max 45 (max 23 45)) +(aeq 'max -23 (max -23 -45)) +(aeq 'min 23 (min 23 45)) +(aeq 'min -45 (min -23 -45)) +(aeq 'zerop t (zerop 0)) +(aeq 'zerop nil (zerop 32767)) +(aeq 'mod 1 (mod 13 4)) +(aeq 'mod 3 (mod -13 4)) +(aeq 'mod -3 (mod 13 -4)) +(aeq 'mod -1 (mod -13 -4)) + +#| Number entry |# + +(aeq 'hex -1 #xFFFFFFFF) +(aeq 'hex 1 #x0001) +(aeq 'hex 4112 #x1010) +(aeq 'oct 511 #o777) +(aeq 'oct 1 #o1) +(aeq 'oct 65535 #o177777) +(aeq 'bin -1 #b11111111111111111111111111111111) +(aeq 'bin 10 #b1010) +(aeq 'bin 0 #b0) +(aeq 'hash 12 #'12) +(aeq 'hash 6 (funcall #'(lambda (x) (+ x 2)) 4)) + +#| Boolean |# + +(aeq 'and 7 (and t t 7)) +(aeq 'and nil (and t nil 7)) +(aeq 'or t (or t nil 7)) +(aeq 'or 1 (or 1 2 3)) +(aeq 'or nil (or nil nil nil)) +(aeq 'or 'a (or 'a 'b 'c)) +(aeq 'or 1 (let ((x 0)) (or (incf x)) x)) + +#| Bitwise |# + +(aeq 'logand -1 (logand)) +(aeq 'logand 170 (logand #xAA)) +(aeq 'logand 0 (logand #xAAAA #x5555)) +(aeq 'logior 0 (logior)) +(aeq 'logior 170 (logior #xAA)) +(aeq 'logior #xFFFF (logior #xAAAA #x5555)) +(aeq 'logxor 0 (logxor)) +(aeq 'logxor 170 (logior #xAA)) +(aeq 'logxor 255 (logxor #xAAAA #xAA55)) +(aeq 'lognot -43691 (lognot #xAAAA)) +(aeq 'ash 492 (ash 123 2)) +(aeq 'ash 65535 (ash #xFFFF 0)) +(aeq 'ash 16383 (ash #xFFFF -2)) +(aeq 'ash 262140 (ash #xFFFF 2)) +(aeq 'ash 8191 (ash #x7FFF -2)) +(aeq 'logbitp t (logbitp 0 1)) +(aeq 'logbitp t (logbitp 1000 -1)) +(aeq 'logbitp nil (logbitp 1000 0)) + +#| Tests |# + +(aeq 'atom t (atom nil)) +(aeq 'atom t (atom t)) +(aeq 'atom nil (atom '(1 2))) +(aeq 'consp nil (consp 'b)) +(aeq 'consp t (consp '(a b))) +(aeq 'consp nil (consp nil)) +(aeq 'listp nil (listp 'b)) +(aeq 'listp t (listp '(a b))) +(aeq 'listp t (listp nil)) +(aeq 'numberp t (numberp (+ 1 2))) +(aeq 'numberp nil (numberp 'b)) +(aeq 'numberp nil (numberp nil)) +(aeq 'symbolp t (symbolp 'b)) +(aeq 'symbolp nil (symbolp 3)) +(aeq 'symbolp t (symbolp nil)) +(aeq 'streamp nil (streamp 'b)) +(aeq 'streamp nil (streamp nil)) +(aeq 'boundp t (let (x) (boundp 'x))) +(aeq 'boundp nil (let (x) (boundp 'y))) + +#| cxr operations |# + +(aeq 'car 'a (car '(a b c))) +(aeq 'car nil (car nil)) +(aeq 'first 'a (first '(a b c))) +(aeq 'first nil (first nil)) +(aeq 'cdr 'b (cdr '(a . b))) +(aeq 'cdr 'b (car (cdr '(a b)))) +(aeq 'cdr nil (cdr nil)) +(aeq 'rest 'b (rest '(a . b))) +(aeq 'rest 'b (car (rest '(a b)))) +(aeq 'rest nil (rest nil)) +(aeq 'caaar 'a (caaar '(((a))))) +(aeq 'caaar 'nil (caaar nil)) +(aeq 'caadr 'b (caadr '(a (b)))) +(aeq 'caadr 'nil (caadr nil)) +(aeq 'caar 'a (caar '((a)))) +(aeq 'caar 'nil (caar nil)) +(aeq 'cadar 'c (cadar '((a c) (b)))) +(aeq 'cadar 'nil (cadar nil)) +(aeq 'caddr 'c (caddr '(a b c))) +(aeq 'caddr 'nil (caddr nil)) +(aeq 'cadr 'b (cadr '(a b))) +(aeq 'second 'nil (second '(a))) +(aeq 'second 'b (second '(a b))) +(aeq 'cadr 'nil (cadr '(a))) +(aeq 'caddr 'c (caddr '(a b c))) +(aeq 'caddr 'nil (caddr nil)) +(aeq 'third 'c (third '(a b c))) +(aeq 'third 'nil (third nil)) +(aeq 'cdaar 'b (car (cdaar '(((a b)) b c)))) +(aeq 'cdaar 'nil (cdaar nil)) +(aeq 'cdadr 'c (car (cdadr '(a (b c))))) +(aeq 'cdadr 'nil (cdadr nil)) +(aeq 'cdar 'b (car (cdar '((a b c))))) +(aeq 'cdar 'nil (cdar nil)) +(aeq 'cddar 'c (car (cddar '((a b c))))) +(aeq 'cddar 'nil (cddar nil)) +(aeq 'cdddr 'd (car (cdddr '(a b c d)))) +(aeq 'cdddr nil (car (cdddr '(a b c)))) +(aeq 'cddr 'c (car (cddr '(a b c)))) +(aeq 'cddr 'nil (cddr '(a))) + +#| List operations |# + +(aeq 'cons 'a (car (cons 'a 'b))) +(aeq 'cons nil (car (cons nil 'b))) +(aeq 'append 6 (length (append '(a b c) '(d e f)))) +(aeq 'append nil (append nil nil)) +(aeq 'append '(1 2 3 4 5 . 6) (append '(1 2 3) '(4 5 . 6))) +(aeq 'list nil (car (list nil))) +(aeq 'list 'a (car (list 'a 'b 'c))) +(aeq 'reverse 'c (car (reverse '(a b c)))) +(aeq 'reverse nil (reverse nil)) +(aeq 'length 0 (length nil)) +(aeq 'length 4 (length '(a b c d))) +(aeq 'length 2 (length '(nil nil))) +(aeq 'assoc nil (assoc 'b nil)) +(aeq 'assoc nil (assoc 'b '(nil nil))) +(aeq 'assoc '(b . 12) (assoc 'b '((a . 10) (b . 12)))) +(aeq 'assoc '(nil . 12) (assoc nil '((a . 10) (nil . 12)))) +(aeq 'assoc '(b) (assoc 'b '((a . 10) (b)))) +(aeq 'assoc '("three" . 3) (assoc "three" '(("one" . 1) ("two" . 2) ("three" . 3)) :test string=)) +(aeq 'member '(3 4) (member 3 '(1 2 3 4))) +(aeq 'member nil (member 5 '(1 2 3 4))) +(aeq 'member '(3 4) (member 3 '(1 2 3 4) :test eq)) +(aeq 'member '("three" "four") (member "three" '("one" "two" "three" "four") :test string=)) +(aeq 'member '("two" "three" "four") (member "three" '("one" "two" "three" "four") :test string<)) + +#| map operations |# + +(aeq 'mapc 2 (cadr (mapc + '(1 2 3 4)))) +(aeq 'mapc 10 (let ((x 0)) (mapc (lambda (y) (incf x y)) '(1 2 3 4)) x)) +(aeq 'mapcar '(1 4 9 16) (mapcar (lambda (x) (* x x)) '(1 2 3 4))) +(aeq 'mapcar '(1 4 9 16) (mapcar * '(1 2 3 4) '(1 2 3 4))) +(aeq 'mapcar '(1 4 9 16 25) (mapcar (lambda (x) (* x x)) '(1 2 3 4 5))) +(aeq 'mapcan '(1 4 2 5 3 6) (mapcan #'list '(1 2 3) '(4 5 6))) +(aeq 'mapcan '(1 3 2 4) (mapcan list '(1 2) '(3 4))) +(aeq 'mapcan '(1 5 9 2 6 10 3 7 11) (mapcan list '(1 2 3 4) '(5 6 7 8) '(9 10 11))) +(aeq 'mapcan '(1 2 3 . 4) (mapcan (lambda (x) x) '((1) (2) (3 . 4)))) +(aeq 'mapcan '(2 3 . 4) (mapcan (lambda (x) x) '(nil (2) (3 . 4)))) +(aeq 'maplist '(((1 2 3) 6 7 8) ((2 3) 7 8) ((3) 8)) (maplist #'cons '(1 2 3) '(6 7 8))) +(aeq 'maplist '(1 2 3) (mapl #'cons '(1 2 3) '(6 7 8))) +(aeq 'mapcan '(3 7 11) (mapcon (lambda (x) (when (eq (first x) (second x)) (list (car x)))) '(1 2 3 3 5 7 7 8 9 11 11))) + +#| let/let*/lambda |# + +(aeq 'let 7 (let ((x 7)) (let ((x 6) (y x)) y))) +(aeq 'let* 6 (let* ((x 7)) (let* ((x 6) (y x)) y))) +(aeq 'let t (let ((x t) (y nil) (w) z) (and x (null y) (null w) (null z)))) +(aeq 'let* t (let* ((x t) (y nil) (w) z) (and x (null y) (null w) (null z)))) +(aeq 'lambda 2 ((lambda (x y) (setq y x) y) 2 3)) +(aeq 'lambda 9 ((lambda (&rest x) (apply + x)) 2 3 4)) +(aeq 'lambda 8 ((lambda (x &optional (y 4)) (* x y)) 2)) +(aeq 'lambda 6 ((lambda (x &optional (y 4)) (* x y)) 2 3)) +(aeq 'lambda 6 ((lambda (x &optional y) (* x y)) 2 3)) +(aeq 'lambda 123 ((lambda (list) list) 123)) + +#| loops and control |# + +(aeq 'progn 8 (let ((x 6)) (progn (incf x) (incf x)))) +(aeq 'dotimes 21 (let ((x 6)) (dotimes (y 6 x) (setq x (+ x y))))) +(aeq 'dotimes 6 (let ((x 6)) (dotimes (y 6 y) (setq x (+ x y))))) +(aeq 'dotimes 0 (let ((x 6)) (dotimes (y 0 y) (setq x (+ x y))))) +(aeq 'dolist 6 (let ((x 0)) (dolist (y '(1 2 3) x) (setq x (+ x y))))) +(aeq 'dolist nil (let ((x 0)) (dolist (y '(1 2 3)) (setq x (+ x y))))) +(aeq 'dolist nil (let ((x 0)) (dolist (y '(1 2 3) y) (setq x (+ x y))))) +(aeq 'loop 6 (let ((x 0)) (loop (when (= x 6) (return x)) (incf x)))) +(aeq 'loop 6 (let ((x 0)) (loop (unless (< x 6) (return x)) (incf x)))) +(aeq 'return 'a (let ((a 7)) (loop (progn (return 'a))))) +(aeq 'return nil (loop (return))) +(aeq 'return 'a (let ((a 7)) (loop (progn (return 'a) nil)))) +(aeq 'do 2 (do* ((x 1 (1+ x)) (y 0 (1+ x))) ((= 3 y) x))) +(aeq 'do 3 (do ((x 1 (1+ x)) (y 0 (1+ x))) ((= 3 y) x))) +(aeq 'do 720 (do* ((n 6) (f 1 (* j f)) (j n (- j 1))) ((= j 0) f))) +(aeq 'do 720 (let ((n 6)) (do ((f 1 (* j f)) (j n (- j 1)) ) ((= j 0) f)))) +(aeq 'do 10 (do (a (b 1 (1+ b))) ((> b 10) a) (setq a b))) + +#| conditions |# + +(aeq 'if 3 (let ((a 2)) (if (= a 2) 3 4))) +(aeq 'if 4 (let ((a 2)) (if (= a 3) 3 4))) +(aeq 'if 4 (let ((a 3)) (if (= a 3) 4))) +(aeq 'if nil (let ((a 4)) (if (= a 3) 4))) +(aeq 'when 4 (let ((a 3)) (when (= a 3) 4))) +(aeq 'when nil (let ((a 2)) (when (= a 3) 4))) +(aeq 'unless nil (let ((a 3)) (unless (= a 3) 4))) +(aeq 'unless 4 (let ((a 2)) (unless (= a 3) 4))) +(aeq 'cond 8 (let ((a 2)) (cond ((= a 3) 7) ((= a 2) 8) (t 9)))) +(aeq 'cond 9 (let ((a 1)) (cond ((= a 3) 7) ((= a 2) 8) (9)))) +(aeq 'cond nil (let ((a 1)) (cond ((= a 3) 7) ((= a 2) 8)))) +(aeq 'cond 12 (car (cond ((evenp 3) (list (* 2 3))) ((list (* 3 4)))))) +(aeq 'case 222 (let ((j 1)) (case j ((0 1) 111 222) ((t) 333) (t 444)))) +(aeq 'case 333 (let ((j t)) (case j ((0 1) 111 222) ((t) 333) (t 444)))) +(aeq 'case 444 (let ((j 2)) (case j ((0 1) 111 222) ((t) 333) (t 444)))) + +#| eval/funcall/apply |# + +(aeq 'funcall 10 (funcall + 1 2 3 4)) +(aeq 'funcall 'a (funcall car '(a b c d))) +(aeq 'funcall 3 (let ((x 0)) (funcall (lambda (y) (incf x y)) 3) x)) +(aeq 'apply 10 (apply + '(1 2 3 4))) +(aeq 'apply 13 (apply + 1 2 '(1 2 3 4))) +(aeq 'eval 10 (eval (list + 1 2 3 4))) +(aeq 'eval nil (eval nil)) +(aeq 'funcall 999 (let ((x 999)) (funcall (lambda (x) x) x))) +(aeq 'funcall 4 (let ((x2 (lambda (fun) (lambda (x) (funcall fun (funcall fun x)))))) (funcall (x2 '1+) 2))) +(aeq 'funcall 4 (let ((x2 (lambda (fun) (lambda (x) (fun (fun x)))))) ((x2 '1+) 2))) +(aeq 'apply 5 (let* ((my (lambda (x y) (+ x y))) (han '(my))) (apply (first han) '(2 3)))) + +#| in-place operations |# + +(aeq 'incf 5 (let ((x 0)) (+ (incf x) (incf x 2) (incf x -2)))) +(aeq 'decf -5 (let ((x 0)) (+ (decf x) (decf x 2) (decf x -2)))) +(aeq 'incf 12 (let ((x 0)) (+ (incf x 2) (incf x 2) (incf x 2)))) +(aeq 'incf 36 (let ((n 10)) (let* ((f1 (lambda () (incf n) n))) (+ (funcall f1) (funcall f1) (funcall f1))))) +(aeq 'setf 25 (let ((a 3) (b 4)) (setf a (* a 3) b (* b 4)) (+ a b))) +(aeq 'setf 9 (let ((a '(2 3))) (setf (car a) 6) (apply + a))) +(aeq 'setf 12 (let ((a '(2 3))) (setf (cdr a) '(6)) (apply * a))) +(aeq 'setf 220 (let ((a '(2 3 4))) (setf (nth 1 a) 11 (nth 2 a) 10) (apply * a))) + +#| recursion |# + +(aeq 'lambda 55 (let ((fib (lambda (n) (if (< n 3) 1 (+ (fib (- n 1)) (fib (- n 2))))))) (fib 10))) +(aeq 'lambda 5040 (let ((f (lambda (n) (if (= n 0) 1 (* n (f (- n 1))))))) (f 7))) +(aeq 'lambda 10 (let ((a 0)) (let ((f (lambda (n) (incf a n) (when (> n 0) (f (1- n)))))) (f 4)) a)) + +#| streams |# + +(aeq 'stream "" (with-output-to-string (s) (princ s s))) +(aeq 'stream "12 23 34" (with-output-to-string (st) (format st "~a ~a ~a" 12 23 34))) + +#| features |# + +(aeq 'features t (not (not (member :floating-point *features*)))) +(aeq 'features t (not (not (member :arrays *features*)))) + +#| printing |# + +(aeq 'princ "hello" (princ-to-string "hello")) +(aeq 'princ "hello \"David\"" (princ-to-string "hello \"David\"")) +(aeq 'prin1 "\"hello\"" (prin1-to-string "hello")) +(aeq 'prin1 "\"hello \\\"David\\\"\"" (prin1-to-string "hello \"David\"")) + +#| prettyprinting |# + +(aeq 'princ "hello" (princ-to-string "hello")) +(aeq 'pprint 10996 (let ((n 0) (st (with-output-to-string (str) (pprint aeq str)))) (dotimes (i (length st) n) (incf n (char-code (char st i)))))) + +#| documentation |# + +(aeq 'apropos '(progn apropos apropos-list unwind-protect) (apropos-list 'pro)) +(aeq 'apropos '(progn apropos apropos-list unwind-protect) (apropos-list "pro")) +(aeq 'documentation 7397 (let ((n 0)) (let ((st (documentation '?))) (dotimes (i (length st) n) (incf n (char-code (char st i))))))) + +#| format |# + +(aeq 'format "hello" (format nil "hello")) +(aeq 'format "Hello23Goodbye" (format nil "Hello~aGoodbye" 23)) +(aeq 'format " 17" (format nil "~5x" 23)) +(aeq 'format " 10111" (format nil "~6b" 23)) +(aeq 'format " 17 23 23 " (format nil "~5x ~5d ~5a" 23 23 23)) +(aeq 'format "00017 00023" (format nil "~5,'0x ~5,'0d" 23 23)) +(aeq 'format "01-45-07" (format nil "~2,'0d-~2,'0d-~2,'0d" 1 45 7)) +(aeq 'format "Hello42" (format nil "Hello~a" 42)) +(aeq 'format "[1,2,3]" (format nil "[~{~a~^,~}]" '(1 2 3))) +(aeq 'format "0003.14159" (format nil "~10,'0g" 3.14159)) +(aeq 'format "nil nil" (format nil "~a ~{ ~a ~} ~a" nil nil nil)) + +#| strings |# + +(aeq 'stringp t (stringp "hello")) +(aeq 'stringp nil (stringp 5)) +(aeq 'stringp nil (stringp '(a b))) +(aeq 'numberp nil (numberp "hello")) +(aeq 'atom t (atom "hello")) +(aeq 'consp nil (consp "hello")) +(aeq 'eq nil (eq "hello" "hello")) +(aeq 'eq t (let ((a "hello")) (eq a a))) +(aeq 'length 0 (length "")) +(aeq 'length 5 (length "hello")) +(aeq 'concatenate t (string= (concatenate 'string "A" "B") "AB")) +(aeq 'concatenate 3 (length (concatenate 'string "A" "BC"))) +(aeq 'concatenate 0 (length (concatenate 'string))) +(aeq 'concatenate "ABCD" (concatenate 'string "AB" "CD")) +(aeq 'concatenate "ABCDE" (concatenate 'string "AB" "CDE")) +(aeq 'concatenate "ABCDE" (concatenate 'string "ABC" "DE")) +(aeq 'concatenate "ABCDEF" (concatenate 'string "ABC" "DEF")) +(aeq 'string= nil (string= "cat" "cat ")) +(aeq 'string= t (string= "cat" "cat")) +(aeq 'string/= 3 (string/= "cat" "catx")) +(aeq 'string/= nil (string/= "cat" "cat")) +(aeq 'string/= nil (string/= "catt" "catt")) +(aeq 'string< nil (string< "cat" "cat")) +(aeq 'string<= 3 (string<= "cat" "cat")) +(aeq 'string< 3 (string< "cat" "cat ")) +(aeq 'string< 4 (string< "fish" "fish ")) +(aeq 'string> nil (string> "cat" "cat")) +(aeq 'string>= 3 (string>= "cat" "cat")) +(aeq 'string>= 5 (string>= "cattx" "cattx")) +(aeq 'string> 0 (string> "c" "a")) +(aeq 'string> 1 (string> "fc" "fa")) +(aeq 'string> 2 (string> "ffc" "ffa")) +(aeq 'string> 3 (string> "fffc" "fffa")) +(aeq 'string> 4 (string> "ffffc" "ffffa")) +(aeq 'string> 5 (string> "fffffc" "fffffa")) +(aeq 'string> nil (string< "fffffc" "fffffa")) +(aeq 'string "albatross" (string "albatross")) +(aeq 'string "x" (string #\x)) +(aeq 'string "cat" (string 'cat)) +(aeq 'string "albatross" (string 'albatross)) + + +#| subseq and search |# + +(aeq 'subseq "hello" (subseq "hellofromdavid" 0 5)) +(aeq 'subseq "fromdavid" (subseq "hellofromdavid" 5)) +(aeq 'subseq '(2 3 4) (subseq '(0 1 2 3 4) 2)) +(aeq 'subseq '(2) (subseq '(0 1 2 3 4) 2 3)) +(aeq 'subseq nil (subseq '() 0)) +(aeq 'search 4 (search "cat" "the cat sat on the mat")) +(aeq 'search 19 (search "mat" "the cat sat on the mat")) +(aeq 'search nil (search "hat" "the cat sat on the mat")) +(aeq 'search 1 (search '(1 2) '( 0 1 2 3 4))) +(aeq 'search nil (search '(2 1 2 3 4 5) '(2 1 2 3 4))) + +#| characters |# + +(aeq 'char-code 97 (char-code #\a)) +(aeq 'char-code 13 (char-code #\return)) +(aeq 'char-code 255 (char-code #\255)) +(aeq 'code-char #\return (code-char 13)) +(aeq 'code-char #\a (code-char 97)) +(aeq 'code-char #\255 (code-char 255)) +(aeq 'eq t (eq #\b #\b)) +(aeq 'eq nil (eq #\b #\B)) +(aeq 'numberp nil (numberp #\b)) +(aeq 'characterp t (characterp #\b)) +(aeq 'char #\o (char "hello" 4)) +(aeq 'char #\h (char "hello" 0)) +(aeq 'char "A" (princ-to-string (code-char 65))) +(aeq 'char "[#\\Bell]" (format nil "[~s]" (code-char 7))) +(aeq 'char "[#\\Return]" (format nil "[~s]" #\return)) +(aeq 'char "[#\\127]" (format nil "[~s]" #\127)) +(aeq 'char "[#\\255]" (format nil "[~s]" #\255)) + +#| read-from-string |# + +(aeq 'read-from-string 123 (read-from-string "123")) +(aeq 'read-from-string 144 (eval (read-from-string "((lambda (x) (* x x)) 12)"))) +(aeq 'read-from-string t (eval (read-from-string "(eq (+ 2 3) 5)"))) +(aeq 'read-from-string nil (read-from-string "()")) + +#| closures |# + +(aeq 'closure 'lex (let ((lex nil)) (funcall (let ((lex t)) (lambda () (if lex 'lex 'dyn)))))) +(aeq 'closure 103 (let* ((c 100) (two (lambda (d) (+ c d))) (one (lambda (c) (funcall two 3)))) (funcall one 1))) +(aeq 'closure 4 (let ((x 0)) (funcall (lambda (y) (incf x y)) 4) x)) +(aeq 'closure 0 (let ((x 0)) (funcall (let ((x 7)) (lambda (y) (setq x (+ x y) ))) 4) x)) +(aeq 'closure '(8 10 13 17) (let ((x 0) (clo (lambda () (let ((x 7)) (lambda (y) (incf x y)))))) (mapcar (funcall clo) '(1 2 3 4)))) +(aeq 'closure 3 (let ((y 0) (test (lambda (x) (+ x 1)))) (dotimes (x 3 y) (progn (test (+ x 2))) (incf y x)))) + +#| arrays |# + +(aeq 'array '(0 0) (array-dimensions #2a())) +(aeq 'array '(1 0) (array-dimensions #2a(()))) +(aeq 'array '(2 0) (array-dimensions #2a(() ()))) +(aeq 'array '(0) (array-dimensions (make-array '(0)))) +(aeq 'array '(0) (array-dimensions (make-array 0))) +(aeq 'array 1 (let ((a (make-array 3 :initial-element 0))) (incf (aref a (+ 1 1))) (aref a 2))) +(aeq 'array 1 (let ((a (make-array '(3) :initial-element 0))) (incf (aref a (+ 1 1))) (aref a 2))) +(aeq 'array 1 (let ((a (make-array '(2 3) :initial-element 0))) (incf (aref a 1 (+ 1 1))) (aref a 1 2))) +(aeq 'array 1 (let ((a (make-array '(2 3 2 2) :initial-element 0))) (incf (aref a 1 (+ 1 1) 1 1)) (aref a 1 2 1 1))) +(aeq 'array 10 (length (make-array 10 :initial-element 1))) + +#| bit arrays |# + +(aeq 'array '(0) (array-dimensions (make-array '(0) :element-type 'bit))) +(aeq 'array '(1 1) (array-dimensions (make-array '(1 1) :element-type 'bit))) +(aeq 'array 10 (length (make-array '(10) :element-type 'bit))) +(aeq 'array 10 (length (make-array 10 :element-type 'bit))) +(aeq 'array 1 (let ((a (make-array 3 :element-type 'bit))) (incf (aref a (+ 1 1))) (aref a 2))) +(aeq 'array 1 (let ((a (make-array 3 :initial-element 0 :element-type 'bit))) (incf (aref a (+ 1 1))) (aref a 2))) +(aeq 'array 0 (let ((a (make-array 10 :element-type 'bit :initial-element 1))) (decf (aref a 4)) (aref a 4))) +(aeq 'array 1 (let ((a (make-array 40 :element-type 'bit :initial-element 0))) (incf (aref a 39)) (aref a 39))) +(aeq 'array 0 (let ((a (make-array 40 :element-type 'bit :initial-element 0))) (incf (aref a 39)) (decf (aref a 39)) (aref a 39))) + +#| repl |# + +(aeq 'repl 23 (read-from-string "23(2)")) +(aeq 'repl nil (read-from-string "()23")) +(aeq 'repl 23 (read-from-string "23\"Hi\"")) +(aeq 'repl "Hi" (read-from-string "\"Hi\"23")) +(aeq 'repl #\1 (read-from-string " #\\1\"Hi\"")) +(aeq 'repl "Hi" (read-from-string (format nil "\"Hi\"~a~a" #\# "*0101"))) + +#| equal |# + +(aeq 'equal t (equal '(1 2 3) '(1 2 3))) +(aeq 'equal t (equal '(1 2 (4) 3) '(1 2 (4) 3))) +(aeq 'equal nil (equal '(1 2 (4) 3) '(1 2 (4 nil) 3))) +(aeq 'equal t (equal "cat" "cat")) +(aeq 'equal nil (equal "cat" "Cat")) +(aeq 'equal t (equal 'cat 'Cat)) +(aeq 'equal t (equal 2 (+ 1 1))) +(aeq 'equal t (equal '("cat" "dog") '("cat" "dog"))) +(aeq 'equal nil (equal '("cat" "dog") '("cat" "dig"))) +(aeq 'equal nil (equal '("cat" "dog") '("cat" "Dog"))) + +#| keywords |# + +(aeq 'keywordp t (keywordp :led-builtin)) +(aeq 'keywordp nil (keywordp print)) +(aeq 'keywordp nil (keywordp nil)) +(aeq 'keywordp nil (keywordp 12)) +(aeq 'keywordp t (keywordp :fred)) +(aeq 'keywordp t (keywordp :initial-element)) +(aeq 'keywordp t (keywordp :element-type)) + +#| errors |# + +(aeq 'error 7 (let ((x 7)) (ignore-errors (setq x (/ 1 0))) x)) +(aeq 'error 5 (unwind-protect (+ 2 3) 13)) + +#| Printing floats |# + +(aeq 'print t (string= (princ-to-string 101.0) "101.0")) +(aeq 'print t (string= (princ-to-string 1010.0) "1010.0")) +(aeq 'print t (string= (princ-to-string 10100.0) "10100.0")) +(aeq 'print t (string= (princ-to-string 101000.0) "1.01e5")) +(aeq 'print t (string= (princ-to-string 1010000.0) "1.01e6")) +(aeq 'print t (string= (princ-to-string 1.01E7) "1.01e7")) +(aeq 'print t (string= (princ-to-string 1.01E8) "1.01e8")) +(aeq 'print t (string= (princ-to-string 7.0) "7.0")) +(aeq 'print t (string= (princ-to-string 70.0) "70.0")) +(aeq 'print t (string= (princ-to-string 700.0) "700.0")) +(aeq 'print t (string= (princ-to-string 7000.0) "7000.0")) +(aeq 'print t (string= (princ-to-string 70000.0) "70000.0")) +(aeq 'print t (string= (princ-to-string 700000.0) "7.0e5")) +(aeq 'print t (string= (princ-to-string 0.7) "0.7")) +(aeq 'print t (string= (princ-to-string 0.07) "0.07")) +(aeq 'print t (string= (princ-to-string 0.007) "0.007")) +(aeq 'print t (string= (princ-to-string 7.0E-4) "7.0e-4")) +(aeq 'print t (string= (princ-to-string 7.0E-5) "7.0e-5")) +(aeq 'print t (string= (princ-to-string 7.0E-6) "7.0e-6")) +(aeq 'print t (string= (princ-to-string 0.9) "0.9")) +(aeq 'print t (string= (princ-to-string 0.99) "0.99")) +(aeq 'print t (string= (princ-to-string 0.999) "0.999")) +(aeq 'print t (string= (princ-to-string 0.9999) "0.9999")) +(aeq 'print t (string= (princ-to-string 0.99999) "0.99999")) +(aeq 'print t (string= (princ-to-string 0.999999) "0.999999")) +(aeq 'print t (string= (princ-to-string 0.9999999) "1.0")) +(aeq 'print t (string= (princ-to-string 1.0) "1.0")) +(aeq 'print t (string= (princ-to-string 10.0) "10.0")) +(aeq 'print t (string= (princ-to-string 100.0) "100.0")) +(aeq 'print t (string= (princ-to-string 1000.0) "1000.0")) +(aeq 'print t (string= (princ-to-string 10000.0) "10000.0")) +(aeq 'print t (string= (princ-to-string 100000.0) "1.0e5")) +(aeq 'print t (string= (princ-to-string 9.0) "9.0")) +(aeq 'print t (string= (princ-to-string 90.0) "90.0")) +(aeq 'print t (string= (princ-to-string 900.0) "900.0")) +(aeq 'print t (string= (princ-to-string 9000.0) "9000.0")) +(aeq 'print t (string= (princ-to-string 90000.0) "90000.0")) +(aeq 'print t (string= (princ-to-string 900000.0) "9.0e5")) +(aeq 'print t (string= (princ-to-string -9.0) "-9.0")) +(aeq 'print t (string= (princ-to-string -90.0) "-90.0")) +(aeq 'print t (string= (princ-to-string -900.0) "-900.0")) +(aeq 'print t (string= (princ-to-string -9000.0) "-9000.0")) +(aeq 'print t (string= (princ-to-string -90000.0) "-90000.0")) +(aeq 'print t (string= (princ-to-string -900000.0) "-9.0e5")) +(aeq 'print t (string= (princ-to-string 1.0) "1.0")) +(aeq 'print t (string= (princ-to-string 1.01) "1.01")) +(aeq 'print t (string= (princ-to-string 1.001) "1.001")) +(aeq 'print t (string= (princ-to-string 1.0001) "1.0001")) +(aeq 'print t (string= (princ-to-string 1.00001) "1.00001")) +(aeq 'print t (string= (princ-to-string 1.000001) "1.0")) +(aeq 'print t (string= (princ-to-string 0.0012345678) "0.00123457")) +(aeq 'print t (string= (princ-to-string 1.2345678E-4) "1.23457e-4")) +(aeq 'print t (string= (princ-to-string 1234567.9) "1.23457e6")) +(aeq 'print t (string= (princ-to-string 1.2345679E7) "1.23457e7")) +(aeq 'print t (string= (princ-to-string 1.2E-9) "1.2e-9")) +(aeq 'print t (string= (princ-to-string 9.9E-8) "9.9e-8")) +(aeq 'print t (string= (princ-to-string 9.9999E-5) "9.9999e-5")) +(aeq 'print t (string= (princ-to-string 9.01) "9.01")) +(aeq 'print t (string= (princ-to-string 0.9999999) "1.0")) +(aeq 'print t (string= (princ-to-string 0.8999999) "0.9")) +(aeq 'print t (string= (princ-to-string 0.01) "0.01")) +(aeq 'print t (string= (princ-to-string 1.2345679) "1.23457")) +(aeq 'print t (string= (princ-to-string 12.345679) "12.3457")) +(aeq 'print t (string= (princ-to-string 123.45679) "123.457")) +(aeq 'print t (string= (princ-to-string 1234.5679) "1234.57")) +(aeq 'print t (string= (princ-to-string 12345.679) "12345.7")) +(aeq 'print t (string= (princ-to-string 123456.79) "1.23457e5")) +(aeq 'print t (string= (princ-to-string 1234567.9) "1.23457e6")) +(aeq 'print t (string= (princ-to-string 0.12345679) "0.123457")) +(aeq 'print t (string= (princ-to-string 0.012345679) "0.0123457")) +(aeq 'print t (string= (princ-to-string 0.0012345678) "0.00123457")) +(aeq 'print t (string= (princ-to-string 1.2345679E-4) "1.23457e-4")) + +#| Arithmetic |# + +(aeq '= t (= (- 4 2 1 1) 0)) +(aeq '* 9 (* -3 -3)) +(aeq '* 32580 (* 180 181)) +(aeq '* 1 (*)) +(aeq '* t (string= "-4.29497e9" (princ-to-string (* 2 -2147483648)))) +(aeq '* -2147483648 (* 2 -1073741824)) +(aeq '+ 32767 (+ 32765 1 1)) +(aeq '+ 0 (+)) +(aeq '+ -2 (+ -1 -1)) +(aeq '- -4 (- 4)) +(aeq '/ 2 (/ 60 10 3)) +(aeq '1+ 2.5 (1+ 1.5)) +(aeq '1+ 2147483647 (1+ 2147483646)) +(aeq '1+ t (string= "2.14748e9" (princ-to-string (1+ 2147483647)))) +(aeq '1- 0.5 (1- 1.5)) +(aeq '1- -2147483648 (1- -2147483647)) +(aeq '1- t (string= "-2.14748e9" (princ-to-string (1- -2147483648)))) + +#| Arithmetic |# + +(aeq '/ 1.75 (/ 3.5 2)) +(aeq '/ 1.75 (/ 3.5 2.0)) +(aeq '/ 0.0625 (/ 1 16)) +(aeq '/ 0.0625 (/ 1.0 16)) +(aeq '/ 0.0625 (/ 1 16.0)) +(aeq '/ 2 (/ 12 2 3)) +(aeq '/ 2.0 (/ 12.0 2 3)) +(aeq '/ 2.0 (/ 12 2.0 3)) +(aeq '/ 2.0 (/ 12 2 3.0)) +(aeq '/ 1 (/ 1)) +(aeq '/ t (string= "2.14748e9" (princ-to-string (/ -2147483648 -1)))) +(aeq '/ 2147483647 (/ -2147483647 -1)) +(aeq '/ 0.5 (/ 2)) +(aeq '* 1.0 (* 0.0625 16)) +(aeq '* 1.0 (* 0.0625 16.0)) + +#| Place |# + +(aeq 'incf 5.4 (let ((x 0)) (+ (incf x) (incf x 0.2) (incf x 2)))) +(aeq 'decf -5.4 (let ((x 0)) (+ (decf x) (decf x 0.2) (decf x 2)))) +(aeq 'incf 30.6 (let ((n 10)) (let* ((f1 (lambda () (incf n 0.1) n))) (+ (funcall f1) (funcall f1) (funcall f1))))) +(aeq 'setf "hellx" (let ((s "hello")) (setf (char s 4) #\x) s)) + +#| Comparisons |# + +(aeq '< t (< 1 2 3 4)) +(aeq '< nil (< 1 2 3 2)) +(aeq '< t (< 1.0 2 3 4)) +(aeq '< nil (< 1 2 3 2)) +(aeq '< t (< 1.0 1.001 3 4)) +(aeq '< nil (< 1.001 1.0 3 4)) +(aeq '< t (< 1.001 1.002 1.003 1.004)) +(aeq '< t (< 1. 2. 3. 4.)) +(aeq '< nil (< 1. 2. 2. 4.)) +(aeq '< t (<= 1. 2. 2. 4.)) +(aeq '< nil (<= 1. 3. 2. 4.)) +(aeq '< t (> 4. 3. 2. 1.)) +(aeq '< nil (> 4. 2. 2. 1.)) +(aeq '< t (>= 4. 2. 2. 1.)) +(aeq '< nil (>= 4. 2. 3. 1.)) +(aeq '/= t (= 1. 1. 1. 1.)) +(aeq '/= nil (= 1. 1. 2. 1.)) +(aeq '/= nil (/= 1. 2. 3. 1.)) +(aeq '/= t (/= 1. 2. 3. 4.)) + +#| Transcendental |# + +(aeq 'sin 0.84147096 (sin 1)) +(aeq 'sin 0.0 (sin 0)) +(aeq 'sin 0.84147096 (sin 1.0)) +(aeq 'sin 0.0 (sin 0.0)) +(aeq 'cos 0.540302 (cos 1)) +(aeq 'cos 0.540302 (cos 1.0)) +(aeq 'tan 1.55741 (tan 1)) +(aeq 'tan 1.55741 (tan 1.0)) +(aeq 'asin 1.5707964 (asin 1)) +(aeq 'asin 1.5707964 (asin 1)) +(aeq 'asin 0.0 (asin 0)) +(aeq 'asin 0.0 (asin 0.0)) +(aeq 'acos 0.0 (acos 1)) +(aeq 'acos 0.0 (acos 1.0)) +(aeq 'acos 1.0471976 (acos 0.5)) +(aeq 'atan 0.4636476 (atan 0.5)) +(aeq 'atan 0.110657 (atan 1 9)) +(aeq 'atan 0.049958397 (atan 1 20)) +(aeq 'atan 0.785398 (atan 1 1)) +(aeq 'atan 0.785398 (atan .5 .5))x +(aeq 'sinh 1.1752 (sinh 1)) +(aeq 'sinh 1.1752 (sinh 1.0)) +(aeq 'sinh 0.0 (sinh 0)) +(aeq 'sinh 0.0 (sin 0.0)) +(aeq 'cosh 1.5430807 (cosh 1)) +(aeq 'cosh 1.5430807 (cosh 1.0)) +(aeq 'tanh 0.7615942 (tanh 1)) +(aeq 'tanh 0.7615942 (tanh 1.0)) + +#| Rounding |# + +(aeq 'truncate 3 (truncate 10 3)) +(aeq 'truncate 3 (truncate 3.3333333)) +(aeq 'ceiling 4 (ceiling 10 3)) +(aeq 'ceiling 4 (ceiling 3.3333333)) +(aeq 'round 3 (round 10 3)) +(aeq 'round 3 (round 3.3333333)) +(aeq 'floor 3 (floor 10 3)) +(aeq 'floor 3 (floor 3.3333333)) +(aeq 'truncate -3 (truncate -10 3)) +(aeq 'truncate -3 (truncate -3.3333333)) +(aeq 'ceiling -3 (ceiling -10 3)) +(aeq 'ceiling -3 (ceiling -3.3333333)) +(aeq 'round -3 (round -10 3)) +(aeq 'round -3 (round -3.3333333)) +(aeq 'floor -4 (floor -10 3)) +(aeq 'floor -4 (floor -3.3333333)) +(aeq 'abs 10.0 (abs 10.0)) +(aeq 'abs 10.0 (abs -10.0)) +(aeq 'abs t (string= "2.14748e9" (princ-to-string (abs -2147483648)))) +(aeq 'abs 2147483647 (abs -2147483647)) +(aeq 'mod 1.0 (mod 13.0 4)) +(aeq 'mod 3.0 (mod -13.0 4)) +(aeq 'mod -3.0 (mod 13.0 -4)) +(aeq 'mod -1.0 (mod -13.0 -4)) +(aeq 'mod -3.0 (mod 13.0 -4)) +(aeq 'mod 1.0 (mod -12.5 1.5)) +(aeq 'mod 0.5 (mod 12.5 1.5)) + +#| Log and exp |# + +(aeq 'exp 2.7182818 (exp 1)) +(aeq 'exp 2.7182818 (exp 1.0)) +(aeq 'exp 0.36787945 (exp -1)) +(aeq 'exp 0.36787945 (exp -1.0)) +(aeq 'exp 0.36787945 (exp -1.0)) +(aeq 'log 0.0 (log 1.0)) +(aeq 'log 4.0 (log 16 2)) +(aeq 'log 4.0 (log 16.0 2)) +(aeq 'log 4.0 (log 16 2.0)) +(aeq 'log 4.0 (log 16.0 2.0)) +(aeq 'log 1.0 (log 2 2)) +(aeq 'log 1.0 (log 2.5 2.5)) +(aeq 'log 2.3025852 (log 10)) +(aeq 'log 2.3025852 (log 10)) +(aeq 'expt 1024 (expt 2 10)) +(aeq 'expt 1024.0 (expt 2.0 10.0)) +(aeq 'expt 1073741824 (expt 2 30)) +(aeq 'expt t (string= "2.14748e9" (princ-to-string (expt 2 31)))) +(aeq 'expt t (string= "4.29497e9" (princ-to-string (expt 2 32)))) +(aeq 'expt 1024 (expt -2 10)) +(aeq 'expt -2048 (expt -2 11)) + +#| Tests |# + +(aeq 'floatp nil (floatp 1)) +(aeq 'floatp nil (floatp nil)) +(aeq 'floatp t (floatp 2.3)) +(aeq 'integerp t (integerp 1)) +(aeq 'integerp nil (integerp nil)) +(aeq 'integerp nil (integerp 2.3)) + +#| error checks |# + +(aeq 'dolist nothing (ignore-errors (dolist 12 (print x)))) +(aeq 'dolist nothing (ignore-errors (dolist () (print x)))) +(aeq 'dolist nothing (ignore-errors (dolist (x) (print x)))) +(aeq 'dolist nothing (ignore-errors (dolist (x nil x x) (print x)))) +(aeq 'dotimes nothing (ignore-errors (dotimes 12 (print x)))) +(aeq 'dotimes nothing (ignore-errors (dotimes () (print x)))) +(aeq 'dotimes nothing (ignore-errors (dotimes (x) (print x)))) +(aeq 'dotimes nothing (ignore-errors (dotimes (x 1 x x) (print x)))) +(aeq 'for-millis nothing (ignore-errors (for-millis 12 (print 12)))) +(aeq 'for-millis nothing (ignore-errors (for-millis (12 12) (print 12)))) +(aeq 'push nothing (ignore-errors (let ((a #*00000000)) (push 1 (aref a 1)) a))) +(aeq 'setf nothing (ignore-errors (let ((s "hello")) (setf (char s 5) #\x) s))) +(aeq 'setf nothing (ignore-errors (let ((s "hello")) (setf (char s 20) #\x) s))) + +#| errors |# + +(aeq 'errors 0 ers) +""" + + +def talk(string, port, ttw=0.1): + port.reset_output_buffer() + port.write(string.encode()) + time.sleep(ttw) + sys.stdout.write(port.read(port.in_waiting).decode().replace("\r\n", "\n")) + + +def test(): + port = serial.Serial("/dev/ttyUSB0", 115200) + # reset the board + port.dtr = False + port.dtr = True + talk("", port, 5.0) + + for line in TESTS.split("\n"): + if line and line.startswith("("): + talk(line, port) + +test() + From 9a2c3eb32fe74aa037518aba819290f0bab8fe8e Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 29 Jun 2024 10:06:51 -0400 Subject: [PATCH 100/109] remove unreachable error condition --- ulisp.hpp | 1 - 1 file changed, 1 deletion(-) diff --git a/ulisp.hpp b/ulisp.hpp index 3239993..13830a9 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -7397,7 +7397,6 @@ object* eval (object* form, object* env) { } if (bfunctionp(function)) { builtin_t bname = builtin(function->name); - if (!builtinp(function->name)) error("can't call a symbol", function); Context = bname; checkminmax(bname, nargs); object* result = ((fn_ptr_type)lookupfn(bname))(args, env); From 79ce0dfc4273131a8535ff86aadb78b5aebcba14 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 29 Jun 2024 10:07:20 -0400 Subject: [PATCH 101/109] garbage collector messages were getting really annoying --- ulisp-esp32.ino | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index d7ca4ef..4f9f250 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -12,7 +12,7 @@ // Compile options #define printfreespace -#define printgcs +// #define printgcs #define sdcardsupport // #define gfxsupport // #define lisplibrary From cf2e1d9d852a02b39c4ae0aac7d939c3d652aeb9 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 29 Jun 2024 10:18:45 -0400 Subject: [PATCH 102/109] count crashes as well as mismatches --- autotest.py | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/autotest.py b/autotest.py index f1fdce4..4ff3f08 100644 --- a/autotest.py +++ b/autotest.py @@ -6,9 +6,10 @@ TESTS = r""" -(defvar ers 0) +(defvar errors 0) +(defvar crashes 0) -(defun aeq (tst x y) (unless (or (and (floatp x) (floatp y) (< (abs (- x y)) 0.000005)) (equal x y)) (incf ers) (format t "~a=~a/~a~%" tst x y))) +(defun aeq (testname x y) (unless (or (and (floatp x) (floatp y) (< (abs (- x y)) 0.000005)) (equal x y)) (incf errors) (format t "~a=~a/~a~%" testname x y))) #| Symbols |# @@ -782,7 +783,8 @@ #| errors |# -(aeq 'errors 0 ers) +(format t "~%~a errors, ~a crashes~%" errors crashes) + """ @@ -790,7 +792,9 @@ def talk(string, port, ttw=0.1): port.reset_output_buffer() port.write(string.encode()) time.sleep(ttw) - sys.stdout.write(port.read(port.in_waiting).decode().replace("\r\n", "\n")) + text = port.read(port.in_waiting).decode().replace("\r\n", "\n") + sys.stdout.write(text) + return text def test(): @@ -802,7 +806,9 @@ def test(): for line in TESTS.split("\n"): if line and line.startswith("("): - talk(line, port) + text = talk(line, port) + if "Error:" in text: + talk("(incf crashes)", port) test() From cf139ac43ac782978973da33b30cf509fc6c9859 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 29 Jun 2024 10:19:22 -0400 Subject: [PATCH 103/109] keep non-function builtin symbols bfrom being turned into "BUILTIN" objects --- ulisp.hpp | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ulisp.hpp b/ulisp.hpp index 13830a9..738f72b 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -7296,8 +7296,10 @@ object* eval (object* form, object* env) { // special symbol macro handling else if (builtinp(name)) { builtin_t bname = builtin(name); - if (fntype(getminmax(bname)) == SPECIAL_SYMBOLS) return ((fn_ptr_type)lookupfn(bname))(NULL, env); - return bfunction_from_symbol(form); + uint8_t ft = fntype(getminmax(bname)); + if (ft == SPECIAL_SYMBOLS) return ((fn_ptr_type)lookupfn(bname))(NULL, env); + else if (ft == OTHER_FORMS) return form; + else return bfunction_from_symbol(form); } Context = NIL; error("undefined", form); From a5f53aff0479c221e3c2e13749277af0ece711c1 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 29 Jun 2024 10:22:00 -0400 Subject: [PATCH 104/109] change output and prompt format --- ulisp.hpp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ulisp.hpp b/ulisp.hpp index 738f72b..89dfe51 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -8003,7 +8003,7 @@ void repl (object* env) { pfstring(" : ", pserial); pint(BreakLevel, pserial); } - pfstring("[Ready.]\n", pserial); + pfstring("[Ready.]\n> ", pserial); Context = NIL; object* line = read(gserial); if (BreakLevel && line == nil) { pln(pserial); return; } @@ -8012,6 +8012,7 @@ void repl (object* env) { pfl(pserial); line = eval(line, env); pfl(pserial); + pfstring("\n=> ", pserial); printobject(line, pserial); unprotect(); pfl(pserial); From ce4281204a0002e1a906690ff13ca35e880be992 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 29 Jun 2024 10:49:34 -0400 Subject: [PATCH 105/109] Add fixes for some bugs revealed by test suite --- autotest.py | 2 +- ulisp.hpp | 9 +++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/autotest.py b/autotest.py index 4ff3f08..2f817f3 100644 --- a/autotest.py +++ b/autotest.py @@ -807,7 +807,7 @@ def test(): for line in TESTS.split("\n"): if line and line.startswith("("): text = talk(line, port) - if "Error:" in text: + if "Error:" in text or "Error in" in text: talk("(incf crashes)", port) test() diff --git a/ulisp.hpp b/ulisp.hpp index 89dfe51..10e76a8 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -1101,7 +1101,7 @@ int intpower (int base, int exp) { testargument - handles the :test argument for functions that accept it */ object* testargument (object* args) { - object* test = bsymbol(EQ); + object* test = bfunction_from_symbol(bsymbol(EQ)); if (args != NULL) { if (cdr(args) == NULL) error("dangling keyword", first(args)); if (isbuiltin(first(args), TEST)) test = second(args); @@ -1795,7 +1795,8 @@ object* closure (bool tc, symbol_t name, object* function, object* args, object* } object* apply (object* function, object* args, object* env) { - if (symbolp(function)) { + if (symbolp(function)) error("can't call a symbol", function); + if (bfunctionp(function)) { builtin_t fname = builtin(function->name); if ((fname < ENDFUNCTIONS) && (fntype(getminmax(fname)) == FUNCTIONS)) { Context = fname; @@ -7001,8 +7002,8 @@ const tbl_entry_t BuiltinTable[] = { { stringcopylist, fn_copylist, MINMAX(FUNCTIONS, 1, 1), doccopylist }, { string86, fn_makearray, MINMAX(FUNCTIONS, 1, 5), doc86 }, { string87, fn_reverse, MINMAX(FUNCTIONS, 1, 1), doc87 }, - { string88, fn_assoc, MINMAX(FUNCTIONS, 2, 2), doc88 }, - { string89, fn_member, MINMAX(FUNCTIONS, 2, 2), doc89 }, + { string88, fn_assoc, MINMAX(FUNCTIONS, 2, 4), doc88 }, + { string89, fn_member, MINMAX(FUNCTIONS, 2, 4), doc89 }, { string90, fn_apply, MINMAX(FUNCTIONS, 2, UNLIMITED), doc90 }, { string91, fn_funcall, MINMAX(FUNCTIONS, 1, UNLIMITED), doc91 }, { string93, fn_mapc, MINMAX(FUNCTIONS, 2, UNLIMITED), doc93 }, From cde41118926dcb9f15f723598663c4100f72aea6 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 29 Jun 2024 10:57:24 -0400 Subject: [PATCH 106/109] typo --- ulisp.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ulisp.hpp b/ulisp.hpp index 10e76a8..73f4f45 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -6229,7 +6229,7 @@ const char string145[] = "string<"; const char string146[] = "string>"; const char stringstringnoteq[] = "string/="; const char stringstringlesseq[] = "string<="; -const char stringstringgteq[] = "string?="; +const char stringstringgteq[] = "string>="; const char string147[] = "sort"; const char string148[] = "concatenate"; const char string149[] = "subseq"; From 0cbbb4180452c1276809b473fe7bf602d8438ca1 Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Fri, 30 Aug 2024 16:41:47 -0400 Subject: [PATCH 107/109] Update README.md :keywords are part of stock uLisp now --- README.md | 1 - 1 file changed, 1 deletion(-) diff --git a/README.md b/README.md index 055bea8..f49d5db 100644 --- a/README.md +++ b/README.md @@ -11,7 +11,6 @@ uLisp 4.3a please see the [4.3a-old](https://github.com/dragoncoder047/ulisp-esp > This version includes (requires?) the [ESP32Servo](https://www.arduino.cc/reference/en/libraries/esp32servo/) library to get the analogWrite() and tone() functioning correctly. If you don't have it installed uLisp will compile but you won't have analogWrite() and tone(). New features, some care in editing required: -* Lisp `:keywords` that auto-quote themselves * Ability to add multiple (more than one) extension tables (using `calloc()`) *may not be portable to other platforms* * Nonlocal exit: `(throw)` and `(catch)` (\*) * Templating: backquote/unquote/unquote-splicing (\*) From 1850182ae3812a00e3c66e13044bc9461f7361ef Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Wed, 2 Oct 2024 10:03:34 -0400 Subject: [PATCH 108/109] change up autotest.py --- autotest.py | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/autotest.py b/autotest.py index 2f817f3..1b54a7f 100644 --- a/autotest.py +++ b/autotest.py @@ -6,10 +6,18 @@ TESTS = r""" -(defvar errors 0) +(defvar errors nil) (defvar crashes 0) -(defun aeq (testname x y) (unless (or (and (floatp x) (floatp y) (< (abs (- x y)) 0.000005)) (equal x y)) (incf errors) (format t "~a=~a/~a~%" testname x y))) +(defun aeq (testname x y) + (unless (or (and (floatp x) + (floatp y) + (< (abs (- x y)) 0.000005)) + (equal x y)) + (let (b (assoc testname errors)) + (if b (incf (cdr b)) + (push (cons testname 1) errors))) + (format t "~a fail: expected ~a, got ~a~%" testname x y))) #| Symbols |# @@ -23,10 +31,10 @@ (aeq 'let 88 (let ((abcdefgh 88)) abcdefgh)) (aeq 'let 99 (let ((abcdefghi 99)) abcdefghi)) (aeq 'let 1010 (let ((abcdefghij 1010)) abcdefghij)) -(aeq 'let "ab9" (princ-to-string 'ab9)) -(aeq 'let t (eq 'me 'me)) -(aeq 'let t (eq 'fishcake 'fishcake)) -(aeq 'let nil (eq 'fishcak 'fishca)) +(aeq 'princ-to-string "ab9" (princ-to-string 'ab9)) +(aeq 'eq t (eq 'me 'me)) +(aeq 'eq t (eq 'fishcake 'fishcake)) +(aeq 'eq nil (eq 'fishcak 'fishca)) #| Arithmetic |# @@ -783,12 +791,12 @@ #| errors |# -(format t "~%~a errors, ~a crashes~%" errors crashes) +(format t "~%Failing tests:~%~{~a~%~}~%~a tests crashed." errors crashes) """ -def talk(string, port, ttw=0.1): +def talk(string: str, port: serial.Serial, ttw: float = 0.1): port.reset_output_buffer() port.write(string.encode()) time.sleep(ttw) @@ -810,5 +818,5 @@ def test(): if "Error:" in text or "Error in" in text: talk("(incf crashes)", port) -test() +test() From 3f9a5bf501a6a31dca1ddc734228034b6ff0019c Mon Sep 17 00:00:00 2001 From: dragoncoder047 <101021094+dragoncoder047@users.noreply.github.com> Date: Sat, 30 Nov 2024 10:42:28 -0500 Subject: [PATCH 109/109] clang-fmt --- bignums.hpp | 205 +-- extensions.hpp | 79 +- ulisp-esp32.ino | 30 +- ulisp.hpp | 3579 ++++++++++++++++++++++++++--------------------- 4 files changed, 2182 insertions(+), 1711 deletions(-) diff --git a/bignums.hpp b/bignums.hpp index 8c19463..89a1f7c 100644 --- a/bignums.hpp +++ b/bignums.hpp @@ -7,12 +7,16 @@ #define MAX_VAL ((uint64_t)0xFFFFFFFF) #define int_to_bignum(x) (cons(number(x), NULL)) -enum { SMALLER = -1, EQUAL = 0, LARGER = 1 }; +enum { + SMALLER = -1, + EQUAL = 0, + LARGER = 1 +}; // Forward references -object* do_operator (object* bignum1, object* bignum2, uint32_t (*op)(uint32_t, uint32_t)); -uint32_t op_ior (uint32_t, uint32_t); -int bignum_cmp (object* bignum1, object* bignum2); +object* do_operator(object* bignum1, object* bignum2, uint32_t (*op)(uint32_t, uint32_t)); +uint32_t op_ior(uint32_t, uint32_t); +int bignum_cmp(object* bignum1, object* bignum2); // Internal utility functions @@ -28,7 +32,7 @@ void maybe_gc(object* arg, object* env) { checkbignum - checks argument is cons. It makes the other routines simpler if we don't allow a null list. */ -object* checkbignum (object* b) { +object* checkbignum(object* b) { if (!consp(b)) error(PSTR("argument is not a bignum"), b); return b; } @@ -36,7 +40,7 @@ object* checkbignum (object* b) { /* bignum_zerop - Tests whether a bignum is zero, allowing for possible trailing zeros. */ -bool bignum_zerop (object* bignum) { +bool bignum_zerop(object* bignum) { while (bignum != NULL) { if (checkinteger(car(bignum)) != 0) return false; bignum = cdr(bignum); @@ -47,7 +51,7 @@ bool bignum_zerop (object* bignum) { /* bignum_normalise - Destructively removes trailing zeros. */ -object* bignum_normalise (object* bignum) { +object* bignum_normalise(object* bignum) { object* result = bignum; object* last = bignum; while (bignum != NULL) { @@ -61,12 +65,13 @@ object* bignum_normalise (object* bignum) { /* copylist - Returns a copy of a list. */ -object* copylist (object* arg) { +object* copylist(object* arg) { object* result = cons(NULL, NULL); object* ptr = result; while (arg != NULL) { cdr(ptr) = cons(car(arg), NULL); - ptr = cdr(ptr); arg = cdr(arg); + ptr = cdr(ptr); + arg = cdr(arg); } return cdr(result); } @@ -74,13 +79,14 @@ object* copylist (object* arg) { /* upshift_bit - Destructively shifts a bignum up one bit; ie multiplies by 2. */ -void upshift_bit (object* bignum) { +void upshift_bit(object* bignum) { uint32_t now = (uint32_t)checkinteger(car(bignum)); car(bignum) = number(now << 1); while (cdr(bignum) != NULL) { uint32_t next = (uint32_t)checkinteger(car(cdr(bignum))); car(cdr(bignum)) = number((next << 1) | (now >> 31)); - now = next; bignum = cdr(bignum); + now = next; + bignum = cdr(bignum); } if (now >> 31 != 0) cdr(bignum) = cons(number(now >> 31), NULL); } @@ -88,12 +94,13 @@ void upshift_bit (object* bignum) { /* downshift_bit - Destructively shifts a bignum down one bit; ie divides by 2. */ -void downshift_bit (object* bignum) { +void downshift_bit(object* bignum) { uint32_t now = (uint32_t)checkinteger(car(bignum)); while (cdr(bignum) != NULL) { uint32_t next = (uint32_t)checkinteger(car(cdr(bignum))); car(bignum) = number((now >> 1) | (next << 31)); - now = next; bignum = cdr(bignum); + now = next; + bignum = cdr(bignum); } car(bignum) = number(now >> 1); } @@ -101,7 +108,7 @@ void downshift_bit (object* bignum) { /* bignum_from_int - Converts a 64-bit integer to a bignum and returns it. */ -object* bignum_from_int (uint64_t n) { +object* bignum_from_int(uint64_t n) { uint32_t high = n >> 32; if (high == 0) return cons(number(n), NULL); return cons(number(n), cons(number(high), NULL)); @@ -110,7 +117,7 @@ object* bignum_from_int (uint64_t n) { /* bignum_add - Performs bignum1 + bignum2. */ -object* bignum_add (object* bignum1, object* bignum2) { +object* bignum_add(object* bignum1, object* bignum2) { object* result = cons(NULL, NULL); object* ptr = result; int carry = 0; @@ -138,7 +145,7 @@ object* bignum_add (object* bignum1, object* bignum2) { /* bignum_sub - Performs bignum1 = bignum1 - bignum2. */ -object* bignum_sub (object* bignum1, object* bignum2) { +object* bignum_sub(object* bignum1, object* bignum2) { object* result = cons(NULL, NULL); object* ptr = result; int borrow = 0; @@ -163,24 +170,26 @@ object* bignum_sub (object* bignum1, object* bignum2) { /* bignum_mul - Performs bignum1 * bignum2. */ -object* bignum_mul (object* bignum1, object* bignum2, object* env) { +object* bignum_mul(object* bignum1, object* bignum2, object* env) { object* result = int_to_bignum(0); object* arg2 = bignum2; int i = 0, j; while (bignum1 != NULL) { - bignum2 = arg2; j = 0; + bignum2 = arg2; + j = 0; while (bignum2 != NULL) { - uint64_t n = (uint64_t)(uint32_t)checkinteger(first(bignum1)) * - (uint64_t)(uint32_t)checkinteger(first(bignum2)); + uint64_t n = (uint64_t)(uint32_t)checkinteger(first(bignum1)) * (uint64_t)(uint32_t)checkinteger(first(bignum2)); object* tmp; if (n > MAX_VAL) tmp = cons(number(n), cons(number(n >> (uint64_t)32), NULL)); else tmp = cons(number(n), NULL); - for (int m = i + j; m > 0; m--) push(number(0), tmp); // upshift i+j words + for (int m = i + j; m > 0; m--) push(number(0), tmp); // upshift i+j words result = bignum_add(result, tmp); - bignum2 = cdr(bignum2); j++; + bignum2 = cdr(bignum2); + j++; maybe_gc(result, env); } - bignum1 = cdr(bignum1); i++; + bignum1 = cdr(bignum1); + i++; } return result; } @@ -190,11 +199,12 @@ object* bignum_mul (object* bignum1, object* bignum2, object* env) { First we normalise the denominator, and then do bitwise subtraction. We need to do gcs in the main loops, while preserving the temporary lists on the GCStack. */ -object* bignum_div (object* bignum1, object* bignum2, object* env) { +object* bignum_div(object* bignum1, object* bignum2, object* env) { object* current = int_to_bignum(1); object* denom = copylist(bignum2); while (bignum_cmp(denom, bignum1) != LARGER) { - push(number(0), current); push(number(0), denom); // upshift current and denom 1 word + push(number(0), current); + push(number(0), denom); // upshift current and denom 1 word protect(current); maybe_gc(denom, env); unprotect(); @@ -207,10 +217,15 @@ object* bignum_div (object* bignum1, object* bignum2, object* env) { remainder = bignum_sub(remainder, denom); result = do_operator(result, current, op_ior); } - downshift_bit(current); downshift_bit(denom); - protect(current); protect(remainder); protect(denom); + downshift_bit(current); + downshift_bit(denom); + protect(current); + protect(remainder); + protect(denom); maybe_gc(result, env); - unprotect(); unprotect(); unprotect(); + unprotect(); + unprotect(); + unprotect(); } return cons(result, cons(remainder, NULL)); } @@ -219,7 +234,7 @@ object* bignum_div (object* bignum1, object* bignum2, object* env) { bignum_cmp - Compares two bignums and returns LARGER (b1>b2), EQUAL (b1=b2), or SMALLER (b1 b2) state = LARGER; else if (b1 < b2) state = SMALLER; + if (b1 > b2) state = LARGER; + else if (b1 < b2) state = SMALLER; } return state; } -uint32_t op_and (uint32_t a, uint32_t b) { return a & b; }; -uint32_t op_ior (uint32_t a, uint32_t b) { return a | b; }; -uint32_t op_xor (uint32_t a, uint32_t b) { return a ^ b; }; +uint32_t op_and(uint32_t a, uint32_t b) { + return a & b; +}; +uint32_t op_ior(uint32_t a, uint32_t b) { + return a | b; +}; +uint32_t op_xor(uint32_t a, uint32_t b) { + return a ^ b; +}; /* do_operator - Returns the result of performing a logical operation on two bignums. */ -object* do_operator (object* bignum1, object* bignum2, uint32_t (*op)(uint32_t, uint32_t)) { +object* do_operator(object* bignum1, object* bignum2, uint32_t (*op)(uint32_t, uint32_t)) { object* result = cons(NULL, NULL); object* ptr = result; uint32_t tmp1 = 0, tmp2 = 0; @@ -268,8 +290,8 @@ object* do_operator (object* bignum1, object* bignum2, uint32_t (*op)(uint32_t, ($bignum int) Converts an integer to a bignum and returns it. */ -object* fn_BIGbignum (object* args, object* env) { - (void) env; +object* fn_BIGbignum(object* args, object* env) { + (void)env; return int_to_bignum(checkinteger(first(args))); } @@ -277,8 +299,8 @@ object* fn_BIGbignum (object* args, object* env) { ($integer bignum) Converts a bignum to an integer and returns it. */ -object* fn_BIGinteger (object* args, object* env) { - (void) env; +object* fn_BIGinteger(object* args, object* env) { + (void)env; object* bignum = checkbignum(first(args)); bignum = bignum_normalise(bignum); uint32_t i = checkinteger(first(bignum)); @@ -291,10 +313,11 @@ object* fn_BIGinteger (object* args, object* env) { Converts a bignum to a string in base 10 (default) or 16 and returns it. Base 16 is trivial. For base 10 we get remainders mod 1000000000 and then print those. */ -object* fn_BIGbignumstring (object* args, object* env) { - (void) env; +object* fn_BIGbignumstring(object* args, object* env) { + (void)env; object* bignum = copylist(checkbignum(first(args))); - int b = 10; uint32_t p; + int b = 10; + uint32_t p; args = cdr(args); if (args != NULL) b = checkinteger(car(args)); object* list = NULL; @@ -308,9 +331,13 @@ object* fn_BIGbignumstring (object* args, object* env) { p = 100000000; object* base = cons(number(p * 10), NULL); while (!bignum_zerop(bignum)) { - protect(bignum); protect(base); protect(list); + protect(bignum); + protect(base); + protect(list); object* result = bignum_div(bignum, base, env); - unprotect(); unprotect(); unprotect(); + unprotect(); + unprotect(); + unprotect(); object* remainder = car(second(result)); bignum = first(result); push(remainder, list); @@ -339,8 +366,8 @@ object* fn_BIGbignumstring (object* args, object* env) { ($string-bignum string [base]) Converts a string in the specified base, 10 (default) or 16, to a bignum and returns it. */ -object* fn_BIGstringbignum (object* args, object* env) { - (void) env; +object* fn_BIGstringbignum(object* args, object* env) { + (void)env; object* string = first(args); if (!stringp(string)) error(notastring, string); int b = 10; @@ -349,7 +376,7 @@ object* fn_BIGstringbignum (object* args, object* env) { if (b != 10 && b != 16) error2(PSTR("only base 10 or 16 supported")); object* base = int_to_bignum(b); object* result = int_to_bignum(0); - object* form = (object* )string->name; + object* form = (object*)string->name; while (form != NULL) { int chars = form->chars; for (int i = (sizeof(int) - 1) * 8; i >= 0; i = i - 8) { @@ -357,9 +384,11 @@ object* fn_BIGstringbignum (object* args, object* env) { if (!ch) break; int d = digitvalue(ch); if (d >= b) error(PSTR("illegal character in bignum"), character(ch)); - protect(result); protect(base); + protect(result); + protect(base); result = bignum_mul(result, base, env); - unprotect(); unprotect(); + unprotect(); + unprotect(); result = bignum_add(result, cons(number(d), NULL)); } form = car(form); @@ -371,8 +400,8 @@ object* fn_BIGstringbignum (object* args, object* env) { ($zerop bignum) Tests whether a bignum is zero, allowing for trailing zeros. */ -object* fn_BIGzerop (object* args, object* env) { - (void) env; +object* fn_BIGzerop(object* args, object* env) { + (void)env; return bignum_zerop(checkbignum(first(args))) ? tee : nil; } @@ -380,8 +409,8 @@ object* fn_BIGzerop (object* args, object* env) { ($+ bignum1 bignum2) Adds two bignums and returns the sum as a new bignum. */ -object* fn_BIGadd (object* args, object* env) { - (void) env; +object* fn_BIGadd(object* args, object* env) { + (void)env; return bignum_add(checkbignum(first(args)), checkbignum(second(args))); } @@ -389,8 +418,8 @@ object* fn_BIGadd (object* args, object* env) { ($- bignum1 bignum2) Subtracts two bignums and returns the difference as a new bignum. */ -object* fn_BIGsub (object* args, object* env) { - (void) env; +object* fn_BIGsub(object* args, object* env) { + (void)env; return bignum_sub(checkbignum(first(args)), checkbignum(second(args))); } @@ -398,7 +427,7 @@ object* fn_BIGsub (object* args, object* env) { ($* bignum1 bignum2) Multiplies two bignums and returns the product as a new bignum. */ -object* fn_BIGmul (object* args, object* env) { +object* fn_BIGmul(object* args, object* env) { return bignum_mul(checkbignum(first(args)), checkbignum(second(args)), env); } @@ -406,7 +435,7 @@ object* fn_BIGmul (object* args, object* env) { ($/ bignum1 bignum2) Divides two bignums and returns the quotient as a new bignum. */ -object* fn_BIGdiv (object* args, object* env) { +object* fn_BIGdiv(object* args, object* env) { return first(bignum_div(checkbignum(first(args)), checkbignum(second(args)), env)); } @@ -414,7 +443,7 @@ object* fn_BIGdiv (object* args, object* env) { ($mod bignum1 bignum2) Divides two bignums and returns the remainder as a new bignum. */ -object* fn_BIGmod (object* args, object* env) { +object* fn_BIGmod(object* args, object* env) { return second(bignum_div(checkbignum(first(args)), checkbignum(second(args)), env)); } @@ -423,8 +452,8 @@ object* fn_BIGmod (object* args, object* env) { ($= bignum1 bignum2) Returns t if the two bignums are equal. */ -object* fn_BIGequal (object* args, object* env) { - (void) env; +object* fn_BIGequal(object* args, object* env) { + (void)env; return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == EQUAL) ? tee : nil; } @@ -432,8 +461,8 @@ object* fn_BIGequal (object* args, object* env) { ($< bignum1 bignum2) Returns t if bignum1 is less than bignum2. */ -object* fn_BIGless (object* args, object* env) { - (void) env; +object* fn_BIGless(object* args, object* env) { + (void)env; return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == SMALLER) ? tee : nil; } @@ -441,8 +470,8 @@ object* fn_BIGless (object* args, object* env) { ($> bignum1 bignum2) Returns t if bignum1 is greater than bignum2. */ -object* fn_BIGgreater (object* args, object* env) { - (void) env; +object* fn_BIGgreater(object* args, object* env) { + (void)env; return (bignum_cmp(checkbignum(first(args)), checkbignum(second(args))) == LARGER) ? tee : nil; } @@ -452,8 +481,8 @@ object* fn_BIGgreater (object* args, object* env) { ($logand bignum1 bignum2) Returns the logical AND of two bignums. */ -object* fn_BIGlogand (object* args, object* env) { - (void) env; +object* fn_BIGlogand(object* args, object* env) { + (void)env; return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_and)); } @@ -461,8 +490,8 @@ object* fn_BIGlogand (object* args, object* env) { ($logior bignum1 bignum2) Returns the logical inclusive OR of two bignums. */ -object* fn_BIGlogior (object* args, object* env) { - (void) env; +object* fn_BIGlogior(object* args, object* env) { + (void)env; return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_ior)); } @@ -470,8 +499,8 @@ object* fn_BIGlogior (object* args, object* env) { ($logxor bignum1 bignum2) Returns the logical exclusive OR of two bignums. */ -object* fn_BIGlogxor (object* args, object* env) { - (void) env; +object* fn_BIGlogxor(object* args, object* env) { + (void)env; return bignum_normalise(do_operator(checkbignum(first(args)), checkbignum(second(args)), op_xor)); } @@ -479,8 +508,8 @@ object* fn_BIGlogxor (object* args, object* env) { ($ash bignum shift) Returns bignum shifted by shift bits; positive means left. */ -object* fn_BIGash (object* args, object* env) { - (void) env; +object* fn_BIGash(object* args, object* env) { + (void)env; object* bignum = copylist(checkbignum(first(args))); int shift = checkinteger(second(args)); for (int i = 0; i < shift; i++) upshift_bit(bignum); @@ -511,39 +540,39 @@ const char stringBIGash[] = "$ash"; // Documentation strings const char docBIGbignum[] = "($bignum int)\n" - "Converts an integer to a bignum and returns it."; + "Converts an integer to a bignum and returns it."; const char docBIGinteger[] = "($integer bignum)\n" - "Converts a bignum to an integer and returns it."; + "Converts a bignum to an integer and returns it."; const char docBIGbignumstring[] = "($bignum-string bignum [base])\n" - "Converts a bignum to a string in base 10 (default) or 16 and returns it."; + "Converts a bignum to a string in base 10 (default) or 16 and returns it."; const char docBIGstringbignum[] = "($string-bignum bignum [base])\n" - "Converts a bignum to a string in the specified base (default 10) and returns it."; + "Converts a bignum to a string in the specified base (default 10) and returns it."; const char docBIGzerop[] = "($zerop bignum)\n" - "Tests whether a bignum is zero, allowing for trailing zeros."; + "Tests whether a bignum is zero, allowing for trailing zeros."; const char docBIGadd[] = "($+ bignum1 bignum2)\n" - "Adds two bignums and returns the sum as a new bignum."; + "Adds two bignums and returns the sum as a new bignum."; const char docBIGsub[] = "($- bignum1 bignum2)\n" - "Subtracts two bignums and returns the difference as a new bignum."; + "Subtracts two bignums and returns the difference as a new bignum."; const char docBIGmul[] = "($* bignum1 bignum2)\n" - "Multiplies two bignums and returns the product as a new bignum."; + "Multiplies two bignums and returns the product as a new bignum."; const char docBIGdiv[] = "($/ bignum1 bignum2)\n" - "Divides two bignums and returns the quotient as a new bignum."; + "Divides two bignums and returns the quotient as a new bignum."; const char docBIGmod[] = "($mod bignum1 bignum2)\n" - "Divides two bignums and returns the remainder as a new bignum."; + "Divides two bignums and returns the remainder as a new bignum."; const char docBIGequal[] = "($= bignum1 bignum2)\n" - "Returns t if the two bignums are equal."; + "Returns t if the two bignums are equal."; const char docBIGless[] = "($< bignum1 bignum2)\n" - "Returns t if bignum1 is less than bignum2."; + "Returns t if bignum1 is less than bignum2."; const char docBIGgreater[] = "($> bignum1 bignum2)\n" - "Returns t if bignum1 is greater than bignum2."; + "Returns t if bignum1 is greater than bignum2."; const char docBIGlogand[] = "($logand bignum bignum)\n" - "Returns the logical AND of two bignums."; + "Returns the logical AND of two bignums."; const char docBIGlogior[] = "($logior bignum bignum)\n" - "Returns the logical inclusive OR of two bignums."; + "Returns the logical inclusive OR of two bignums."; const char docBIGlogxor[] = "($logxor bignum bignum)\n" - "Returns the logical exclusive OR of two bignums."; + "Returns the logical exclusive OR of two bignums."; const char docBIGash[] = "($ash bignum shift)\n" - "Returns bignum shifted by shift bits; positive means left."; + "Returns bignum shifted by shift bits; positive means left."; // Symbol lookup table const tbl_entry_t BignumsTable[] = { diff --git a/extensions.hpp b/extensions.hpp index 2beac02..fe6d782 100644 --- a/extensions.hpp +++ b/extensions.hpp @@ -1,3 +1,4 @@ +#include "esp32-hal-rgb-led.h" /* User Extensions */ @@ -5,34 +6,34 @@ #include "ulisp.hpp" // Definitions -object* fn_now (object* args, object* env) { - (void) env; +object* fn_now(object* args, object* env) { + (void)env; static unsigned long Offset; - unsigned long now = millis()/1000; + unsigned long now = millis() / 1000; int nargs = listlength(args); // Set time if (nargs == 3) { - Offset = (unsigned long)((checkinteger(first(args))*60 + checkinteger(second(args)))*60 - + checkinteger(third(args)) - now); + Offset = (unsigned long)((checkinteger(first(args)) * 60 + checkinteger(second(args))) * 60 + + checkinteger(third(args)) - now); } else if (nargs > 0) error2(PSTR("wrong number of arguments")); // Return time unsigned long secs = Offset + now; - object* seconds = number(secs%60); - object* minutes = number((secs/60)%60); - object* hours = number((secs/3600)%24); + object* seconds = number(secs % 60); + object* minutes = number((secs / 60) % 60); + object* hours = number((secs / 3600) % 24); return cons(hours, cons(minutes, cons(seconds, nil))); } const char stringnow[] = "now"; const char docnow[] = "(now [hh mm ss])\n" -"Sets the current time, or with no arguments returns the current time\n" -"as a list of three integers (hh mm ss)."; + "Sets the current time, or with no arguments returns the current time\n" + "as a list of three integers (hh mm ss)."; -object* fn_gensym (object* args, object* env) { +object* fn_gensym(object* args, object* env) { unsigned int counter = 0; - char buffer[BUFFERSIZE+10]; + char buffer[BUFFERSIZE + 10]; char prefix[BUFFERSIZE]; if (args != NULL) { cstring(checkstring(first(args)), prefix, sizeof(prefix)); @@ -50,24 +51,24 @@ object* fn_gensym (object* args, object* env) { const char stringgensym[] = "gensym"; const char docgensym[] = "(gensym [prefix])\n" -"Returns a new symbol, optionally beginning with prefix (which must be a string).\n" -"The returned symbol is guaranteed to not conflict with any existing bound symbol."; + "Returns a new symbol, optionally beginning with prefix (which must be a string).\n" + "The returned symbol is guaranteed to not conflict with any existing bound symbol."; -object* fn_intern (object* args, object* env) { +object* fn_intern(object* args, object* env) { char b[BUFFERSIZE]; return buftosymbol(cstring(checkstring(first(args)), b, BUFFERSIZE)); } const char stringintern[] = "intern"; const char docintern[] = "(intern string)\n" -"Creates a symbol, with the same name as the string.\n" -"Unlike gensym, the returned symbol is not modified from the string in any way,\n" -"and so it may be bound."; + "Creates a symbol, with the same name as the string.\n" + "Unlike gensym, the returned symbol is not modified from the string in any way,\n" + "and so it may be bound."; -object* fn_sizeof (object* args, object* env) { +object* fn_sizeof(object* args, object* env) { int count = 0; markobject(first(args)); - for (int i=0; i 0xFFFFFF || color < 0) error("color out of range", first(args)); + r = (color >> 16) & 255; + g = (color >> 8) & 255; + b = color & 255; + } else if (listlength(args) == 3) { + r = checkinteger(first(args)); + g = checkinteger(second(args)); + b = checkinteger(third(args)); + if (r > 255) error("red out of range", first(args)); + if (g > 255) error("green out of range", second(args)); + if (b > 255) error("blue out of range", third(args)); + } else error2("don't take 2 args"); + neopixelWrite(2, r, g, b); + return nil; +} + +const char stringneopixel[] = "neopixel"; // Symbol lookup table const tbl_entry_t ExtensionsTable[] = { @@ -118,4 +141,6 @@ const tbl_entry_t ExtensionsTable[] = { { stringintern, fn_intern, MINMAX(FUNCTIONS, 1, 1), docintern }, { stringsizeof, fn_sizeof, MINMAX(FUNCTIONS, 1, 1), docsizeof }, { stringdestructuringbind, sp_destructuring_bind, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), docdestructuringbind }, + { stringdestructuringbind, sp_destructuring_bind, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), docdestructuringbind }, + { stringneopixel, fn_neopixel, MINMAX(FUNCTIONS, 1, 3), NULL } }; diff --git a/ulisp-esp32.ino b/ulisp-esp32.ino index 4f9f250..2b013f2 100644 --- a/ulisp-esp32.ino +++ b/ulisp-esp32.ino @@ -4,11 +4,6 @@ Licensed under the MIT license: https://opensource.org/licenses/MIT */ -#include -#include -#include -#include - // Compile options #define printfreespace @@ -23,11 +18,12 @@ #include "bignums.hpp" const char foo[] = -"(defvar *loaded* nil)" -"(defun load(filename)(if(null(search(list filename)*loaded*))(with-sd-card(f filename)(push filename *loaded*)(loop(let((form(read f)))(unless form(return))(eval form))))))" -"(load \"main.lisp\")" -"(princ \"main.lisp returned, entering REPL...\")" -; + "(pinmode 13 :output)(dotimes(_ 4)(digitalwrite 13 :high)(delay 75)(digitalwrite 13 :low)(delay 75))" + "(defvar *loaded* nil)" + "(defun load(filename)(if(null(search(list filename)*loaded*))(with-sd-card(f filename)(push filename *loaded*)(loop(let((form(read f)))(unless form(return))(eval form))))))" + "(if(eq'nothing(ignore-errors(load\"main.lisp\")'a))" + "(progn(princ\"Error trying to run main.lisp\")(neopixel#xff0000)))" + "(progn(princ\"main.lisp returned, entering REPL...\")(neopixel#x0000ff))"; const size_t foolen = arraysize(foo); size_t fooi = 0; int getfoo() { @@ -45,11 +41,11 @@ int getfoo() { /* sdmain - Run main.lisp on startup */ -void sdmain () { +void sdmain() { SD.begin(); if (setjmp(toplevel_handler)) return; object* fooform; - for(;;) { + for (;;) { fooform = read(getfoo); if (fooform == NULL) return; protect(fooform); @@ -61,10 +57,12 @@ void sdmain () { /* setup - entry point from the Arduino IDE */ -void setup () { +void setup() { Serial.begin(115200); int start = millis(); - while ((millis() - start) < 5000) { if (Serial) break; } + while ((millis() - start) < 5000) { + if (Serial) break; + } ulispinit(); addtable(ExtensionsTable); addtable(BignumsTable); @@ -75,9 +73,9 @@ void setup () { /* loop - the Arduino IDE main execution loop */ -void loop () { +void loop() { if (!setjmp(toplevel_handler)) { - ; // noop + ; // noop } ulisperrcleanup(); repl(NULL); diff --git a/ulisp.hpp b/ulisp.hpp index 73f4f45..7aab819 100644 --- a/ulisp.hpp +++ b/ulisp.hpp @@ -26,8 +26,8 @@ const char LispLibrary[] = ""; #if defined(gfxsupport) #define COLOR_WHITE ST77XX_WHITE #define COLOR_BLACK ST77XX_BLACK -#include // Core graphics library -#include // Hardware-specific library for ST7789 +#include // Core graphics library +#include // Hardware-specific library for ST7789 #if defined(ARDUINO_ESP32_DEV) Adafruit_ST7789 tft = Adafruit_ST7789(5, 16, 19, 18); #define TFT_BACKLITE 4 @@ -36,25 +36,15 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); #endif #endif -#ifdef __has_include -#if __has_include() -#include -#include -#include -#include -#define toneimplemented -#endif -#endif - #include #define SDSIZE 172 // Platform specific settings -#define WORDALIGNED __attribute__((aligned (4))) +#define WORDALIGNED __attribute__((aligned(4))) #define BUFFERSIZE 260 -#define WORKSPACESIZE (9216-SDSIZE) /* Cells (8*bytes) */ +#define WORKSPACESIZE (9216 - SDSIZE) /* Cells (8*bytes) */ #define LITTLEFS #include "FS.h" #include @@ -68,66 +58,92 @@ Adafruit_ST7789 tft = Adafruit_ST7789(TFT_CS, TFT_DC, MOSI, SCK, TFT_RST); // C Macros -#define nil NULL -#define car(x) (((object*)(x))->car) -#define cdr(x) (((object*)(x))->cdr) - -#define first(x) car(x) -#define rest(x) cdr(x) -#define second(x) first(rest(x)) -#define cddr(x) cdr(cdr(x)) -#define third(x) first(cddr(x)) - -#define push(x, y) ((y) = cons((x), (y))) -#define pop(y) ((y) = cdr(y)) - -#define protect(y) push((y), GCStack) -#define unprotect() pop(GCStack) - -#define integerp(x) ((x) != NULL && (x)->type == NUMBER) -#define floatp(x) ((x) != NULL && (x)->type == FLOAT) -#define symbolp(x) ((x) != NULL && (x)->type == SYMBOL) -#define bfunctionp(x) ((x) != NULL && (x)->type == BFUNCTION) -#define stringp(x) ((x) != NULL && (x)->type == STRING) -#define characterp(x) ((x) != NULL && (x)->type == CHARACTER) -#define arrayp(x) ((x) != NULL && (x)->type == ARRAY) -#define streamp(x) ((x) != NULL && (x)->type == STREAM) - -#define mark(x) (car(x) = (object*)(((uintptr_t)(car(x))) | MARKBIT)) -#define unmark(x) (car(x) = (object*)(((uintptr_t)(car(x))) & ~MARKBIT)) -#define marked(x) ((((uintptr_t)(car(x))) & MARKBIT) != 0) -#define MARKBIT 1 - -#define setflag(x) (Flags |= 1<<(x)) -#define clrflag(x) (Flags &= ~(1<<(x))) -#define tstflag(x) (Flags & 1<<(x)) - -#define issp(x) (x == ' ' || x == '\n' || x == '\r' || x == '\t') -#define isbr(x) (x == ')' || x == '(' || x == '"' || x == '#' || x == '\'') -#define longsymbolp(x) longnamep((x)->name) -#define longnamep(x) (((x) & 0x03) == 0) -#define arraysize(x) (sizeof(x) / sizeof(x[0])) -#define stringifyX(x) #x -#define stringify(x) stringifyX(x) -#define PACKEDS 0x43238000 -#define BUILTINS 0xF4240000 -#define ENDFUNCTIONS 0x0BDC0000 - -#define fntype(x) (((uint8_t)(x))>>6) -#define getminargs(x) ((((uint8_t)(x))>>3)&7) -#define getmaxargs(x) (((uint8_t)(x))&7) -#define unlimitedp(x) (getmaxargs(x)==UNLIMITED) -#define UNLIMITED 7 +#define nil NULL +#define car(x) (((object*)(x))->car) +#define cdr(x) (((object*)(x))->cdr) + +#define first(x) car(x) +#define rest(x) cdr(x) +#define second(x) first(rest(x)) +#define cddr(x) cdr(cdr(x)) +#define third(x) first(cddr(x)) + +#define push(x, y) ((y) = cons((x), (y))) +#define pop(y) ((y) = cdr(y)) + +#define protect(y) push((y), GCStack) +#define unprotect() pop(GCStack) + +#define integerp(x) ((x) != NULL && (x)->type == NUMBER) +#define floatp(x) ((x) != NULL && (x)->type == FLOAT) +#define symbolp(x) ((x) != NULL && (x)->type == SYMBOL) +#define bfunctionp(x) ((x) != NULL && (x)->type == BFUNCTION) +#define stringp(x) ((x) != NULL && (x)->type == STRING) +#define characterp(x) ((x) != NULL && (x)->type == CHARACTER) +#define arrayp(x) ((x) != NULL && (x)->type == ARRAY) +#define streamp(x) ((x) != NULL && (x)->type == STREAM) + +#define mark(x) (car(x) = (object*)(((uintptr_t)(car(x))) | MARKBIT)) +#define unmark(x) (car(x) = (object*)(((uintptr_t)(car(x))) & ~MARKBIT)) +#define marked(x) ((((uintptr_t)(car(x))) & MARKBIT) != 0) +#define MARKBIT 1 + +#define setflag(x) (Flags |= 1 << (x)) +#define clrflag(x) (Flags &= ~(1 << (x))) +#define tstflag(x) (Flags & 1 << (x)) + +#define issp(x) (x == ' ' || x == '\n' || x == '\r' || x == '\t') +#define isbr(x) (x == ')' || x == '(' || x == '"' || x == '#' || x == '\'') +#define longsymbolp(x) longnamep((x)->name) +#define longnamep(x) (((x)&0x03) == 0) +#define arraysize(x) (sizeof(x) / sizeof(x[0])) +#define stringifyX(x) #x +#define stringify(x) stringifyX(x) +#define PACKEDS 0x43238000 +#define BUILTINS 0xF4240000 +#define ENDFUNCTIONS 0x0BDC0000 + +#define fntype(x) (((uint8_t)(x)) >> 6) +#define getminargs(x) ((((uint8_t)(x)) >> 3) & 7) +#define getmaxargs(x) (((uint8_t)(x)) & 7) +#define unlimitedp(x) (getmaxargs(x) == UNLIMITED) +#define UNLIMITED 7 // let's hope the compiler can do constant folding!! -#define MINMAX(fntype, min, max) (((fntype)<<6)|((min)<<3)|(max)) +#define MINMAX(fntype, min, max) (((fntype) << 6) | ((min) << 3) | (max)) // Constants -#define TRACEMAX 3 // Number of traced functions -enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, BFUNCTION=8, STREAM=10, CHARACTER=12, FLOAT=14, ARRAY=16, STRING=18, PAIR=20 }; // ARRAY, STRING, and PAIR must be last -enum token { UNUSED, OPEN_PAREN, CLOSE_PAREN, SINGLE_QUOTE, PERIOD, BACKTICK, COMMA, COMMA_AT }; -enum fntypes_t { OTHER_FORMS, SPECIAL_FORMS, FUNCTIONS, SPECIAL_SYMBOLS }; +#define TRACEMAX 3 // Number of traced functions +enum type { + ZZERO = 0, + SYMBOL = 2, + CODE = 4, + NUMBER = 6, + BFUNCTION = 8, + STREAM = 10, + CHARACTER = 12, + FLOAT = 14, + ARRAY = 16, + STRING = 18, + PAIR = 20 +}; // ARRAY, STRING, and PAIR must be last +enum token { + UNUSED, + OPEN_PAREN, + CLOSE_PAREN, + SINGLE_QUOTE, + PERIOD, + BACKTICK, + COMMA, + COMMA_AT +}; +enum fntypes_t { + OTHER_FORMS, + SPECIAL_FORMS, + FUNCTIONS, + SPECIAL_SYMBOLS +}; // Stream names used by printobject const char serialstream[] = "serial"; @@ -137,8 +153,18 @@ const char sdstream[] = "sd"; const char wifistream[] = "wifi"; const char stringstream[] = "string"; const char gfxstream[] = "gfx"; -const char* const streamname[] = {serialstream, i2cstream, spistream, sdstream, wifistream, stringstream, gfxstream}; -enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM}; +const char* const streamname[] = { + serialstream, i2cstream, spistream, sdstream, wifistream, stringstream, gfxstream +}; +enum stream { + SERIALSTREAM, + I2CSTREAM, + SPISTREAM, + SDSTREAM, + WIFISTREAM, + STRINGSTREAM, + GFXSTREAM +}; // Typedefs @@ -166,8 +192,8 @@ typedef struct sobject { }; } object; -typedef object* (*fn_ptr_type)(object* , object*); -typedef void (*mapfun_t)(object* , object**); +typedef object* (*fn_ptr_type)(object*, object*); +typedef void (*mapfun_t)(object*, object**); typedef const struct { const char* string; @@ -184,9 +210,48 @@ typedef struct { typedef int (*gfun_t)(); typedef void (*pfun_t)(char); -enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, FEATURES, INITIALELEMENT, ELEMENTTYPE, TEST, EQ, BIT, AMPREST, LAMBDA, MACRO, LET, LETSTAR, -CLOSURE, PSTAR, QUOTE, BACKQUOTE, UNQUOTE, UNQUOTE_SPLICING, CONS, APPEND, DEFUN, SETF, CHAR, DEFVAR, DEFMACRO, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE, -ANALOGREAD, REGISTER, FORMAT }; +enum builtins : builtin_t { + NIL, + TEE, + NOTHING, + OPTIONAL, + FEATURES, + INITIALELEMENT, + ELEMENTTYPE, + TEST, + EQ, + BIT, + AMPREST, + LAMBDA, + MACRO, + LET, + LETSTAR, + CLOSURE, + PSTAR, + QUOTE, + BACKQUOTE, + UNQUOTE, + UNQUOTE_SPLICING, + CONS, + APPEND, + DEFUN, + SETF, + CHAR, + DEFVAR, + DEFMACRO, + CAR, + FIRST, + CDR, + REST, + NTH, + AREF, + STRINGFN, + PINMODE, + DIGITALWRITE, + ANALOGREAD, + REGISTER, + FORMAT +}; // Global variables @@ -195,7 +260,7 @@ mtbl_entry_t* Metatable; size_t NumTables; jmp_buf toplevel_handler; -jmp_buf *handler = &toplevel_handler; +jmp_buf* handler = &toplevel_handler; size_t Freespace = 0; object* Freelist; builtin_t Context; @@ -219,63 +284,74 @@ unsigned int TraceDepth[TRACEMAX]; void* StackBottom; // Flags -enum flag { PRINTREADABLY, RETURNFLAG, ESCAPE, EXITEDITOR, LIBRARYLOADED, NOESC, NOECHO, MUFFLEERRORS, TAILCALL, INCATCH }; -volatile flags_t Flags = 1; // PRINTREADABLY set by default +enum flag { + PRINTREADABLY, + RETURNFLAG, + ESCAPE, + EXITEDITOR, + LIBRARYLOADED, + NOESC, + NOECHO, + MUFFLEERRORS, + TAILCALL, + INCATCH +}; +volatile flags_t Flags = 1; // PRINTREADABLY set by default // Forward references -bool builtin_keywordp (object*); -inline bool builtinp (symbol_t name); -bool keywordp (object*); -void pfstring (const char*, pfun_t); -char nthchar (object*, int); -void pfl (pfun_t); -void pln (pfun_t); -void pserial (char); -int gserial (); -int glibrary (); -void pstr (char); -void psymbol (symbol_t, pfun_t); -void printobject (object*, pfun_t); -symbol_t sym (builtin_t); -void indent (uint8_t, char, pfun_t); -object* lispstring (const char*); -uint32_t pack40 (const char*); -bool valid40 (const char*); -char* cstring (object*, char*, int); -void pint (int, pfun_t); -void pintbase (uint32_t, uint8_t, pfun_t); -void printstring (object*, pfun_t); -int subwidthlist (object*, int); -minmax_t getminmax (builtin_t); -fn_ptr_type lookupfn (builtin_t); -int listlength (object*); -void checkminmax (builtin_t, int); -object* findpair (object*, object*); -object* findvalue (object*, object*); -const char* lookupdoc (builtin_t); -void printsymbol (object*, pfun_t); -bool findsubstring (char*, builtin_t); -int stringcompare (object*, bool, bool, bool); -void pbuiltin (builtin_t, pfun_t); -object* value (symbol_t, object*); -void supersub (object*, int, int, pfun_t); -object* sp_progn (object*, object*); -object* progn_no_tc (object*, object*); -object* fn_princtostring (object*, object*); -object* read (gfun_t); -object* eval (object*, object*); -void repl (object*); -void prin1object (object*, pfun_t); -void plispstr (symbol_t, pfun_t); -void testescape (); -bool is_macro_call (object*, object*); - -inline symbol_t twist (builtin_t x) { - return (x<<2) | ((x & 0xC0000000)>>30); -} - -inline builtin_t untwist (symbol_t x) { - return (x>>2 & 0x3FFFFFFF) | ((x & 0x03)<<30); +bool builtin_keywordp(object*); +inline bool builtinp(symbol_t name); +bool keywordp(object*); +void pfstring(const char*, pfun_t); +char nthchar(object*, int); +void pfl(pfun_t); +void pln(pfun_t); +void pserial(char); +int gserial(); +int glibrary(); +void pstr(char); +void psymbol(symbol_t, pfun_t); +void printobject(object*, pfun_t); +symbol_t sym(builtin_t); +void indent(uint8_t, char, pfun_t); +object* lispstring(const char*); +uint32_t pack40(const char*); +bool valid40(const char*); +char* cstring(object*, char*, int); +void pint(int, pfun_t); +void pintbase(uint32_t, uint8_t, pfun_t); +void printstring(object*, pfun_t); +int subwidthlist(object*, int); +minmax_t getminmax(builtin_t); +fn_ptr_type lookupfn(builtin_t); +int listlength(object*); +void checkminmax(builtin_t, int); +object* findpair(object*, object*); +object* findvalue(object*, object*); +const char* lookupdoc(builtin_t); +void printsymbol(object*, pfun_t); +bool findsubstring(char*, builtin_t); +int stringcompare(object*, bool, bool, bool); +void pbuiltin(builtin_t, pfun_t); +object* value(symbol_t, object*); +void supersub(object*, int, int, pfun_t); +object* sp_progn(object*, object*); +object* progn_no_tc(object*, object*); +object* fn_princtostring(object*, object*); +object* read(gfun_t); +object* eval(object*, object*); +void repl(object*); +void prin1object(object*, pfun_t); +void plispstr(symbol_t, pfun_t); +void testescape(); +bool is_macro_call(object*, object*); + +inline symbol_t twist(builtin_t x) { + return (x << 2) | ((x & 0xC0000000) >> 30); +} + +inline builtin_t untwist(symbol_t x) { + return (x >> 2 & 0x3FFFFFFF) | ((x & 0x03) << 30); } // Error handling @@ -284,20 +360,26 @@ inline builtin_t untwist (symbol_t x) { errorsub - used by all the error routines. Prints: "Error in fname: string", where fname is the name of the Lisp function in which the error occurred. */ -void errorsub (symbol_t fname, const char* string) { - pfl(pserial); pfstring("Error", pserial); +void errorsub(symbol_t fname, const char* string) { + pfl(pserial); + pfstring("Error", pserial); if (fname != sym(NIL)) { pfstring(" in ", pserial); psymbol(fname, pserial); } - pserial(':'); pserial(' '); + pserial(':'); + pserial(' '); pfstring(string, pserial); } #ifdef __cplusplus [[noreturn]] #endif -void errorend () { GCStack = NULL; longjmp(*handler, 1); } +void +errorend() { + GCStack = NULL; + longjmp(*handler, 1); +} /* errorsym - prints an error message and reenters the REPL. @@ -307,10 +389,12 @@ void errorend () { GCStack = NULL; longjmp(*handler, 1); } #ifdef __cplusplus [[noreturn]] #endif -void errorsym (symbol_t fname, const char* string, object* symbol) { +void +errorsym(symbol_t fname, const char* string, object* symbol) { if (!tstflag(MUFFLEERRORS)) { errorsub(fname, string); - pserial(':'); pserial(' '); + pserial(':'); + pserial(' '); printobject(symbol, pserial); pln(pserial); } @@ -324,7 +408,8 @@ void errorsym (symbol_t fname, const char* string, object* symbol) { #ifdef __cplusplus [[noreturn]] #endif -void errorsym2 (symbol_t fname, const char* string) { +void +errorsym2(symbol_t fname, const char* string) { if (!tstflag(MUFFLEERRORS)) { errorsub(fname, string); pln(pserial); @@ -340,7 +425,8 @@ void errorsym2 (symbol_t fname, const char* string) { #ifdef __cplusplus [[noreturn]] #endif -void error (const char* string, object* symbol) { +void +error(const char* string, object* symbol) { errorsym(sym(Context), string, symbol); } @@ -351,7 +437,8 @@ void error (const char* string, object* symbol) { #ifdef __cplusplus [[noreturn]] #endif -void error2 (const char* string) { +void +error2(const char* string) { errorsym2(sym(Context), string); } @@ -361,9 +448,14 @@ void error2 (const char* string) { #ifdef __cplusplus [[noreturn]] #endif -void formaterr (object* formatstr, const char* string, uint8_t p) { - pln(pserial); indent(4, ' ', pserial); printstring(formatstr, pserial); pln(pserial); - indent(p+5, ' ', pserial); pserial('^'); +void +formaterr(object* formatstr, const char* string, uint8_t p) { + pln(pserial); + indent(4, ' ', pserial); + printstring(formatstr, pserial); + pln(pserial); + indent(p + 5, ' ', pserial); + pserial('^'); error2(string); pln(pserial); GCStack = NULL; @@ -399,9 +491,9 @@ const char unknownstreamtype[] = "unknown stream type"; /* initworkspace - initialises the workspace into a linked list of free objects */ -void initworkspace () { +void initworkspace() { Freelist = NULL; - for (int i=WORKSPACESIZE-1; i>=0; i--) { + for (int i = WORKSPACESIZE - 1; i >= 0; i--) { object* obj = &Workspace[i]; car(obj) = NULL; cdr(obj) = Freelist; @@ -413,7 +505,7 @@ void initworkspace () { /* myalloc - returns the first object from the linked list of free objects */ -object* myalloc () { +object* myalloc() { if (Freespace == 0) { Context = NIL; error2("out of memory"); @@ -428,7 +520,7 @@ object* myalloc () { myfree - adds obj to the linked list of free objects. inline makes gc significantly faster */ -inline void myfree (object* obj) { +inline void myfree(object* obj) { car(obj) = NULL; cdr(obj) = Freelist; Freelist = obj; @@ -441,8 +533,8 @@ inline void myfree (object* obj) { number - make an integer object with value n and return it or return the existing one with the same value */ -object* number (int n) { - for (int i=0; itype == NUMBER && obj->integer == n) return obj; } @@ -456,8 +548,8 @@ object* number (int n) { makefloat - make a floating point object with value f and return it or return the existing one with the same value */ -object* makefloat (float f) { - for (int i=0; itype == FLOAT && obj->single_float == f) return obj; } @@ -471,8 +563,8 @@ object* makefloat (float f) { character - make a character object with value c and return it or return the existing one with the same value */ -object* character (char c) { - for (int i=0; itype == CHARACTER && obj->chars == c) return obj; } @@ -485,7 +577,7 @@ object* character (char c) { /* cons - make a cons with arg1 and arg2 return it */ -object* cons (object* arg1, object* arg2) { +object* cons(object* arg1, object* arg2) { object* ptr = myalloc(); ptr->car = arg1; ptr->cdr = arg2; @@ -496,8 +588,8 @@ object* cons (object* arg1, object* arg2) { symbol - make a symbol object with value name and return it or returns the existing one with the same value */ -object* symbol (symbol_t name) { - for (int i=0; itype == SYMBOL && obj->name == name) return obj; } @@ -507,10 +599,10 @@ object* symbol (symbol_t name) { return ptr; } -object* bfunction_from_symbol (object* symbol) { +object* bfunction_from_symbol(object* symbol) { if (!(symbolp(symbol) && builtinp(symbol->name))) return nil; symbol_t nm = symbol->name; - for (int i=0; itype == BFUNCTION && obj->name == nm) return obj; } @@ -523,22 +615,22 @@ object* bfunction_from_symbol (object* symbol) { /* bsymbol - make a built-in symbol */ -inline object* bsymbol (builtin_t name) { - return symbol(twist(name+BUILTINS)); +inline object* bsymbol(builtin_t name) { + return symbol(twist(name + BUILTINS)); } /* eqsymbols - compares the long string/symbol obj with the string in buffer. */ -bool eqsymbols (object* obj, const char* buffer) { +bool eqsymbols(object* obj, const char* buffer) { object* arg = cdr(obj); int i = 0; while (!(arg == NULL && buffer[i] == 0)) { if (arg == NULL || buffer[i] == 0) return false; int test = 0, shift = 24; - for (int j=0; j<4; j++, i++) { + for (int j = 0; j < 4; j++, i++) { if (buffer[i] == 0) break; - test |= buffer[i]<chars != test) return false; @@ -551,8 +643,8 @@ bool eqsymbols (object* obj, const char* buffer) { internlong - looks through the workspace for an existing occurrence of the long symbol in buffer and returns it, otherwise calls lispstring(buffer) and coerces it to symbol. */ -object* internlong (const char* buffer) { - for (int i=0; itype == SYMBOL && longsymbolp(obj) && eqsymbols(obj, buffer)) return obj; } @@ -564,7 +656,7 @@ object* internlong (const char* buffer) { /* buftosymbol - checks the characters in buffer and calls symbol() or internlong() to make it a symbol. */ -object* buftosymbol (const char* b) { +object* buftosymbol(const char* b) { int l = strlen(b); if (l <= 6 && valid40(b)) return symbol(twist(pack40(b))); else return internlong(b); @@ -573,17 +665,17 @@ object* buftosymbol (const char* b) { /* stream - makes a stream object defined by streamtype and address, and returns it */ -object* stream (uint8_t streamtype, uint8_t address) { +object* stream(uint8_t streamtype, uint8_t address) { object* ptr = myalloc(); ptr->type = STREAM; - ptr->integer = streamtype<<8 | address; + ptr->integer = streamtype << 8 | address; return ptr; } /* newstring - makes an empty string object and returns it */ -object* newstring () { +object* newstring() { object* ptr = myalloc(); ptr->type = STRING; ptr->chars = 0; @@ -602,13 +694,13 @@ const char gfx[] = ":gfx"; /* *features* - create a list of features symbols from const strings. */ -object* ss_features (object* args, object* env) { +object* ss_features(object* args, object* env) { (void)env; if (args) error2("*features* is read only"); object* result = NULL; - #ifdef gfxsupport +#ifdef gfxsupport push(internlong(gfx), result); - #endif +#endif push(internlong(wifi), result); push(internlong(errorhandling), result); push(internlong(doc), result); @@ -622,8 +714,8 @@ object* ss_features (object* args, object* env) { /* markobject - recursively marks reachable objects, starting from obj */ -void markobject (object* obj) { - MARK: +void markobject(object* obj) { +MARK: if (obj == NULL) return; if (marked(obj)) return; @@ -631,7 +723,7 @@ void markobject (object* obj) { unsigned int type = obj->type; mark(obj); - if (type >= PAIR || type == ZZERO) { // cons + if (type >= PAIR || type == ZZERO) { // cons markobject(arg); obj = cdr(obj); goto MARK; @@ -656,12 +748,13 @@ void markobject (object* obj) { sweep - goes through the workspace freeing objects that have not been marked, and unmarks marked objects */ -void sweep () { +void sweep() { Freelist = NULL; Freespace = 0; - for (int i=WORKSPACESIZE-1; i>=0; i--) { + for (int i = WORKSPACESIZE - 1; i >= 0; i--) { object* obj = &Workspace[i]; - if (marked(obj)) unmark(obj); else myfree(obj); + if (marked(obj)) unmark(obj); + else myfree(obj); } } @@ -669,11 +762,11 @@ void sweep () { gc - performs garbage collection by calling markobject() on each of the pointers to objects in use, followed by sweep() to free unused objects. */ -void gc (object* form, object* env) { - #if defined(printgcs) +void gc(object* form, object* env) { +#if defined(printgcs) int start = Freespace; static int GC_Count = 0; - #endif +#endif markobject(tee); markobject(Thrown); markobject(GlobalEnv); @@ -681,7 +774,7 @@ void gc (object* form, object* env) { markobject(form); markobject(env); sweep(); - #if defined(printgcs) +#if defined(printgcs) GC_Count++; pfl(pserial); pfstring("{GC#", pserial); @@ -693,18 +786,18 @@ void gc (object* form, object* env) { pserial('/'); pint(WORKSPACESIZE, pserial); pserial('}'); - #endif +#endif } -char *MakeFilename (object* arg, char *buffer) { - int max = BUFFERSIZE-1; - buffer[0]='/'; +char* MakeFilename(object* arg, char* buffer) { + int max = BUFFERSIZE - 1; + buffer[0] = '/'; int i = 1; do { - char c = nthchar(arg, i-1); + char c = nthchar(arg, i - 1); if (c == '\0') break; buffer[i++] = c; - } while (itype; return type >= PAIR || type == ZZERO; @@ -767,7 +867,7 @@ bool consp (object* x) { /* listp - implements Lisp listp */ -bool listp (object* x) { +bool listp(object* x) { if (x == NULL) return true; unsigned int type = x->type; return type >= PAIR || type == ZZERO; @@ -782,7 +882,7 @@ bool listp (object* x) { quoteit - quote a symbol with the specified type of quote */ -object* quoteit (builtin_t q, object* it) { +object* quoteit(builtin_t q, object* it) { return cons(bsymbol(q), cons(it, nil)); } @@ -791,14 +891,14 @@ object* quoteit (builtin_t q, object* it) { /* builtin - converts a symbol name to builtin */ -builtin_t builtin (symbol_t name) { +builtin_t builtin(symbol_t name) { return (builtin_t)(untwist(name) - BUILTINS); } /* sym - converts a builtin to a symbol name */ -symbol_t sym (builtin_t x) { +symbol_t sym(builtin_t x) { return twist(x + BUILTINS); } @@ -807,18 +907,18 @@ const char radix40alphabet[] = "\0000123456789abcdefghijklmnopqrstuvwxyz-*$"; /* toradix40 - returns a number from 0 to 39 if the character can be encoded, or -1 otherwise. */ -int8_t toradix40 (char ch) { +int8_t toradix40(char ch) { ch = tolower(ch); - for (int8_t i=0; i<40; i++) { + for (int8_t i = 0; i < 40; i++) { if (radix40alphabet[i] == ch) return i; } - return -1; // Invalid + return -1; // Invalid } /* fromradix40 - returns the character encoded by the number n. */ -char fromradix40 (char n) { +char fromradix40(char n) { if (n < 0 || n >= 40) return 0; return radix40alphabet[n]; } @@ -826,11 +926,11 @@ char fromradix40 (char n) { /* pack40 - packs six radix40-encoded characters from buffer into a 32-bit number and returns it. */ -uint32_t pack40 (const char* buffer) { +uint32_t pack40(const char* buffer) { int x = 0, gz = 0, c = 0; - for (int i=0; i<6; i++) { + for (int i = 0; i < 6; i++) { if (gz) c = 0; - else c = buffer[i]; // Don't dereference the buffer if we reached the end of the string already + else c = buffer[i]; // Don't dereference the buffer if we reached the end of the string already x *= 40; if (c == 0) gz = 1; else x += toradix40(c); @@ -841,9 +941,9 @@ uint32_t pack40 (const char* buffer) { /* valid40 - returns true if the symbol in buffer can be encoded as six radix40-encoded characters. */ -bool valid40 (const char* buffer) { +bool valid40(const char* buffer) { int t = 11; - for (int i=0; i<6; i++) { + for (int i = 0; i < 6; i++) { if (toradix40(buffer[i]) < t) return false; if (buffer[i] == 0) break; t = 0; @@ -854,17 +954,17 @@ bool valid40 (const char* buffer) { /* digitvalue - returns the numerical value of a hexadecimal digit, or 16 if invalid. */ -int8_t digitvalue (char d) { - if (d>='0' && d<='9') return d-'0'; +int8_t digitvalue(char d) { + if (d >= '0' && d <= '9') return d - '0'; d = d | 0x20; - if (d>='a' && d<='f') return d-'a'+10; + if (d >= 'a' && d <= 'f') return d - 'a' + 10; return 16; } /* checkinteger - check that obj is an integer and return it */ -int checkinteger (object* obj) { +int checkinteger(object* obj) { if (!integerp(obj)) error(notaninteger, obj); return obj->integer; } @@ -872,7 +972,7 @@ int checkinteger (object* obj) { /* checkbitvalue - check that obj is an integer equal to 0 or 1 and return it */ -int checkbitvalue (object* obj) { +int checkbitvalue(object* obj) { if (!integerp(obj)) error(notaninteger, obj); int n = obj->integer; if (n & ~1) error("argument is not a bit value", obj); @@ -882,7 +982,7 @@ int checkbitvalue (object* obj) { /* checkintfloat - check that obj is an integer or floating-point number and return the number */ -float checkintfloat (object* obj){ +float checkintfloat(object* obj) { if (integerp(obj)) return (float)obj->integer; if (!floatp(obj)) error(notanumber, obj); return obj->single_float; @@ -891,7 +991,7 @@ float checkintfloat (object* obj){ /* checkchar - check that obj is a character and return the character */ -int checkchar (object* obj) { +int checkchar(object* obj) { if (!characterp(obj)) error("argument is not a character", obj); return obj->chars; } @@ -899,25 +999,25 @@ int checkchar (object* obj) { /* checkstring - check that obj is a string */ -object* checkstring (object* obj) { +object* checkstring(object* obj) { if (!stringp(obj)) error(notastring, obj); return obj; } -int isstream (object* obj){ +int isstream(object* obj) { if (!streamp(obj)) error("not a stream", obj); return obj->integer; } -int isbuiltin (object* obj, builtin_t n) { +int isbuiltin(object* obj, builtin_t n) { return symbolp(obj) && obj->name == sym(n); } -inline bool builtinp (symbol_t name) { +inline bool builtinp(symbol_t name) { return (untwist(name) >= BUILTINS); } -int checkkeyword (object* obj) { +int checkkeyword(object* obj) { if (!builtin_keywordp(obj)) error("argument is not a keyword", obj); builtin_t kname = builtin(obj->name); minmax_t context = getminmax(kname); @@ -929,7 +1029,7 @@ int checkkeyword (object* obj) { checkargs - checks that the number of objects in the list args is within the range specified in the symbol lookup table */ -void checkargs (object* args) { +void checkargs(object* args) { int nargs = listlength(args); checkminmax(Context, nargs); } @@ -937,13 +1037,13 @@ void checkargs (object* args) { /* eq - implements Lisp eq */ -boolean eq (object* arg1, object* arg2) { - if (arg1 == arg2) return true; // Same object - if ((arg1 == nil) || (arg2 == nil)) return false; // Not both values - if (arg1->cdr != arg2->cdr) return false; // Different values - if (symbolp(arg1) && symbolp(arg2)) return true; // Same symbol - if (integerp(arg1) && integerp(arg2)) return true; // Same integer - if (floatp(arg1) && floatp(arg2)) return true; // Same float +boolean eq(object* arg1, object* arg2) { + if (arg1 == arg2) return true; // Same object + if ((arg1 == nil) || (arg2 == nil)) return false; // Not both values + if (arg1->cdr != arg2->cdr) return false; // Different values + if (symbolp(arg1) && symbolp(arg2)) return true; // Same symbol + if (integerp(arg1) && integerp(arg2)) return true; // Same integer + if (floatp(arg1) && floatp(arg2)) return true; // Same float if (characterp(arg1) && characterp(arg2)) return true; // Same character return false; } @@ -951,7 +1051,7 @@ boolean eq (object* arg1, object* arg2) { /* equal - implements Lisp equal */ -bool equal (object* arg1, object* arg2) { +bool equal(object* arg1, object* arg2) { if (stringp(arg1) && stringp(arg2)) return (stringcompare(cons(arg1, cons(arg2, nil)), false, false, true) != -1); if (consp(arg1) && consp(arg2)) return (equal(car(arg1), car(arg2)) && equal(cdr(arg1), cdr(arg2))); return eq(arg1, arg2); @@ -960,7 +1060,7 @@ bool equal (object* arg1, object* arg2) { /* listlength - returns the length of a list */ -int listlength (object* list) { +int listlength(object* list) { int length = 0; while (list != NULL) { if (improperp(list)) error2(notproper); @@ -974,7 +1074,7 @@ int listlength (object* list) { checkarguments - checks the arguments list in a special form such as with-xxx, dolist, or dotimes. */ -object* checkarguments (object* args, int min, int max) { +object* checkarguments(object* args, int min, int max) { if (args == NULL) error2(noargument); args = first(args); if (!listp(args)) error(notalist, args); @@ -990,7 +1090,7 @@ object* checkarguments (object* args, int min, int max) { add_floats - used by fn_add Converts the numbers in args to floats, adds them to fresult, and returns the sum as a Lisp float. */ -object* add_floats (object* args, float fresult) { +object* add_floats(object* args, float fresult) { while (args != NULL) { object* arg = car(args); fresult = fresult + checkintfloat(arg); @@ -1003,7 +1103,7 @@ object* add_floats (object* args, float fresult) { subtract_floats - used by fn_subtract with more than one argument Converts the numbers in args to floats, subtracts them from fresult, and returns the result as a Lisp float. */ -object* subtract_floats (object* args, float fresult) { +object* subtract_floats(object* args, float fresult) { while (args != NULL) { object* arg = car(args); fresult = fresult - checkintfloat(arg); @@ -1017,7 +1117,7 @@ object* subtract_floats (object* args, float fresult) { If the result is an integer, and negating it doesn't overflow, keep the result as an integer. Otherwise convert the result to a float, negate it, and return the result as a Lisp float. */ -object* negate (object* arg) { +object* negate(object* arg) { if (integerp(arg)) { int result = arg->integer; if (result == INT_MIN) return makefloat(-result); @@ -1031,9 +1131,9 @@ object* negate (object* arg) { multiply_floats - used by fn_multiply Converts the numbers in args to floats, adds them to fresult, and returns the result as a Lisp float. */ -object* multiply_floats (object* args, float fresult) { +object* multiply_floats(object* args, float fresult) { while (args != NULL) { - object* arg = car(args); + object* arg = car(args); fresult = fresult * checkintfloat(arg); args = cdr(args); } @@ -1044,7 +1144,7 @@ object* multiply_floats (object* args, float fresult) { divide_floats - used by fn_divide Converts the numbers in args to floats, divides fresult by them, and returns the result as a Lisp float. */ -object* divide_floats (object* args, float fresult) { +object* divide_floats(object* args, float fresult) { while (args != NULL) { object* arg = car(args); float f = checkintfloat(arg); @@ -1062,7 +1162,7 @@ object* divide_floats (object* args, float fresult) { If gt is true the result is true if each argument is greater than the next argument. If eq is true the result is true if each argument is equal to the next argument. */ -object* compare (object* args, bool lt, bool gt, bool eq) { +object* compare(object* args, bool lt, bool gt, bool eq) { object* arg1 = first(args); args = cdr(args); while (args != NULL) { @@ -1085,7 +1185,7 @@ object* compare (object* args, bool lt, bool gt, bool eq) { /* intpower - calculates base to the power exp as an integer */ -int intpower (int base, int exp) { +int intpower(int base, int exp) { int result = 1; while (exp) { if (exp & 1) result = result * base; @@ -1100,7 +1200,7 @@ int intpower (int base, int exp) { /* testargument - handles the :test argument for functions that accept it */ -object* testargument (object* args) { +object* testargument(object* args) { object* test = bfunction_from_symbol(bsymbol(EQ)); if (args != NULL) { if (cdr(args) == NULL) error("dangling keyword", first(args)); @@ -1113,12 +1213,12 @@ object* testargument (object* args) { /* assoc - looks for key in an association list and returns the matching pair, or nil if not found */ -object* assoc (object* key, object* list) { +object* assoc(object* key, object* list) { while (list != NULL) { if (improperp(list)) error(notproper, list); object* pair = first(list); if (!listp(pair)) error("element is not a list", pair); - if (pair != NULL && eq(key,car(pair))) return pair; + if (pair != NULL && eq(key, car(pair))) return pair; list = cdr(list); } return nil; @@ -1127,12 +1227,12 @@ object* assoc (object* key, object* list) { /* delassoc - deletes the pair matching key from an association list and returns the key, or nil if not found */ -object* delassoc (object* key, object** alist) { +object* delassoc(object* key, object** alist) { object* list = *alist; object* prev = NULL; while (list != NULL) { object* pair = first(list); - if (eq(key,car(pair))) { + if (eq(key, car(pair))) { if (prev == NULL) *alist = cdr(list); else cdr(prev) = cdr(list); return key; @@ -1148,18 +1248,23 @@ object* delassoc (object* key, object** alist) { /* nextpower2 - returns the smallest power of 2 that is equal to or greater than n */ -int nextpower2 (int n) { - n--; n |= n >> 1; n |= n >> 2; n |= n >> 4; - n |= n >> 8; n |= n >> 16; n++; - return n<2 ? 2 : n; +int nextpower2(int n) { + n--; + n |= n >> 1; + n |= n >> 2; + n |= n >> 4; + n |= n >> 8; + n |= n >> 16; + n++; + return n < 2 ? 2 : n; } /* buildarray - builds an array with n elements using a tree of size s which must be a power of 2 The elements are initialised to the default def */ -object* buildarray (int n, int s, object* def) { - int s2 = s>>1; +object* buildarray(int n, int s, object* def) { + int s2 = s >> 1; if (s2 == 1) { if (n == 2) return cons(def, def); else if (n == 1) return cons(def, NULL); @@ -1168,7 +1273,7 @@ object* buildarray (int n, int s, object* def) { else return cons(buildarray(n, s2, def), nil); } -object* makearray (object* dims, object* def, bool bitp) { +object* makearray(object* dims, object* def, bool bitp) { int size = 1; object* dimensions = dims; while (dims != NULL) { @@ -1179,7 +1284,7 @@ object* makearray (object* dims, object* def, bool bitp) { } // Bit array identified by making first dimension negative if (bitp) { - size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); + size = (size + sizeof(int) * 8 - 1) / (sizeof(int) * 8); car(dimensions) = number(-(car(dimensions)->integer)); } object* ptr = myalloc(); @@ -1193,12 +1298,13 @@ object* makearray (object* dims, object* def, bool bitp) { /* arrayref - returns a pointer to the element specified by index in the array of size s */ -object** arrayref (object* array, int index, int size) { - int mask = nextpower2(size)>>1; +object** arrayref(object* array, int index, int size) { + int mask = nextpower2(size) >> 1; object** p = &car(cdr(array)); while (mask) { - if ((index & mask) == 0) p = &(car(*p)); else p = &(cdr(*p)); - mask = mask>>1; + if ((index & mask) == 0) p = &(car(*p)); + else p = &(cdr(*p)); + mask = mask >> 1; } return p; } @@ -1207,26 +1313,31 @@ object** arrayref (object* array, int index, int size) { getarray - gets a pointer to an element in a multi-dimensional array, given a list of the subscripts subs If the first subscript is negative it's a bit array and bit is set to the bit number */ -object** getarray (object* array, object* subs, object* env, int* bit) { +object** getarray(object* array, object* subs, object* env, int* bit) { int index = 0, size = 1, s; *bit = -1; bool bitp = false; object* dims = cddr(array); while (dims != NULL && subs != NULL) { int d = car(dims)->integer; - if (d < 0) { d = -d; bitp = true; } - if (env) s = checkinteger(eval(car(subs), env)); else s = checkinteger(car(subs)); + if (d < 0) { + d = -d; + bitp = true; + } + if (env) s = checkinteger(eval(car(subs), env)); + else s = checkinteger(car(subs)); if (s < 0 || s >= d) error("subscript out of range", car(subs)); size = size * d; index = index * d + s; - dims = cdr(dims); subs = cdr(subs); + dims = cdr(dims); + subs = cdr(subs); } if (dims != NULL) error2("too few subscripts"); if (subs != NULL) error2("too many subscripts"); if (bitp) { - size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); - *bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); - index = index>>(sizeof(int)==4 ? 5 : 4); + size = (size + sizeof(int) * 8 - 1) / (sizeof(int) * 8); + *bit = index & (sizeof(int) == 4 ? 0x1F : 0x0F); + index = index >> (sizeof(int) == 4 ? 5 : 4); } return arrayref(array, index, size); } @@ -1234,7 +1345,7 @@ object** getarray (object* array, object* subs, object* env, int* bit) { /* rslice - reads a slice of an array recursively */ -void rslice (object* array, int size, int slice, object* dims, object* args) { +void rslice(object* array, int size, int slice, object* dims, object* args) { int d = first(dims)->integer; for (int i = 0; i < d; i++) { int index = slice * d + i; @@ -1251,15 +1362,21 @@ void rslice (object* array, int size, int slice, object* dims, object* args) { readarray - reads a list structure from args and converts it to a d-dimensional array. Uses rslice for each of the slices of the array. */ -object* readarray (int d, object* args) { +object* readarray(int d, object* args) { object* list = args; - object* dims = NULL; object* head = NULL; + object* dims = NULL; + object* head = NULL; int size = 1; for (int i = 0; i < d; i++) { if (!listp(list)) error2("initial contents don't match array type"); int l = listlength(list); - if (dims == NULL) { dims = cons(number(l), NULL); head = dims; } - else { cdr(dims) = cons(number(l), NULL); dims = cdr(dims); } + if (dims == NULL) { + dims = cons(number(l), NULL); + head = dims; + } else { + cdr(dims) = cons(number(l), NULL); + dims = cdr(dims); + } size = size * l; if (list != NULL) list = car(list); } @@ -1272,7 +1389,7 @@ object* readarray (int d, object* args) { readbitarray - reads an item in the format #*1010101000110 by reading it and returning a list of integers, and then converting that to a bit array */ -object* readbitarray (gfun_t gfun) { +object* readbitarray(gfun_t gfun) { char ch = gfun(); object* head = NULL; object* tail = NULL; @@ -1287,12 +1404,12 @@ object* readbitarray (gfun_t gfun) { LastChar = ch; int size = listlength(head); object* array = makearray(cons(number(size), NULL), number(0), true); - size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); + size = (size + sizeof(int) * 8 - 1) / (sizeof(int) * 8); int index = 0; while (head != NULL) { - object** loc = arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size); - int bit = index & (sizeof(int)==4 ? 0x1F : 0x0F); - *loc = number((((*loc)->integer) & ~(1<integer)<> (sizeof(int) == 4 ? 5 : 4), size); + int bit = index & (sizeof(int) == 4 ? 0x1F : 0x0F); + *loc = number((((*loc)->integer) & ~(1 << bit)) | (car(head)->integer) << bit); index++; head = cdr(head); } @@ -1302,55 +1419,72 @@ object* readbitarray (gfun_t gfun) { /* pslice - prints a slice of an array recursively */ -void pslice (object* array, int size, int slice, object* dims, pfun_t pfun, bool bitp) { +void pslice(object* array, int size, int slice, object* dims, pfun_t pfun, bool bitp) { bool spaces = true; - if (slice == -1) { spaces = false; slice = 0; } + if (slice == -1) { + spaces = false; + slice = 0; + } int d = first(dims)->integer; if (d < 0) d = -d; for (int i = 0; i < d; i++) { if (i && spaces) pfun(' '); int index = slice * d + i; if (cdr(dims) == NULL) { - if (bitp) pint(((*arrayref(array, index>>(sizeof(int)==4 ? 5 : 4), size))->integer)>> - (index & (sizeof(int)==4 ? 0x1F : 0x0F)) & 1, pfun); + if (bitp) pint(((*arrayref(array, index >> (sizeof(int) == 4 ? 5 : 4), size))->integer) >> (index & (sizeof(int) == 4 ? 0x1F : 0x0F)) & 1, pfun); else printobject(*arrayref(array, index, size), pfun); - } else { pfun('('); pslice(array, size, index, cdr(dims), pfun, bitp); pfun(')'); } + } else { + pfun('('); + pslice(array, size, index, cdr(dims), pfun, bitp); + pfun(')'); + } } } /* printarray - prints an array in the appropriate Lisp format */ -void printarray (object* array, pfun_t pfun) { +void printarray(object* array, pfun_t pfun) { object* dimensions = cddr(array); object* dims = dimensions; bool bitp = false; int size = 1, n = 0; while (dims != NULL) { int d = car(dims)->integer; - if (d < 0) { bitp = true; d = -d; } + if (d < 0) { + bitp = true; + d = -d; + } size = size * d; - dims = cdr(dims); n++; + dims = cdr(dims); + n++; } - if (bitp) size = (size + sizeof(int)*8 - 1)/(sizeof(int)*8); + if (bitp) size = (size + sizeof(int) * 8 - 1) / (sizeof(int) * 8); pfun('#'); - if (n == 1 && bitp) { pfun('*'); pslice(array, size, -1, dimensions, pfun, bitp); } - else { - if (n > 1) { pint(n, pfun); pfun('A'); } - pfun('('); pslice(array, size, 0, dimensions, pfun, bitp); pfun(')'); + if (n == 1 && bitp) { + pfun('*'); + pslice(array, size, -1, dimensions, pfun, bitp); + } else { + if (n > 1) { + pint(n, pfun); + pfun('A'); + } + pfun('('); + pslice(array, size, 0, dimensions, pfun, bitp); + pfun(')'); } } // String utilities -void indent (uint8_t spaces, char ch, pfun_t pfun) { - for (uint8_t i=0; ichars & 0xFFFFFF) == 0) { - (*tail)->chars |= ch<<16; return; + (*tail)->chars |= ch << 16; + return; } else if (((*tail)->chars & 0xFFFF) == 0) { - (*tail)->chars |= ch<<8; return; + (*tail)->chars |= ch << 8; + return; } else if (((*tail)->chars & 0xFF) == 0) { - (*tail)->chars |= ch; return; + (*tail)->chars |= ch; + return; } else { - cell = myalloc(); car(*tail) = cell; + cell = myalloc(); + car(*tail) = cell; } - car(cell) = NULL; cell->chars = ch<<24; *tail = cell; + car(cell) = NULL; + cell->chars = ch << 24; + *tail = cell; } /* copystring - returns a copy of a Lisp string */ -object* copystring (object* arg) { +object* copystring(object* arg) { object* obj = newstring(); object* ptr = obj; arg = cdr(arg); while (arg != NULL) { - object* cell = myalloc(); car(cell) = NULL; - if (cdr(obj) == NULL) cdr(obj) = cell; else car(ptr) = cell; + object* cell = myalloc(); + car(cell) = NULL; + if (cdr(obj) == NULL) cdr(obj) = cell; + else car(ptr) = cell; ptr = cell; ptr->chars = arg->chars; arg = car(arg); @@ -1407,7 +1550,7 @@ object* copystring (object* arg) { readstring - reads characters from an input stream up to delimiter delim and returns a Lisp string */ -object* readstring (char delim, bool do_escape, gfun_t gfun) { +object* readstring(char delim, bool do_escape, gfun_t gfun) { object* obj = newstring(); object* tail = obj; int ch = gfun(); @@ -1424,13 +1567,13 @@ object* readstring (char delim, bool do_escape, gfun_t gfun) { stringlength - returns the length of a Lisp string Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word */ -int stringlength (object* form) { +int stringlength(object* form) { int length = 0; form = cdr(form); while (form != NULL) { int chars = form->chars; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - if (chars>>i & 0xFF) length++; + for (int i = (sizeof(int) - 1) * 8; i >= 0; i = i - 8) { + if (chars >> i & 0xFF) length++; } form = car(form); } @@ -1441,13 +1584,18 @@ int stringlength (object* form) { getcharplace - gets character n in a Lisp string, and sets shift to (- the shift position -2) Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word. */ -object** getcharplace (object* string, int n, int* shift) { +object** getcharplace(object* string, int n, int* shift) { object** arg = &cdr(string); int top; - if /* constexpr */ (sizeof(int) == 4) { top = n>>2; *shift = 3 - (n&3); } - else { top = n>>1; *shift = 1 - (n&1); } - *shift = - (*shift + 2); - for (int i=0; i> 2; + *shift = 3 - (n & 3); + } else { + top = n >> 1; + *shift = 1 - (n & 1); + } + *shift = -(*shift + 2); + for (int i = 0; i < top; i++) { if (*arg == NULL) break; arg = &car(*arg); } @@ -1457,17 +1605,17 @@ object** getcharplace (object* string, int n, int* shift) { /* nthchar - returns the nth character from a Lisp string */ -char nthchar (object* string, int n) { +char nthchar(object* string, int n) { int shift; object** arg = getcharplace(string, n, &shift); if (*arg == NULL) return '\0'; - return (((*arg)->chars)>>((-shift-2)<<3)) & 0xFF; + return (((*arg)->chars) >> ((-shift - 2) << 3)) & 0xFF; } /* gstr - reads a character from a string stream */ -int gstr () { +int gstr() { if (LastChar) { char temp = LastChar; LastChar = 0; @@ -1475,24 +1623,27 @@ int gstr () { } char c = nthchar(GlobalString, GlobalStringIndex++); if (c != 0) return c; - return '\n'; // -1? + return '\n'; // -1? } /* pstr - prints a character to a string stream */ -void pstr (char c) { +void pstr(char c) { buildstring(c, &GlobalStringTail); } /* iptostring - converts a 32-bit IP address to a lisp string */ -object* iptostring (uint32_t ip) { - union { uint32_t data2; uint8_t u8[4]; }; +object* iptostring(uint32_t ip) { + union { + uint32_t data2; + uint8_t u8[4]; + }; object* obj = startstring(); data2 = ip; - for (int i=0; i<4; i++) { + for (int i = 0; i < 4; i++) { if (i) pstr('.'); pintbase(u8[i], 10, pstr); } @@ -1502,7 +1653,7 @@ object* iptostring (uint32_t ip) { /* lispstring - converts a C string to a Lisp string */ -object* lispstring (const char* s) { +object* lispstring(const char* s) { object* obj = newstring(); object* tail = obj; for (;;) { @@ -1522,7 +1673,7 @@ object* lispstring (const char* s) { If gt is true the result is true if the first argument is greater than the second argument. If eq is true the result is true if the first argument is equal to the second argument. */ -int stringcompare (object* args, bool lt, bool gt, bool eq) { +int stringcompare(object* args, bool lt, bool gt, bool eq) { object* arg1 = checkstring(first(args)); object* arg2 = checkstring(second(args)); arg1 = cdr(arg1); @@ -1532,7 +1683,8 @@ int stringcompare (object* args, bool lt, bool gt, bool eq) { while (arg1 || arg2) { if (!arg1) return lt ? m : -1; if (!arg2) return gt ? m : -1; - a = arg1->chars; b = arg2->chars; + a = arg1->chars; + b = arg2->chars; if (a < b) { if (lt) { m += sizeof(int); @@ -1542,8 +1694,7 @@ int stringcompare (object* args, bool lt, bool gt, bool eq) { b = b >> 8; } return m; - } - else return -1; + } else return -1; } if (a > b) { if (gt) { @@ -1554,8 +1705,7 @@ int stringcompare (object* args, bool lt, bool gt, bool eq) { b = b >> 8; } return m; - } - else return -1; + } else return -1; } arg1 = car(arg1); arg2 = car(arg2); @@ -1575,7 +1725,7 @@ int stringcompare (object* args, bool lt, bool gt, bool eq) { /* documentation - returns the documentation string of a built-in or user-defined function. */ -object* documentation (object* arg, object* env) { +object* documentation(object* arg, object* env) { if (arg == NULL) return nil; if (!symbolp(arg)) error(notasymbol, arg); object* pair = findpair(arg, env); @@ -1598,7 +1748,7 @@ object* documentation (object* arg, object* env) { apropos - finds the user-defined and built-in functions whose names contain the specified string or symbol, and prints them if print is true, or returns them in a list. */ -object* apropos (object* arg, bool print) { +object* apropos(object* arg, bool print) { char buf[17], buf2[33]; char* part = cstring(princtostring(arg), buf, 17); object* result = cons(NULL, NULL); @@ -1612,13 +1762,17 @@ object* apropos (object* arg, bool print) { char* full = cstring(princtostring(var), buf2, 33); if (strstr(full, part) != NULL) { if (print) { - printsymbol(var, pserial); pserial(' '); pserial('('); + printsymbol(var, pserial); + pserial(' '); + pserial('('); if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) pfstring("user function", pserial); else if (consp(val) && car(val)->type == CODE) pfstring("code", pserial); else pfstring("user symbol", pserial); - pserial(')'); pln(pserial); + pserial(')'); + pln(pserial); } else { - cdr(ptr) = cons(var, NULL); ptr = cdr(ptr); + cdr(ptr) = cons(var, NULL); + ptr = cdr(ptr); } } globals = cdr(globals); @@ -1630,14 +1784,18 @@ object* apropos (object* arg, bool print) { if (findsubstring(part, (builtin_t)i)) { if (print) { uint8_t ft = fntype(getminmax(i)); - pbuiltin((builtin_t)i, pserial); pserial(' '); pserial('('); + pbuiltin((builtin_t)i, pserial); + pserial(' '); + pserial('('); if (ft == FUNCTIONS) pfstring("function", pserial); else if (ft == SPECIAL_FORMS) pfstring("special form", pserial); else if (ft == SPECIAL_SYMBOLS) pfstring("special symbol", pserial); else pfstring("symbol/keyword", pserial); - pserial(')'); pln(pserial); + pserial(')'); + pln(pserial); } else { - cdr(ptr) = cons(bsymbol(i), NULL); ptr = cdr(ptr); + cdr(ptr) = cons(bsymbol(i), NULL); + ptr = cdr(ptr); } } testescape(); @@ -1649,15 +1807,15 @@ object* apropos (object* arg, bool print) { cstring - converts a Lisp string to a C string in buffer and returns buffer Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word */ -char* cstring (object* form, char* buffer, int buflen) { +char* cstring(object* form, char* buffer, int buflen) { form = cdr(checkstring(form)); int index = 0; while (form != NULL) { int chars = form->integer; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; + for (int i = (sizeof(int) - 1) * 8; i >= 0; i = i - 8) { + char ch = chars >> i & 0xFF; if (ch) { - if (index >= buflen-1) error2("no room for string"); + if (index >= buflen - 1) error2("no room for string"); buffer[index++] = ch; } } @@ -1671,18 +1829,23 @@ char* cstring (object* form, char* buffer, int buflen) { ipstring - parses an IP address from a Lisp string and returns it as an IPAddress type (uint32_t) Handles Lisp strings packed two characters per 16-bit word, or four characters per 32-bit word */ -uint32_t ipstring (object* form) { +uint32_t ipstring(object* form) { form = cdr(checkstring(form)); int p = 0; - union { uint32_t ipaddress; uint8_t ipbytes[4]; } ; + union { + uint32_t ipaddress; + uint8_t ipbytes[4]; + }; ipaddress = 0; while (form != NULL) { int chars = form->integer; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; + for (int i = (sizeof(int) - 1) * 8; i >= 0; i = i - 8) { + char ch = chars >> i & 0xFF; if (ch) { - if (ch == '.') { p++; if (p > 3) error("illegal IP address", form); } - else ipbytes[p] = (ipbytes[p] * 10) + ch - '0'; + if (ch == '.') { + p++; + if (p > 3) error("illegal IP address", form); + } else ipbytes[p] = (ipbytes[p] * 10) + ch - '0'; } } form = car(form); @@ -1692,7 +1855,7 @@ uint32_t ipstring (object* form) { // Lookup variable in environment -object* value (symbol_t n, object* env) { +object* value(symbol_t n, object* env) { while (env != NULL) { object* pair = car(env); if (pair != NULL && car(pair)->name == n) return pair; @@ -1704,7 +1867,7 @@ object* value (symbol_t n, object* env) { /* findpair - returns the (var . value) pair bound to variable var in the local or global environment */ -object* findpair (object* var, object* env) { +object* findpair(object* var, object* env) { symbol_t name = var->name; object* pair = value(name, env); if (pair == NULL) pair = value(name, GlobalEnv); @@ -1714,7 +1877,7 @@ object* findpair (object* var, object* env) { /* boundp - tests whether var is bound to a value */ -bool boundp (object* var, object* env) { +bool boundp(object* var, object* env) { if (!symbolp(var)) error(notasymbol, var); return (findpair(var, env) != NULL); } @@ -1722,7 +1885,7 @@ bool boundp (object* var, object* env) { /* findvalue - returns the value bound to variable var, or gives an error if unbound */ -object* findvalue (object* var, object* env) { +object* findvalue(object* var, object* env) { object* pair = findpair(var, env); if (pair == NULL) error("unknown variable", var); return pair; @@ -1730,15 +1893,18 @@ object* findvalue (object* var, object* env) { // Handling closures -object* closure (bool tc, symbol_t name, object* function, object* args, object** env) { +object* closure(bool tc, symbol_t name, object* function, object* args, object** env) { object* state = car(function); function = cdr(function); int trace = 0; if (name) trace = tracing(name); if (trace) { - indent(TraceDepth[trace-1]<<1, ' ', pserial); - pint(TraceDepth[trace-1]++, pserial); - pserial(':'); pserial(' '); pserial('('); printsymbol(symbol(name), pserial); + indent(TraceDepth[trace - 1] << 1, ' ', pserial); + pint(TraceDepth[trace - 1]++, pserial); + pserial(':'); + pserial(' '); + pserial('('); + printsymbol(symbol(name), pserial); } object* params = first(function); if (!listp(params)) errorsym(name, notalist, params); @@ -1766,7 +1932,10 @@ object* closure (bool tc, symbol_t name, object* function, object* args, object* if (consp(var)) { if (!optional) errorsym(name, "invalid default value", var); if (args == NULL) value = eval(second(var), *env); - else { value = first(args); args = cdr(args); } + else { + value = first(args); + args = cdr(args); + } var = first(var); if (!symbolp(var)) errorsym(name, "illegal optional parameter", var); } else if (!symbolp(var)) { @@ -1780,21 +1949,30 @@ object* closure (bool tc, symbol_t name, object* function, object* args, object* if (args == NULL) { if (optional) value = nil; else errorsym2(name, toofewargs); - } else { value = first(args); args = cdr(args); } + } else { + value = first(args); + args = cdr(args); + } + } + push(cons(var, value), *env); + if (trace) { + pserial(' '); + printobject(value, pserial); } - push(cons(var,value), *env); - if (trace) { pserial(' '); printobject(value, pserial); } } params = cdr(params); } if (args != NULL) errorsym2(name, toomanyargs); - if (trace) { pserial(')'); pln(pserial); } + if (trace) { + pserial(')'); + pln(pserial); + } // Do an implicit progn if (tc) push(nil, *env); return sp_progn(function, *env); } -object* apply (object* function, object* args, object* env) { +object* apply(object* function, object* args, object* env) { if (symbolp(function)) error("can't call a symbol", function); if (bfunctionp(function)) { builtin_t fname = builtin(function->name); @@ -1825,8 +2003,8 @@ object* apply (object* function, object* args, object* env) { place - returns a pointer to an object referenced in the second argument of an in-place operation such as setf. bit is used to indicate the bit position in a bit array */ -object** place (object* args, object* env, int* bit) { - PLACE: +object** place(object* args, object* env, int* bit) { +PLACE: *bit = -1; if (atom(args)) return &cdr(findvalue(args, env)); object* function = first(args); @@ -1845,11 +2023,17 @@ object** place (object* args, object* env, int* bit) { if (sname == sym(NTH)) { int index = checkinteger(eval(second(args), env)); object* list = eval(third(args), env); - if (atom(list)) { Context = NTH; error("second argument is not a list", list); } + if (atom(list)) { + Context = NTH; + error("second argument is not a list", list); + } int i = index; while (i > 0) { list = cdr(list); - if (list == NULL) { Context = NTH; error(indexrange, number(index)); } + if (list == NULL) { + Context = NTH; + error(indexrange, number(index)); + } i--; } return &car(list); @@ -1858,16 +2042,21 @@ object** place (object* args, object* env, int* bit) { int index = checkinteger(eval(third(args), env)); object* string = checkstring(eval(second(args), env)); object** loc = getcharplace(string, index, bit); - if ((*loc) == NULL || (((((*loc)->chars)>>((-(*bit)-2)<<3)) & 0xFF) == 0)) { Context = CHAR; error(indexrange, number(index)); } + if ((*loc) == NULL || (((((*loc)->chars) >> ((-(*bit) - 2) << 3)) & 0xFF) == 0)) { + Context = CHAR; + error(indexrange, number(index)); + } return loc; } if (sname == sym(AREF)) { object* array = eval(second(args), env); - if (!arrayp(array)) { Context = AREF; error("first argument is not an array", array); } + if (!arrayp(array)) { + Context = AREF; + error("first argument is not an array", array); + } return getarray(array, cddr(args), env, bit); } - } - else if (is_macro_call(args, env)) { + } else if (is_macro_call(args, env)) { function = eval(function, env); goto PLACE; } @@ -1880,7 +2069,7 @@ object** place (object* args, object* env, int* bit) { /* carx - car with error checking */ -object* carx (object* arg) { +object* carx(object* arg) { if (!listp(arg)) error(canttakecar, arg); if (arg == nil) return nil; return car(arg); @@ -1889,7 +2078,7 @@ object* carx (object* arg) { /* cdrx - cdr with error checking */ -object* cdrx (object* arg) { +object* cdrx(object* arg) { if (!listp(arg)) error(canttakecdr, arg); if (arg == nil) return nil; return cdr(arg); @@ -1899,11 +2088,12 @@ object* cdrx (object* arg) { cxxxr - implements a general cxxxr function, pattern is a sequence of bits 0b1xxx where x is 0 for a and 1 for d. */ -object* cxxxr (object* args, uint8_t pattern) { +object* cxxxr(object* args, uint8_t pattern) { object* arg = first(args); while (pattern != 1) { - if ((pattern & 1) == 0) arg = carx(arg); else arg = cdrx(arg); - pattern = pattern>>1; + if ((pattern & 1) == 0) arg = carx(arg); + else arg = cdrx(arg); + pattern = pattern >> 1; } return arg; } @@ -1913,7 +2103,7 @@ object* cxxxr (object* args, uint8_t pattern) { /* mapcl - handles either mapc when mapl=false, or mapl when mapl=true */ -object* mapcl (object* args, object* env, bool mapl) { +object* mapcl(object* args, object* env, bool mapl) { object* function = first(args); args = cdr(args); object* result = first(args); @@ -1927,14 +2117,16 @@ object* mapcl (object* args, object* env, bool mapl) { while (lists != NULL) { object* list = car(lists); if (list == NULL) { - unprotect(); unprotect(); + unprotect(); + unprotect(); return result; } if (improperp(list)) error(notproper, list); object* item = mapl ? list : first(list); object* obj = cons(item, NULL); car(lists) = cdr(list); - cdr(tailp) = obj; tailp = obj; + cdr(tailp) = obj; + tailp = obj; lists = cdr(lists); } apply(function, cdr(params), env); @@ -1944,18 +2136,20 @@ object* mapcl (object* args, object* env, bool mapl) { /* mapcarfun - function specifying how to combine the results in mapcar */ -void mapcarfun (object* result, object** tail) { - object* obj = cons(result,NULL); - cdr(*tail) = obj; *tail = obj; +void mapcarfun(object* result, object** tail) { + object* obj = cons(result, NULL); + cdr(*tail) = obj; + *tail = obj; } /* mapcanfun - function specifying how to combine the results in mapcan */ -void mapcanfun (object* result, object** tail) { +void mapcanfun(object* result, object** tail) { if (cdr(*tail) != NULL) error(notproper, *tail); while (consp(result)) { - cdr(*tail) = result; *tail = result; + cdr(*tail) = result; + *tail = result; result = cdr(result); } } @@ -1964,7 +2158,7 @@ void mapcanfun (object* result, object** tail) { mapcarcan - function used by marcar and mapcan when maplist=false, and maplist when maplist=true It takes the arguments, the env, a function specifying how the results are combined, and a bool. */ -object* mapcarcan (object* args, object* env, mapfun_t fun, bool maplist) { +object* mapcarcan(object* args, object* env, mapfun_t fun, bool maplist) { object* function = first(args); args = cdr(args); object* params = cons(NULL, NULL); @@ -1979,14 +2173,16 @@ object* mapcarcan (object* args, object* env, mapfun_t fun, bool maplist) { while (lists != NULL) { object* list = car(lists); if (list == NULL) { - unprotect(); unprotect(); + unprotect(); + unprotect(); return cdr(head); } if (improperp(list)) error(notproper, list); object* item = maplist ? list : first(list); object* obj = cons(item, NULL); car(lists) = cdr(list); - cdr(tailp) = obj; tailp = obj; + cdr(tailp) = obj; + tailp = obj; lists = cdr(lists); } object* result = apply(function, cdr(params), env); @@ -1997,7 +2193,7 @@ object* mapcarcan (object* args, object* env, mapfun_t fun, bool maplist) { /* dobody - function used by do when star=false and do* when star=true */ -object* dobody (object* args, object* env, bool star) { +object* dobody(object* args, object* env, bool star) { object* varlist = first(args); object* endlist = second(args); object* head = cons(NULL, NULL); @@ -2013,17 +2209,18 @@ object* dobody (object* args, object* env, bool star) { else { var = first(varform); varform = cdr(varform); - if (varform != NULL) { + if (varform != NULL) { init = eval(first(varform), env); varform = cdr(varform); if (varform != NULL) step = cons(first(varform), NULL); } - } + } object* pair = cons(var, init); push(pair, newenv); if (star) env = newenv; object* cell = cons(cons(step, pair), NULL); - cdr(ptr) = cell; ptr = cdr(ptr); + cdr(ptr) = cell; + ptr = cdr(ptr); varlist = cdr(varlist); } env = newenv; @@ -2060,7 +2257,8 @@ object* dobody (object* args, object* env, bool star) { } while (count > 0) { cdr(car(GCStack)) = car(cdr(GCStack)); - pop(GCStack); pop(GCStack); + pop(GCStack); + pop(GCStack); count--; } } @@ -2070,39 +2268,38 @@ object* dobody (object* args, object* env, bool star) { // I2C interface for up to two ports, using Arduino Wire -void I2Cinit (TwoWire *port, bool enablePullup) { - (void) enablePullup; +void I2Cinit(TwoWire* port, bool enablePullup) { + (void)enablePullup; port->begin(); } -int I2Cread (TwoWire *port) { +int I2Cread(TwoWire* port) { return port->read(); } -void I2Cwrite (TwoWire *port, uint8_t data) { +void I2Cwrite(TwoWire* port, uint8_t data) { port->write(data); } -bool I2Cstart (TwoWire *port, uint8_t address, uint8_t read) { +bool I2Cstart(TwoWire* port, uint8_t address, uint8_t read) { int ok = true; if (read == 0) { port->beginTransmission(address); ok = (port->endTransmission(true) == 0); port->beginTransmission(address); - } - else port->requestFrom(address, I2Ccount); + } else port->requestFrom(address, I2Ccount); return ok; } -bool I2Crestart (TwoWire *port, uint8_t address, uint8_t read) { +bool I2Crestart(TwoWire* port, uint8_t address, uint8_t read) { int error = (port->endTransmission(false) != 0); if (read == 0) port->beginTransmission(address); else port->requestFrom(address, I2Ccount); return error ? false : true; } -void I2Cstop (TwoWire *port, uint8_t read) { - if (read == 0) port->endTransmission(); // Check for error? +void I2Cstop(TwoWire* port, uint8_t read) { + if (read == 0) port->endTransmission(); // Check for error? // Release pins port->end(); } @@ -2115,15 +2312,24 @@ void I2Cstop (TwoWire *port, uint8_t read) { #endif -inline int spiread () { return SPI.transfer(0); } -inline int i2cread () { return I2Cread(&Wire); } +inline int spiread() { + return SPI.transfer(0); +} +inline int i2cread() { + return I2Cread(&Wire); +} #if defined(ULISP_I2C1) -inline int i2c1read () { return I2Cread(&Wire1); } +inline int i2c1read() { + return I2Cread(&Wire1); +} #endif -inline int serial1read () { while (!Serial1.available()) testescape(); return Serial1.read(); } +inline int serial1read() { + while (!Serial1.available()) testescape(); + return Serial1.read(); +} #if defined(sdcardsupport) File SDpfile, SDgfile; -inline int SDread () { +inline int SDread() { if (LastChar) { char temp = LastChar; LastChar = 0; @@ -2136,7 +2342,7 @@ inline int SDread () { WiFiClient client; WiFiServer server(80); -inline int WiFiread () { +inline int WiFiread() { if (LastChar) { char temp = LastChar; LastChar = 0; @@ -2146,84 +2352,106 @@ inline int WiFiread () { return client.read(); } -void serialbegin (int address, int baud) { - if (address == 1) Serial1.begin((long)baud*100); +void serialbegin(int address, int baud) { + if (address == 1) Serial1.begin((long)baud * 100); else error("port not supported", number(address)); } -void serialend (int address) { - if (address == 1) {Serial1.flush(); Serial1.end(); } +void serialend(int address) { + if (address == 1) { + Serial1.flush(); + Serial1.end(); + } } -gfun_t gstreamfun (object* args) { +gfun_t gstreamfun(object* args) { int streamtype = SERIALSTREAM; int address = 0; gfun_t gfun = gserial; if (args != NULL) { int stream = isstream(first(args)); - streamtype = stream>>8; address = stream & 0xFF; + streamtype = stream >> 8; + address = stream & 0xFF; } if (streamtype == I2CSTREAM) { if (address < 128) gfun = i2cread; - #if defined(ULISP_I2C1) +#if defined(ULISP_I2C1) else gfun = i2c1read; - #endif - } - else if (streamtype == SPISTREAM) gfun = spiread; +#endif + } else if (streamtype == SPISTREAM) gfun = spiread; else if (streamtype == SERIALSTREAM) { if (address == 0) gfun = gserial; else if (address == 1) gfun = serial1read; } - #if defined(sdcardsupport) - else if (streamtype == SDSTREAM) gfun = (gfun_t)SDread; - #endif +#if defined(sdcardsupport) + else if (streamtype == SDSTREAM) + gfun = (gfun_t)SDread; +#endif else if (streamtype == WIFISTREAM) gfun = (gfun_t)WiFiread; else error2("unknown stream type"); return gfun; } -inline void spiwrite (char c) { SPI.transfer(c); } -inline void i2cwrite (char c) { I2Cwrite(&Wire, c); } +inline void spiwrite(char c) { + SPI.transfer(c); +} +inline void i2cwrite(char c) { + I2Cwrite(&Wire, c); +} #if defined(ULISP_I2C1) -inline void i2c1write (char c) { I2Cwrite(&Wire1, c); } +inline void i2c1write(char c) { + I2Cwrite(&Wire1, c); +} #endif -inline void serial1write (char c) { Serial1.write(c); } -inline void WiFiwrite (char c) { client.write(c); } +inline void serial1write(char c) { + Serial1.write(c); +} +inline void WiFiwrite(char c) { + client.write(c); +} #if defined(sdcardsupport) -inline void SDwrite (char c) { int w = SDpfile.write(c); if (w != 1) { Context = NIL; error2("failed to write to file"); } } +inline void SDwrite(char c) { + int w = SDpfile.write(c); + if (w != 1) { + Context = NIL; + error2("failed to write to file"); + } +} #endif #if defined(gfxsupport) -inline void gfxwrite (char c) { tft.write(c); } +inline void gfxwrite(char c) { + tft.write(c); +} #endif -pfun_t pstreamfun (object* args) { +pfun_t pstreamfun(object* args) { int streamtype = SERIALSTREAM; int address = 0; pfun_t pfun = pserial; if (args != NULL && first(args) != NULL) { int stream = isstream(first(args)); - streamtype = stream>>8; address = stream & 0xFF; + streamtype = stream >> 8; + address = stream & 0xFF; } if (streamtype == I2CSTREAM) { if (address < 128) pfun = i2cwrite; - #if defined(ULISP_I2C1) +#if defined(ULISP_I2C1) else pfun = i2c1write; - #endif - } - else if (streamtype == SPISTREAM) pfun = spiwrite; +#endif + } else if (streamtype == SPISTREAM) pfun = spiwrite; else if (streamtype == SERIALSTREAM) { if (address == 0) pfun = pserial; else if (address == 1) pfun = serial1write; - } - else if (streamtype == STRINGSTREAM) { + } else if (streamtype == STRINGSTREAM) { pfun = pstr; } - #if defined(sdcardsupport) - else if (streamtype == SDSTREAM) pfun = (pfun_t)SDwrite; - #endif - #if defined(gfxsupport) +#if defined(sdcardsupport) + else if (streamtype == SDSTREAM) + pfun = (pfun_t)SDwrite; +#endif +#if defined(gfxsupport) else if (streamtype == GFXSTREAM) pfun = (pfun_t)gfxwrite; - #endif +#endif else if (streamtype == WIFISTREAM) pfun = (pfun_t)WiFiwrite; else error2("unknown stream type"); return pfun; @@ -2231,52 +2459,51 @@ pfun_t pstreamfun (object* args) { // Check pins -void checkanalogread (int pin) { - -// if (!(pin==0 || pin==2 || pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) -// error("invalid pin", number(pin)); - (void)pin; +void checkanalogread(int pin) { + // if (!(pin==0 || pin==2 || pin==4 || (pin>=12 && pin<=15) || (pin>=25 && pin<=27) || (pin>=32 && pin<=36) || pin==39)) + // error("invalid pin", number(pin)); + (void)pin; } -void checkanalogwrite (int pin) { - #ifdef toneimplemented +void checkanalogwrite(int pin) { +#ifdef toneimplemented // ERROR PWM channel unavailable on pin requested! 1 // PWM available on: 2,4,5,12-19,21-23,25-27,32-33 - if (!(pin==2 || pin==4 || pin==5 || (pin>=12 && pin<=19) || (pin>=21 && pin<=23) || (pin>=25 && pin<=27) || pin==32 || pin==33)) error("not a PWM-capable pin", number(pin)); - #else - if (!(pin>=25 && pin<=26)) error("not a DAC pin", number(pin)); - #endif + if (!(pin == 2 || pin == 4 || pin == 5 || (pin >= 12 && pin <= 19) || (pin >= 21 && pin <= 23) || (pin >= 25 && pin <= 27) || pin == 32 || pin == 33)) error("not a PWM-capable pin", number(pin)); +#else + if (!(pin >= 25 && pin <= 26)) error("not a DAC pin", number(pin)); +#endif } // Note -const int scale[] = {4186,4435,4699,4978,5274,5588,5920,6272,6645,7040,7459,7902}; +const int scale[] = { 4186, 4435, 4699, 4978, 5274, 5588, 5920, 6272, 6645, 7040, 7459, 7902 }; -void playnote (int pin, int note, int octave) { - #ifdef toneimplemented - int oct = octave + note/12; +void playnote(int pin, int note, int octave) { +#ifdef toneimplemented + int oct = octave + note / 12; int prescaler = 8 - oct; - if (prescaler<0 || prescaler>8) error("octave out of range", number(prescaler)); - tone(pin, scale[note%12]>>prescaler); - #else + if (prescaler < 0 || prescaler > 8) error("octave out of range", number(prescaler)); + tone((uint8_t)pin, scale[note % 12] >> prescaler); +#else error2("not available"); - #endif +#endif } -void nonote (int pin) { - #ifdef toneimplemented +void nonote(int pin) { +#ifdef toneimplemented noTone(pin); - #else +#else error2("not available"); - #endif +#endif } // Sleep -void initsleep () { } +void initsleep() {} -void doze (int secs) { +void doze(int secs) { delay(1000 * secs); } @@ -2284,10 +2511,10 @@ void doze (int secs) { const int PPINDENT = 2; const int PPWIDTH = 80; -const int GFXPPWIDTH = 52; // 320 pixel wide screen +const int GFXPPWIDTH = 52; // 320 pixel wide screen int ppwidth = PPWIDTH; -void pcount (char c) { +void pcount(char c) { if (c == '\n') PrintCount++; PrintCount++; } @@ -2295,7 +2522,7 @@ void pcount (char c) { /* atomwidth - calculates the character width of an atom */ -uint8_t atomwidth (object* obj) { +uint8_t atomwidth(object* obj) { PrintCount = 0; printobject(obj, pcount); return PrintCount; @@ -2304,7 +2531,7 @@ uint8_t atomwidth (object* obj) { /* basewidth - calculates the character width of an integer printed in a given base */ -uint8_t basewidth (object* obj, uint8_t base) { +uint8_t basewidth(object* obj, uint8_t base) { PrintCount = 0; pintbase(obj->integer, base, pcount); return PrintCount; @@ -2313,17 +2540,17 @@ uint8_t basewidth (object* obj, uint8_t base) { /* quoted - tests whether an object is quoted with the right quote type */ -bool quoted (object* obj, builtin_t which) { +bool quoted(object* obj, builtin_t which) { return (consp(obj) && car(obj) != NULL && car(obj)->name == sym(which) && consp(cdr(obj)) && cddr(obj) == NULL); } /* subwidth - returns the space left from w after printing object */ -int subwidth (object* obj, int w) { +int subwidth(object* obj, int w) { if (atom(obj)) return w - atomwidth(obj); if (quoted(obj, QUOTE) || quoted(obj, BACKQUOTE) || quoted(obj, UNQUOTE) || quoted(obj, UNQUOTE_SPLICING)) { - if (builtin(car(obj)->name) == UNQUOTE_SPLICING) w--; // unquote splicing is 2 chars + if (builtin(car(obj)->name) == UNQUOTE_SPLICING) w--; // unquote splicing is 2 chars obj = car(cdr(obj)); } return subwidthlist(obj, w - 1); @@ -2332,7 +2559,7 @@ int subwidth (object* obj, int w) { /* subwidth - returns the space left from w after printing a list */ -int subwidthlist (object* form, int w) { +int subwidthlist(object* form, int w) { while (form != NULL && w >= 0) { if (atom(form)) return w - (2 + atomwidth(form)); w = subwidth(car(form), w - 1); @@ -2344,37 +2571,53 @@ int subwidthlist (object* form, int w) { /* superprint - handles pretty-printing */ -void superprint (object* form, int lm, pfun_t pfun) { +void superprint(object* form, int lm, pfun_t pfun) { if (atom(form)) { if (symbolp(form) && form->name == sym(NOTHING)) printsymbol(form, pfun); else printobject(form, pfun); - } - else if (quoted(form, QUOTE)) { pfun('\''); superprint(car(cdr(form)), lm + 1, pfun); } - else if (quoted(form, BACKQUOTE)) { pfun('`'); superprint(car(cdr(form)), lm + 1, pfun); } - else if (quoted(form, UNQUOTE)) { pfun(','); superprint(car(cdr(form)), lm + 1, pfun); } - else if (quoted(form, UNQUOTE_SPLICING)) { pfun(','); pfun('@'); superprint(car(cdr(form)), lm + 2, pfun); } - else { + } else if (quoted(form, QUOTE)) { + pfun('\''); + superprint(car(cdr(form)), lm + 1, pfun); + } else if (quoted(form, BACKQUOTE)) { + pfun('`'); + superprint(car(cdr(form)), lm + 1, pfun); + } else if (quoted(form, UNQUOTE)) { + pfun(','); + superprint(car(cdr(form)), lm + 1, pfun); + } else if (quoted(form, UNQUOTE_SPLICING)) { + pfun(','); + pfun('@'); + superprint(car(cdr(form)), lm + 2, pfun); + } else { lm = lm + PPINDENT; bool fits = (subwidth(form, ppwidth - lm - PPINDENT) >= 0); - int special = 0, extra = 0; bool separate = true; + int special = 0, extra = 0; + bool separate = true; object* arg = car(form); if (symbolp(arg) && builtinp(arg->name)) { uint8_t minmax = getminmax(builtin(arg->name)); - if (minmax == 0327 || minmax == 0313) special = 2; // defun, setq, setf, defvar + if (minmax == 0327 || minmax == 0313) special = 2; // defun, setq, setf, defvar else if (minmax == 0317 || minmax == 0017 || minmax == 0117 || minmax == 0123) special = 1; } while (form != NULL) { - if (atom(form)) { pfstring(" . ", pfun); printobject(form, pfun); pfun(')'); return; } - else if (separate) { + if (atom(form)) { + pfstring(" . ", pfun); + printobject(form, pfun); + pfun(')'); + return; + } else if (separate) { pfun('('); separate = false; } else if (special) { pfun(' '); - special--; + special--; } else if (fits) { pfun(' '); - } else { pln(pfun); indent(lm, ' ', pfun); } - superprint(car(form), lm+extra, pfun); + } else { + pln(pfun); + indent(lm, ' ', pfun); + } + superprint(car(form), lm + extra, pfun); form = cdr(form); } pfun(')'); @@ -2385,15 +2628,18 @@ void superprint (object* form, int lm, pfun_t pfun) { edit - the Lisp tree editor Steps through a function definition, editing it a bit at a time, using single-key editing commands. */ -object* edit (object* fun) { +object* edit(object* fun) { while (1) { if (tstflag(EXITEDITOR)) return fun; char c = gserial(); if (c == 'q') setflag(EXITEDITOR); else if (c == 'b') return fun; else if (c == 'r') fun = read(gserial); - else if (c == '\n') { pfl(pserial); superprint(fun, 0, pserial); pln(pserial); } - else if (c == 'c') fun = cons(read(gserial), fun); + else if (c == '\n') { + pfl(pserial); + superprint(fun, 0, pserial); + pln(pserial); + } else if (c == 'c') fun = cons(read(gserial), fun); else if (atom(fun)) pserial('!'); else if (c == 'd') fun = cons(car(fun), edit(cdr(fun))); else if (c == 'a') fun = cons(edit(car(fun)), cdr(fun)); @@ -2404,8 +2650,8 @@ object* edit (object* fun) { // Special forms -object* sp_quote (object* args, object* env) { - (void) env; +object* sp_quote(object* args, object* env) { + (void)env; return first(args); } @@ -2413,7 +2659,7 @@ object* sp_quote (object* args, object* env) { (or item*) Evaluates its arguments until one returns non-nil, and returns its value. */ -object* sp_or (object* args, object* env) { +object* sp_or(object* args, object* env) { while (args != NULL) { object* val = eval(car(args), env); if (val != NULL) return val; @@ -2423,7 +2669,7 @@ object* sp_or (object* args, object* env) { } // Need to do manual search because findvalue() uses eq() but we need equal() for this. -object* find_setf_func (object* whatenv, object* funcname) { +object* find_setf_func(object* whatenv, object* funcname) { object* what = cons(bsymbol(SETF), cons(funcname, nil)); for (object* z = whatenv; z != nil; z = cdr(z)) { object* pair = car(z); @@ -2436,12 +2682,13 @@ object* find_setf_func (object* whatenv, object* funcname) { (defun name (parameters) form*) Defines a function. */ -object* sp_defun (object* args, object* env) { - (void) env; +object* sp_defun(object* args, object* env) { + (void)env; object* var = first(args); if (!symbolp(var)) { // Check for (setf foo) forms - if (consp(var) && listlength(var) == 2 && eq(first(var), bsymbol(SETF))) /* do nothing */; + if (consp(var) && listlength(var) == 2 && eq(first(var), bsymbol(SETF))) /* do nothing */ + ; else error(notasymbol, var); } object* val = cons(bsymbol(LAMBDA), cdr(args)); @@ -2456,12 +2703,16 @@ object* sp_defun (object* args, object* env) { (defvar variable form) Defines a global variable. */ -object* sp_defvar (object* args, object* env) { +object* sp_defvar(object* args, object* env) { object* var = first(args); if (!symbolp(var)) error(notasymbol, var); object* val = NULL; args = cdr(args); - if (args != NULL) { setflag(NOESC); val = eval(first(args), env); clrflag(NOESC); } + if (args != NULL) { + setflag(NOESC); + val = eval(first(args), env); + clrflag(NOESC); + } object* pair = value(var->name, GlobalEnv); if (pair != NULL) cdr(pair) = val; else push(cons(var, val), GlobalEnv); @@ -2472,8 +2723,8 @@ object* sp_defvar (object* args, object* env) { (defmacro name (parameters) form*) Defines a syntactic macro. */ -object* sp_defmacro (object* args, object* env) { - (void) env; +object* sp_defmacro(object* args, object* env) { + (void)env; object* var = first(args); if (!symbolp(var)) error(notasymbol, var); object* val = cons(bsymbol(MACRO), cdr(args)); @@ -2488,7 +2739,7 @@ object* sp_defmacro (object* args, object* env) { For each pair of arguments assigns the value of the second argument to the variable specified in the first argument. */ -object* sp_setq (object* args, object* env) { +object* sp_setq(object* args, object* env) { object* arg = nil; while (args != NULL) { if (cdr(args) == NULL) error2(oddargs); @@ -2505,13 +2756,13 @@ object* sp_setq (object* args, object* env) { Executes its arguments repeatedly until one of the arguments calls (return), which then causes an exit from the loop. */ -object* sp_loop (object* args, object* env) { +object* sp_loop(object* args, object* env) { object* start = args; for (;;) { yield(); args = start; while (args != NULL) { - object* result = eval(car(args),env); + object* result = eval(car(args), env); if (tstflag(RETURNFLAG)) { clrflag(RETURNFLAG); return result; @@ -2525,7 +2776,7 @@ object* sp_loop (object* args, object* env) { (return [value]) Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value. */ -object* fn_return (object* args, object* env) { +object* fn_return(object* args, object* env) { setflag(RETURNFLAG); return args ? first(args) : nil; } @@ -2535,7 +2786,7 @@ object* fn_return (object* args, object* env) { Modifies the value of place, which should be a list, to add item onto the front of the list, and returns the new list. */ -object* sp_push (object* args, object* env) { +object* sp_push(object* args, object* env) { int bit; object* item = eval(first(args), env); object** loc = place(second(args), env, &bit); @@ -2548,7 +2799,7 @@ object* sp_push (object* args, object* env) { (pop place) Modifies the value of place, which should be a non-nil list, to remove its first item, and returns that item. */ -object* sp_pop (object* args, object* env) { +object* sp_pop(object* args, object* env) { int bit; object* arg = first(args); if (arg == NULL) error2(invalidarg); @@ -2567,7 +2818,7 @@ object* sp_pop (object* args, object* env) { Increments a place, which should have an numeric value, and returns the result. The third argument is an optional increment which defaults to 1. */ -object* sp_incf (object* args, object* env) { +object* sp_incf(object* args, object* env) { int bit; object** loc = place(first(args), env, &bit); if (bit < -1) error2(notanumber); @@ -2578,11 +2829,12 @@ object* sp_incf (object* args, object* env) { if (bit != -1) { int increment; - if (inc == NULL) increment = 1; else increment = checkbitvalue(inc); - int newvalue = (((*loc)->integer)>>bit & 1) + increment; + if (inc == NULL) increment = 1; + else increment = checkbitvalue(inc); + int newvalue = (((*loc)->integer) >> bit & 1) + increment; if (newvalue & ~1) error2("result is not a bit value"); - *loc = number((((*loc)->integer) & ~(1<integer) & ~(1 << bit)) | newvalue << bit); return number(newvalue); } @@ -2590,14 +2842,16 @@ object* sp_incf (object* args, object* env) { float increment; float value = checkintfloat(x); - if (inc == NULL) increment = 1.0; else increment = checkintfloat(inc); + if (inc == NULL) increment = 1.0; + else increment = checkintfloat(inc); *loc = makefloat(value + increment); } else if (integerp(x) && (integerp(inc) || inc == NULL)) { int increment; int value = x->integer; - if (inc == NULL) increment = 1; else increment = inc->integer; + if (inc == NULL) increment = 1; + else increment = inc->integer; if (increment < 1) { if (INT_MIN - increment > value) *loc = makefloat((float)value + (float)increment); @@ -2615,7 +2869,7 @@ object* sp_incf (object* args, object* env) { Decrements a place, which should have an numeric value, and returns the result. The third argument is an optional decrement which defaults to 1. */ -object* sp_decf (object* args, object* env) { +object* sp_decf(object* args, object* env) { int bit; object** loc = place(first(args), env, &bit); if (bit < -1) error2(notanumber); @@ -2626,11 +2880,12 @@ object* sp_decf (object* args, object* env) { if (bit != -1) { int decrement; - if (dec == NULL) decrement = 1; else decrement = checkbitvalue(dec); - int newvalue = (((*loc)->integer)>>bit & 1) - decrement; + if (dec == NULL) decrement = 1; + else decrement = checkbitvalue(dec); + int newvalue = (((*loc)->integer) >> bit & 1) - decrement; if (newvalue & ~1) error2("result is not a bit value"); - *loc = number((((*loc)->integer) & ~(1<integer) & ~(1 << bit)) | newvalue << bit); return number(newvalue); } @@ -2638,14 +2893,16 @@ object* sp_decf (object* args, object* env) { float decrement; float value = checkintfloat(x); - if (dec == NULL) decrement = 1.0; else decrement = checkintfloat(dec); + if (dec == NULL) decrement = 1.0; + else decrement = checkintfloat(dec); *loc = makefloat(value - decrement); } else if (integerp(x) && (integerp(dec) || dec == NULL)) { int decrement; int value = x->integer; - if (dec == NULL) decrement = 1; else decrement = dec->integer; + if (dec == NULL) decrement = 1; + else decrement = dec->integer; if (decrement < 1) { if (INT_MAX + decrement < value) *loc = makefloat((float)value - (float)decrement); @@ -2662,7 +2919,7 @@ object* sp_decf (object* args, object* env) { (setf place value [place value]*) For each pair of arguments modifies a place to the result of evaluating value. */ -object* sp_setf (object* args, object* env) { +object* sp_setf(object* args, object* env) { int bit; object* arg = nil; object* placeform = nil; @@ -2684,9 +2941,9 @@ object* sp_setf (object* args, object* env) { arg = eval(second(args), env); loc = place(placeform, env, &bit); if (bit == -1) *loc = arg; - else if (bit < -1) (*loc)->chars = ((*loc)->chars & ~(0xff<<((-bit-2)<<3))) | checkchar(arg)<<((-bit-2)<<3); - else *loc = number((checkinteger(*loc) & ~(1<chars = ((*loc)->chars & ~(0xff << ((-bit - 2) << 3))) | checkchar(arg) << ((-bit - 2) << 3); + else *loc = number((checkinteger(*loc) & ~(1 << bit)) | checkbitvalue(arg) << bit); +next: args = cddr(args); } return arg; @@ -2699,13 +2956,13 @@ object* sp_setf (object* args, object* env) { Sets the local variable var to each element of list in turn, and executes the forms. It then returns result, or nil if result is omitted. */ -object* sp_dolist (object* args, object* env) { +object* sp_dolist(object* args, object* env) { object* params = checkarguments(args, 2, 3); object* var = first(params); object* list = eval(second(params), env); - protect(list); // Don't GC the list - object* pair = cons(var,nil); - push(pair,env); + protect(list); // Don't GC the list + object* pair = cons(var, nil); + push(pair, env); params = cddr(params); args = cdr(args); while (list != NULL) { @@ -2734,15 +2991,15 @@ object* sp_dolist (object* args, object* env) { Executes the forms number times, with the local variable var set to each integer from 0 to number-1 in turn. It then returns result, or nil if result is omitted. */ -object* sp_dotimes (object* args, object* env) { +object* sp_dotimes(object* args, object* env) { if (args == NULL || listlength(first(args)) < 2) error2(noargument); object* params = first(args); object* var = first(params); int count = checkinteger(eval(second(params), env)); int index = 0; params = cddr(params); - object* pair = cons(var,number(0)); - push(pair,env); + object* pair = cons(var, number(0)); + push(pair, env); args = cdr(args); while (index < count) { cdr(pair) = number(index); @@ -2767,7 +3024,7 @@ object* sp_dotimes (object* args, object* env) { Accepts an arbitrary number of iteration vars, which are initialised to init and stepped by step sequentially. The forms are executed until end-test is true. It returns result. */ -object* sp_do (object* args, object* env) { +object* sp_do(object* args, object* env) { return dobody(args, env, false); } @@ -2776,7 +3033,7 @@ object* sp_do (object* args, object* env) { Accepts an arbitrary number of iteration vars, which are initialised to init and stepped by step in parallel. The forms are executed until end-test is true. It returns result. */ -object* sp_dostar (object* args, object* env) { +object* sp_dostar(object* args, object* env) { return dobody(args, env, true); } @@ -2785,8 +3042,8 @@ object* sp_dostar (object* args, object* env) { Turns on tracing of up to TRACEMAX user-defined functions, and returns a list of the functions currently being traced. */ -object* sp_trace (object* args, object* env) { - (void) env; +object* sp_trace(object* args, object* env) { + (void)env; while (args != NULL) { object* var = first(args); if (!symbolp(var)) error(notasymbol, var); @@ -2806,8 +3063,8 @@ object* sp_trace (object* args, object* env) { Turns off tracing of up to TRACEMAX user-defined functions, and returns a list of the functions untraced. If no functions are specified it untraces all functions. */ -object* sp_untrace (object* args, object* env) { - (void) env; +object* sp_untrace(object* args, object* env) { + (void)env; if (args == NULL) { int i = 0; while (i < TRACEMAX) { @@ -2831,7 +3088,7 @@ object* sp_untrace (object* args, object* env) { Executes the forms and then waits until a total of number milliseconds have elapsed. Returns the total number of milliseconds taken. */ -object* sp_formillis (object* args, object* env) { +object* sp_formillis(object* args, object* env) { object* param = checkarguments(args, 0, 1); unsigned long start = millis(); unsigned long now, total = 0; @@ -2850,7 +3107,7 @@ object* sp_formillis (object* args, object* env) { Prints the value returned by the form, and the time taken to evaluate the form in milliseconds or seconds. */ -object* sp_time (object* args, object* env) { +object* sp_time(object* args, object* env) { unsigned long start = millis(); object* result = eval(first(args), env); unsigned long elapsed = millis() - start; @@ -2860,9 +3117,10 @@ object* sp_time (object* args, object* env) { pint(elapsed, pserial); pfstring(" ms\n", pserial); } else { - elapsed = elapsed+50; - pint(elapsed/1000, pserial); - pserial('.'); pint((elapsed/100)%10, pserial); + elapsed = elapsed + 50; + pint(elapsed / 1000, pserial); + pserial('.'); + pint((elapsed / 100) % 10, pserial); pfstring(" s\n", pserial); } return bsymbol(NOTHING); @@ -2872,12 +3130,12 @@ object* sp_time (object* args, object* env) { (with-output-to-string (str) form*) Returns a string containing the output to the stream variable str. */ -object* sp_withoutputtostring (object* args, object* env) { +object* sp_withoutputtostring(object* args, object* env) { object* params = checkarguments(args, 1, 1); if (params == NULL) error2(nostream); object* var = first(params); object* pair = cons(var, stream(STRINGSTREAM, 0)); - push(pair,env); + push(pair, env); object* string = startstring(); protect(string); object* forms = cdr(args); @@ -2891,7 +3149,7 @@ object* sp_withoutputtostring (object* args, object* env) { Evaluates the forms with str bound to a serial-stream using port. The optional baud gives the baud rate divided by 100, default 96. */ -object* sp_withserial (object* args, object* env) { +object* sp_withserial(object* args, object* env) { object* params = checkarguments(args, 2, 3); object* var = first(params); int address = checkinteger(eval(second(params), env)); @@ -2899,7 +3157,7 @@ object* sp_withserial (object* args, object* env) { int baud = 96; if (params != NULL) baud = checkinteger(eval(first(params), env)); object* pair = cons(var, stream(SERIALSTREAM, address)); - push(pair,env); + push(pair, env); serialbegin(address, baud); object* forms = cdr(args); object* result = progn_no_tc(forms, env); @@ -2913,7 +3171,7 @@ object* sp_withserial (object* args, object* env) { If read-p is nil or omitted the stream is written to, otherwise it specifies the number of bytes to be read from the stream. If port is omitted it defaults to 0, otherwise it specifies the port, 0 or 1. */ -object* sp_withi2c (object* args, object* env) { +object* sp_withi2c(object* args, object* env) { object* params = checkarguments(args, 2, 4); object* var = first(params); object* addr = eval(second(params), env); @@ -2923,7 +3181,7 @@ object* sp_withi2c (object* args, object* env) { address = address * 128 + checkinteger(eval(first(params), env)); params = cdr(params); } - int read = 0; // Write + int read = 0; // Write I2Ccount = 0; if (params != NULL) { object* rw = eval(first(params), env); @@ -2931,11 +3189,11 @@ object* sp_withi2c (object* args, object* env) { read = (rw != NULL); } // Top bit of address is I2C port - TwoWire *port = &Wire; - #if defined(ULISP_I2C1) + TwoWire* port = &Wire; +#if defined(ULISP_I2C1) if (address > 127) port = &Wire1; - #endif - I2Cinit(port, 1); // Pullups +#endif + I2Cinit(port, 1); // Pullups object* pair = cons(var, (I2Cstart(port, address & 0x7F, read)) ? stream(I2CSTREAM, address) : nil); push(pair, env); object* forms = cdr(args); @@ -2950,7 +3208,7 @@ object* sp_withi2c (object* args, object* env) { The parameters specify the enable pin, clock in kHz (default 4000), bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0). */ -object* sp_withspi (object* args, object* env) { +object* sp_withspi(object* args, object* env) { object* params = checkarguments(args, 2, 6); object* var = first(params); params = cdr(params); @@ -2959,7 +3217,7 @@ object* sp_withspi (object* args, object* env) { pinMode(pin, OUTPUT); digitalWrite(pin, HIGH); params = cdr(params); - int clock = 4000, mode = SPI_MODE0; // Defaults + int clock = 4000, mode = SPI_MODE0; // Defaults int bitorder = MSBFIRST; if (params != NULL) { clock = checkinteger(eval(car(params), env)); @@ -2969,12 +3227,14 @@ object* sp_withspi (object* args, object* env) { params = cdr(params); if (params != NULL) { int modeval = checkinteger(eval(car(params), env)); - mode = (modeval == 3) ? SPI_MODE3 : (modeval == 2) ? SPI_MODE2 : (modeval == 1) ? SPI_MODE1 : SPI_MODE0; + mode = (modeval == 3) ? SPI_MODE3 : (modeval == 2) ? SPI_MODE2 + : (modeval == 1) ? SPI_MODE1 + : SPI_MODE0; } } } object* pair = cons(var, stream(SPISTREAM, pin)); - push(pair,env); + push(pair, env); SPI.begin(); SPI.beginTransaction(SPISettings(((unsigned long)clock * 1000), bitorder, mode)); digitalWrite(pin, LOW); @@ -2990,7 +3250,7 @@ object* sp_withspi (object* args, object* env) { Evaluates the forms with str bound to an sd-stream reading from or writing to the file filename. If mode is omitted the file is read, otherwise 0 means read, 1 write-append, or 2 write-overwrite. */ -object* sp_withsdcard (object* args, object* env) { +object* sp_withsdcard(object* args, object* env) { #if defined(sdcardsupport) object* params = checkarguments(args, 2, 3); object* var = first(params); @@ -3005,7 +3265,8 @@ object* sp_withsdcard (object* args, object* env) { int mode = 0; if (params != NULL && first(params) != NULL) mode = checkinteger(first(params)); const char* oflag = FILE_READ; - if (mode == 1) oflag = FILE_APPEND; else if (mode == 2) oflag = FILE_WRITE; + if (mode == 1) oflag = FILE_APPEND; + else if (mode == 2) oflag = FILE_WRITE; if (mode >= 1) { char buffer[BUFFERSIZE]; SDpfile = SD.open(MakeFilename(filename, buffer), oflag); @@ -3016,13 +3277,14 @@ object* sp_withsdcard (object* args, object* env) { if (!SDgfile) error("problem reading from SD card or invalid filename", filename); } object* pair = cons(var, stream(SDSTREAM, 1)); - push(pair,env); + push(pair, env); object* forms = cdr(args); object* result = progn_no_tc(forms, env); - if (mode >= 1) SDpfile.close(); else SDgfile.close(); + if (mode >= 1) SDpfile.close(); + else SDgfile.close(); return result; #else - (void) args, (void) env; + (void)args, (void)env; error2("not supported"); return nil; #endif @@ -3034,11 +3296,11 @@ object* sp_withsdcard (object* args, object* env) { (progn form*) Evaluates several forms grouped together into a block, and returns the result of evaluating the last form. */ -object* sp_progn (object* args, object* env) { +object* sp_progn(object* args, object* env) { if (args == NULL) return nil; object* more = cdr(args); while (more != NULL) { - object* result = eval(car(args),env); + object* result = eval(car(args), env); if (tstflag(RETURNFLAG)) return result; args = more; more = cdr(args); @@ -3047,7 +3309,7 @@ object* sp_progn (object* args, object* env) { return car(args); } -object* progn_no_tc (object* args, object* env) { +object* progn_no_tc(object* args, object* env) { object* value = sp_progn(args, env); if (tstflag(TAILCALL)) { clrflag(TAILCALL); @@ -3061,7 +3323,7 @@ object* progn_no_tc (object* args, object* env) { Evaluates test. If it's non-nil the form then is evaluated and returned; otherwise the form else is evaluated and returned. */ -object* sp_if (object* args, object* env) { +object* sp_if(object* args, object* env) { if (args == NULL || cdr(args) == NULL) error2(toofewargs); if (eval(first(args), env) != nil) { setflag(TAILCALL); @@ -3081,7 +3343,7 @@ object* sp_if (object* args, object* env) { If the test evaluates to non-nil the forms are evaluated, and the last value is returned as the result of the cond. If the test evaluates to nil, none of the forms are evaluated, and the next argument is processed in the same way. */ -object* sp_cond (object* args, object* env) { +object* sp_cond(object* args, object* env) { while (args != NULL) { object* clause = first(args); if (!consp(clause)) error(illegalclause, clause); @@ -3100,7 +3362,7 @@ object* sp_cond (object* args, object* env) { (when test form*) Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned. */ -object* sp_when (object* args, object* env) { +object* sp_when(object* args, object* env) { if (args == NULL) error2(noargument); if (eval(first(args), env) != nil) return sp_progn(cdr(args), env); else return nil; @@ -3110,7 +3372,7 @@ object* sp_when (object* args, object* env) { (unless test form*) Evaluates the test. If it's nil the forms are evaluated and the last value is returned. */ -object* sp_unless (object* args, object* env) { +object* sp_unless(object* args, object* env) { if (args == NULL) error2(noargument); if (eval(first(args), env) != nil) return nil; else return sp_progn(cdr(args), env); @@ -3121,7 +3383,7 @@ object* sp_unless (object* args, object* env) { Evaluates a keyform to produce a test key, and then tests this against a series of arguments, each of which is a list containing a key optionally followed by one or more forms. */ -object* sp_case (object* args, object* env) { +object* sp_case(object* args, object* env) { object* test = eval(first(args), env); args = cdr(args); while (args != NULL) { @@ -3131,7 +3393,7 @@ object* sp_case (object* args, object* env) { object* forms = cdr(clause); if (consp(key)) { while (key != NULL) { - if (eq(test,car(key))) return sp_progn(forms, env); + if (eq(test, car(key))) return sp_progn(forms, env); key = cdr(key); } } else if (eq(test, key) || eq(key, tee)) return sp_progn(forms, env); @@ -3144,7 +3406,7 @@ object* sp_case (object* args, object* env) { (and item*) Evaluates its arguments until one returns nil, and returns the last value. */ -object* sp_and (object* args, object* env) { +object* sp_and(object* args, object* env) { if (args == NULL) return tee; object* more = cdr(args); while (more != NULL) { @@ -3162,8 +3424,8 @@ object* sp_and (object* args, object* env) { (not item) Returns t if its argument is nil, or nil otherwise. Equivalent to null. */ -object* fn_not (object* args, object* env) { - (void) env; +object* fn_not(object* args, object* env) { + (void)env; return (first(args) == nil) ? tee : nil; } @@ -3172,8 +3434,8 @@ object* fn_not (object* args, object* env) { If the second argument is a list, cons returns a new list with item added to the front of the list. If the second argument isn't a list cons returns a dotted pair. */ -object* fn_cons (object* args, object* env) { - (void) env; +object* fn_cons(object* args, object* env) { + (void)env; return cons(first(args), second(args)); } @@ -3181,8 +3443,8 @@ object* fn_cons (object* args, object* env) { (atom item) Returns t if its argument is a single number, symbol, or nil. */ -object* fn_atom (object* args, object* env) { - (void) env; +object* fn_atom(object* args, object* env) { + (void)env; return atom(first(args)) ? tee : nil; } @@ -3190,8 +3452,8 @@ object* fn_atom (object* args, object* env) { (listp item) Returns t if its argument is a list. */ -object* fn_listp (object* args, object* env) { - (void) env; +object* fn_listp(object* args, object* env) { + (void)env; return listp(first(args)) ? tee : nil; } @@ -3199,8 +3461,8 @@ object* fn_listp (object* args, object* env) { (consp item) Returns t if its argument is a non-null list. */ -object* fn_consp (object* args, object* env) { - (void) env; +object* fn_consp(object* args, object* env) { + (void)env; return consp(first(args)) ? tee : nil; } @@ -3208,8 +3470,8 @@ object* fn_consp (object* args, object* env) { (symbolp item) Returns t if its argument is a symbol. */ -object* fn_symbolp (object* args, object* env) { - (void) env; +object* fn_symbolp(object* args, object* env) { + (void)env; object* arg = first(args); return (arg == NULL || symbolp(arg)) ? tee : nil; } @@ -3218,8 +3480,8 @@ object* fn_symbolp (object* args, object* env) { (arrayp item) Returns t if its argument is an array. */ -object* fn_arrayp (object* args, object* env) { - (void) env; +object* fn_arrayp(object* args, object* env) { + (void)env; return arrayp(first(args)) ? tee : nil; } @@ -3227,7 +3489,7 @@ object* fn_arrayp (object* args, object* env) { (boundp item) Returns t if its argument is a symbol with a value. */ -object* fn_boundp (object* args, object* env) { +object* fn_boundp(object* args, object* env) { return boundp(first(args), env) ? tee : nil; } @@ -3235,8 +3497,8 @@ object* fn_boundp (object* args, object* env) { (keywordp item) Returns t if its argument is a keyword. */ -object* fn_keywordp (object* args, object* env) { - (void) env; +object* fn_keywordp(object* args, object* env) { + (void)env; if (!symbolp(first(args))) return nil; return keywordp(first(args)) ? tee : nil; } @@ -3245,7 +3507,7 @@ object* fn_keywordp (object* args, object* env) { (set symbol value [symbol value]*) For each pair of arguments, assigns the value of the second argument to the value of the first argument. */ -object* fn_setfn (object* args, object* env) { +object* fn_setfn(object* args, object* env) { object* arg = nil; while (args != NULL) { if (cdr(args) == NULL) error2(oddargs); @@ -3261,8 +3523,8 @@ object* fn_setfn (object* args, object* env) { (streamp item) Returns t if its argument is a stream. */ -object* fn_streamp (object* args, object* env) { - (void) env; +object* fn_streamp(object* args, object* env) { + (void)env; object* arg = first(args); return streamp(arg) ? tee : nil; } @@ -3272,8 +3534,8 @@ object* fn_streamp (object* args, object* env) { Tests whether the two arguments are the same symbol, same character, equal numbers, or point to the same cons, and returns t or nil as appropriate. */ -object* fn_eq (object* args, object* env) { - (void) env; +object* fn_eq(object* args, object* env) { + (void)env; return eq(first(args), second(args)) ? tee : nil; } @@ -3282,8 +3544,8 @@ object* fn_eq (object* args, object* env) { Tests whether the two arguments are the same symbol, same character, equal numbers, or point to the same cons, and returns t or nil as appropriate. */ -object* fn_equal (object* args, object* env) { - (void) env; +object* fn_equal(object* args, object* env) { + (void)env; return equal(first(args), second(args)) ? tee : nil; } @@ -3293,8 +3555,8 @@ object* fn_equal (object* args, object* env) { (car list) Returns the first item in a list. */ -object* fn_car (object* args, object* env) { - (void) env; +object* fn_car(object* args, object* env) { + (void)env; return carx(first(args)); } @@ -3302,24 +3564,24 @@ object* fn_car (object* args, object* env) { (cdr list) Returns a list with the first item removed. */ -object* fn_cdr (object* args, object* env) { - (void) env; +object* fn_cdr(object* args, object* env) { + (void)env; return cdrx(first(args)); } /* (caar list) */ -object* fn_caar (object* args, object* env) { - (void) env; +object* fn_caar(object* args, object* env) { + (void)env; return cxxxr(args, 0b100); } /* (cadr list) */ -object* fn_cadr (object* args, object* env) { - (void) env; +object* fn_cadr(object* args, object* env) { + (void)env; return cxxxr(args, 0b101); } @@ -3327,8 +3589,8 @@ object* fn_cadr (object* args, object* env) { (cdar list) Equivalent to (cdr (car list)). */ -object* fn_cdar (object* args, object* env) { - (void) env; +object* fn_cdar(object* args, object* env) { + (void)env; return cxxxr(args, 0b110); } @@ -3336,8 +3598,8 @@ object* fn_cdar (object* args, object* env) { (cddr list) Equivalent to (cdr (cdr list)). */ -object* fn_cddr (object* args, object* env) { - (void) env; +object* fn_cddr(object* args, object* env) { + (void)env; return cxxxr(args, 0b111); } @@ -3345,8 +3607,8 @@ object* fn_cddr (object* args, object* env) { (caaar list) Equivalent to (car (car (car list))). */ -object* fn_caaar (object* args, object* env) { - (void) env; +object* fn_caaar(object* args, object* env) { + (void)env; return cxxxr(args, 0b1000); } @@ -3354,17 +3616,18 @@ object* fn_caaar (object* args, object* env) { (caadr list) Equivalent to (car (car (cdar list))). */ -object* fn_caadr (object* args, object* env) { - (void) env; - return cxxxr(args, 0b1001);; +object* fn_caadr(object* args, object* env) { + (void)env; + return cxxxr(args, 0b1001); + ; } /* (cadar list) Equivalent to (car (cdr (car list))). */ -object* fn_cadar (object* args, object* env) { - (void) env; +object* fn_cadar(object* args, object* env) { + (void)env; return cxxxr(args, 0b1010); } @@ -3372,8 +3635,8 @@ object* fn_cadar (object* args, object* env) { (caddr list) Equivalent to (car (cdr (cdr list))). */ -object* fn_caddr (object* args, object* env) { - (void) env; +object* fn_caddr(object* args, object* env) { + (void)env; return cxxxr(args, 0b1011); } @@ -3381,8 +3644,8 @@ object* fn_caddr (object* args, object* env) { (cdaar list) Equivalent to (cdar (car (car list))). */ -object* fn_cdaar (object* args, object* env) { - (void) env; +object* fn_cdaar(object* args, object* env) { + (void)env; return cxxxr(args, 0b1100); } @@ -3390,8 +3653,8 @@ object* fn_cdaar (object* args, object* env) { (cdadr list) Equivalent to (cdr (car (cdr list))). */ -object* fn_cdadr (object* args, object* env) { - (void) env; +object* fn_cdadr(object* args, object* env) { + (void)env; return cxxxr(args, 0b1101); } @@ -3399,8 +3662,8 @@ object* fn_cdadr (object* args, object* env) { (cddar list) Equivalent to (cdr (cdr (car list))). */ -object* fn_cddar (object* args, object* env) { - (void) env; +object* fn_cddar(object* args, object* env) { + (void)env; return cxxxr(args, 0b1110); } @@ -3408,8 +3671,8 @@ object* fn_cddar (object* args, object* env) { (cdddr list) Equivalent to (cdr (cdr (cdr list))). */ -object* fn_cdddr (object* args, object* env) { - (void) env; +object* fn_cdddr(object* args, object* env) { + (void)env; return cxxxr(args, 0b1111); } @@ -3417,8 +3680,8 @@ object* fn_cdddr (object* args, object* env) { (length item) Returns the number of items in a list, the length of a string, or the length of a one-dimensional array. */ -object* fn_length (object* args, object* env) { - (void) env; +object* fn_length(object* args, object* env) { + (void)env; object* arg = first(args); if (listp(arg)) return number(listlength(arg)); if (stringp(arg)) return number(stringlength(arg)); @@ -3430,8 +3693,8 @@ object* fn_length (object* args, object* env) { (array-dimensions item) Returns a list of the dimensions of an array. */ -object* fn_arraydimensions (object* args, object* env) { - (void) env; +object* fn_arraydimensions(object* args, object* env) { + (void)env; object* array = first(args); if (!arrayp(array)) error("argument is not an array", array); object* dimensions = cddr(array); @@ -3442,8 +3705,8 @@ object* fn_arraydimensions (object* args, object* env) { (list item*) Returns a list of the values of its arguments. */ -object* fn_list (object* args, object* env) { - (void) env; +object* fn_list(object* args, object* env) { + (void)env; return args; } @@ -3451,15 +3714,16 @@ object* fn_list (object* args, object* env) { (copy-list list) Returns a copy of a list. */ -object* fn_copylist (object* args, object* env) { - (void) env; +object* fn_copylist(object* args, object* env) { + (void)env; object* arg = first(args); if (!listp(arg)) error(notalist, arg); object* result = cons(NULL, NULL); object* ptr = result; while (arg != NULL) { - cdr(ptr) = cons(car(arg), NULL); - ptr = cdr(ptr); arg = cdr(arg); + cdr(ptr) = cons(car(arg), NULL); + ptr = cdr(ptr); + arg = cdr(arg); } return cdr(result); } @@ -3470,8 +3734,8 @@ object* fn_copylist (object* args, object* env) { If size is a list of n integers it creates an n-dimensional array with those dimensions. If :element-type 'bit is specified the array is a bit array. */ -object* fn_makearray (object* args, object* env) { - (void) env; +object* fn_makearray(object* args, object* env) { + (void)env; object* def = nil; bool bitp = false; object* dims = first(args); @@ -3487,7 +3751,7 @@ object* fn_makearray (object* args, object* env) { } if (bitp) { if (def == nil) def = number(0); - else def = number(-checkbitvalue(def)); // 1 becomes all ones + else def = number(-checkbitvalue(def)); // 1 becomes all ones } return makearray(dims, def, bitp); } @@ -3496,13 +3760,13 @@ object* fn_makearray (object* args, object* env) { (reverse list) Returns a list with the elements of list in reverse order. */ -object* fn_reverse (object* args, object* env) { - (void) env; +object* fn_reverse(object* args, object* env) { + (void)env; object* list = first(args); object* result = NULL; while (list != NULL) { if (improperp(list)) error(notproper, list); - push(first(list),result); + push(first(list), result); list = cdr(list); } return result; @@ -3512,8 +3776,8 @@ object* fn_reverse (object* args, object* env) { (nth number list) Returns the nth item in list, counting from zero. */ -object* fn_nth (object* args, object* env) { - (void) env; +object* fn_nth(object* args, object* env) { + (void)env; int n = checkinteger(first(args)); if (n < 0) error(indexnegative, first(args)); object* list = second(args); @@ -3530,14 +3794,14 @@ object* fn_nth (object* args, object* env) { (aref array index [index*]) Returns an element from the specified array. */ -object* fn_aref (object* args, object* env) { - (void) env; +object* fn_aref(object* args, object* env) { + (void)env; int bit; object* array = first(args); if (!arrayp(array)) error("first argument is not an array", array); object* loc = *getarray(array, cdr(args), 0, &bit); if (bit == -1) return loc; - else return number((loc->integer)>>bit & 1); + else return number((loc->integer) >> bit & 1); } /* @@ -3545,8 +3809,8 @@ object* fn_aref (object* args, object* env) { Looks up a key in an association list of (key . value) pairs, using eq or the specified test function, and returns the matching pair, or nil if no pair is found. */ -object* fn_assoc (object* args, object* env) { - (void) env; +object* fn_assoc(object* args, object* env) { + (void)env; object* key = first(args); object* list = second(args); object* test = testargument(cddr(args)); @@ -3565,8 +3829,8 @@ object* fn_assoc (object* args, object* env) { Searches for an item in a list, using eq or the specified test function, and returns the list starting from the first occurrence of the item, or nil if it is not found. */ -object* fn_member (object* args, object* env) { - (void) env; +object* fn_member(object* args, object* env) { + (void)env; object* item = first(args); object* list = second(args); object* test = testargument(cddr(args)); @@ -3582,7 +3846,7 @@ object* fn_member (object* args, object* env) { (apply function list) Returns the result of evaluating function, with the list of arguments specified by the second parameter. */ -object* fn_apply (object* args, object* env) { +object* fn_apply(object* args, object* env) { object* previous = NULL; object* last = args; while (cdr(last) != NULL) { @@ -3599,7 +3863,7 @@ object* fn_apply (object* args, object* env) { (funcall function argument*) Evaluates function with the specified arguments. */ -object* fn_funcall (object* args, object* env) { +object* fn_funcall(object* args, object* env) { return apply(first(args), cdr(args), env); } @@ -3607,8 +3871,8 @@ object* fn_funcall (object* args, object* env) { (append list*) Joins its arguments, which should be lists, into a single list. */ -object* fn_append (object* args, object* env) { - (void) env; +object* fn_append(object* args, object* env) { + (void)env; object* head = NULL; object* tail; while (args != NULL) { @@ -3632,7 +3896,7 @@ object* fn_append (object* args, object* env) { Applies the function to each element in one or more lists, ignoring the results. It returns the first list argument. */ -object* fn_mapc (object* args, object* env) { +object* fn_mapc(object* args, object* env) { return mapcl(args, env, false); } @@ -3641,7 +3905,7 @@ object* fn_mapc (object* args, object* env) { Applies the function to one or more lists and then successive cdrs of those lists, ignoring the results. It returns the first list argument. */ -object* fn_mapl (object* args, object* env) { +object* fn_mapl(object* args, object* env) { return mapcl(args, env, true); } @@ -3649,7 +3913,7 @@ object* fn_mapl (object* args, object* env) { (mapcar function list1 [list]*) Applies the function to each element in one or more lists, and returns the resulting list. */ -object* fn_mapcar (object* args, object* env) { +object* fn_mapcar(object* args, object* env) { return mapcarcan(args, env, mapcarfun, false); } @@ -3658,7 +3922,7 @@ object* fn_mapcar (object* args, object* env) { Applies the function to each element in one or more lists. The results should be lists, and these are destructively nconc'ed together to give the value returned. */ -object* fn_mapcan (object* args, object* env) { +object* fn_mapcan(object* args, object* env) { return mapcarcan(args, env, mapcanfun, false); } @@ -3667,7 +3931,7 @@ object* fn_mapcan (object* args, object* env) { Applies the function to one or more lists and then successive cdrs of those lists, and returns the resulting list. */ -object* fn_maplist (object* args, object* env) { +object* fn_maplist(object* args, object* env) { return mapcarcan(args, env, mapcarfun, true); } @@ -3676,7 +3940,7 @@ object* fn_maplist (object* args, object* env) { Applies the function to one or more lists and then successive cdrs of those lists, and these are destructively concatenated together to give the value returned. */ -object* fn_mapcon (object* args, object* env) { +object* fn_mapcon(object* args, object* env) { return mapcarcan(args, env, mapcanfun, true); } @@ -3688,16 +3952,19 @@ object* fn_mapcon (object* args, object* env) { If each argument is an integer, and the running total doesn't overflow, the result is an integer, otherwise a floating-point number. */ -object* fn_add (object* args, object* env) { - (void) env; +object* fn_add(object* args, object* env) { + (void)env; int result = 0; while (args != NULL) { object* arg = car(args); if (floatp(arg)) return add_floats(args, (float)result); else if (integerp(arg)) { int val = arg->integer; - if (val < 1) { if (INT_MIN - val > result) return add_floats(args, (float)result); } - else { if (INT_MAX - val < result) return add_floats(args, (float)result); } + if (val < 1) { + if (INT_MIN - val > result) return add_floats(args, (float)result); + } else { + if (INT_MAX - val < result) return add_floats(args, (float)result); + } result = result + val; } else error(notanumber, arg); args = cdr(args); @@ -3712,8 +3979,8 @@ object* fn_add (object* args, object* env) { If each argument is an integer, and the running total doesn't overflow, returns the result as an integer, otherwise a floating-point number. */ -object* fn_subtract (object* args, object* env) { - (void) env; +object* fn_subtract(object* args, object* env) { + (void)env; object* arg = car(args); args = cdr(args); if (args == NULL) return negate(arg); @@ -3725,8 +3992,11 @@ object* fn_subtract (object* args, object* env) { if (floatp(arg)) return subtract_floats(args, result); else if (integerp(arg)) { int val = (car(args))->integer; - if (val < 1) { if (INT_MAX + val < result) return subtract_floats(args, result); } - else { if (INT_MIN + val > result) return subtract_floats(args, result); } + if (val < 1) { + if (INT_MAX + val < result) return subtract_floats(args, result); + } else { + if (INT_MIN + val > result) return subtract_floats(args, result); + } result = result - val; } else error(notanumber, arg); args = cdr(args); @@ -3742,10 +4012,10 @@ object* fn_subtract (object* args, object* env) { If each argument is an integer, and the running total doesn't overflow, the result is an integer, otherwise it's a floating-point number. */ -object* fn_multiply (object* args, object* env) { - (void) env; +object* fn_multiply(object* args, object* env) { + (void)env; int result = 1; - while (args != NULL){ + while (args != NULL) { object* arg = car(args); if (floatp(arg)) return multiply_floats(args, result); else if (integerp(arg)) { @@ -3764,8 +4034,8 @@ object* fn_multiply (object* args, object* env) { If each argument is an integer, and each division produces an exact result, the result is an integer; otherwise it's a floating-point number. */ -object* fn_divide (object* args, object* env) { - (void) env; +object* fn_divide(object* args, object* env) { + (void)env; object* arg = first(args); args = cdr(args); // One argument @@ -3808,8 +4078,8 @@ object* fn_divide (object* args, object* env) { Returns its first argument modulo the second argument. If both arguments are integers the result is an integer; otherwise it's a floating-point number. */ -object* fn_mod (object* args, object* env) { - (void) env; +object* fn_mod(object* args, object* env) { + (void)env; object* arg1 = first(args); object* arg2 = second(args); if (integerp(arg1) && integerp(arg2)) { @@ -3817,14 +4087,14 @@ object* fn_mod (object* args, object* env) { if (divisor == 0) error2("division by zero"); int dividend = arg1->integer; int remainder = dividend % divisor; - if ((dividend<0) != (divisor<0)) remainder = remainder + divisor; + if ((dividend < 0) != (divisor < 0)) remainder = remainder + divisor; return number(remainder); } else { float fdivisor = checkintfloat(arg2); if (fdivisor == 0.0) error2("division by zero"); float fdividend = checkintfloat(arg1); - float fremainder = fmod(fdividend , fdivisor); - if ((fdividend<0) != (fdivisor<0)) fremainder = fremainder + fdivisor; + float fremainder = fmod(fdividend, fdivisor); + if ((fdividend < 0) != (fdivisor < 0)) fremainder = fremainder + fdivisor; return makefloat(fremainder); } } @@ -3835,8 +4105,8 @@ object* fn_mod (object* args, object* env) { If the argument is an integer the result is an integer if possible; otherwise it's a floating-point number. */ -object* fn_oneplus (object* args, object* env) { - (void) env; +object* fn_oneplus(object* args, object* env) { + (void)env; object* arg = first(args); if (floatp(arg)) return makefloat((arg->single_float) + 1.0); else if (integerp(arg)) { @@ -3853,8 +4123,8 @@ object* fn_oneplus (object* args, object* env) { If the argument is an integer the result is an integer if possible; otherwise it's a floating-point number. */ -object* fn_oneminus (object* args, object* env) { - (void) env; +object* fn_oneminus(object* args, object* env) { + (void)env; object* arg = first(args); if (floatp(arg)) return makefloat((arg->single_float) - 1.0); else if (integerp(arg)) { @@ -3871,8 +4141,8 @@ object* fn_oneminus (object* args, object* env) { If the argument is an integer the result will be returned as an integer if possible, otherwise a floating-point number. */ -object* fn_abs (object* args, object* env) { - (void) env; +object* fn_abs(object* args, object* env) { + (void)env; object* arg = first(args); if (floatp(arg)) return makefloat(abs(arg->single_float)); else if (integerp(arg)) { @@ -3888,11 +4158,11 @@ object* fn_abs (object* args, object* env) { If number is an integer returns a random number between 0 and one less than its argument. Otherwise returns a floating-point number between zero and number. */ -object* fn_random (object* args, object* env) { - (void) env; +object* fn_random(object* args, object* env) { + (void)env; object* arg = first(args); if (integerp(arg)) return number(random(arg->integer)); - else if (floatp(arg)) return makefloat((float)rand()/(float)(RAND_MAX/(arg->single_float))); + else if (floatp(arg)) return makefloat((float)rand() / (float)(RAND_MAX / (arg->single_float))); else error(notanumber, arg); return nil; } @@ -3901,8 +4171,8 @@ object* fn_random (object* args, object* env) { (max number*) Returns the maximum of one or more arguments. */ -object* fn_maxfn (object* args, object* env) { - (void) env; +object* fn_maxfn(object* args, object* env) { + (void)env; object* result = first(args); args = cdr(args); while (args != NULL) { @@ -3919,8 +4189,8 @@ object* fn_maxfn (object* args, object* env) { (min number*) Returns the minimum of one or more arguments. */ -object* fn_minfn (object* args, object* env) { - (void) env; +object* fn_minfn(object* args, object* env) { + (void)env; object* result = first(args); args = cdr(args); while (args != NULL) { @@ -3939,8 +4209,8 @@ object* fn_minfn (object* args, object* env) { (/= number*) Returns t if none of the arguments are equal, or nil if two or more arguments are equal. */ -object* fn_noteq (object* args, object* env) { - (void) env; +object* fn_noteq(object* args, object* env) { + (void)env; while (args != NULL) { object* nargs = args; object* arg1 = first(nargs); @@ -3961,8 +4231,8 @@ object* fn_noteq (object* args, object* env) { (= number*) Returns t if all the arguments, which must be numbers, are numerically equal, and nil otherwise. */ -object* fn_numeq (object* args, object* env) { - (void) env; +object* fn_numeq(object* args, object* env) { + (void)env; return compare(args, false, false, true); } @@ -3970,8 +4240,8 @@ object* fn_numeq (object* args, object* env) { (< number*) Returns t if each argument is less than the next argument, and nil otherwise. */ -object* fn_less (object* args, object* env) { - (void) env; +object* fn_less(object* args, object* env) { + (void)env; return compare(args, true, false, false); } @@ -3979,8 +4249,8 @@ object* fn_less (object* args, object* env) { (<= number*) Returns t if each argument is less than or equal to the next argument, and nil otherwise. */ -object* fn_lesseq (object* args, object* env) { - (void) env; +object* fn_lesseq(object* args, object* env) { + (void)env; return compare(args, true, false, true); } @@ -3988,8 +4258,8 @@ object* fn_lesseq (object* args, object* env) { (> number*) Returns t if each argument is greater than the next argument, and nil otherwise. */ -object* fn_greater (object* args, object* env) { - (void) env; +object* fn_greater(object* args, object* env) { + (void)env; return compare(args, false, true, false); } @@ -3997,8 +4267,8 @@ object* fn_greater (object* args, object* env) { (>= number*) Returns t if each argument is greater than or equal to the next argument, and nil otherwise. */ -object* fn_greatereq (object* args, object* env) { - (void) env; +object* fn_greatereq(object* args, object* env) { + (void)env; return compare(args, false, true, true); } @@ -4006,8 +4276,8 @@ object* fn_greatereq (object* args, object* env) { (plusp number) Returns t if the argument is greater than zero, or nil otherwise. */ -object* fn_plusp (object* args, object* env) { - (void) env; +object* fn_plusp(object* args, object* env) { + (void)env; object* arg = first(args); if (floatp(arg)) return ((arg->single_float) > 0.0) ? tee : nil; else if (integerp(arg)) return ((arg->integer) > 0) ? tee : nil; @@ -4019,8 +4289,8 @@ object* fn_plusp (object* args, object* env) { (minusp number) Returns t if the argument is less than zero, or nil otherwise. */ -object* fn_minusp (object* args, object* env) { - (void) env; +object* fn_minusp(object* args, object* env) { + (void)env; object* arg = first(args); if (floatp(arg)) return ((arg->single_float) < 0.0) ? tee : nil; else if (integerp(arg)) return ((arg->integer) < 0) ? tee : nil; @@ -4032,8 +4302,8 @@ object* fn_minusp (object* args, object* env) { (zerop number) Returns t if the argument is zero. */ -object* fn_zerop (object* args, object* env) { - (void) env; +object* fn_zerop(object* args, object* env) { + (void)env; object* arg = first(args); if (floatp(arg)) return ((arg->single_float) == 0.0) ? tee : nil; else if (integerp(arg)) return ((arg->integer) == 0) ? tee : nil; @@ -4045,8 +4315,8 @@ object* fn_zerop (object* args, object* env) { (oddp number) Returns t if the integer argument is odd. */ -object* fn_oddp (object* args, object* env) { - (void) env; +object* fn_oddp(object* args, object* env) { + (void)env; int arg = checkinteger(first(args)); return ((arg & 1) == 1) ? tee : nil; } @@ -4055,8 +4325,8 @@ object* fn_oddp (object* args, object* env) { (evenp number) Returns t if the integer argument is even. */ -object* fn_evenp (object* args, object* env) { - (void) env; +object* fn_evenp(object* args, object* env) { + (void)env; int arg = checkinteger(first(args)); return ((arg & 1) == 0) ? tee : nil; } @@ -4067,8 +4337,8 @@ object* fn_evenp (object* args, object* env) { (integerp number) Returns t if the argument is an integer. */ -object* fn_integerp (object* args, object* env) { - (void) env; +object* fn_integerp(object* args, object* env) { + (void)env; return integerp(first(args)) ? tee : nil; } @@ -4076,8 +4346,8 @@ object* fn_integerp (object* args, object* env) { (numberp number) Returns t if the argument is a number. */ -object* fn_numberp (object* args, object* env) { - (void) env; +object* fn_numberp(object* args, object* env) { + (void)env; object* arg = first(args); return (integerp(arg) || floatp(arg)) ? tee : nil; } @@ -4088,8 +4358,8 @@ object* fn_numberp (object* args, object* env) { (float number) Returns its argument converted to a floating-point number. */ -object* fn_floatfn (object* args, object* env) { - (void) env; +object* fn_floatfn(object* args, object* env) { + (void)env; object* arg = first(args); return (floatp(arg)) ? arg : makefloat((float)(arg->integer)); } @@ -4098,8 +4368,8 @@ object* fn_floatfn (object* args, object* env) { (floatp number) Returns t if the argument is a floating-point number. */ -object* fn_floatp (object* args, object* env) { - (void) env; +object* fn_floatp(object* args, object* env) { + (void)env; return floatp(first(args)) ? tee : nil; } @@ -4107,8 +4377,8 @@ object* fn_floatp (object* args, object* env) { (sin number) Returns sin(number). */ -object* fn_sin (object* args, object* env) { - (void) env; +object* fn_sin(object* args, object* env) { + (void)env; return makefloat(sin(checkintfloat(first(args)))); } @@ -4116,8 +4386,8 @@ object* fn_sin (object* args, object* env) { (cos number) Returns cos(number). */ -object* fn_cos (object* args, object* env) { - (void) env; +object* fn_cos(object* args, object* env) { + (void)env; return makefloat(cos(checkintfloat(first(args)))); } @@ -4125,8 +4395,8 @@ object* fn_cos (object* args, object* env) { (tan number) Returns tan(number). */ -object* fn_tan (object* args, object* env) { - (void) env; +object* fn_tan(object* args, object* env) { + (void)env; return makefloat(tan(checkintfloat(first(args)))); } @@ -4134,8 +4404,8 @@ object* fn_tan (object* args, object* env) { (asin number) Returns asin(number). */ -object* fn_asin (object* args, object* env) { - (void) env; +object* fn_asin(object* args, object* env) { + (void)env; return makefloat(asin(checkintfloat(first(args)))); } @@ -4143,8 +4413,8 @@ object* fn_asin (object* args, object* env) { (acos number) Returns acos(number). */ -object* fn_acos (object* args, object* env) { - (void) env; +object* fn_acos(object* args, object* env) { + (void)env; return makefloat(acos(checkintfloat(first(args)))); } @@ -4152,8 +4422,8 @@ object* fn_acos (object* args, object* env) { (atan number1 [number2]) Returns the arc tangent of number1/number2, in radians. If number2 is omitted it defaults to 1. */ -object* fn_atan (object* args, object* env) { - (void) env; +object* fn_atan(object* args, object* env) { + (void)env; object* arg = first(args); float div = 1.0; args = cdr(args); @@ -4165,8 +4435,8 @@ object* fn_atan (object* args, object* env) { (sinh number) Returns sinh(number). */ -object* fn_sinh (object* args, object* env) { - (void) env; +object* fn_sinh(object* args, object* env) { + (void)env; return makefloat(sinh(checkintfloat(first(args)))); } @@ -4174,8 +4444,8 @@ object* fn_sinh (object* args, object* env) { (cosh number) Returns cosh(number). */ -object* fn_cosh (object* args, object* env) { - (void) env; +object* fn_cosh(object* args, object* env) { + (void)env; return makefloat(cosh(checkintfloat(first(args)))); } @@ -4183,8 +4453,8 @@ object* fn_cosh (object* args, object* env) { (tanh number) Returns tanh(number). */ -object* fn_tanh (object* args, object* env) { - (void) env; +object* fn_tanh(object* args, object* env) { + (void)env; return makefloat(tanh(checkintfloat(first(args)))); } @@ -4192,8 +4462,8 @@ object* fn_tanh (object* args, object* env) { (exp number) Returns exp(number). */ -object* fn_exp (object* args, object* env) { - (void) env; +object* fn_exp(object* args, object* env) { + (void)env; return makefloat(exp(checkintfloat(first(args)))); } @@ -4201,8 +4471,8 @@ object* fn_exp (object* args, object* env) { (sqrt number) Returns sqrt(number). */ -object* fn_sqrt (object* args, object* env) { - (void) env; +object* fn_sqrt(object* args, object* env) { + (void)env; return makefloat(sqrt(checkintfloat(first(args)))); } @@ -4210,8 +4480,8 @@ object* fn_sqrt (object* args, object* env) { (log number [base]) Returns the logarithm of number to the specified base. If base is omitted it defaults to e. */ -object* fn_log (object* args, object* env) { - (void) env; +object* fn_log(object* args, object* env) { + (void)env; object* arg = first(args); float fresult = log(checkintfloat(arg)); args = cdr(args); @@ -4225,9 +4495,10 @@ object* fn_log (object* args, object* env) { Returns the result as an integer if the arguments are integers and the result will be within range, otherwise a floating-point number. */ -object* fn_expt (object* args, object* env) { - (void) env; - object* arg1 = first(args); object* arg2 = second(args); +object* fn_expt(object* args, object* env) { + (void)env; + object* arg1 = first(args); + object* arg2 = second(args); float float1 = checkintfloat(arg1); float value = log(abs(float1)) * checkintfloat(arg2); if (integerp(arg1) && integerp(arg2) && ((arg2->integer) >= 0) && (abs(value) < 21.4875)) @@ -4243,8 +4514,8 @@ object* fn_expt (object* args, object* env) { (ceiling number [divisor]) Returns ceil(number/divisor). If omitted, divisor is 1. */ -object* fn_ceiling (object* args, object* env) { - (void) env; +object* fn_ceiling(object* args, object* env) { + (void)env; object* arg = first(args); args = cdr(args); if (args != NULL) return number(ceil(checkintfloat(arg) / checkintfloat(first(args)))); @@ -4255,8 +4526,8 @@ object* fn_ceiling (object* args, object* env) { (floor number [divisor]) Returns floor(number/divisor). If omitted, divisor is 1. */ -object* fn_floor (object* args, object* env) { - (void) env; +object* fn_floor(object* args, object* env) { + (void)env; object* arg = first(args); args = cdr(args); if (args != NULL) return number(floor(checkintfloat(arg) / checkintfloat(first(args)))); @@ -4267,8 +4538,8 @@ object* fn_floor (object* args, object* env) { (truncate number [divisor]) Returns the integer part of number/divisor. If divisor is omitted it defaults to 1. */ -object* fn_truncate (object* args, object* env) { - (void) env; +object* fn_truncate(object* args, object* env) { + (void)env; object* arg = first(args); args = cdr(args); if (args != NULL) return number((int)(checkintfloat(arg) / checkintfloat(first(args)))); @@ -4279,8 +4550,8 @@ object* fn_truncate (object* args, object* env) { (round number [divisor]) Returns the integer closest to number/divisor. If divisor is omitted it defaults to 1. */ -object* fn_round (object* args, object* env) { - (void) env; +object* fn_round(object* args, object* env) { + (void)env; object* arg = first(args); args = cdr(args); if (args != NULL) return number(round(checkintfloat(arg) / checkintfloat(first(args)))); @@ -4293,8 +4564,8 @@ object* fn_round (object* args, object* env) { (char string n) Returns the nth character in a string, counting from zero. */ -object* fn_char (object* args, object* env) { - (void) env; +object* fn_char(object* args, object* env) { + (void)env; object* arg = first(args); if (!stringp(arg)) error(notastring, arg); object* n = second(args); @@ -4307,8 +4578,8 @@ object* fn_char (object* args, object* env) { (char-code character) Returns the ASCII code for a character, as an integer. */ -object* fn_charcode (object* args, object* env) { - (void) env; +object* fn_charcode(object* args, object* env) { + (void)env; return number(checkchar(first(args))); } @@ -4316,8 +4587,8 @@ object* fn_charcode (object* args, object* env) { (code-char integer) Returns the character for the specified ASCII code. */ -object* fn_codechar (object* args, object* env) { - (void) env; +object* fn_codechar(object* args, object* env) { + (void)env; return character(checkinteger(first(args))); } @@ -4325,8 +4596,8 @@ object* fn_codechar (object* args, object* env) { (characterp item) Returns t if the argument is a character and nil otherwise. */ -object* fn_characterp (object* args, object* env) { - (void) env; +object* fn_characterp(object* args, object* env) { + (void)env; return characterp(first(args)) ? tee : nil; } @@ -4336,8 +4607,8 @@ object* fn_characterp (object* args, object* env) { (stringp item) Returns t if the argument is a string and nil otherwise. */ -object* fn_stringp (object* args, object* env) { - (void) env; +object* fn_stringp(object* args, object* env) { + (void)env; return stringp(first(args)) ? tee : nil; } @@ -4345,8 +4616,8 @@ object* fn_stringp (object* args, object* env) { (string= string string) Returns t if the two strings are the same, or nil otherwise. */ -object* fn_stringeq (object* args, object* env) { - (void) env; +object* fn_stringeq(object* args, object* env) { + (void)env; int m = stringcompare(args, false, false, true); return m == -1 ? nil : tee; } @@ -4356,8 +4627,8 @@ object* fn_stringeq (object* args, object* env) { Returns the index to the first mismatch if the first string is alphabetically less than the second string, or nil otherwise. */ -object* fn_stringless (object* args, object* env) { - (void) env; +object* fn_stringless(object* args, object* env) { + (void)env; int m = stringcompare(args, true, false, false); return m == -1 ? nil : number(m); } @@ -4367,8 +4638,8 @@ object* fn_stringless (object* args, object* env) { Returns the index to the first mismatch if the first string is alphabetically greater than the second string, or nil otherwise. */ -object* fn_stringgreater (object* args, object* env) { - (void) env; +object* fn_stringgreater(object* args, object* env) { + (void)env; int m = stringcompare(args, false, true, false); return m == -1 ? nil : number(m); } @@ -4377,10 +4648,10 @@ object* fn_stringgreater (object* args, object* env) { (string/= string string) Returns the index to the first mismatch if the two strings are not the same, or nil otherwise. */ -object* fn_stringnoteq (object* args, object* env) { - (void) env; - int m = stringcompare(args, true, true, false); - return m == -1 ? nil : number(m); +object* fn_stringnoteq(object* args, object* env) { + (void)env; + int m = stringcompare(args, true, true, false); + return m == -1 ? nil : number(m); } /* @@ -4388,8 +4659,8 @@ object* fn_stringnoteq (object* args, object* env) { Returns the index to the first mismatch if the first string is alphabetically less than or equal to the second string, or nil otherwise. */ -object* fn_stringlesseq (object* args, object* env) { - (void) env; +object* fn_stringlesseq(object* args, object* env) { + (void)env; int m = stringcompare(args, true, false, true); return m == -1 ? nil : number(m); } @@ -4399,8 +4670,8 @@ object* fn_stringlesseq (object* args, object* env) { Returns the index to the first mismatch if the first string is alphabetically greater than or equal to the second string, or nil otherwise. */ -object* fn_stringgreatereq (object* args, object* env) { - (void) env; +object* fn_stringgreatereq(object* args, object* env) { + (void)env; int m = stringcompare(args, false, true, true); return m == -1 ? nil : number(m); } @@ -4409,9 +4680,9 @@ object* fn_stringgreatereq (object* args, object* env) { (sort list test) Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list. */ -object* fn_sort (object* args, object* env) { +object* fn_sort(object* args, object* env) { if (first(args) == NULL) return nil; - object* list = cons(nil,first(args)); + object* list = cons(nil, first(args)); protect(list); object* predicate = second(args); object* compare = cons(NULL, cons(NULL, NULL)); @@ -4432,7 +4703,8 @@ object* fn_sort (object* args, object* env) { cdr(go) = obj; } else ptr = cdr(ptr); } - unprotect(); unprotect(); + unprotect(); + unprotect(); return cdr(list); } @@ -4440,7 +4712,7 @@ object* fn_sort (object* args, object* env) { (string item) Converts its argument to a string. */ -object* fn_stringfn (object* args, object* env) { +object* fn_stringfn(object* args, object* env) { return fn_princtostring(args, env); } @@ -4448,8 +4720,8 @@ object* fn_stringfn (object* args, object* env) { (concatenate 'string string*) Joins together the strings given in the second and subsequent arguments, and returns a single string. */ -object* fn_concatenate (object* args, object* env) { - (void) env; +object* fn_concatenate(object* args, object* env) { + (void)env; object* arg = first(args); if (builtin(arg->name) != STRINGFN) error2("only supports strings"); args = cdr(args); @@ -4461,9 +4733,9 @@ object* fn_concatenate (object* args, object* env) { while (obj != NULL) { int quad = obj->chars; while (quad != 0) { - char ch = quad>>((sizeof(int)-1)*8) & 0xFF; - buildstring(ch, &tail); - quad = quad<<8; + char ch = quad >> ((sizeof(int) - 1) * 8) & 0xFF; + buildstring(ch, &tail); + quad = quad << 8; } obj = car(obj); } @@ -4476,30 +4748,35 @@ object* fn_concatenate (object* args, object* env) { (subseq seq start [end]) Returns a subsequence of a list or string from item start to item end-1. */ -object* fn_subseq (object* args, object* env) { - (void) env; +object* fn_subseq(object* args, object* env) { + (void)env; object* arg = first(args); int start = checkinteger(second(args)), end; if (start < 0) error(indexnegative, second(args)); args = cddr(args); if (listp(arg)) { int length = listlength(arg); - if (args != NULL) end = checkinteger(car(args)); else end = length; + if (args != NULL) end = checkinteger(car(args)); + else end = length; if (start > end || end > length) error2(indexrange); object* result = cons(NULL, NULL); object* ptr = result; for (int x = 0; x < end; x++) { - if (x >= start) { cdr(ptr) = cons(car(arg), NULL); ptr = cdr(ptr); } + if (x >= start) { + cdr(ptr) = cons(car(arg), NULL); + ptr = cdr(ptr); + } arg = cdr(arg); } return cdr(result); } else if (stringp(arg)) { int length = stringlength(arg); - if (args != NULL) end = checkinteger(car(args)); else end = length; + if (args != NULL) end = checkinteger(car(args)); + else end = length; if (start > end || end > length) error2(indexrange); object* result = newstring(); object* tail = result; - for (int i=start; i= 0) return number(value << count); @@ -4655,8 +4933,8 @@ object* fn_ash (object* args, object* env) { (logbitp bit value) Returns t if bit number bit in value is a '1', and nil if it is a '0'. */ -object* fn_logbitp (object* args, object* env) { - (void) env; +object* fn_logbitp(object* args, object* env) { + (void)env; int index = checkinteger(first(args)); int value = checkinteger(second(args)); return (bitRead(value, index) == 1) ? tee : nil; @@ -4668,7 +4946,7 @@ object* fn_logbitp (object* args, object* env) { (eval form*) Evaluates its argument an extra time. */ -object* fn_eval (object* args, object* env) { +object* fn_eval(object* args, object* env) { return eval(first(args), env); } @@ -4676,13 +4954,14 @@ object* fn_eval (object* args, object* env) { (globals) Returns a list of global variables. */ -object* fn_globals (object* args, object* env) { - (void) args, (void) env; +object* fn_globals(object* args, object* env) { + (void)args, (void)env; object* result = cons(NULL, NULL); object* ptr = result; object* arg = GlobalEnv; while (arg != NULL) { - cdr(ptr) = cons(car(car(arg)), NULL); ptr = cdr(ptr); + cdr(ptr) = cons(car(car(arg)), NULL); + ptr = cdr(ptr); arg = cdr(arg); } return cdr(result); @@ -4692,8 +4971,8 @@ object* fn_globals (object* args, object* env) { (locals) Returns an association list of local variables and their values. */ -object* fn_locals (object* args, object* env) { - (void) args; +object* fn_locals(object* args, object* env) { + (void)args; return env; } @@ -4701,8 +4980,8 @@ object* fn_locals (object* args, object* env) { (makunbound symbol) Removes the value of the symbol from GlobalEnv and returns the symbol. */ -object* fn_makunbound (object* args, object* env) { - (void) env; +object* fn_makunbound(object* args, object* env) { + (void)env; object* var = first(args); if (!symbolp(var)) error(notasymbol, var); delassoc(var, &GlobalEnv); @@ -4713,8 +4992,8 @@ object* fn_makunbound (object* args, object* env) { (break) Inserts a breakpoint in the program. When evaluated prints Break! and reenters the REPL. */ -object* fn_break (object* args, object* env) { - (void) args; +object* fn_break(object* args, object* env) { + (void)args; pfstring("\nBreak!\n", pserial); BreakLevel++; repl(env); @@ -4727,8 +5006,8 @@ object* fn_break (object* args, object* env) { Reads an atom or list from the serial input and returns it. If stream is specified the item is read from the specified stream. */ -object* fn_read (object* args, object* env) { - (void) env; +object* fn_read(object* args, object* env) { + (void)env; gfun_t gfun = gstreamfun(args); return read(gfun); } @@ -4738,8 +5017,8 @@ object* fn_read (object* args, object* env) { Prints its argument, and returns its value. Strings are printed with quotation marks and escape characters. */ -object* fn_prin1 (object* args, object* env) { - (void) env; +object* fn_prin1(object* args, object* env) { + (void)env; object* obj = first(args); pfun_t pfun = pstreamfun(cdr(args)); printobject(obj, pfun); @@ -4751,8 +5030,8 @@ object* fn_prin1 (object* args, object* env) { Prints its argument with quotation marks and escape characters, on a new line, and followed by a space. If stream is specified the argument is printed to the specified stream. */ -object* fn_print (object* args, object* env) { - (void) env; +object* fn_print(object* args, object* env) { + (void)env; object* obj = first(args); pfun_t pfun = pstreamfun(cdr(args)); pln(pfun); @@ -4766,8 +5045,8 @@ object* fn_print (object* args, object* env) { Prints its argument, and returns its value. Characters and strings are printed without quotation marks or escape characters. */ -object* fn_princ (object* args, object* env) { - (void) env; +object* fn_princ(object* args, object* env) { + (void)env; object* obj = first(args); pfun_t pfun = pstreamfun(cdr(args)); prin1object(obj, pfun); @@ -4779,8 +5058,8 @@ object* fn_princ (object* args, object* env) { Prints a new line, and returns nil. If stream is specified the new line is written to the specified stream. */ -object* fn_terpri (object* args, object* env) { - (void) env; +object* fn_terpri(object* args, object* env) { + (void)env; pfun_t pfun = pstreamfun(args); pln(pfun); return nil; @@ -4790,8 +5069,8 @@ object* fn_terpri (object* args, object* env) { (read-byte stream) Reads a byte from a stream and returns it. */ -object* fn_readbyte (object* args, object* env) { - (void) env; +object* fn_readbyte(object* args, object* env) { + (void)env; gfun_t gfun = gstreamfun(args); int c = gfun(); return (c == -1) ? nil : number(c); @@ -4802,8 +5081,8 @@ object* fn_readbyte (object* args, object* env) { Reads characters from the serial input up to a newline character, and returns them as a string, excluding the newline. If stream is specified the line is read from the specified stream. */ -object* fn_readline (object* args, object* env) { - (void) env; +object* fn_readline(object* args, object* env) { + (void)env; gfun_t gfun = gstreamfun(args); return readstring('\n', false, gfun); } @@ -4812,8 +5091,8 @@ object* fn_readline (object* args, object* env) { (write-byte number [stream]) Writes a byte to a stream. */ -object* fn_writebyte (object* args, object* env) { - (void) env; +object* fn_writebyte(object* args, object* env) { + (void)env; int value = checkinteger(first(args)); pfun_t pfun = pstreamfun(cdr(args)); (pfun)(value); @@ -4824,8 +5103,8 @@ object* fn_writebyte (object* args, object* env) { (write-string string [stream]) Writes a string. If stream is specified the string is written to the stream. */ -object* fn_writestring (object* args, object* env) { - (void) env; +object* fn_writestring(object* args, object* env) { + (void)env; object* obj = first(args); pfun_t pfun = pstreamfun(cdr(args)); flags_t temp = Flags; @@ -4839,8 +5118,8 @@ object* fn_writestring (object* args, object* env) { (write-line string [stream]) Writes a string terminated by a newline character. If stream is specified the string is written to the stream. */ -object* fn_writeline (object* args, object* env) { - (void) env; +object* fn_writeline(object* args, object* env) { + (void)env; object* obj = first(args); pfun_t pfun = pstreamfun(cdr(args)); flags_t temp = Flags; @@ -4857,11 +5136,11 @@ object* fn_writeline (object* args, object* env) { If read-p is nil or omitted the stream is written to. If read-p is an integer it specifies the number of bytes to be read from the stream. */ -object* fn_restarti2c (object* args, object* env) { - (void) env; +object* fn_restarti2c(object* args, object* env) { + (void)env; int stream = isstream(first(args)); args = cdr(args); - int read = 0; // Write + int read = 0; // Write I2Ccount = 0; if (args != NULL) { object* rw = first(args); @@ -4869,12 +5148,12 @@ object* fn_restarti2c (object* args, object* env) { read = (rw != NULL); } int address = stream & 0xFF; - if (stream>>8 != I2CSTREAM) error2("not an i2c stream"); - TwoWire *port; + if (stream >> 8 != I2CSTREAM) error2("not an i2c stream"); + TwoWire* port; if (address < 128) port = &Wire; - #if defined(ULISP_I2C1) +#if defined(ULISP_I2C1) else port = &Wire1; - #endif +#endif return I2Crestart(port, address & 0x7F, read) ? tee : nil; } @@ -4882,7 +5161,7 @@ object* fn_restarti2c (object* args, object* env) { (gc) Forces a garbage collection and prints the number of objects collected, and the time taken. */ -object* fn_gc (object* obj, object* env) { +object* fn_gc(object* obj, object* env) { int initial = Freespace; unsigned long start = micros(); gc(obj, env); @@ -4899,8 +5178,8 @@ object* fn_gc (object* obj, object* env) { (room) Returns the number of free Lisp cells remaining. */ -object* fn_room (object* args, object* env) { - (void) args, (void) env; +object* fn_room(object* args, object* env) { + (void)args, (void)env; return number(Freespace); } @@ -4908,8 +5187,8 @@ object* fn_room (object* args, object* env) { (cls) Prints a clear-screen character. */ -object* fn_cls (object* args, object* env) { - (void) args, (void) env; +object* fn_cls(object* args, object* env) { + (void)args, (void)env; pserial(12); return nil; } @@ -4921,8 +5200,9 @@ object* fn_cls (object* args, object* env) { Sets the input/output mode of an Arduino pin number, and returns nil. The mode parameter can be an integer, a keyword, or t or nil. */ -object* fn_pinmode (object* args, object* env) { - (void) env; int pin; +object* fn_pinmode(object* args, object* env) { + (void)env; + int pin; object* arg = first(args); if (builtin_keywordp(arg)) pin = checkkeyword(arg); else pin = checkinteger(first(args)); @@ -4931,10 +5211,11 @@ object* fn_pinmode (object* args, object* env) { if (builtin_keywordp(arg)) pm = checkkeyword(arg); else if (integerp(arg)) { int mode = arg->integer; - if (mode == 1) pm = OUTPUT; else if (mode == 2) pm = INPUT_PULLUP; - #if defined(INPUT_PULLDOWN) + if (mode == 1) pm = OUTPUT; + else if (mode == 2) pm = INPUT_PULLUP; +#if defined(INPUT_PULLDOWN) else if (mode == 4) pm = INPUT_PULLDOWN; - #endif +#endif } else if (arg != nil) pm = OUTPUT; pinMode(pin, pm); return nil; @@ -4944,21 +5225,22 @@ object* fn_pinmode (object* args, object* env) { (digitalread pin) Reads the state of the specified Arduino pin number and returns t (high) or nil (low). */ -object* fn_digitalread (object* args, object* env) { - (void) env; +object* fn_digitalread(object* args, object* env) { + (void)env; int pin; object* arg = first(args); if (builtin_keywordp(arg)) pin = checkkeyword(arg); else pin = checkinteger(arg); - if (digitalRead(pin) != 0) return tee; else return nil; + if (digitalRead(pin) != 0) return tee; + else return nil; } /* (digitalwrite pin state) Sets the state of the specified Arduino pin number. */ -object* fn_digitalwrite (object* args, object* env) { - (void) env; +object* fn_digitalwrite(object* args, object* env) { + (void)env; int pin; object* arg = first(args); if (builtin_keywordp(arg)) pin = checkkeyword(arg); @@ -4976,8 +5258,8 @@ object* fn_digitalwrite (object* args, object* env) { (analogread pin) Reads the specified Arduino analogue pin number and returns the value. */ -object* fn_analogread (object* args, object* env) { - (void) env; +object* fn_analogread(object* args, object* env) { + (void)env; int pin; object* arg = first(args); if (builtin_keywordp(arg)) pin = checkkeyword(arg); @@ -4993,8 +5275,8 @@ object* fn_analogread (object* args, object* env) { Specifies the resolution for the analogue inputs on platforms that support it. The default resolution on all platforms is 10 bits. */ -object* fn_analogreadresolution (object* args, object* env) { - (void) env; +object* fn_analogreadresolution(object* args, object* env) { + (void)env; object* arg = first(args); analogReadResolution(checkinteger(arg)); return arg; @@ -5004,20 +5286,20 @@ object* fn_analogreadresolution (object* args, object* env) { (analogwrite pin value) Writes the value to the specified Arduino pin number. */ -object* fn_analogwrite (object* args, object* env) { - (void) env; +object* fn_analogwrite(object* args, object* env) { + (void)env; int pin; object* arg = first(args); if (builtin_keywordp(arg)) pin = checkkeyword(arg); else pin = checkinteger(arg); checkanalogwrite(pin); object* value = second(args); - #ifdef toneimplemented +#ifdef toneimplemented analogWrite - #else +#else dacWrite - #endif - (pin, checkinteger(value)); +#endif + (pin, checkinteger(value)); return value; } @@ -5025,12 +5307,13 @@ object* fn_analogwrite (object* args, object* env) { (delay number) Delays for a specified number of milliseconds. */ -object* fn_delay (object* args, object* env) { - (void) env; +object* fn_delay(object* args, object* env) { + (void)env; object* arg1 = first(args); unsigned long start = millis(); unsigned long total = checkinteger(arg1); - do testescape(); while (millis() - start < total); + do testescape(); + while (millis() - start < total); return arg1; } @@ -5038,8 +5321,8 @@ object* fn_delay (object* args, object* env) { (millis) Returns the time in milliseconds that uLisp has been running. */ -object* fn_millis (object* args, object* env) { - (void) args, (void) env; +object* fn_millis(object* args, object* env) { + (void)args, (void)env; return number(millis()); } @@ -5048,8 +5331,8 @@ object* fn_millis (object* args, object* env) { Puts the processor into a low-power sleep mode for secs. Only supported on some platforms. On other platforms it does delay(1000*secs). */ -object* fn_sleep (object* args, object* env) { - (void) env; +object* fn_sleep(object* args, object* env) { + (void)env; object* arg1 = first(args); doze(checkinteger(arg1)); return arg1; @@ -5063,8 +5346,8 @@ object* fn_sleep (object* args, object* env) { The argument octave can be from 3 to 6. If omitted it defaults to 0. When called with no arguments, turns off the PWM on the last-used pin. */ -object* fn_note (object* args, object* env) { - (void) env; +object* fn_note(object* args, object* env) { + (void)env; static int pin = 255; if (args != NULL) { pin = checkinteger(first(args)); @@ -5084,14 +5367,14 @@ object* fn_note (object* args, object* env) { If value is not specified the function returns the value of the register at address. If value is specified the value is written to the register at address and the function returns value. */ -object* fn_register (object* args, object* env) { - (void) env; +object* fn_register(object* args, object* env) { + (void)env; object* arg = first(args); int addr; if (builtin_keywordp(arg)) addr = checkkeyword(arg); else addr = checkinteger(first(args)); - if (cdr(args) == NULL) return number(*(uint32_t *)addr); - (*(uint32_t *)addr) = checkinteger(second(args)); + if (cdr(args) == NULL) return number(*(uint32_t*)addr); + (*(uint32_t*)addr) = checkinteger(second(args)); return second(args); } @@ -5101,7 +5384,7 @@ object* fn_register (object* args, object* env) { (edit 'function) Calls the Lisp tree editor to allow you to edit a function definition. */ -object* fn_edit (object* args, object* env) { +object* fn_edit(object* args, object* env) { object* fun = first(args); object* pair = findvalue(fun, env); clrflag(EXITEDITOR); @@ -5117,13 +5400,13 @@ object* fn_edit (object* args, object* env) { Prints its argument, using the pretty printer, to display it formatted in a structured way. If str is specified it prints to the specified stream. It returns no value. */ -object* fn_pprint (object* args, object* env) { - (void) env; +object* fn_pprint(object* args, object* env) { + (void)env; object* obj = first(args); pfun_t pfun = pstreamfun(cdr(args)); - #if defined(gfxsupport) +#if defined(gfxsupport) if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; - #endif +#endif pln(pfun); superprint(obj, 0, pfun); ppwidth = PPWIDTH; @@ -5135,12 +5418,12 @@ object* fn_pprint (object* args, object* env) { Pretty-prints the definition of every function and variable defined in the uLisp workspace. If str is specified it prints to the specified stream. It returns no value. */ -object* fn_pprintall (object* args, object* env) { - (void) env; +object* fn_pprintall(object* args, object* env) { + (void)env; pfun_t pfun = pstreamfun(args); - #if defined(gfxsupport) +#if defined(gfxsupport) if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; - #endif +#endif object* globals = GlobalEnv; while (globals != NULL) { object* pair = first(globals); @@ -5166,13 +5449,15 @@ object* fn_pprintall (object* args, object* env) { (format output controlstring [arguments]*) Outputs its arguments formatted according to the format directives in controlstring. */ -object* fn_format (object* args, object* env) { - (void) env; +object* fn_format(object* args, object* env) { + (void)env; pfun_t pfun = pserial; object* output = first(args); object* obj; - if (output == nil) { obj = startstring(); pfun = pstr; } - else if (output != tee) pfun = pstreamfun(args); + if (output == nil) { + obj = startstring(); + pfun = pstr; + } else if (output != tee) pfun = pstreamfun(args); object* formatstr = checkstring(second(args)); object* save = NULL; args = cddr(args); @@ -5182,59 +5467,87 @@ object* fn_format (object* args, object* env) { bool tilde = false, mute = false, comma = false, quote = false; while (n < len) { char ch = nthchar(formatstr, n); - char ch2 = ch & ~0x20; // force to upper case + char ch2 = ch & ~0x20; // force to upper case if (tilde) { - if (ch == '}') { + if (ch == '}') { if (save == NULL) formaterr(formatstr, "no matching ~{", n); - if (args == NULL) { args = cdr(save); save = NULL; } else n = bra; - mute = false; tilde = false; - } - else if (!mute) { - if (comma && quote) { pad = ch; comma = false, quote = false; } - else if (ch == '\'') { + if (args == NULL) { + args = cdr(save); + save = NULL; + } else n = bra; + mute = false; + tilde = false; + } else if (!mute) { + if (comma && quote) { + pad = ch; + comma = false, quote = false; + } else if (ch == '\'') { if (comma) quote = true; else formaterr(formatstr, "quote not valid", n); - } - else if (ch == '~') { pfun('~'); tilde = false; } - else if (ch >= '0' && ch <= '9') width = width*10 + ch - '0'; + } else if (ch == '~') { + pfun('~'); + tilde = false; + } else if (ch >= '0' && ch <= '9') width = width * 10 + ch - '0'; else if (ch == ',') comma = true; - else if (ch == '%') { pln(pfun); tilde = false; } - else if (ch == '&') { pfl(pfun); tilde = false; } - else if (ch == '^') { + else if (ch == '%') { + pln(pfun); + tilde = false; + } else if (ch == '&') { + pfl(pfun); + tilde = false; + } else if (ch == '^') { if (save != NULL && args == NULL) mute = true; tilde = false; - } - else if (ch == '{') { + } else if (ch == '{') { if (save != NULL) formaterr(formatstr, "can't nest ~{", n); if (args == NULL) formaterr(formatstr, noargument, n); if (!listp(first(args))) formaterr(formatstr, notalist, n); - save = args; args = first(args); bra = n; tilde = false; + save = args; + args = first(args); + bra = n; + tilde = false; if (args == NULL) mute = true; - } - else if (ch2 == 'A' || ch2 == 'S' || ch2 == 'D' || ch2 == 'G' || ch2 == 'X' || ch2 == 'B') { + } else if (ch2 == 'A' || ch2 == 'S' || ch2 == 'D' || ch2 == 'G' || ch2 == 'X' || ch2 == 'B') { if (args == NULL) formaterr(formatstr, noargument, n); - object* arg = first(args); args = cdr(args); + object* arg = first(args); + args = cdr(args); uint8_t aw = atomwidth(arg); - if (width < aw) w = 0; else w = width-aw; + if (width < aw) w = 0; + else w = width - aw; tilde = false; - if (ch2 == 'A') { prin1object(arg, pfun); indent(w, pad, pfun); } - else if (ch2 == 'S') { printobject(arg, pfun); indent(w, pad, pfun); } - else if (ch2 == 'D' || ch2 == 'G') { indent(w, pad, pfun); prin1object(arg, pfun); } - else if (ch2 == 'X' || ch2 == 'B') { + if (ch2 == 'A') { + prin1object(arg, pfun); + indent(w, pad, pfun); + } else if (ch2 == 'S') { + printobject(arg, pfun); + indent(w, pad, pfun); + } else if (ch2 == 'D' || ch2 == 'G') { + indent(w, pad, pfun); + prin1object(arg, pfun); + } else if (ch2 == 'X' || ch2 == 'B') { if (integerp(arg)) { uint8_t base = (ch2 == 'B') ? 2 : 16; - uint8_t hw = basewidth(arg, base); if (width < hw) w = 0; else w = width-hw; - indent(w, pad, pfun); pintbase(arg->integer, base, pfun); + uint8_t hw = basewidth(arg, base); + if (width < hw) w = 0; + else w = width - hw; + indent(w, pad, pfun); + pintbase(arg->integer, base, pfun); } else { - indent(w, pad, pfun); prin1object(arg, pfun); + indent(w, pad, pfun); + prin1object(arg, pfun); } } tilde = false; } else formaterr(formatstr, "invalid directive", n); } } else { - if (ch == '~') { tilde = true; pad = ' '; width = 0; comma = false; quote = false; } - else if (!mute) pfun(ch); + if (ch == '~') { + tilde = true; + pad = ' '; + width = 0; + comma = false; + quote = false; + } else if (!mute) pfun(ch); } n++; } @@ -5249,7 +5562,7 @@ object* fn_format (object* args, object* env) { Loads the definition of a function defined with defun, or a variable defined with defvar, from the Lisp Library. It returns t if it was loaded, or nil if the symbol is already defined or isn't defined in the Lisp Library. */ -object* fn_require (object* args, object* env) { +object* fn_require(object* args, object* env) { object* arg = first(args); object* globals = GlobalEnv; if (!symbolp(arg)) error(notasymbol, arg); @@ -5277,14 +5590,15 @@ object* fn_require (object* args, object* env) { (list-library) Prints a list of the functions defined in the List Library. */ -object* fn_listlibrary (object* args, object* env) { - (void) args, (void) env; +object* fn_listlibrary(object* args, object* env) { + (void)args, (void)env; GlobalStringIndex = 0; object* line = read(glibrary); while (line != NULL) { builtin_t bname = builtin(first(line)->name); if (bname == DEFUN || bname == DEFVAR) { - printsymbol(second(line), pserial); pserial(' '); + printsymbol(second(line), pserial); + pserial(' '); } line = read(glibrary); } @@ -5297,7 +5611,7 @@ object* fn_listlibrary (object* args, object* env) { (? item) Prints the documentation string of a built-in or user-defined function. */ -object* sp_help (object* args, object* env) { +object* sp_help(object* args, object* env) { if (args == NULL) error2(noargument); object* docstring = documentation(first(args), env); if (docstring) { @@ -5313,7 +5627,7 @@ object* sp_help (object* args, object* env) { (documentation 'symbol [type]) Returns the documentation string of a built-in or user-defined function. The type argument is ignored. */ -object* fn_documentation (object* args, object* env) { +object* fn_documentation(object* args, object* env) { return documentation(first(args), env); } @@ -5321,8 +5635,8 @@ object* fn_documentation (object* args, object* env) { (apropos item) Prints the user-defined and built-in functions whose names contain the specified string or symbol. */ -object* fn_apropos (object* args, object* env) { - (void) env; +object* fn_apropos(object* args, object* env) { + (void)env; apropos(first(args), true); return bsymbol(NOTHING); } @@ -5331,8 +5645,8 @@ object* fn_apropos (object* args, object* env) { (apropos-list item) Returns a list of user-defined and built-in functions whose names contain the specified string or symbol. */ -object* fn_aproposlist (object* args, object* env) { - (void) env; +object* fn_aproposlist(object* args, object* env) { + (void)env; return apropos(first(args), false); } @@ -5343,11 +5657,11 @@ object* fn_aproposlist (object* args, object* env) { Evaluates form1 and forms in order and returns the value of form1, but guarantees to evaluate forms even if an error occurs in form1. */ -object* sp_unwindprotect (object* args, object* env) { +object* sp_unwindprotect(object* args, object* env) { if (args == NULL) error2(toofewargs); object* current_GCStack = GCStack; jmp_buf dynamic_handler; - jmp_buf *previous_handler = handler; + jmp_buf* previous_handler = handler; handler = &dynamic_handler; object* protected_form = first(args); object* result; @@ -5377,10 +5691,10 @@ object* sp_unwindprotect (object* args, object* env) { (ignore-errors [forms]*) Evaluates forms ignoring errors. */ -object* sp_ignoreerrors (object* args, object* env) { +object* sp_ignoreerrors(object* args, object* env) { object* current_GCStack = GCStack; jmp_buf dynamic_handler; - jmp_buf *previous_handler = handler; + jmp_buf* previous_handler = handler; handler = &dynamic_handler; object* result = nil; @@ -5408,12 +5722,13 @@ object* sp_ignoreerrors (object* args, object* env) { (error controlstring [arguments]*) Signals an error. The message is printed by format using the controlstring and arguments. */ -object* sp_error (object* args, object* env) { +object* sp_error(object* args, object* env) { object* message = eval(cons(bsymbol(FORMAT), cons(nil, args)), env); if (!tstflag(MUFFLEERRORS)) { flags_t temp = Flags; clrflag(PRINTREADABLY); - pfstring("Error: ", pserial); printstring(message, pserial); + pfstring("Error: ", pserial); + printstring(message, pserial); Flags = temp; pln(pserial); } @@ -5427,7 +5742,7 @@ object* sp_error (object* args, object* env) { (with-client (str [address port]) form*) Evaluates the forms with str bound to a wifi-stream. */ -object* sp_withclient (object* args, object* env) { +object* sp_withclient(object* args, object* env) { object* params = first(args); object* var = first(params); char buffer[BUFFERSIZE]; @@ -5448,7 +5763,7 @@ object* sp_withclient (object* args, object* env) { n = 1; } object* pair = cons(var, stream(WIFISTREAM, n)); - push(pair,env); + push(pair, env); object* forms = cdr(args); object* result = progn_no_tc(forms, env); client.stop(); @@ -5459,9 +5774,9 @@ object* sp_withclient (object* args, object* env) { (available stream) Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available. */ -object* fn_available (object* args, object* env) { - (void) env; - if (isstream(first(args))>>8 != WIFISTREAM) error2("invalid stream"); +object* fn_available(object* args, object* env) { + (void)env; + if (isstream(first(args)) >> 8 != WIFISTREAM) error2("invalid stream"); return number(client.available()); } @@ -5469,8 +5784,8 @@ object* fn_available (object* args, object* env) { (wifi-server) Starts a Wi-Fi server running. It returns nil. */ -object* fn_wifiserver (object* args, object* env) { - (void) args, (void) env; +object* fn_wifiserver(object* args, object* env) { + (void)args, (void)env; server.begin(); return nil; } @@ -5480,11 +5795,12 @@ object* fn_wifiserver (object* args, object* env) { Set up a soft access point to establish a Wi-Fi network. Returns the IP address as a string or nil if unsuccessful. */ -object* fn_wifisoftap (object* args, object* env) { - (void) env; +object* fn_wifisoftap(object* args, object* env) { + (void)env; char ssid[33], pass[65]; if (args == NULL) return WiFi.softAPdisconnect(true) ? tee : nil; - object* first = first(args); args = cdr(args); + object* first = first(args); + args = cdr(args); if (args == NULL) WiFi.softAP(cstring(first, ssid, 33)); else { object* second = first(args); @@ -5505,9 +5821,9 @@ object* fn_wifisoftap (object* args, object* env) { (connected stream) Returns t or nil to indicate if the client on stream is connected. */ -object* fn_connected (object* args, object* env) { - (void) env; - if (isstream(first(args))>>8 != WIFISTREAM) error2("invalid stream"); +object* fn_connected(object* args, object* env) { + (void)env; + if (isstream(first(args)) >> 8 != WIFISTREAM) error2("invalid stream"); return client.connected() ? tee : nil; } @@ -5515,8 +5831,8 @@ object* fn_connected (object* args, object* env) { (wifi-localip) Returns the IP address of the local network as a string. */ -object* fn_wifilocalip (object* args, object* env) { - (void) args, (void) env; +object* fn_wifilocalip(object* args, object* env) { + (void)args, (void)env; return iptostring(WiFi.localIP()); } @@ -5524,10 +5840,13 @@ object* fn_wifilocalip (object* args, object* env) { (wifi-connect [ssid pass]) Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string. */ -object* fn_wificonnect (object* args, object* env) { - (void) env; +object* fn_wificonnect(object* args, object* env) { + (void)env; char ssid[33], pass[65]; - if (args == NULL) { WiFi.disconnect(true); return nil; } + if (args == NULL) { + WiFi.disconnect(true); + return nil; + } if (cdr(args) == NULL) WiFi.begin(cstring(first(args), ssid, 33)); else WiFi.begin(cstring(first(args), ssid, 33), cstring(second(args), pass, 65)); int result = WiFi.waitForConnectResult(); @@ -5545,17 +5864,17 @@ object* fn_wificonnect (object* args, object* env) { Evaluates the forms with str bound to an gfx-stream so you can print text to the graphics display using the standard uLisp print commands. */ -object* sp_withgfx (object* args, object* env) { +object* sp_withgfx(object* args, object* env) { #if defined(gfxsupport) object* params = checkarguments(args, 1, 1); object* var = first(params); object* pair = cons(var, stream(GFXSTREAM, 1)); - push(pair,env); + push(pair, env); object* forms = cdr(args); object* result = progn_no_tc(forms, env); return result; #else - (void) args, (void) env; + (void)args, (void)env; error2("not supported"); return nil; #endif @@ -5565,15 +5884,15 @@ object* sp_withgfx (object* args, object* env) { (draw-pixel x y [colour]) Draws a pixel at coordinates (x,y) in colour, or white if omitted. */ -object* fn_drawpixel (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_drawpixel(object* args, object* env) { + (void)env; +#if defined(gfxsupport) uint16_t colour = COLOR_WHITE; if (cddr(args) != NULL) colour = checkinteger(third(args)); tft.drawPixel(checkinteger(first(args)), checkinteger(second(args)), colour); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5581,16 +5900,19 @@ object* fn_drawpixel (object* args, object* env) { (draw-line x0 y0 x1 y1 [colour]) Draws a line from (x0,y0) to (x1,y1) in colour, or white if omitted. */ -object* fn_drawline (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_drawline(object* args, object* env) { + (void)env; +#if defined(gfxsupport) uint16_t params[4], colour = COLOR_WHITE; - for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + for (int i = 0; i < 4; i++) { + params[i] = checkinteger(car(args)); + args = cdr(args); + } if (args != NULL) colour = checkinteger(car(args)); tft.drawLine(params[0], params[1], params[2], params[3], colour); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5599,16 +5921,19 @@ object* fn_drawline (object* args, object* env) { Draws an outline rectangle with its top left corner at (x,y), with width w, and with height h. The outline is drawn in colour, or white if omitted. */ -object* fn_drawrect (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_drawrect(object* args, object* env) { + (void)env; +#if defined(gfxsupport) uint16_t params[4], colour = COLOR_WHITE; - for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + for (int i = 0; i < 4; i++) { + params[i] = checkinteger(car(args)); + args = cdr(args); + } if (args != NULL) colour = checkinteger(car(args)); tft.drawRect(params[0], params[1], params[2], params[3], colour); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5617,16 +5942,19 @@ object* fn_drawrect (object* args, object* env) { Draws a filled rectangle with its top left corner at (x,y), with width w, and with height h. The outline is drawn in colour, or white if omitted. */ -object* fn_fillrect (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_fillrect(object* args, object* env) { + (void)env; +#if defined(gfxsupport) uint16_t params[4], colour = COLOR_WHITE; - for (int i=0; i<4; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + for (int i = 0; i < 4; i++) { + params[i] = checkinteger(car(args)); + args = cdr(args); + } if (args != NULL) colour = checkinteger(car(args)); tft.fillRect(params[0], params[1], params[2], params[3], colour); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5635,16 +5963,19 @@ object* fn_fillrect (object* args, object* env) { Draws an outline circle with its centre at (x, y) and with radius r. The circle is drawn in colour, or white if omitted. */ -object* fn_drawcircle (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_drawcircle(object* args, object* env) { + (void)env; +#if defined(gfxsupport) uint16_t params[3], colour = COLOR_WHITE; - for (int i=0; i<3; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + for (int i = 0; i < 3; i++) { + params[i] = checkinteger(car(args)); + args = cdr(args); + } if (args != NULL) colour = checkinteger(car(args)); tft.drawCircle(params[0], params[1], params[2], colour); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5653,16 +5984,19 @@ object* fn_drawcircle (object* args, object* env) { Draws a filled circle with its centre at (x, y) and with radius r. The circle is drawn in colour, or white if omitted. */ -object* fn_fillcircle (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_fillcircle(object* args, object* env) { + (void)env; +#if defined(gfxsupport) uint16_t params[3], colour = COLOR_WHITE; - for (int i=0; i<3; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + for (int i = 0; i < 3; i++) { + params[i] = checkinteger(car(args)); + args = cdr(args); + } if (args != NULL) colour = checkinteger(car(args)); tft.fillCircle(params[0], params[1], params[2], colour); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5671,16 +6005,19 @@ object* fn_fillcircle (object* args, object* env) { Draws an outline rounded rectangle with its top left corner at (x,y), with width w, height h, and corner radius radius. The outline is drawn in colour, or white if omitted. */ -object* fn_drawroundrect (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_drawroundrect(object* args, object* env) { + (void)env; +#if defined(gfxsupport) uint16_t params[5], colour = COLOR_WHITE; - for (int i=0; i<5; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + for (int i = 0; i < 5; i++) { + params[i] = checkinteger(car(args)); + args = cdr(args); + } if (args != NULL) colour = checkinteger(car(args)); tft.drawRoundRect(params[0], params[1], params[2], params[3], params[4], colour); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5689,16 +6026,19 @@ object* fn_drawroundrect (object* args, object* env) { Draws a filled rounded rectangle with its top left corner at (x,y), with width w, height h, and corner radius radius. The outline is drawn in colour, or white if omitted. */ -object* fn_fillroundrect (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_fillroundrect(object* args, object* env) { + (void)env; +#if defined(gfxsupport) uint16_t params[5], colour = COLOR_WHITE; - for (int i=0; i<5; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + for (int i = 0; i < 5; i++) { + params[i] = checkinteger(car(args)); + args = cdr(args); + } if (args != NULL) colour = checkinteger(car(args)); tft.fillRoundRect(params[0], params[1], params[2], params[3], params[4], colour); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5707,16 +6047,19 @@ object* fn_fillroundrect (object* args, object* env) { Draws an outline triangle between (x1,y1), (x2,y2), and (x3,y3). The outline is drawn in colour, or white if omitted. */ -object* fn_drawtriangle (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_drawtriangle(object* args, object* env) { + (void)env; +#if defined(gfxsupport) uint16_t params[6], colour = COLOR_WHITE; - for (int i=0; i<6; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + for (int i = 0; i < 6; i++) { + params[i] = checkinteger(car(args)); + args = cdr(args); + } if (args != NULL) colour = checkinteger(car(args)); tft.drawTriangle(params[0], params[1], params[2], params[3], params[4], params[5], colour); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5725,16 +6068,19 @@ object* fn_drawtriangle (object* args, object* env) { Draws a filled triangle between (x1,y1), (x2,y2), and (x3,y3). The outline is drawn in colour, or white if omitted. */ -object* fn_filltriangle (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_filltriangle(object* args, object* env) { + (void)env; +#if defined(gfxsupport) uint16_t params[6], colour = COLOR_WHITE; - for (int i=0; i<6; i++) { params[i] = checkinteger(car(args)); args = cdr(args); } + for (int i = 0; i < 6; i++) { + params[i] = checkinteger(car(args)); + args = cdr(args); + } if (args != NULL) colour = checkinteger(car(args)); tft.fillTriangle(params[0], params[1], params[2], params[3], params[4], params[5], colour); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5745,9 +6091,9 @@ object* fn_filltriangle (object* args, object* env) { which default to white and black respectively. The character can optionally be scaled by size. */ -object* fn_drawchar (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_drawchar(object* args, object* env) { + (void)env; +#if defined(gfxsupport) uint16_t colour = COLOR_WHITE, bg = COLOR_BLACK, size = 1; object* more = cdr(cddr(args)); if (more != NULL) { @@ -5760,10 +6106,10 @@ object* fn_drawchar (object* args, object* env) { } } tft.drawChar(checkinteger(first(args)), checkinteger(second(args)), checkchar(third(args)), - colour, bg, size); - #else - (void) args; - #endif + colour, bg, size); +#else + (void)args; +#endif return nil; } @@ -5771,13 +6117,13 @@ object* fn_drawchar (object* args, object* env) { (set-cursor x y) Sets the start point for text plotting to (x, y). */ -object* fn_setcursor (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_setcursor(object* args, object* env) { + (void)env; +#if defined(gfxsupport) tft.setCursor(checkinteger(first(args)), checkinteger(second(args))); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5785,14 +6131,14 @@ object* fn_setcursor (object* args, object* env) { (set-text-color colour [background]) Sets the text colour for text plotted using (with-gfx ...). */ -object* fn_settextcolor (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_settextcolor(object* args, object* env) { + (void)env; +#if defined(gfxsupport) if (cdr(args) != NULL) tft.setTextColor(checkinteger(first(args)), checkinteger(second(args))); else tft.setTextColor(checkinteger(first(args))); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5800,13 +6146,13 @@ object* fn_settextcolor (object* args, object* env) { (set-text-size scale) Scales text by the specified size, default 1. */ -object* fn_settextsize (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_settextsize(object* args, object* env) { + (void)env; +#if defined(gfxsupport) tft.setTextSize(checkinteger(first(args))); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5814,13 +6160,13 @@ object* fn_settextsize (object* args, object* env) { (set-text-wrap boolean) Specified whether text wraps at the right-hand edge of the display; the default is t. */ -object* fn_settextwrap (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_settextwrap(object* args, object* env) { + (void)env; +#if defined(gfxsupport) tft.setTextWrap(first(args) != NULL); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5828,15 +6174,15 @@ object* fn_settextwrap (object* args, object* env) { (fill-screen [colour]) Fills or clears the screen with colour, default black. */ -object* fn_fillscreen (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_fillscreen(object* args, object* env) { + (void)env; +#if defined(gfxsupport) uint16_t colour = COLOR_BLACK; if (args != NULL) colour = checkinteger(first(args)); tft.fillScreen(colour); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5844,13 +6190,13 @@ object* fn_fillscreen (object* args, object* env) { (set-rotation option) Sets the display orientation for subsequent graphics commands; values are 0, 1, 2, or 3. */ -object* fn_setrotation (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_setrotation(object* args, object* env) { + (void)env; +#if defined(gfxsupport) tft.setRotation(checkinteger(first(args))); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5858,13 +6204,13 @@ object* fn_setrotation (object* args, object* env) { (invert-display boolean) Mirror-images the display. */ -object* fn_invertdisplay (object* args, object* env) { - (void) env; - #if defined(gfxsupport) +object* fn_invertdisplay(object* args, object* env) { + (void)env; +#if defined(gfxsupport) tft.invertDisplay(first(args) != NULL); - #else - (void) args; - #endif +#else + (void)args; +#endif return nil; } @@ -5875,11 +6221,11 @@ object* fn_invertdisplay (object* args, object* env) { tag, returns the "thrown" value. If none throw, returns the value returned by the last form. */ -object* sp_catch (object* args, object* env) { +object* sp_catch(object* args, object* env) { object* current_GCStack = GCStack; jmp_buf dynamic_handler; - jmp_buf *previous_handler = handler; + jmp_buf* previous_handler = handler; handler = &dynamic_handler; flags_t temp = Flags; @@ -5911,8 +6257,7 @@ object* sp_catch (object* args, object* env) { if (Thrown == NULL) { // Not a (throw) --> propagate the error longjmp(*handler, 1); - } - else if (!eq(car(Thrown), tag)) { + } else if (!eq(car(Thrown), tag)) { // Wrong tag if (tstflag(INCATCH)) { // Try next-in-line catch @@ -5938,7 +6283,7 @@ object* sp_catch (object* args, object* env) { It is an error to call (throw) without first entering a (catch) with the same tag. */ -object* fn_throw (object* args, object* env) { +object* fn_throw(object* args, object* env) { if (!tstflag(INCATCH)) error2("not in a catch"); object* tag = first(args); args = rest(args); @@ -5954,7 +6299,7 @@ object* fn_throw (object* args, object* env) { // see https://github.com/kanaka/mal/blob/master/process/guide.md#step-7-quoting // and https://github.com/kanaka/mal/issues/103#issuecomment-159047401 -object* reverse (object* what) { +object* reverse(object* what) { object* result = NULL; for (; what != NULL; what = cdr(what)) { push(car(what), result); @@ -5962,7 +6307,7 @@ object* reverse (object* what) { return result; } -object* process_backquote (object* arg, size_t level = 0) { +object* process_backquote(object* arg, size_t level = 0) { // "If ast is a map or a symbol, return a list containing: the "quote" symbol, then ast." if (arg == NULL || atom(arg)) return quoteit(QUOTE, arg); // "If ast is a list starting with the "unquote" symbol, return its second element." @@ -5990,7 +6335,8 @@ object* process_backquote (object* arg, size_t level = 0) { // "Else replace the current result with a list containing: // the "cons" symbol, the result of calling quasiquote with // elt as argument, then the previous result." - else result = cons(bsymbol(CONS), cons(process_backquote(element, level), cons(result, nil))); + else + result = cons(bsymbol(CONS), cons(process_backquote(element, level), cons(result, nil))); } return result; } @@ -5999,13 +6345,13 @@ object* process_backquote (object* arg, size_t level = 0) { // but evaluates the result in the current environment before returning it, either by // recursively calling EVAL with the result and env, or by assigning ast with the result // and continuing execution at the top of the loop (TCO)." -object* sp_backquote (object* args, object* env) { +object* sp_backquote(object* args, object* env) { object* result = process_backquote(first(args)); setflag(TAILCALL); return result; } -object* bq_invalid (object* args, object* env) { +object* bq_invalid(object* args, object* env) { (void)args, (void)env; error2("not valid outside backquote"); // unreachable @@ -6015,9 +6361,9 @@ object* bq_invalid (object* args, object* env) { //////////////////////////////////////////////////////////////////////// // MACRO support -bool is_macro_call (object* form, object* env) { +bool is_macro_call(object* form, object* env) { if (form == nil) return false; - CHECK: +CHECK: if (symbolp(car(form))) { object* pair = findpair(car(form), env); if (pair == NULL) return false; @@ -6030,7 +6376,7 @@ bool is_macro_call (object* form, object* env) { return isbuiltin(first(lambda), MACRO); } -object* macroexpand1 (object* form, object* env, bool* done) { +object* macroexpand1(object* form, object* env, bool* done) { if (!is_macro_call(form, env)) { *done = true; return form; @@ -6044,12 +6390,12 @@ object* macroexpand1 (object* form, object* env, bool* done) { return result; } -object* fn_macroexpand1 (object* args, object* env) { +object* fn_macroexpand1(object* args, object* env) { bool dummy; return macroexpand1(first(args), env, &dummy); } -object* macroexpand (object* form, object* env) { +object* macroexpand(object* form, object* env) { bool done = false; protect(form); while (!done) { @@ -6060,7 +6406,7 @@ object* macroexpand (object* form, object* env) { return form; } -object* fn_macroexpand (object* args, object* env) { +object* fn_macroexpand(object* args, object* env) { return macroexpand(first(args), env); } @@ -6324,581 +6670,581 @@ const char stringmacroexpand[] = "macroexpand"; // Documentation strings const char doc0[] = "nil\n" -"A symbol equivalent to the empty list (). Also represents false."; + "A symbol equivalent to the empty list (). Also represents false."; const char doc1[] = "t\n" -"A symbol representing true."; + "A symbol representing true."; const char doc2[] = "nothing\n" -"A symbol with no value.\n" -"It is useful if you want to suppress printing the result of evaluating a function."; + "A symbol with no value.\n" + "It is useful if you want to suppress printing the result of evaluating a function."; const char doc3[] = "&optional\n" -"Can be followed by one or more optional parameters in a lambda or defun parameter list."; + "Can be followed by one or more optional parameters in a lambda or defun parameter list."; const char docfeatures[] = "*features*\n" -"Expands to a list of keywords representing features supported by this platform."; + "Expands to a list of keywords representing features supported by this platform."; const char doc7[] = "&rest\n" -"Can be followed by a parameter in a lambda or defun parameter list,\n" -"and is assigned a list of the corresponding arguments."; + "Can be followed by a parameter in a lambda or defun parameter list,\n" + "and is assigned a list of the corresponding arguments."; const char doc8[] = "(lambda (parameter*) form*)\n" -"Creates an unnamed function with parameters. The body is evaluated with the parameters as local variables\n" -"whose initial values are defined by the values of the forms after the lambda form."; + "Creates an unnamed function with parameters. The body is evaluated with the parameters as local variables\n" + "whose initial values are defined by the values of the forms after the lambda form."; const char docmacro[] = "(macro (parameter*) form*)\n" -"Creates an unnamed lambda-macro with parameters. The body is evaluated with the parameters as local variables\n" -"whose initial values are defined by the values of the forms after the macro form;\n" -"the resultant Lisp code returned is then evaluated again, this time in the scope of where the macro was called."; + "Creates an unnamed lambda-macro with parameters. The body is evaluated with the parameters as local variables\n" + "whose initial values are defined by the values of the forms after the macro form;\n" + "the resultant Lisp code returned is then evaluated again, this time in the scope of where the macro was called."; const char doc9[] = "(let ((var value) ... ) forms*)\n" -"Declares local variables with values, and evaluates the forms with those local variables."; + "Declares local variables with values, and evaluates the forms with those local variables."; const char doc10[] = "(let* ((var value) ... ) forms*)\n" -"Declares local variables with values, and evaluates the forms with those local variables.\n" -"Each declaration can refer to local variables that have been defined earlier in the let*."; + "Declares local variables with values, and evaluates the forms with those local variables.\n" + "Each declaration can refer to local variables that have been defined earlier in the let*."; const char docbackquote[] = "(backquote form) or `form\n" -"Expands the unquotes present in the form as a syntactic template. Most commonly used in macros."; + "Expands the unquotes present in the form as a syntactic template. Most commonly used in macros."; const char docunquote[] = "(unquote form) or ,form\n" -"Marks a form to be evaluated and the value inserted when (backquote) expands the template."; + "Marks a form to be evaluated and the value inserted when (backquote) expands the template."; const char docunquotesplicing[] = "(unquote-splicing form) or ,@form\n" -"Marks a form to be evaluated and the value spliced in when (backquote) expands the template.\n" -"If the value returned when evaluating form is not a proper list (backquote) will bork very badly."; + "Marks a form to be evaluated and the value spliced in when (backquote) expands the template.\n" + "If the value returned when evaluating form is not a proper list (backquote) will bork very badly."; const char doc57[] = "(cons item item)\n" -"If the second argument is a list, cons returns a new list with item added to the front of the list.\n" -"If the second argument isn't a list cons returns a dotted pair."; + "If the second argument is a list, cons returns a new list with item added to the front of the list.\n" + "If the second argument isn't a list cons returns a dotted pair."; const char doc92[] = "(append list*)\n" -"Joins its arguments, which should be lists, into a single list."; + "Joins its arguments, which should be lists, into a single list."; const char doc14[] = "(defun name (parameters) form*)\n" -"Defines a function."; + "Defines a function."; const char doc15[] = "(defvar variable form)\n" -"Defines a global variable."; + "Defines a global variable."; const char docdefmacro[] = "(defmacro name (parameters) form*)\n" -"Defines a syntactic macro."; + "Defines a syntactic macro."; const char doceq[] = "(eq item item)\n" -"Tests whether the two arguments are the same symbol, same character, equal numbers,\n" -"or point to the same cons, and returns t or nil as appropriate."; + "Tests whether the two arguments are the same symbol, same character, equal numbers,\n" + "or point to the same cons, and returns t or nil as appropriate."; const char doc16[] = "(car list)\n" -"Returns the first item in a list."; + "Returns the first item in a list."; const char doc18[] = "(cdr list)\n" -"Returns a list with the first item removed."; + "Returns a list with the first item removed."; const char doc20[] = "(nth number list)\n" -"Returns the nth item in list, counting from zero."; + "Returns the nth item in list, counting from zero."; const char doc21[] = "(aref array index [index*])\n" -"Returns an element from the specified array."; + "Returns an element from the specified array."; const char docchar[] = "(char string n)\n" -"Returns the nth character in a string, counting from zero."; + "Returns the nth character in a string, counting from zero."; const char doc22[] = "(string item)\n" -"Converts its argument to a string."; + "Converts its argument to a string."; const char doc23[] = "(pinmode pin mode)\n" -"Sets the input/output mode of an Arduino pin number, and returns nil.\n" -"The mode parameter can be an integer, a keyword, or t or nil."; + "Sets the input/output mode of an Arduino pin number, and returns nil.\n" + "The mode parameter can be an integer, a keyword, or t or nil."; const char doc24[] = "(digitalwrite pin state)\n" -"Sets the state of the specified Arduino pin number."; + "Sets the state of the specified Arduino pin number."; const char doc25[] = "(analogread pin)\n" -"Reads the specified Arduino analogue pin number and returns the value."; + "Reads the specified Arduino analogue pin number and returns the value."; const char doc26[] = "(register address [value])\n" -"Reads or writes the value of a peripheral register.\n" -"If value is not specified the function returns the value of the register at address.\n" -"If value is specified the value is written to the register at address and the function returns value."; + "Reads or writes the value of a peripheral register.\n" + "If value is not specified the function returns the value of the register at address.\n" + "If value is specified the value is written to the register at address and the function returns value."; const char doc27[] = "(format output controlstring [arguments]*)\n" -"Outputs its arguments formatted according to the format directives in controlstring."; + "Outputs its arguments formatted according to the format directives in controlstring."; const char doc28[] = "(or item*)\n" -"Evaluates its arguments until one returns non-nil, and returns its value."; + "Evaluates its arguments until one returns non-nil, and returns its value."; const char doc29[] = "(setq symbol value [symbol value]*)\n" -"For each pair of arguments assigns the value of the second argument\n" -"to the variable specified in the first argument."; + "For each pair of arguments assigns the value of the second argument\n" + "to the variable specified in the first argument."; const char doc30[] = "(loop forms*)\n" -"Executes its arguments repeatedly until one of the arguments calls (return),\n" -"which then causes an exit from the loop."; + "Executes its arguments repeatedly until one of the arguments calls (return),\n" + "which then causes an exit from the loop."; const char doc31[] = "(return [value])\n" -"Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value."; + "Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value."; const char doc32[] = "(push item place)\n" -"Modifies the value of place, which should be a list, to add item onto the front of the list,\n" -"and returns the new list."; + "Modifies the value of place, which should be a list, to add item onto the front of the list,\n" + "and returns the new list."; const char doc33[] = "(pop place)\n" -"Modifies the value of place, which should be a list, to remove its first item, and returns that item."; + "Modifies the value of place, which should be a list, to remove its first item, and returns that item."; const char doc34[] = "(incf place [number])\n" -"Increments a place, which should have an numeric value, and returns the result.\n" -"The third argument is an optional increment which defaults to 1."; + "Increments a place, which should have an numeric value, and returns the result.\n" + "The third argument is an optional increment which defaults to 1."; const char doc35[] = "(decf place [number])\n" -"Decrements a place, which should have an numeric value, and returns the result.\n" -"The third argument is an optional decrement which defaults to 1."; + "Decrements a place, which should have an numeric value, and returns the result.\n" + "The third argument is an optional decrement which defaults to 1."; const char doc36[] = "(setf place value [place value]*)\n" -"For each pair of arguments modifies a place to the result of evaluating value."; + "For each pair of arguments modifies a place to the result of evaluating value."; const char doc37[] = "(dolist (var list [result]) form*)\n" -"Sets the local variable var to each element of list in turn, and executes the forms.\n" -"It then returns result, or nil if result is omitted."; + "Sets the local variable var to each element of list in turn, and executes the forms.\n" + "It then returns result, or nil if result is omitted."; const char doc38[] = "(dotimes (var number [result]) form*)\n" -"Executes the forms number times, with the local variable var set to each integer from 0 to number-1 in turn.\n" -"It then returns result, or nil if result is omitted."; + "Executes the forms number times, with the local variable var set to each integer from 0 to number-1 in turn.\n" + "It then returns result, or nil if result is omitted."; const char docdo[] PROGMEM = "(do ((var [init [step]])*) (end-test result*) form*)\n" -"Accepts an arbitrary number of iteration vars, which are initialised to init and stepped by step sequentially.\n" -"The forms are executed until end-test is true. It returns result."; + "Accepts an arbitrary number of iteration vars, which are initialised to init and stepped by step sequentially.\n" + "The forms are executed until end-test is true. It returns result."; const char docdostar[] PROGMEM = "(do* ((var [init [step]])*) (end-test result*) form*)\n" -"Accepts an arbitrary number of iteration vars, which are initialised to init and stepped by step in parallel.\n" -"The forms are executed until end-test is true. It returns result."; + "Accepts an arbitrary number of iteration vars, which are initialised to init and stepped by step in parallel.\n" + "The forms are executed until end-test is true. It returns result."; const char doc39[] = "(trace [function]*)\n" -"Turns on tracing of up to " stringify(TRACEMAX) " user-defined functions,\n" -"and returns a list of the functions currently being traced."; + "Turns on tracing of up to " stringify(TRACEMAX) " user-defined functions,\n" + "and returns a list of the functions currently being traced."; const char doc40[] = "(untrace [function]*)\n" -"Turns off tracing of up to " stringify(TRACEMAX) " user-defined functions, and returns a list of the functions untraced.\n" -"If no functions are specified it untraces all functions."; + "Turns off tracing of up to " stringify(TRACEMAX) " user-defined functions, and returns a list of the functions untraced.\n" + "If no functions are specified it untraces all functions."; const char doc41[] = "(for-millis ([number]) form*)\n" -"Executes the forms and then waits until a total of number milliseconds have elapsed.\n" -"Returns the total number of milliseconds taken."; + "Executes the forms and then waits until a total of number milliseconds have elapsed.\n" + "Returns the total number of milliseconds taken."; const char doc42[] = "(time form)\n" -"Prints the value returned by the form, and the time taken to evaluate the form\n" -"in milliseconds or seconds."; + "Prints the value returned by the form, and the time taken to evaluate the form\n" + "in milliseconds or seconds."; const char doc43[] = "(with-output-to-string (str) form*)\n" -"Returns a string containing the output to the stream variable str."; + "Returns a string containing the output to the stream variable str."; const char doc44[] = "(with-serial (str port [baud]) form*)\n" -"Evaluates the forms with str bound to a serial-stream using port.\n" -"The optional baud gives the baud rate divided by 100, default 96."; + "Evaluates the forms with str bound to a serial-stream using port.\n" + "The optional baud gives the baud rate divided by 100, default 96."; const char doc45[] = "(with-i2c (str [port] address [read-p]) form*)\n" -"Evaluates the forms with str bound to an i2c-stream defined by address.\n" -"If read-p is nil or omitted the stream is written to, otherwise it specifies the number of bytes\n" -"to be read from the stream. The port if specified is ignored."; + "Evaluates the forms with str bound to an i2c-stream defined by address.\n" + "If read-p is nil or omitted the stream is written to, otherwise it specifies the number of bytes\n" + "to be read from the stream. The port if specified is ignored."; const char doc46[] = "(with-spi (str pin [clock] [bitorder] [mode]) form*)\n" -"Evaluates the forms with str bound to an spi-stream.\n" -"The parameters specify the enable pin, clock in kHz (default 4000),\n" -"bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0)."; + "Evaluates the forms with str bound to an spi-stream.\n" + "The parameters specify the enable pin, clock in kHz (default 4000),\n" + "bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0)."; const char doc47[] = "(with-sd-card (str filename [mode]) form*)\n" -"Evaluates the forms with str bound to an sd-stream reading from or writing to the file filename.\n" -"If mode is omitted the file is read, otherwise 0 means read, 1 write-append, or 2 write-overwrite."; + "Evaluates the forms with str bound to an sd-stream reading from or writing to the file filename.\n" + "If mode is omitted the file is read, otherwise 0 means read, 1 write-append, or 2 write-overwrite."; const char doc48[] = "(progn form*)\n" -"Evaluates several forms grouped together into a block, and returns the result of evaluating the last form."; + "Evaluates several forms grouped together into a block, and returns the result of evaluating the last form."; const char doc49[] = "(if test then [else])\n" -"Evaluates test. If it's non-nil the form then is evaluated and returned;\n" -"otherwise the form else is evaluated and returned."; + "Evaluates test. If it's non-nil the form then is evaluated and returned;\n" + "otherwise the form else is evaluated and returned."; const char doc50[] = "(cond ((test form*) (test form*) ... ))\n" -"Each argument is a list consisting of a test optionally followed by one or more forms.\n" -"If the test evaluates to non-nil the forms are evaluated, and the last value is returned as the result of the cond.\n" -"If the test evaluates to nil, none of the forms are evaluated, and the next argument is processed in the same way."; + "Each argument is a list consisting of a test optionally followed by one or more forms.\n" + "If the test evaluates to non-nil the forms are evaluated, and the last value is returned as the result of the cond.\n" + "If the test evaluates to nil, none of the forms are evaluated, and the next argument is processed in the same way."; const char doc51[] = "(when test form*)\n" -"Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned."; + "Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned."; const char doc52[] = "(unless test form*)\n" -"Evaluates the test. If it's nil the forms are evaluated and the last value is returned."; + "Evaluates the test. If it's nil the forms are evaluated and the last value is returned."; const char doc53[] = "(case keyform ((key form*) (key form*) ... ))\n" -"Evaluates a keyform to produce a test key, and then tests this against a series of arguments,\n" -"each of which is a list containing a key optionally followed by one or more forms."; + "Evaluates a keyform to produce a test key, and then tests this against a series of arguments,\n" + "each of which is a list containing a key optionally followed by one or more forms."; const char doc54[] = "(and item*)\n" -"Evaluates its arguments until one returns nil, and returns the last value."; + "Evaluates its arguments until one returns nil, and returns the last value."; const char doc55[] = "(not item)\n" -"Returns t if its argument is nil, or nil otherwise. Equivalent to null."; + "Returns t if its argument is nil, or nil otherwise. Equivalent to null."; const char doc58[] = "(atom item)\n" -"Returns t if its argument is a single number, symbol, or nil."; + "Returns t if its argument is a single number, symbol, or nil."; const char doc59[] = "(listp item)\n" -"Returns t if its argument is a list."; + "Returns t if its argument is a list."; const char doc60[] = "(consp item)\n" -"Returns t if its argument is a non-null list."; + "Returns t if its argument is a non-null list."; const char doc61[] = "(symbolp item)\n" -"Returns t if its argument is a symbol."; + "Returns t if its argument is a symbol."; const char doc62[] = "(arrayp item)\n" -"Returns t if its argument is an array."; + "Returns t if its argument is an array."; const char doc63[] = "(boundp item)\n" -"Returns t if its argument is a symbol with a value."; + "Returns t if its argument is a symbol with a value."; const char doc64[] = "(keywordp item)\n" -"Returns t if its argument is a built-in or user-defined keyword."; + "Returns t if its argument is a built-in or user-defined keyword."; const char doc65[] = "(set symbol value [symbol value]*)\n" -"For each pair of arguments, assigns the value of the second argument to the value of the first argument."; + "For each pair of arguments, assigns the value of the second argument to the value of the first argument."; const char doc66[] = "(streamp item)\n" -"Returns t if its argument is a stream."; + "Returns t if its argument is a stream."; const char doc67[] = "(eq item item)\n" -"Tests whether the two arguments are the same symbol, same character, equal numbers,\n" -"or point to the same cons, and returns t or nil as appropriate."; + "Tests whether the two arguments are the same symbol, same character, equal numbers,\n" + "or point to the same cons, and returns t or nil as appropriate."; const char doc68[] = "(equal item item)\n" -"Tests whether the two arguments are the same symbol, same character, equal numbers,\n" -"or point to the same cons, and returns t or nil as appropriate."; + "Tests whether the two arguments are the same symbol, same character, equal numbers,\n" + "or point to the same cons, and returns t or nil as appropriate."; const char doc69[] = "(caar list)"; const char doc70[] = "(cadr list)"; const char doc72[] = "(cdar list)\n" -"Equivalent to (cdr (car list))."; + "Equivalent to (cdr (car list))."; const char doc73[] = "(cddr list)\n" -"Equivalent to (cdr (cdr list))."; + "Equivalent to (cdr (cdr list))."; const char doc74[] = "(caaar list)\n" -"Equivalent to (car (car (car list)))."; + "Equivalent to (car (car (car list)))."; const char doc75[] = "(caadr list)\n" -"Equivalent to (car (car (cdar list)))."; + "Equivalent to (car (car (cdar list)))."; const char doc76[] = "(cadar list)\n" -"Equivalent to (car (cdr (car list)))."; + "Equivalent to (car (cdr (car list)))."; const char doc77[] = "(caddr list)\n" -"Equivalent to (car (cdr (cdr list)))."; + "Equivalent to (car (cdr (cdr list)))."; const char doc79[] = "(cdaar list)\n" -"Equivalent to (cdar (car (car list)))."; + "Equivalent to (cdar (car (car list)))."; const char doc80[] = "(cdadr list)\n" -"Equivalent to (cdr (car (cdr list)))."; + "Equivalent to (cdr (car (cdr list)))."; const char doc81[] = "(cddar list)\n" -"Equivalent to (cdr (cdr (car list)))."; + "Equivalent to (cdr (cdr (car list)))."; const char doc82[] = "(cdddr list)\n" -"Equivalent to (cdr (cdr (cdr list)))."; + "Equivalent to (cdr (cdr (cdr list)))."; const char doc83[] = "(length item)\n" -"Returns the number of items in a list, the length of a string, or the length of a one-dimensional array."; + "Returns the number of items in a list, the length of a string, or the length of a one-dimensional array."; const char doc84[] = "(array-dimensions item)\n" -"Returns a list of the dimensions of an array."; + "Returns a list of the dimensions of an array."; const char doc85[] = "(list item*)\n" -"Returns a list of the values of its arguments."; + "Returns a list of the values of its arguments."; const char doccopylist[] = "(copy-list list)\n" -"Returns a copy of a list."; + "Returns a copy of a list."; const char doc86[] = "(make-array size [:initial-element element] [:element-type 'bit])\n" -"If size is an integer it creates a one-dimensional array with elements from 0 to size-1.\n" -"If size is a list of n integers it creates an n-dimensional array with those dimensions.\n" -"If :element-type 'bit is specified the array is a bit array."; + "If size is an integer it creates a one-dimensional array with elements from 0 to size-1.\n" + "If size is a list of n integers it creates an n-dimensional array with those dimensions.\n" + "If :element-type 'bit is specified the array is a bit array."; const char doc87[] = "(reverse list)\n" -"Returns a list with the elements of list in reverse order."; + "Returns a list with the elements of list in reverse order."; const char doc88[] = "(assoc key list [:test function])\n" -"Looks up a key in an association list of (key . value) pairs, using eq or the specified test function,\n" -"and returns the matching pair, or nil if no pair is found."; + "Looks up a key in an association list of (key . value) pairs, using eq or the specified test function,\n" + "and returns the matching pair, or nil if no pair is found."; const char doc89[] = "(member item list [:test function])\n" -"Searches for an item in a list, using eq or the specified test function, and returns the list starting\n" -"or nil if it is not found."; + "Searches for an item in a list, using eq or the specified test function, and returns the list starting\n" + "or nil if it is not found."; const char doc90[] = "(apply function list)\n" -"Returns the result of evaluating function, with the list of arguments specified by the second parameter."; + "Returns the result of evaluating function, with the list of arguments specified by the second parameter."; const char doc91[] = "(funcall function argument*)\n" -"Evaluates function with the specified arguments."; + "Evaluates function with the specified arguments."; const char doc93[] = "(mapc function list1 [list]*)\n" -"Applies the function to each element in one or more lists, ignoring the results.\n" -"It returns the first list argument."; + "Applies the function to each element in one or more lists, ignoring the results.\n" + "It returns the first list argument."; const char docmapl[] = "(mapl function list1 [list]*)\n" -"Applies the function to one or more lists and then successive cdrs of those lists,\n" -"ignoring the results. It returns the first list argument."; + "Applies the function to one or more lists and then successive cdrs of those lists,\n" + "ignoring the results. It returns the first list argument."; const char doc94[] = "(mapcar function list1 [list]*)\n" -"Applies the function to each element in one or more lists, and returns the resulting list."; + "Applies the function to each element in one or more lists, and returns the resulting list."; const char doc95[] = "(mapcan function list1 [list]*)\n" -"Applies the function to each element in one or more lists. The results should be lists,\n" -"and these are destructively nconc'ed together to give the value returned."; + "Applies the function to each element in one or more lists. The results should be lists,\n" + "and these are destructively nconc'ed together to give the value returned."; const char docmaplist[] = "(maplist function list1 [list]*)\n" -"Applies the function to one or more lists and then successive cdrs of those lists,\n" -"and returns the resulting list."; + "Applies the function to one or more lists and then successive cdrs of those lists,\n" + "and returns the resulting list."; const char docmapcon[] = "(mapcon function list1 [list]*)\n" -"Applies the function to one or more lists and then successive cdrs of those lists,\n" -"and these are destructively concatenated together to give the value returned."; + "Applies the function to one or more lists and then successive cdrs of those lists,\n" + "and these are destructively concatenated together to give the value returned."; const char doc96[] = "(+ number*)\n" -"Adds its arguments together.\n" -"If each argument is an integer, and the running total doesn't overflow, the result is an integer,\n" -"otherwise a floating-point number."; + "Adds its arguments together.\n" + "If each argument is an integer, and the running total doesn't overflow, the result is an integer,\n" + "otherwise a floating-point number."; const char doc97[] = "(- number*)\n" -"If there is one argument, negates the argument.\n" -"If there are two or more arguments, subtracts the second and subsequent arguments from the first argument.\n" -"If each argument is an integer, and the running total doesn't overflow, returns the result as an integer,\n" -"otherwise a floating-point number."; + "If there is one argument, negates the argument.\n" + "If there are two or more arguments, subtracts the second and subsequent arguments from the first argument.\n" + "If each argument is an integer, and the running total doesn't overflow, returns the result as an integer,\n" + "otherwise a floating-point number."; const char doc98[] = "(* number*)\n" -"Multiplies its arguments together.\n" -"If each argument is an integer, and the running total doesn't overflow, the result is an integer,\n" -"otherwise it's a floating-point number."; + "Multiplies its arguments together.\n" + "If each argument is an integer, and the running total doesn't overflow, the result is an integer,\n" + "otherwise it's a floating-point number."; const char doc99[] = "(/ number*)\n" -"Divides the first argument by the second and subsequent arguments.\n" -"If each argument is an integer, and each division produces an exact result, the result is an integer;\n" -"otherwise it's a floating-point number."; + "Divides the first argument by the second and subsequent arguments.\n" + "If each argument is an integer, and each division produces an exact result, the result is an integer;\n" + "otherwise it's a floating-point number."; const char doc100[] = "(mod number number)\n" -"Returns its first argument modulo the second argument.\n" -"If both arguments are integers the result is an integer; otherwise it's a floating-point number."; + "Returns its first argument modulo the second argument.\n" + "If both arguments are integers the result is an integer; otherwise it's a floating-point number."; const char doc101[] = "(1+ number)\n" -"Adds one to its argument and returns it.\n" -"If the argument is an integer the result is an integer if possible;\n" -"otherwise it's a floating-point number."; + "Adds one to its argument and returns it.\n" + "If the argument is an integer the result is an integer if possible;\n" + "otherwise it's a floating-point number."; const char doc102[] = "(1- number)\n" -"Subtracts one from its argument and returns it.\n" -"If the argument is an integer the result is an integer if possible;\n" -"otherwise it's a floating-point number."; + "Subtracts one from its argument and returns it.\n" + "If the argument is an integer the result is an integer if possible;\n" + "otherwise it's a floating-point number."; const char doc103[] = "(abs number)\n" -"Returns the absolute, positive value of its argument.\n" -"If the argument is an integer the result will be returned as an integer if possible,\n" -"otherwise a floating-point number."; + "Returns the absolute, positive value of its argument.\n" + "If the argument is an integer the result will be returned as an integer if possible,\n" + "otherwise a floating-point number."; const char doc104[] = "(random number)\n" -"If number is an integer returns a random number between 0 and one less than its argument.\n" -"Otherwise returns a floating-point number between zero and number."; + "If number is an integer returns a random number between 0 and one less than its argument.\n" + "Otherwise returns a floating-point number between zero and number."; const char doc105[] = "(max number*)\n" -"Returns the maximum of one or more arguments."; + "Returns the maximum of one or more arguments."; const char doc106[] = "(min number*)\n" -"Returns the minimum of one or more arguments."; + "Returns the minimum of one or more arguments."; const char doc107[] = "(/= number*)\n" -"Returns t if none of the arguments are equal, or nil if two or more arguments are equal."; + "Returns t if none of the arguments are equal, or nil if two or more arguments are equal."; const char doc108[] = "(= number*)\n" -"Returns t if all the arguments, which must be numbers, are numerically equal, and nil otherwise."; + "Returns t if all the arguments, which must be numbers, are numerically equal, and nil otherwise."; const char doc109[] = "(< number*)\n" -"Returns t if each argument is less than the next argument, and nil otherwise."; + "Returns t if each argument is less than the next argument, and nil otherwise."; const char doc110[] = "(<= number*)\n" -"Returns t if each argument is less than or equal to the next argument, and nil otherwise."; + "Returns t if each argument is less than or equal to the next argument, and nil otherwise."; const char doc111[] = "(> number*)\n" -"Returns t if each argument is greater than the next argument, and nil otherwise."; + "Returns t if each argument is greater than the next argument, and nil otherwise."; const char doc112[] = "(>= number*)\n" -"Returns t if each argument is greater than or equal to the next argument, and nil otherwise."; + "Returns t if each argument is greater than or equal to the next argument, and nil otherwise."; const char doc113[] = "(plusp number)\n" -"Returns t if the argument is greater than zero, or nil otherwise."; + "Returns t if the argument is greater than zero, or nil otherwise."; const char doc114[] = "(minusp number)\n" -"Returns t if the argument is less than zero, or nil otherwise."; + "Returns t if the argument is less than zero, or nil otherwise."; const char doc115[] = "(zerop number)\n" -"Returns t if the argument is zero."; + "Returns t if the argument is zero."; const char doc116[] = "(oddp number)\n" -"Returns t if the integer argument is odd."; + "Returns t if the integer argument is odd."; const char doc117[] = "(evenp number)\n" -"Returns t if the integer argument is even."; + "Returns t if the integer argument is even."; const char doc118[] = "(integerp number)\n" -"Returns t if the argument is an integer."; + "Returns t if the argument is an integer."; const char doc119[] = "(numberp number)\n" -"Returns t if the argument is a number."; + "Returns t if the argument is a number."; const char doc120[] = "(float number)\n" -"Returns its argument converted to a floating-point number."; + "Returns its argument converted to a floating-point number."; const char doc121[] = "(floatp number)\n" -"Returns t if the argument is a floating-point number."; + "Returns t if the argument is a floating-point number."; const char doc122[] = "(sin number)\n" -"Returns sin(number)."; + "Returns sin(number)."; const char doc123[] = "(cos number)\n" -"Returns cos(number)."; + "Returns cos(number)."; const char doc124[] = "(tan number)\n" -"Returns tan(number)."; + "Returns tan(number)."; const char doc125[] = "(asin number)\n" -"Returns asin(number)."; + "Returns asin(number)."; const char doc126[] = "(acos number)\n" -"Returns acos(number)."; + "Returns acos(number)."; const char doc127[] = "(atan number1 [number2])\n" -"Returns the arc tangent of number1/number2, in radians. If number2 is omitted it defaults to 1."; + "Returns the arc tangent of number1/number2, in radians. If number2 is omitted it defaults to 1."; const char doc128[] = "(sinh number)\n" -"Returns sinh(number)."; + "Returns sinh(number)."; const char doc129[] = "(cosh number)\n" -"Returns cosh(number)."; + "Returns cosh(number)."; const char doc130[] = "(tanh number)\n" -"Returns tanh(number)."; + "Returns tanh(number)."; const char doc131[] = "(exp number)\n" -"Returns exp(number)."; + "Returns exp(number)."; const char doc132[] = "(sqrt number)\n" -"Returns sqrt(number)."; + "Returns sqrt(number)."; const char doc133[] = "(log number [base])\n" -"Returns the logarithm of number to the specified base. If base is omitted it defaults to e."; + "Returns the logarithm of number to the specified base. If base is omitted it defaults to e."; const char doc134[] = "(expt number power)\n" -"Returns number raised to the specified power.\n" -"Returns the result as an integer if the arguments are integers and the result will be within range,\n" -"otherwise a floating-point number."; + "Returns number raised to the specified power.\n" + "Returns the result as an integer if the arguments are integers and the result will be within range,\n" + "otherwise a floating-point number."; const char doc135[] = "(ceiling number [divisor])\n" -"Returns ceil(number/divisor). If omitted, divisor is 1."; + "Returns ceil(number/divisor). If omitted, divisor is 1."; const char doc136[] = "(floor number [divisor])\n" -"Returns floor(number/divisor). If omitted, divisor is 1."; + "Returns floor(number/divisor). If omitted, divisor is 1."; const char doc137[] = "(truncate number [divisor])\n" -"Returns the integer part of number/divisor. If divisor is omitted it defaults to 1."; + "Returns the integer part of number/divisor. If divisor is omitted it defaults to 1."; const char doc138[] = "(round number [divisor])\n" -"Returns the integer closest to number/divisor. If divisor is omitted it defaults to 1."; + "Returns the integer closest to number/divisor. If divisor is omitted it defaults to 1."; const char doc139[] = "(char string n)\n" -"Returns the nth character in a string, counting from zero."; + "Returns the nth character in a string, counting from zero."; const char doc140[] = "(char-code character)\n" -"Returns the ASCII code for a character, as an integer."; + "Returns the ASCII code for a character, as an integer."; const char doc141[] = "(code-char integer)\n" -"Returns the character for the specified ASCII code."; + "Returns the character for the specified ASCII code."; const char doc142[] = "(characterp item)\n" -"Returns t if the argument is a character and nil otherwise."; + "Returns t if the argument is a character and nil otherwise."; const char doc143[] = "(stringp item)\n" -"Returns t if the argument is a string and nil otherwise."; + "Returns t if the argument is a string and nil otherwise."; const char doc144[] = "(string= string string)\n" -"Returns t if the two strings are the same, or nil otherwise."; + "Returns t if the two strings are the same, or nil otherwise."; const char doc145[] = "(string< string string)\n" -"Returns the index to the first mismatch if the first string is alphabetically less than the second string,\n" -"or nil otherwise."; + "Returns the index to the first mismatch if the first string is alphabetically less than the second string,\n" + "or nil otherwise."; const char doc146[] = "(string> string string)\n" -"Returns the index to the first mismatch if the first string is alphabetically greater than the second string,\n" -"or nil otherwise."; + "Returns the index to the first mismatch if the first string is alphabetically greater than the second string,\n" + "or nil otherwise."; const char docstringnoteq[] = "(string/= string string)\n" -"Returns the index to the first mismatch if the two strings are not the same, or nil otherwise."; + "Returns the index to the first mismatch if the two strings are not the same, or nil otherwise."; const char docstringlteq[] = "(string<= string string)\n" -"Returns the index to the first mismatch if the first string is alphabetically less than or equal to\n" -"the second string, or nil otherwise."; + "Returns the index to the first mismatch if the first string is alphabetically less than or equal to\n" + "the second string, or nil otherwise."; const char docstringgteq[] = "(string>= string string)\n" -"Returns the index to the first mismatch if the first string is alphabetically greater than or equal to\n" -"the second string, or nil otherwise."; + "Returns the index to the first mismatch if the first string is alphabetically greater than or equal to\n" + "the second string, or nil otherwise."; const char doc147[] = "(sort list test)\n" -"Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list."; + "Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list."; const char doc148[] = "(concatenate 'string string*)\n" -"Joins together the strings given in the second and subsequent arguments, and returns a single string."; + "Joins together the strings given in the second and subsequent arguments, and returns a single string."; const char doc149[] = "(subseq seq start [end])\n" -"Returns a subsequence of a list or string from item start to item end-1."; + "Returns a subsequence of a list or string from item start to item end-1."; const char doc150[] = "(search pattern target [:test function])\n" -"Returns the index of the first occurrence of pattern in target, or nil if it's not found.\n" -"The target can be a list or string. If it's a list a test function can be specified; default eq."; + "Returns the index of the first occurrence of pattern in target, or nil if it's not found.\n" + "The target can be a list or string. If it's a list a test function can be specified; default eq."; const char doc151[] = "(read-from-string string)\n" -"Reads an atom or list from the specified string and returns it."; + "Reads an atom or list from the specified string and returns it."; const char doc152[] = "(princ-to-string item)\n" -"Prints its argument to a string, and returns the string.\n" -"Characters and strings are printed without quotation marks or escape characters."; + "Prints its argument to a string, and returns the string.\n" + "Characters and strings are printed without quotation marks or escape characters."; const char doc153[] = "(prin1-to-string item [stream])\n" -"Prints its argument to a string, and returns the string.\n" -"Characters and strings are printed with quotation marks and escape characters,\n" -"in a format that will be suitable for read-from-string."; + "Prints its argument to a string, and returns the string.\n" + "Characters and strings are printed with quotation marks and escape characters,\n" + "in a format that will be suitable for read-from-string."; const char doc154[] = "(logand [value*])\n" -"Returns the bitwise & of the values."; + "Returns the bitwise & of the values."; const char doc155[] = "(logior [value*])\n" -"Returns the bitwise | of the values."; + "Returns the bitwise | of the values."; const char doc156[] = "(logxor [value*])\n" -"Returns the bitwise ^ of the values."; + "Returns the bitwise ^ of the values."; const char doc157[] = "(lognot value)\n" -"Returns the bitwise logical NOT of the value."; + "Returns the bitwise logical NOT of the value."; const char doc158[] = "(ash value shift)\n" -"Returns the result of bitwise shifting value by shift bits. If shift is positive, value is shifted to the left."; + "Returns the result of bitwise shifting value by shift bits. If shift is positive, value is shifted to the left."; const char doc159[] = "(logbitp bit value)\n" -"Returns t if bit number bit in value is a '1', and nil if it is a '0'."; + "Returns t if bit number bit in value is a '1', and nil if it is a '0'."; const char doc160[] = "(eval form*)\n" -"Evaluates its argument an extra time."; + "Evaluates its argument an extra time."; const char doc161[] = "(globals)\n" -"Returns a list of global variables."; + "Returns a list of global variables."; const char doc162[] = "(locals)\n" -"Returns an association list of local variables and their values."; + "Returns an association list of local variables and their values."; const char doc163[] = "(makunbound symbol)\n" -"Removes the value of the symbol from GlobalEnv and returns the symbol."; + "Removes the value of the symbol from GlobalEnv and returns the symbol."; const char doc164[] = "(break)\n" -"Inserts a breakpoint in the program. When evaluated prints Break! and reenters the REPL."; + "Inserts a breakpoint in the program. When evaluated prints Break! and reenters the REPL."; const char doc165[] = "(read [stream])\n" -"Reads an atom or list from the serial input and returns it.\n" -"If stream is specified the item is read from the specified stream."; + "Reads an atom or list from the serial input and returns it.\n" + "If stream is specified the item is read from the specified stream."; const char doc166[] = "(prin1 item [stream])\n" -"Prints its argument, and returns its value.\n" -"Strings are printed with quotation marks and escape characters."; + "Prints its argument, and returns its value.\n" + "Strings are printed with quotation marks and escape characters."; const char doc167[] = "(print item [stream])\n" -"Prints its argument with quotation marks and escape characters, on a new line, and followed by a space.\n" -"If stream is specified the argument is printed to the specified stream."; + "Prints its argument with quotation marks and escape characters, on a new line, and followed by a space.\n" + "If stream is specified the argument is printed to the specified stream."; const char doc168[] = "(princ item [stream])\n" -"Prints its argument, and returns its value.\n" -"Characters and strings are printed without quotation marks or escape characters."; + "Prints its argument, and returns its value.\n" + "Characters and strings are printed without quotation marks or escape characters."; const char doc169[] = "(terpri [stream])\n" -"Prints a new line, and returns nil.\n" -"If stream is specified the new line is written to the specified stream."; + "Prints a new line, and returns nil.\n" + "If stream is specified the new line is written to the specified stream."; const char doc170[] = "(read-byte stream)\n" -"Reads a byte from a stream and returns it."; + "Reads a byte from a stream and returns it."; const char doc171[] = "(read-line [stream])\n" -"Reads characters from the serial input up to a newline character, and returns them as a string, excluding the newline.\n" -"If stream is specified the line is read from the specified stream."; + "Reads characters from the serial input up to a newline character, and returns them as a string, excluding the newline.\n" + "If stream is specified the line is read from the specified stream."; const char doc172[] = "(write-byte number [stream])\n" -"Writes a byte to a stream."; + "Writes a byte to a stream."; const char doc173[] = "(write-string string [stream])\n" -"Writes a string. If stream is specified the string is written to the stream."; + "Writes a string. If stream is specified the string is written to the stream."; const char doc174[] = "(write-line string [stream])\n" -"Writes a string terminated by a newline character. If stream is specified the string is written to the stream."; + "Writes a string terminated by a newline character. If stream is specified the string is written to the stream."; const char doc175[] = "(restart-i2c stream [read-p])\n" -"Restarts an i2c-stream.\n" -"If read-p is nil or omitted the stream is written to.\n" -"If read-p is an integer it specifies the number of bytes to be read from the stream."; + "Restarts an i2c-stream.\n" + "If read-p is nil or omitted the stream is written to.\n" + "If read-p is an integer it specifies the number of bytes to be read from the stream."; const char doc176[] = "(gc)\n" -"Forces a garbage collection and prints the number of objects collected, and the time taken."; + "Forces a garbage collection and prints the number of objects collected, and the time taken."; const char doc177[] = "(room)\n" -"Returns the number of free Lisp cells remaining."; + "Returns the number of free Lisp cells remaining."; const char doc180[] = "(cls)\n" -"Prints a clear-screen character."; + "Prints a clear-screen character."; const char doc181[] = "(digitalread pin)\n" -"Reads the state of the specified Arduino pin number and returns t (high) or nil (low)."; + "Reads the state of the specified Arduino pin number and returns t (high) or nil (low)."; const char doc182[] = "(analogreadresolution bits)\n" -"Specifies the resolution for the analogue inputs on platforms that support it.\n" -"The default resolution on all platforms is 10 bits."; + "Specifies the resolution for the analogue inputs on platforms that support it.\n" + "The default resolution on all platforms is 10 bits."; const char doc183[] = "(analogwrite pin value)\n" -"Writes the value to the specified Arduino pin number."; + "Writes the value to the specified Arduino pin number."; const char doc184[] = "(delay number)\n" -"Delays for a specified number of milliseconds."; + "Delays for a specified number of milliseconds."; const char doc185[] = "(millis)\n" -"Returns the time in milliseconds that uLisp has been running."; + "Returns the time in milliseconds that uLisp has been running."; const char doc186[] = "(sleep secs)\n" -"Puts the processor into a low-power sleep mode for secs.\n" -"Only supported on some platforms. On other platforms it does delay(1000*secs)."; + "Puts the processor into a low-power sleep mode for secs.\n" + "Only supported on some platforms. On other platforms it does delay(1000*secs)."; const char doc187[] = "(note [pin] [note] [octave])\n" -"Generates a square wave on pin.\n" -"The argument note represents the note in the well-tempered scale, from 0 to 11,\n" -"where 0 represents C, 1 represents C#, and so on.\n" -"The argument octave can be from 3 to 6. If omitted it defaults to 0."; + "Generates a square wave on pin.\n" + "The argument note represents the note in the well-tempered scale, from 0 to 11,\n" + "where 0 represents C, 1 represents C#, and so on.\n" + "The argument octave can be from 3 to 6. If omitted it defaults to 0."; const char doc188[] = "(edit 'function)\n" -"Calls the Lisp tree editor to allow you to edit a function definition."; + "Calls the Lisp tree editor to allow you to edit a function definition."; const char doc189[] = "(pprint item [str])\n" -"Prints its argument, using the pretty printer, to display it formatted in a structured way.\n" -"If str is specified it prints to the specified stream. It returns no value."; + "Prints its argument, using the pretty printer, to display it formatted in a structured way.\n" + "If str is specified it prints to the specified stream. It returns no value."; const char doc190[] = "(pprintall [str])\n" -"Pretty-prints the definition of every function and variable defined in the uLisp workspace.\n" -"If str is specified it prints to the specified stream. It returns no value."; + "Pretty-prints the definition of every function and variable defined in the uLisp workspace.\n" + "If str is specified it prints to the specified stream. It returns no value."; const char doc191[] = "(require 'symbol)\n" -"Loads the definition of a function defined with defun, or a variable defined with defvar, from the Lisp Library.\n" -"It returns t if it was loaded, or nil if the symbol is already defined or isn't defined in the Lisp Library."; + "Loads the definition of a function defined with defun, or a variable defined with defvar, from the Lisp Library.\n" + "It returns t if it was loaded, or nil if the symbol is already defined or isn't defined in the Lisp Library."; const char doc192[] = "(list-library)\n" -"Prints a list of the functions defined in the List Library."; + "Prints a list of the functions defined in the List Library."; const char doc193[] = "(? item)\n" -"Prints the documentation string of a built-in or user-defined function."; + "Prints the documentation string of a built-in or user-defined function."; const char doc194[] = "(documentation 'symbol [type])\n" -"Returns the documentation string of a built-in or user-defined function. The type argument is ignored."; + "Returns the documentation string of a built-in or user-defined function. The type argument is ignored."; const char doc195[] = "(apropos item)\n" -"Prints the user-defined and built-in functions whose names contain the specified string or symbol."; + "Prints the user-defined and built-in functions whose names contain the specified string or symbol."; const char doc196[] = "(apropos-list item)\n" -"Returns a list of user-defined and built-in functions whose names contain the specified string or symbol."; + "Returns a list of user-defined and built-in functions whose names contain the specified string or symbol."; const char doc197[] = "(unwind-protect form1 [forms]*)\n" -"Evaluates form1 and forms in order and returns the value of form1,\n" -"but guarantees to evaluate forms even if an error occurs in form1."; + "Evaluates form1 and forms in order and returns the value of form1,\n" + "but guarantees to evaluate forms even if an error occurs in form1."; const char doc198[] = "(ignore-errors [forms]*)\n" -"Evaluates forms ignoring errors."; + "Evaluates forms ignoring errors."; const char doc199[] = "(error controlstring [arguments]*)\n" -"Signals an error. The message is printed by format using the controlstring and arguments."; + "Signals an error. The message is printed by format using the controlstring and arguments."; const char doc200[] = "(with-client (str [address port]) form*)\n" -"Evaluates the forms with str bound to a wifi-stream."; + "Evaluates the forms with str bound to a wifi-stream."; const char doc201[] = "(available stream)\n" -"Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available."; + "Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available."; const char doc202[] = "(wifi-server)\n" -"Starts a Wi-Fi server running. It returns nil."; + "Starts a Wi-Fi server running. It returns nil."; const char doc203[] = "(wifi-softap ssid [password channel hidden])\n" -"Set up a soft access point to establish a Wi-Fi network.\n" -"Returns the IP address as a string or nil if unsuccessful."; + "Set up a soft access point to establish a Wi-Fi network.\n" + "Returns the IP address as a string or nil if unsuccessful."; const char doc204[] = "(connected stream)\n" -"Returns t or nil to indicate if the client on stream is connected."; + "Returns t or nil to indicate if the client on stream is connected."; const char doc205[] = "(wifi-localip)\n" -"Returns the IP address of the local network as a string."; + "Returns the IP address of the local network as a string."; const char doc206[] = "(wifi-connect [ssid pass])\n" -"Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string."; + "Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string."; const char doc207[] = "(with-gfx (str) form*)\n" -"Evaluates the forms with str bound to an gfx-stream so you can print text\n" -"to the graphics display using the standard uLisp print commands."; + "Evaluates the forms with str bound to an gfx-stream so you can print text\n" + "to the graphics display using the standard uLisp print commands."; const char doc208[] = "(draw-pixel x y [colour])\n" -"Draws a pixel at coordinates (x,y) in colour, or white if omitted."; + "Draws a pixel at coordinates (x,y) in colour, or white if omitted."; const char doc209[] = "(draw-line x0 y0 x1 y1 [colour])\n" -"Draws a line from (x0,y0) to (x1,y1) in colour, or white if omitted."; + "Draws a line from (x0,y0) to (x1,y1) in colour, or white if omitted."; const char doc210[] = "(draw-rect x y w h [colour])\n" -"Draws an outline rectangle with its top left corner at (x,y), with width w,\n" -"and with height h. The outline is drawn in colour, or white if omitted."; + "Draws an outline rectangle with its top left corner at (x,y), with width w,\n" + "and with height h. The outline is drawn in colour, or white if omitted."; const char doc211[] = "(fill-rect x y w h [colour])\n" -"Draws a filled rectangle with its top left corner at (x,y), with width w,\n" -"and with height h. The outline is drawn in colour, or white if omitted."; + "Draws a filled rectangle with its top left corner at (x,y), with width w,\n" + "and with height h. The outline is drawn in colour, or white if omitted."; const char doc212[] = "(draw-circle x y r [colour])\n" -"Draws an outline circle with its centre at (x, y) and with radius r.\n" -"The circle is drawn in colour, or white if omitted."; + "Draws an outline circle with its centre at (x, y) and with radius r.\n" + "The circle is drawn in colour, or white if omitted."; const char doc213[] = "(fill-circle x y r [colour])\n" -"Draws a filled circle with its centre at (x, y) and with radius r.\n" -"The circle is drawn in colour, or white if omitted."; + "Draws a filled circle with its centre at (x, y) and with radius r.\n" + "The circle is drawn in colour, or white if omitted."; const char doc214[] = "(draw-round-rect x y w h radius [colour])\n" -"Draws an outline rounded rectangle with its top left corner at (x,y), with width w,\n" -"height h, and corner radius radius. The outline is drawn in colour, or white if omitted."; + "Draws an outline rounded rectangle with its top left corner at (x,y), with width w,\n" + "height h, and corner radius radius. The outline is drawn in colour, or white if omitted."; const char doc215[] = "(fill-round-rect x y w h radius [colour])\n" -"Draws a filled rounded rectangle with its top left corner at (x,y), with width w,\n" -"height h, and corner radius radius. The outline is drawn in colour, or white if omitted."; + "Draws a filled rounded rectangle with its top left corner at (x,y), with width w,\n" + "height h, and corner radius radius. The outline is drawn in colour, or white if omitted."; const char doc216[] = "(draw-triangle x0 y0 x1 y1 x2 y2 [colour])\n" -"Draws an outline triangle between (x1,y1), (x2,y2), and (x3,y3).\n" -"The outline is drawn in colour, or white if omitted."; + "Draws an outline triangle between (x1,y1), (x2,y2), and (x3,y3).\n" + "The outline is drawn in colour, or white if omitted."; const char doc217[] = "(fill-triangle x0 y0 x1 y1 x2 y2 [colour])\n" -"Draws a filled triangle between (x1,y1), (x2,y2), and (x3,y3).\n" -"The outline is drawn in colour, or white if omitted."; + "Draws a filled triangle between (x1,y1), (x2,y2), and (x3,y3).\n" + "The outline is drawn in colour, or white if omitted."; const char doc218[] = "(draw-char x y char [colour background size])\n" -"Draws the character char with its top left corner at (x,y).\n" -"The character is drawn in a 5 x 7 pixel font in colour against background,\n" -"which default to white and black respectively.\n" -"The character can optionally be scaled by size."; + "Draws the character char with its top left corner at (x,y).\n" + "The character is drawn in a 5 x 7 pixel font in colour against background,\n" + "which default to white and black respectively.\n" + "The character can optionally be scaled by size."; const char doc219[] = "(set-cursor x y)\n" -"Sets the start point for text plotting to (x, y)."; + "Sets the start point for text plotting to (x, y)."; const char doc220[] = "(set-text-color colour [background])\n" -"Sets the text colour for text plotted using (with-gfx ...)."; + "Sets the text colour for text plotted using (with-gfx ...)."; const char doc221[] = "(set-text-size scale)\n" -"Scales text by the specified size, default 1."; + "Scales text by the specified size, default 1."; const char doc222[] = "(set-text-wrap boolean)\n" -"Specified whether text wraps at the right-hand edge of the display; the default is t."; + "Specified whether text wraps at the right-hand edge of the display; the default is t."; const char doc223[] = "(fill-screen [colour])\n" -"Fills or clears the screen with colour, default black."; + "Fills or clears the screen with colour, default black."; const char doc224[] = "(set-rotation option)\n" -"Sets the display orientation for subsequent graphics commands; values are 0, 1, 2, or 3."; + "Sets the display orientation for subsequent graphics commands; values are 0, 1, 2, or 3."; const char doc225[] = "(invert-display boolean)\n" -"Mirror-images the display."; + "Mirror-images the display."; const char doccatch[] = "(catch 'tag form*)\n" -"Evaluates the forms, and if at any point (throw) is called with the same\n" -"tag, immediately returns the \"thrown\" value from (catch). If none throw,\n" -"returns the value returned by the last form."; + "Evaluates the forms, and if at any point (throw) is called with the same\n" + "tag, immediately returns the \"thrown\" value from (catch). If none throw,\n" + "returns the value returned by the last form."; const char docthrow[] = "(throw 'tag [value])\n" -"Exits the (catch) form opened with the same tag (compared using eq).\n" -"It is an error to call (throw) without first entering a (catch) with\n" -"the same tag."; + "Exits the (catch) form opened with the same tag (compared using eq).\n" + "It is an error to call (throw) without first entering a (catch) with\n" + "the same tag."; const char docmacroexpand1[] = "(macroexpand-1 'form)\n" -"If the form represents a call to a macro, expands the macro once and returns the expanded code."; + "If the form represents a call to a macro, expands the macro once and returns the expanded code."; const char docmacroexpand[] = "(macroexpand 'form)\n" -"Repeatedly applies (macroexpand-1) until the form no longer represents a call to a macro,\n" -"then returns the new form."; + "Repeatedly applies (macroexpand-1) until the form no longer represents a call to a macro,\n" + "then returns the new form."; // Built-in symbol lookup table const tbl_entry_t BuiltinTable[] = { @@ -7157,7 +7503,7 @@ const tbl_entry_t BuiltinTable[] = { // Metatable cross-reference functions -void inittables () { +void inittables() { Metatable = (mtbl_entry_t*)calloc(1, sizeof(mtbl_entry_t)); NumTables = 1; Metatable[0].table = BuiltinTable; @@ -7165,14 +7511,14 @@ void inittables () { } #define addtable(x) __addtable(x, arraysize(x)) -void __addtable (const tbl_entry_t table[], size_t sz) { +void __addtable(const tbl_entry_t table[], size_t sz) { NumTables++; Metatable = (mtbl_entry_t*)realloc(Metatable, NumTables * sizeof(mtbl_entry_t)); - Metatable[NumTables-1].table = table; - Metatable[NumTables-1].size = sz; + Metatable[NumTables - 1].table = table; + Metatable[NumTables - 1].size = sz; } -tbl_entry_t* getentry (builtin_t x) { +tbl_entry_t* getentry(builtin_t x) { int t = 0; while (x >= Metatable[t].size) { x -= Metatable[t].size; @@ -7187,13 +7533,13 @@ tbl_entry_t* getentry (builtin_t x) { lookupbuiltin - looks up a string in BuiltinTable[], and returns the index of its entry, or ENDFUNCTIONS if no match is found */ -builtin_t lookupbuiltin (char* c) { +builtin_t lookupbuiltin(char* c) { unsigned int end = 0, start; - for (int n=0; nfptr; } @@ -7213,14 +7559,14 @@ fn_ptr_type lookupfn (builtin_t name) { getminmax - gets the minmax byte from BuiltinTable[] whose octets specify the type of function and minimum and maximum number of arguments for name */ -minmax_t getminmax (builtin_t name) { +minmax_t getminmax(builtin_t name) { return getentry(name)->minmax; } /* checkminmax - checks that the number of arguments nargs for name is within the range specified by minmax */ -void checkminmax (builtin_t name, int nargs) { +void checkminmax(builtin_t name, int nargs) { if (name >= ENDFUNCTIONS) error2("internal error: not a builtin"); minmax_t minmax = getminmax(name); if (nargs < getminargs(minmax)) error2(toofewargs); @@ -7230,37 +7576,37 @@ void checkminmax (builtin_t name, int nargs) { /* lookupdoc - looks up the documentation string for the built-in function name */ -const char* lookupdoc (builtin_t name) { +const char* lookupdoc(builtin_t name) { return getentry(name)->doc; } /* findsubstring - tests whether a specified substring occurs in the name of a built-in function */ -bool findsubstring (char* part, builtin_t name) { +bool findsubstring(char* part, builtin_t name) { return strstr(getentry(name)->string, part) != NULL; } /* testescape - tests whether the '~' escape character has been typed */ -void testescape () { +void testescape() { if (Serial.available() && Serial.read() == '~') error2("escape!"); } /* builtin_keywordp - check that obj is a built-in keyword */ -bool builtin_keywordp (object* obj) { +bool builtin_keywordp(object* obj) { if (!(symbolp(obj) && builtinp(obj->name))) return false; return getentry(builtin(obj->name))->string[0] == ':'; } -bool keywordp (object* obj) { +bool keywordp(object* obj) { if (obj == nil) return false; if (builtin_keywordp(obj)) return true; symbol_t name = obj->name; - if ((name & 3) != 0) return false; // Packed symbols are never keywords + if ((name & 3) != 0) return false; // Packed symbols are never keywords object* first_chunk = (object*)name; if (!first_chunk) return false; return (((first_chunk->chars) >> ((sizeof(int) - 1) * 8)) & 255) == ':'; @@ -7271,24 +7617,27 @@ bool keywordp (object* obj) { /* eval - the main Lisp evaluator */ -object* eval (object* form, object* env) { +object* eval(object* form, object* env) { bool tailcall = false; - EVAL: +EVAL: // Enough space? - if (Freespace <= WORKSPACESIZE>>4) gc(form, env); + if (Freespace <= WORKSPACESIZE >> 4) gc(form, env); // Escape - if (tstflag(ESCAPE)) { clrflag(ESCAPE); error2("escape!");} + if (tstflag(ESCAPE)) { + clrflag(ESCAPE); + error2("escape!"); + } if (!tstflag(NOESC)) testescape(); // Stack overflow check if (abs(static_cast(StackBottom) - &tailcall) > MAX_STACK) error("C stack overflow", form); if (form == NULL) return nil; - if (form->type >= NUMBER && form->type <= STRING) return form; // Literal + if (form->type >= NUMBER && form->type <= STRING) return form; // Literal if (symbolp(form)) { if (form == tee) return form; - if (keywordp(form)) return form; // Keyword + if (keywordp(form)) return form; // Keyword symbol_t name = form->name; object* pair = value(name, env); if (pair != NULL) return cdr(pair); @@ -7377,12 +7726,12 @@ object* eval (object* form, object* env) { object* fname = car(form); bool old_tailcall = tailcall; object* head = cons(eval(fname, env), NULL); - protect(head); // Don't GC the result list + protect(head); // Don't GC the result list object* tail = head; form = cdr(form); int nargs = 0; - while (form != NULL){ + while (form != NULL) { object* obj = cons(eval(car(form), env), NULL); cdr(tail) = obj; tail = obj; @@ -7392,7 +7741,7 @@ object* eval (object* form, object* env) { function = car(head); args = cdr(head); - + // fail early on calling a symbol if (symbolp(function)) { Context = NIL; @@ -7418,11 +7767,14 @@ object* eval (object* form, object* env) { int trace = tracing(fname->name); if (trace) { object* result = eval(form, env); - indent((--(TraceDepth[trace-1]))<<1, ' ', pserial); - pint(TraceDepth[trace-1], pserial); - pserial(':'); pserial(' '); - printobject(fname, pserial); pfstring(" returned ", pserial); - printobject(result, pserial); pln(pserial); + indent((--(TraceDepth[trace - 1])) << 1, ' ', pserial); + pint(TraceDepth[trace - 1], pserial); + pserial(':'); + pserial(' '); + printobject(fname, pserial); + pfstring(" returned ", pserial); + printobject(result, pserial); + pln(pserial); return result; } else { tailcall = true; @@ -7438,7 +7790,6 @@ object* eval (object* form, object* env) { tailcall = true; goto EVAL; } - } error("illegal function", fname); // unreachable @@ -7450,14 +7801,14 @@ object* eval (object* form, object* env) { /* pserial - prints a character to the serial port */ -void pserial (char c) { +void pserial(char c) { LastPrint = c; if (c == '\n') Serial.write('\r'); Serial.write(c); } const char ControlCodes[] = "Null\0SOH\0STX\0ETX\0EOT\0ENQ\0ACK\0Bell\0Backspace\0Tab\0Newline\0VT\0" -"Page\0Return\0SO\0SI\0DLE\0DC1\0DC2\0DC3\0DC4\0NAK\0SYN\0ETB\0CAN\0EM\0SUB\0Escape\0FS\0GS\0RS\0US\0Space\0"; + "Page\0Return\0SO\0SI\0DLE\0DC1\0DC2\0DC3\0DC4\0NAK\0SYN\0ETB\0CAN\0EM\0SUB\0Escape\0FS\0GS\0RS\0US\0Space\0"; /* pcharacter - prints a character to a stream, escaping special characters if PRINTREADABLY is false @@ -7465,13 +7816,17 @@ const char ControlCodes[] = "Null\0SOH\0STX\0ETX\0EOT\0ENQ\0ACK\0Bell\0Backspace If < 127 prints ASCII; eg #\A Otherwise prints decimal; eg #\234 */ -void pcharacter (char c, pfun_t pfun) { +void pcharacter(char c, pfun_t pfun) { if (!tstflag(PRINTREADABLY)) pfun(c); else { - pfun('#'); pfun('\\'); + pfun('#'); + pfun('\\'); if (c <= 32) { const char* p = ControlCodes; - while (c > 0) {p = p + strlen_P(p) + 1; c--; } + while (c > 0) { + p = p + strlen_P(p) + 1; + c--; + } pfstring(p, pfun); } else if (c < 127) pfun(c); else pint(c, pfun); @@ -7481,26 +7836,26 @@ void pcharacter (char c, pfun_t pfun) { /* pstring - prints a C string to the specified stream */ -void pstring (char* s, pfun_t pfun) { +void pstring(char* s, pfun_t pfun) { while (*s) pfun(*s++); } /* plispstring - prints a Lisp string object to the specified stream */ -void plispstring (object* form, pfun_t pfun) { +void plispstring(object* form, pfun_t pfun) { plispstr(form->name, pfun); } /* plispstr - prints a Lisp string name to the specified stream */ -void plispstr (symbol_t name, pfun_t pfun) { +void plispstr(symbol_t name, pfun_t pfun) { object* form = (object*)name; while (form != NULL) { int chars = form->chars; - for (int i=(sizeof(int)-1)*8; i>=0; i=i-8) { - char ch = chars>>i & 0xFF; + for (int i = (sizeof(int) - 1) * 8; i >= 0; i = i - 8) { + char ch = chars >> i & 0xFF; if (tstflag(PRINTREADABLY) && (ch == '"' || ch == '\\')) pfun('\\'); if (ch) pfun(ch); } @@ -7512,7 +7867,7 @@ void plispstr (symbol_t name, pfun_t pfun) { printstring - prints a Lisp string object to the specified stream taking account of the PRINTREADABLY flag */ -void printstring (object* form, pfun_t pfun) { +void printstring(object* form, pfun_t pfun) { if (tstflag(PRINTREADABLY)) pfun('"'); plispstr(form->name, pfun); if (tstflag(PRINTREADABLY)) pfun('"'); @@ -7521,9 +7876,9 @@ void printstring (object* form, pfun_t pfun) { /* pbuiltin - prints a built-in symbol to the specified stream */ -void pbuiltin (builtin_t name, pfun_t pfun) { +void pbuiltin(builtin_t name, pfun_t pfun) { int p = 0; - const char* s = getentry(name)->string; + const char* s = getentry(name)->string; for (;;) { char c = s[p++]; if (c == 0) return; @@ -7534,32 +7889,33 @@ void pbuiltin (builtin_t name, pfun_t pfun) { /* pradix40 - prints a radix 40 symbol to the specified stream */ -void pradix40 (symbol_t name, pfun_t pfun) { +void pradix40(symbol_t name, pfun_t pfun) { uint32_t x = untwist(name); - for (int d=102400000; d>0; d = d/40) { - uint32_t j = x/d; + for (int d = 102400000; d > 0; d = d / 40) { + uint32_t j = x / d; char c = fromradix40(j); if (c == 0) return; - pfun(c); x = x - j*d; + pfun(c); + x = x - j * d; } } /* printsymbol - prints any symbol from a symbol object to the specified stream */ -void printsymbol (object* form, pfun_t pfun) { +void printsymbol(object* form, pfun_t pfun) { psymbol(form->name, pfun); } /* psymbol - prints any symbol from a symbol name to the specified stream */ -void psymbol (symbol_t name, pfun_t pfun) { +void psymbol(symbol_t name, pfun_t pfun) { if (longnamep(name)) plispstr(name, pfun); else { uint32_t value = untwist(name); if (value < PACKEDS) error2("invalid symbol"); - else if (value >= BUILTINS) pbuiltin((builtin_t)(value-BUILTINS), pfun); + else if (value >= BUILTINS) pbuiltin((builtin_t)(value - BUILTINS), pfun); else pradix40(name, pfun); } } @@ -7567,7 +7923,7 @@ void psymbol (symbol_t name, pfun_t pfun) { /* pfstring - prints a string from flash memory to the specified stream */ -void pfstring (const char* s, pfun_t pfun) { +void pfstring(const char* s, pfun_t pfun) { for (;;) { char c = *s++; if (c == 0) return; @@ -7578,51 +7934,68 @@ void pfstring (const char* s, pfun_t pfun) { /* pint - prints an integer in decimal to the specified stream */ -void pint (int i, pfun_t pfun) { +void pint(int i, pfun_t pfun) { uint32_t j = i; - if (i<0) { pfun('-'); j=-i; } + if (i < 0) { + pfun('-'); + j = -i; + } pintbase(j, 10, pfun); } /* pintbase - prints an integer in base 'base' to the specified stream */ -void pintbase (uint32_t i, uint8_t base, pfun_t pfun) { - int lead = 0; uint32_t p = 1000000000; - if (base == 2) p = 0x80000000; else if (base == 16) p = 0x10000000; - for (uint32_t d=p; d>0; d=d/base) { - uint32_t j = i/d; - if (j!=0 || lead || d==1) { pfun((j<10) ? j+'0' : j+'W'); lead=1;} - i = i - j*d; +void pintbase(uint32_t i, uint8_t base, pfun_t pfun) { + int lead = 0; + uint32_t p = 1000000000; + if (base == 2) p = 0x80000000; + else if (base == 16) p = 0x10000000; + for (uint32_t d = p; d > 0; d = d / base) { + uint32_t j = i / d; + if (j != 0 || lead || d == 1) { + pfun((j < 10) ? j + '0' : j + 'W'); + lead = 1; + } + i = i - j * d; } } /* pmantissa - prints the mantissa of a floating-point number to the specified stream */ -void pmantissa (float f, pfun_t pfun) { +void pmantissa(float f, pfun_t pfun) { int sig = floor(log10(f)); int mul = pow(10, 5 - sig); int i = round(f * mul); bool point = false; - if (i == 1000000) { i = 100000; sig++; } + if (i == 1000000) { + i = 100000; + sig++; + } if (sig < 0) { - pfun('0'); pfun('.'); point = true; - for (int j=0; j < - sig - 1; j++) pfun('0'); + pfun('0'); + pfun('.'); + point = true; + for (int j = 0; j < -sig - 1; j++) pfun('0'); } mul = 100000; - for (int j=0; j<7; j++) { + for (int j = 0; j < 7; j++) { int d = (int)(i / mul); pfun(d + '0'); i = i - d * mul; if (i == 0) { if (!point) { - for (int k=j; k= 0) { pfun('.'); point = true; } + if (j == sig && sig >= 0) { + pfun('.'); + point = true; + } mul = mul / 10; } } @@ -7630,19 +8003,31 @@ void pmantissa (float f, pfun_t pfun) { /* pfloat - prints a floating-point number to the specified stream */ -void pfloat (float f, pfun_t pfun) { - if (isnan(f)) { pfstring("NaN", pfun); return; } - if (f == 0.0) { pfun('0'); return; } - if (isinf(f)) { pfstring("Inf", pfun); return; } - if (f < 0) { pfun('-'); f = -f; } +void pfloat(float f, pfun_t pfun) { + if (isnan(f)) { + pfstring("NaN", pfun); + return; + } + if (f == 0.0) { + pfun('0'); + return; + } + if (isinf(f)) { + pfstring("Inf", pfun); + return; + } + if (f < 0) { + pfun('-'); + f = -f; + } // Calculate exponent int e = 0; if (f < 1e-3 || f >= 1e5) { - e = floor(log(f) / 2.302585); // log10 gives wrong result + e = floor(log(f) / 2.302585); // log10 gives wrong result f = f / pow(10, e); } - pmantissa (f, pfun); + pmantissa(f, pfun); // Exponent if (e != 0) { @@ -7654,21 +8039,21 @@ void pfloat (float f, pfun_t pfun) { /* pln - prints a newline to the specified stream */ -inline void pln (pfun_t pfun) { +inline void pln(pfun_t pfun) { pfun('\n'); } /* pfl - prints a newline to the specified stream if a newline has not just been printed */ -void pfl (pfun_t pfun) { +void pfl(pfun_t pfun) { if (LastPrint != '\n') pfun('\n'); } /* plist - prints a list to the specified stream */ -void plist (object* form, pfun_t pfun) { +void plist(object* form, pfun_t pfun) { pfun('('); printobject(car(form), pfun); form = cdr(form); @@ -7687,9 +8072,9 @@ void plist (object* form, pfun_t pfun) { /* pstream - prints a stream name to the specified stream */ -void pstream (object* form, pfun_t pfun) { +void pstream(object* form, pfun_t pfun) { pfun('<'); - pfstring(streamname[(form->integer)>>8], pfun); + pfstring(streamname[(form->integer) >> 8], pfun); pfstring("-stream ", pfun); pint(form->integer & 0xFF, pfun); pfun('>'); @@ -7698,14 +8083,15 @@ void pstream (object* form, pfun_t pfun) { /* printobject - prints any Lisp object to the specified stream */ -void printobject (object* form, pfun_t pfun) { +void printobject(object* form, pfun_t pfun) { if (form == NULL) pfstring("nil", pfun); else if (listp(form) && isbuiltin(car(form), CLOSURE)) pfstring("", pfun); else if (listp(form)) plist(form, pfun); else if (integerp(form)) pint(form->integer, pfun); else if (floatp(form)) pfloat(form->single_float, pfun); - else if (symbolp(form)) { if (form->name != sym(NOTHING)) printsymbol(form, pfun); } - else if (bfunctionp(form)) { + else if (symbolp(form)) { + if (form->name != sym(NOTHING)) printsymbol(form, pfun); + } else if (bfunctionp(form)) { pfstring("name)))) { case FUNCTIONS: pfstring("function ", pfun); break; @@ -7713,8 +8099,7 @@ void printobject (object* form, pfun_t pfun) { } printsymbol(form, pfun); pfun('>'); - } - else if (characterp(form)) pcharacter(form->chars, pfun); + } else if (characterp(form)) pcharacter(form->chars, pfun); else if (stringp(form)) printstring(form, pfun); else if (arrayp(form)) printarray(form, pfun); else if (streamp(form)) pstream(form, pfun); @@ -7724,7 +8109,7 @@ void printobject (object* form, pfun_t pfun) { /* prin1object - prints any Lisp object to the specified stream escaping special characters */ -void prin1object (object* form, pfun_t pfun) { +void prin1object(object* form, pfun_t pfun) { flags_t temp = Flags; clrflag(PRINTREADABLY); printobject(form, pfun); @@ -7736,20 +8121,20 @@ void prin1object (object* form, pfun_t pfun) { /* glibrary - reads a character from the Lisp Library */ -int glibrary () { +int glibrary() { if (LastChar) { char temp = LastChar; LastChar = 0; return temp; } char c = LispLibrary[GlobalStringIndex++]; - return (c != 0) ? c : -1; // -1? + return (c != 0) ? c : -1; // -1? } /* loadfromlibrary - reads and evaluates a form from the Lisp Library */ -void loadfromlibrary (object* env) { +void loadfromlibrary(object* env) { GlobalStringIndex = 0; object* line = read(glibrary); while (line != NULL) { @@ -7763,14 +8148,17 @@ void loadfromlibrary (object* env) { /* gserial - gets a character from the serial port */ -int gserial () { +int gserial() { if (LastChar) { char temp = LastChar; LastChar = 0; return temp; } unsigned long start = millis(); - while (!Serial.available()) { delay(1); if (millis() - start > 1000) clrflag(NOECHO); } + while (!Serial.available()) { + delay(1); + if (millis() - start > 1000) clrflag(NOECHO); + } char temp = Serial.read(); if (temp != '\n' && !tstflag(NOECHO)) pserial(temp); return temp; @@ -7779,13 +8167,15 @@ int gserial () { /* nextitem - reads the next token from the specified stream */ -object* nextitem (gfun_t gfun) { +object* nextitem(gfun_t gfun) { int ch = gfun(); - while(issp(ch)) ch = gfun(); + while (issp(ch)) ch = gfun(); if (ch == ';') { - do { ch = gfun(); if (ch == ';' || ch == '(') setflag(NOECHO); } - while(ch != '('); + do { + ch = gfun(); + if (ch == ';' || ch == '(') setflag(NOECHO); + } while (ch != '('); } if (ch == '\n') ch = gfun(); if (ch == -1) return nil; @@ -7793,7 +8183,7 @@ object* nextitem (gfun_t gfun) { if (ch == '(') return (object*)OPEN_PAREN; if (ch == '\'') return (object*)SINGLE_QUOTE; if (ch == '`') return (object*)BACKTICK; - if (ch == '@') return (object*)COMMA_AT; // maintain compatibility with old Dave Astels code + if (ch == '@') return (object*)COMMA_AT; // maintain compatibility with old Dave Astels code if (ch == ',') { ch = gfun(); if (ch == '@') return (object*)COMMA_AT; @@ -7809,7 +8199,7 @@ object* nextitem (gfun_t gfun) { // Parse symbol, character, or number int index = 0, base = 10, sign = 1; char buffer[BUFFERSIZE]; - int bufmax = BUFFERSIZE-3; // Max index + int bufmax = BUFFERSIZE - 3; // Max index unsigned int result = 0; bool isfloat = false; float fresult = 0.0; @@ -7831,14 +8221,17 @@ object* nextitem (gfun_t gfun) { // Parse reader macros else if (ch == '#') { ch = gfun(); - char ch2 = ch & ~0x20; // force to upper case - if (ch == '\\') { // Character - base = 0; ch = gfun(); + char ch2 = ch & ~0x20; // force to upper case + if (ch == '\\') { // Character + base = 0; + ch = gfun(); if (issp(ch) || isbr(ch)) return character(ch); else LastChar = ch; } else if (ch == '|') { - do { while (gfun() != '|'); } - while (gfun() != '#'); + do { + while (gfun() != '|') + ; + } while (gfun() != '#'); return nextitem(gfun); } else if (ch2 == 'B') base = 2; else if (ch2 == 'O') base = 8; @@ -7849,18 +8242,24 @@ object* nextitem (gfun_t gfun) { object* result = eval(read(gfun), NULL); clrflag(NOESC); return result; - } - else if (ch == '(') { LastChar = ch; return readarray(1, read(gfun)); } - else if (ch == '*') return readbitarray(gfun); + } else if (ch == '(') { + LastChar = ch; + return readarray(1, read(gfun)); + } else if (ch == '*') return readbitarray(gfun); else if (ch >= '1' && ch <= '9' && (gfun() & ~0x20) == 'A') return readarray(ch - '0', read(gfun)); else error2("illegal character after #"); ch = gfun(); } - int valid; // 0=undecided, -1=invalid, +1=valid - if (ch == '.') valid = 0; else if (digitvalue(ch) ((unsigned int)INT_MAX+(1-sign)/2)) - return makefloat((float)result*sign); - return number(result*sign); + if (base == 10 && result > ((unsigned int)INT_MAX + (1 - sign) / 2)) + return makefloat((float)result * sign); + return number(result * sign); } else if (base == 0) { if (index == 1) return character(buffer[0]); - const char* p = ControlCodes; char c = 0; + const char* p = ControlCodes; + char c = 0; while (c < 33) { if (strcasecmp_P(buffer, p) == 0) return character(c); - p = p + strlen_P(p) + 1; c++; + p = p + strlen_P(p) + 1; + c++; } - if (index == 3) return character((buffer[0]*10+buffer[1])*10+buffer[2]-5328); + if (index == 3) return character((buffer[0] * 10 + buffer[1]) * 10 + buffer[2] - 5328); error2("unknown character"); } @@ -7917,7 +8323,7 @@ object* nextitem (gfun_t gfun) { /* readrest - reads the remaining tokens from the specified stream */ -object* readrest (gfun_t gfun) { +object* readrest(gfun_t gfun) { object* item = nextitem(gfun); object* head = NULL; object* tail = NULL; @@ -7946,7 +8352,7 @@ object* readrest (gfun_t gfun) { /* read - recursively reads a Lisp object from the stream gfun and returns it */ -object* read (gfun_t gfun) { +object* read(gfun_t gfun) { object* item = nextitem(gfun); if (item == (object*)CLOSE_PAREN) error2("unexpected close paren"); if (item == (object*)OPEN_PAREN) return readrest(gfun); @@ -7963,7 +8369,7 @@ object* read (gfun_t gfun) { /* initenv - initialises the uLisp environment */ -void initenv () { +void initenv() { GlobalEnv = NULL; tee = bsymbol(TEE); } @@ -7971,17 +8377,17 @@ void initenv () { /* initgfx - initialises the graphics */ -void initgfx () { - #if defined(gfxsupport) +void initgfx() { +#if defined(gfxsupport) tft.init(135, 240); tft.setRotation(1); tft.fillScreen(ST77XX_BLACK); pinMode(TFT_BACKLITE, OUTPUT); digitalWrite(TFT_BACKLITE, HIGH); - #endif +#endif } -void ulispinit () { +void ulispinit() { int foo = 0; StackBottom = &foo; initworkspace(); @@ -7996,7 +8402,7 @@ void ulispinit () { /* repl - the Lisp Read/Evaluate/Print loop */ -void repl (object* env) { +void repl(object* env) { for (;;) { randomSeed(micros()); gc(NULL, env); @@ -8004,10 +8410,17 @@ void repl (object* env) { pfstring(" : ", pserial); pint(BreakLevel, pserial); } - pfstring("[Ready.]\n> ", pserial); + pfstring("[Ready.]\n", pserial); + pint(Freespace, pserial); + pserial('/'); + pint(WORKSPACESIZE, pserial); + pfstring("> ", pserial); Context = NIL; object* line = read(gserial); - if (BreakLevel && line == nil) { pln(pserial); return; } + if (BreakLevel && line == nil) { + pln(pserial); + return; + } if (line == (object*)CLOSE_PAREN) error2("unmatched right bracket"); protect(line); pfl(pserial); @@ -8021,17 +8434,23 @@ void repl (object* env) { } } -void ulisperrcleanup () { +void ulisperrcleanup() { // Come here after error - delay(100); while (Serial.available()) Serial.read(); - clrflag(NOESC); BreakLevel = 0; - for (int i=0; i pFad - Phonifier reborn

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.

Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.


Alternative Proxies:

Alternative Proxy

pFad Proxy

pFad v3 Proxy

pFad v4 Proxy