diff --git a/ulisp-arm-comments.ino b/ulisp-arm-comments.ino deleted file mode 100644 index 3544af9..0000000 --- a/ulisp-arm-comments.ino +++ /dev/null @@ -1,9605 +0,0 @@ -/* uLisp ARM Release 4.7b - www.ulisp.com - David Johnson-Davies - www.technoblogy.com - 20th March 2025 - - Licensed under the MIT license: https://opensource.org/licenses/MIT -*/ - -// Lisp Library -const char LispLibrary[] = ""; - -// Compile options - -// #define resetautorun -#define printfreespace -// #define printgcs -// #define sdcardsupport -// #define gfxsupport -// #define lisplibrary -#define assemblerlist -// #define lineeditor -// #define vt100 -// #define extensions - -// Includes - -// #include "LispLibrary.h" -#include -#include -#include -#include - -#if defined(sdcardsupport) -#include -#define SDSIZE 720 -#else -#define SDSIZE 0 -#endif - -// Platform specific settings - -#define WORDALIGNED __attribute__((aligned (4))) -#define BUFFERSIZE 36 // Number of bits+4 -#define RAMFUNC __attribute__ ((section (".ramfunctions"))) -#define MEMBANK - -// ATSAMD21 boards *************************************************************** - -#if defined(ARDUINO_GEMMA_M0) || defined(ARDUINO_SEEED_XIAO_M0) || defined(ARDUINO_QTPY_M0) - #define WORKSPACESIZE (2816-SDSIZE) /* Objects (8*bytes) */ - #define CPUFLASH - #define FLASHSIZE 32768 /* Bytes */ - #define CODESIZE 128 /* Bytes */ - #define STACKDIFF 320 - #define CPU_ATSAMD21 - -#elif defined(ARDUINO_ITSYBITSY_M0) || defined(ARDUINO_SAMD_FEATHER_M0_EXPRESS) - #define WORKSPACESIZE (2816-SDSIZE) /* Objects (8*bytes) */ - #define DATAFLASH - #define FLASHSIZE 2048000 /* 2 MBytes */ - #define CODESIZE 128 /* Bytes */ - #define STACKDIFF 320 - #define SDCARD_SS_PIN 4 - #define CPU_ATSAMD21 - -#elif defined(ADAFRUIT_FEATHER_M0) /* Feather M0 without DataFlash */ - #define WORKSPACESIZE (2816-SDSIZE) /* Objects (8*bytes) */ - #define CPUFLASH - #define FLASHSIZE 32768 /* Bytes */ - #define CODESIZE 128 /* Bytes */ - #define STACKDIFF 320 - #define SDCARD_SS_PIN 4 - #define CPU_ATSAMD21 - -#elif defined(ARDUINO_SAMD_MKRZERO) - #define WORKSPACESIZE (2640-SDSIZE) /* Objects (8*bytes) */ - #define CPUFLASH - #define FLASHSIZE 32768 /* Bytes */ - #define CODESIZE 128 /* Bytes */ - #define STACKDIFF 840 - #define CPU_ATSAMD21 - -#elif defined(ARDUINO_SAMD_ZERO) /* Put this last, otherwise overrides the Adafruit boards */ - #define WORKSPACESIZE (2500-SDSIZE) /* Objects (8*bytes) */ - #define CPUFLASH - #define FLASHSIZE 32768 /* Bytes */ - #define CODESIZE 128 /* Bytes */ - #define STACKDIFF 320 - #define SDCARD_SS_PIN 10 - #define CPU_ATSAMD21 - -// ATSAMD51 boards *************************************************************** - -#elif defined(ARDUINO_METRO_M4) || defined(ARDUINO_ITSYBITSY_M4) || defined(ARDUINO_FEATHER_M4) - #define WORKSPACESIZE (20608-SDSIZE) /* Objects (8*bytes) */ - #define DATAFLASH - #define FLASHSIZE 2048000 /* 2 MBytes */ - #define CODESIZE 256 /* Bytes */ - #define STACKDIFF 400 - #define SDCARD_SS_PIN 10 - #define CPU_ATSAMD51 - -#elif defined(ARDUINO_PYBADGE_M4) || defined(ARDUINO_PYGAMER_M4) - #define WORKSPACESIZE (20608-SDSIZE) /* Objects (8*bytes) */ - #define DATAFLASH - #define FLASHSIZE 2048000 /* 2 MBytes */ - #define CODESIZE 256 /* Bytes */ - #define STACKDIFF 400 - #define SDCARD_SS_PIN 10 - #define CPU_ATSAMD51 - #if defined(gfxsupport) - const int COLOR_WHITE = 0xffff, COLOR_BLACK = 0, TFT_BACKLIGHT = 47; - #include // Core graphics library - #include // Hardware-specific library for ST7735 - Adafruit_ST7735 tft = Adafruit_ST7735(44, 45, 41, 42, 46); - #endif - -#elif defined(ARDUINO_WIO_TERMINAL) - #define WORKSPACESIZE (20480-SDSIZE) /* Objects (8*bytes) */ - #define DATAFLASH - #define FLASHSIZE 2048000 /* 2 MBytes */ - #define CODESIZE 256 /* Bytes */ - #define STACKDIFF 400 - #define CPU_ATSAMD51 - #define EXTERNAL_FLASH_USE_QSPI - #if defined(gfxsupport) - const int COLOR_WHITE = 0xffff, COLOR_BLACK = 0; - #include // Hardware-specific library - TFT_eSPI tft = TFT_eSPI(); - #endif - -#elif defined(ARDUINO_GRAND_CENTRAL_M4) - #define WORKSPACESIZE (28800-SDSIZE) /* Objects (8*bytes) */ - #define DATAFLASH - #define FLASHSIZE 8192000 /* 8 MBytes */ - #define CODESIZE 256 /* Bytes */ - #define STACKDIFF 440 - #define CPU_ATSAMD51 - -// nRF51 boards *************************************************************** - -#elif defined(ARDUINO_BBC_MICROBIT) || defined(ARDUINO_SINOBIT) - #define WORKSPACESIZE 1344 /* Objects (8*bytes) */ - #define CODESIZE 64 /* Bytes */ - #define STACKDIFF 320 - #define CPU_NRF51822 - -#elif defined(ARDUINO_CALLIOPE_MINI) - #define WORKSPACESIZE 3392 /* Objects (8*bytes) */ - #define CODESIZE 64 /* Bytes */ - #define STACKDIFF 320 - #define CPU_NRF51822 - -// nRF52 boards *************************************************************** - -#elif defined(ARDUINO_BBC_MICROBIT_V2) - #define WORKSPACESIZE 12928 /* Objects (8*bytes) */ - #define CODESIZE 128 /* Bytes */ - #define STACKDIFF 320 - #define CPU_NRF52833 - -#elif defined(ARDUINO_NRF52840_ITSYBITSY) || defined(ARDUINO_Seeed_XIAO_nRF52840) \ - || defined(ARDUINO_Seeed_XIAO_nRF52840_Sense) || defined(ARDUINO_NRF52840_CIRCUITPLAY) - #define WORKSPACESIZE (21120-SDSIZE) /* Objects (8*bytes) */ - #define DATAFLASH - #define FLASHSIZE 2048000 /* 2 MBytes */ - #define CODESIZE 256 /* Bytes */ - #define STACKDIFF 8 - #define CPU_NRF52840 - -#elif defined(ARDUINO_NRF52840_CLUE) - #define WORKSPACESIZE (21120-SDSIZE) /* Objects (8*bytes) */ - #define DATAFLASH - #define FLASHSIZE 2048000 /* 2 MBytes */ - #define CODESIZE 256 /* Bytes */ - #define STACKDIFF 8 - #define CPU_NRF52840 - #if defined(gfxsupport) - const int COLOR_WHITE = 0xffff, COLOR_BLACK = 0; - #include - #include - Adafruit_ST7789 tft = Adafruit_ST7789(&SPI1, PIN_TFT_CS, PIN_TFT_DC, PIN_TFT_RST); - #endif - -// MAX32620 boards *************************************************************** - -#elif defined(MAX32620) - #define WORKSPACESIZE (24704-SDSIZE) /* Objects (8*bytes) */ - #define CODESIZE 256 /* Bytes */ - #define STACKDIFF 320 - #define CPU_MAX32620 - #define Wire1 Wire2 - -// iMXRT1062 boards *************************************************************** - -#elif defined(ARDUINO_TEENSY40) || defined(ARDUINO_TEENSY41) - #define WORKSPACESIZE 60000 /* Objects (8*bytes) */ - #define CODESIZE 256 /* Bytes */ - #define STACKDIFF 15000 - #define LITTLEFS (960 * 1024) - #include - LittleFS_Program LittleFS; - #define FS_FILE_WRITE FILE_WRITE_BEGIN - #define FS_FILE_READ FILE_READ - #define CPU_iMXRT1062 - #define SDCARD_SS_PIN BUILTIN_SDCARD - #define BitOrder uint8_t - #undef RAMFUNC - #define RAMFUNC FASTRUN - #undef MEMBANK - #define MEMBANK DMAMEM - -// RP2040 boards *************************************************************** - -#elif defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_ADAFRUIT_QTPY_RP2040) \ - || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040) || defined(ARDUINO_SEEED_XIAO_RP2040) - #define WORKSPACESIZE (23000-SDSIZE) /* Objects (8*bytes) */ - #define CODESIZE 256 /* Bytes */ - #define STACKDIFF 480 - #define LITTLEFS - #include - #define FS_FILE_WRITE "w" - #define FS_FILE_READ "r" - #define CPU_RP2040 - #if defined(gfxsupport) - const int COLOR_WHITE = 0xffff, COLOR_BLACK = 0; - #include // Core graphics library - #include // Hardware-specific library for ST7789 - Adafruit_ST7789 tft = Adafruit_ST7789(5, 1, 3, 2, 0); // TTGO RP2040 TFT - #define TFT_BACKLIGHT 4 - #define TFT_I2C_POWER 22 - #endif - -#elif defined(ARDUINO_ADAFRUIT_FEATHER_RP2040_ADALOGGER) - #define WORKSPACESIZE 23000 /* Objects (8*bytes) */ - #define CODESIZE 256 /* Bytes */ - #define STACKDIFF 480 - #define LITTLEFS - #include - #define FS_FILE_WRITE "w" - #define FS_FILE_READ "r" - #define SDCARD_SS_PIN 23 - #define CPU_RP2040 - -#elif defined(ARDUINO_RASPBERRY_PI_PICO_W) - #define WORKSPACESIZE (15232-SDSIZE) /* Objects (8*bytes) */ - #define CODESIZE 256 /* Bytes */ - #define STACKDIFF 480 - #define LITTLEFS - #include - #include - #define FS_FILE_WRITE "w" - #define FS_FILE_READ "r" - #define CPU_RP2040 - -// RP2350 boards *************************************************************** - -#elif defined(ARDUINO_RASPBERRY_PI_PICO_2) - #if defined(__riscv) - #define WORKSPACESIZE (42500-SDSIZE) /* Objects (8*bytes) */ - #define STACKDIFF 580 - #else - #define WORKSPACESIZE (47000-SDSIZE) /* Objects (8*bytes) */ - #define STACKDIFF 520 - #endif - #define CODESIZE 256 /* Bytes */ - #define LITTLEFS - #include - #define FS_FILE_WRITE "w" - #define FS_FILE_READ "r" - #define CPU_RP2350 - -#elif defined(ARDUINO_RASPBERRY_PI_PICO_2W) - #if defined(__riscv) - #define WORKSPACESIZE (34850-SDSIZE) /* Objects (8*bytes) */ - #define STACKDIFF 580 - #else - #define WORKSPACESIZE (39200-SDSIZE) /* Objects (8*bytes) */ - #define STACKDIFF 520 - #endif - #define CODESIZE 256 /* Bytes */ - #define LITTLEFS - #include - #include - #define FS_FILE_WRITE "w" - #define FS_FILE_READ "r" - #define CPU_RP2350 - -#elif defined(ARDUINO_PIMORONI_PICO_PLUS_2) - //#define BOARD_HAS_PSRAM /* Uncomment to use PSRAM */ - #if defined(BOARD_HAS_PSRAM) - #undef MEMBANK - #define MEMBANK PSRAM - #define WORKSPACESIZE 1000000 /* Objects (8*bytes) */ - #define STACKDIFF 580 - #elif defined(__riscv) - #define WORKSPACESIZE (42000-SDSIZE) /* Objects (8*bytes) */ - #define STACKDIFF 580 - #else - #define WORKSPACESIZE (46500-SDSIZE) /* Objects (8*bytes) */ - #define STACKDIFF 520 - #endif - #define CODESIZE 256 /* Bytes */ - #define LITTLEFS - #include - #define FS_FILE_WRITE "w" - #define FS_FILE_READ "r" - #define SDCARD_SS_PIN 10 - #define CPU_RP2350 - -#elif defined(ARDUINO_PIMORONI_TINY2350) - #if defined(__riscv) - #define WORKSPACESIZE (42500-SDSIZE) /* Objects (8*bytes) */ - #define STACKDIFF 580 - #else - #define WORKSPACESIZE (47000-SDSIZE) /* Objects (8*bytes) */ - #define STACKDIFF 520 - #endif - #define CODESIZE 256 /* Bytes */ - #define LITTLEFS - #include - #define FS_FILE_WRITE "w" - #define FS_FILE_READ "r" - #define CPU_RP2350 - -// RA4M1 boards *************************************************************** - -#elif defined(ARDUINO_MINIMA) - #define WORKSPACESIZE (2032-SDSIZE) /* Objects (8*bytes) */ - #include - #define EEPROMFLASH - #define FLASHSIZE 8192 /* Bytes */ - #define CODESIZE 128 /* Bytes */ - #define STACKDIFF 320 - #define eAnalogReference ar_aref - #define CPU_RA4M1 - #define SDCARD_SS_PIN 10 - -#elif defined(ARDUINO_UNOWIFIR4) - #define WORKSPACESIZE (1610-SDSIZE) /* Objects (8*bytes) */ - #include - #include "WiFiS3.h" - #define EEPROMFLASH - #define FLASHSIZE 8192 /* Bytes */ - #define CODESIZE 128 /* Bytes */ - #define STACKDIFF 320 - #define eAnalogReference ar_aref - #define CPU_RA4M1 - #define SDCARD_SS_PIN 10 - -#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) 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 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 == '#' || x == '\'') -#define fntype(x) (getminmax((uint16_t)(x))>>6) -#define longsymbolp(x) (((x)->name & 0x03) == 0) -#define longnamep(x) (((x) & 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) -#define PACKEDS 0x43238000 -#define BUILTINS 0xF4240000 -#define ENDFUNCTIONS 0x0BDC0000 - -// Code marker stores start and end of code block -#define startblock(x) ((x->integer) & 0xFFFF) -#define endblock(x) ((x->integer) >> 16 & 0xFFFF) - -// Constants - -#define TRACEMAX 3 // Maximum 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[] = "serial"; -const char i2cstream[] = "i2c"; -const char spistream[] = "spi"; -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}; - -// Typedefs - -typedef uint32_t symbol_t; -typedef uint32_t builtin_t; -typedef uint32_t chars_t; - -typedef struct sobject { - union { - struct { - sobject *car; - sobject *cdr; - }; - struct { - unsigned int type; - union { - symbol_t name; - int integer; - chars_t chars; // For strings - float single_float; - }; - }; - }; -} object; - -typedef object *(*fn_ptr_type)(object *, object *); -typedef void (*mapfun_t)(object *, object **); -typedef int (*intfn_ptr_type)(int w, int x, int y, int z); - -typedef const struct { - const char *string; - fn_ptr_type fptr; - uint8_t minmax; - const char *doc; -} tbl_entry_t; - -typedef int (*gfun_t)(); -typedef void (*pfun_t)(char); - -enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, FEATURES, INITIALELEMENT, ELEMENTTYPE, TEST, COLONA, COLONB, -COLONC, BIT, AMPREST, LAMBDA, LET, LETSTAR, CLOSURE, PSTAR, QUOTE, DEFUN, DEFVAR, DEFCODE, EQ, CAR, FIRST, -CDR, REST, NTH, AREF, CHAR, STRINGFN, PINMODE, DIGITALWRITE, ANALOGREAD, ANALOGREFERENCE, REGISTER, -FORMAT, - }; - -// Global variables - -object Workspace[WORKSPACESIZE] WORDALIGNED MEMBANK; -#if defined(CODESIZE) -RAMFUNC uint8_t MyCode[CODESIZE] WORDALIGNED; -#endif - -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; -#define BACKTRACESIZE 8 -uint8_t TraceStart = 0, TraceTop = 0; -symbol_t Backtrace[BACKTRACESIZE]; - -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, BACKTRACE }; -typedef uint16_t flags_t; -volatile flags_t Flags = 1<=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) { Context = NIL; error2("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)); -} - -/* - codehead - make a code header object with value entry and return it -*/ -object *codehead (int entry) { - object *ptr = myalloc(); - ptr->type = CODE; - ptr->integer = entry; - return ptr; -} - -/* - intern - unless PSRAM: 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) { - #if !defined(BOARD_HAS_PSRAM) - for (int i=0; itype == SYMBOL && obj->name == name) return obj; - } - #endif - 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) return false; - chars_t test = 0; int shift = 24; - for (int j=0; j<4; j++, i++) { - if (buffer[i] == 0) break; - test = test | buffer[i]<chars != test) return false; - arg = car(arg); - } - return true; -} - -/* - internlong - unless PSRAM 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) { - #if !defined(BOARD_HAS_PSRAM) - for (int i=0; itype == SYMBOL && longsymbolp(obj) && eqsymbols(obj, buffer)) return obj; - } - #endif - 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; -} - -// Features - -const char floatingpoint[] = ":floating-point"; -const char arrays[] = ":arrays"; -const char doc[] = ":documentation"; -const char machinecode[] = ":machine-code"; -const char errorhandling[] = ":error-handling"; -const char wifi[] = ":wi-fi"; -const char gfx[] = ":gfx"; -const char sdcard[] = ":sd-card"; -const char arm[] = ":arm"; -const char riscv[] = ":risc-v"; - -object *features () { - object *result = NULL; - #if defined(__riscv) - push(internlong((char *)riscv), result); - #else - push(internlong((char *)arm), result); - #endif - #if defined(sdcardsupport) - push(internlong((char *)sdcard), result); - #endif - push(internlong((char *)gfx), result); - push(internlong((char *)wifi), result); - push(internlong((char *)errorhandling), result); - push(internlong((char *)machinecode), result); - push(internlong((char *)doc), result); - push(internlong((char *)arrays), result); - push(internlong((char *)floatingpoint), result); - return result; -} - -// 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; - #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 - -/* - movepointer - Corrects pointers to an object that has been moved from 'from' to 'to'. - Only need to scan addresses below 'from' as there are no accessible objects above that. -*/ -void movepointer (object *from, object *to) { - uintptr_t limit = ((uintptr_t)(from) - (uintptr_t)(Workspace))/sizeof(uintptr_t); - for (uintptr_t 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 (uintptr_t 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 - Marks all accessible objects. Moves the last marked object down to the first free space gap, correcting - pointers by calling movepointer(). Then repeats until there are no more gaps. -*/ -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 SDRead32 (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("not enough room"); -} - -uint32_t FSRead32 (File file) { - union { uint32_t data; uint8_t u8[4]; }; - file.read(u8, 4); - return data; -} -#elif defined(DATAFLASH) -// Winbond DataFlash support for Adafruit M4 Express boards -#define PAGEPROG 0x02 -#define READSTATUS 0x05 -#define READDATA 0x03 -#define WRITEENABLE 0x06 -#define BLOCK64K 0xD8 -#define READID 0x90 - -// Arduino pins used for dataflash -#if defined(ARDUINO_ITSYBITSY_M0) || defined(ARDUINO_SAMD_FEATHER_M0_EXPRESS) -const int sck = 38, ssel = 39, mosi = 37, miso = 36; -#elif defined(EXTERNAL_FLASH_USE_QSPI) -const int sck = PIN_QSPI_SCK, ssel = PIN_QSPI_CS, mosi = PIN_QSPI_IO0, miso = PIN_QSPI_IO1; -#endif - -void FlashBusy () { - digitalWrite(ssel, 0); - FlashWrite(READSTATUS); - while ((FlashReadByte() & 1) != 0); - digitalWrite(ssel, 1); -} - -inline void FlashWrite (uint8_t data) { - shiftOut(mosi, sck, MSBFIRST, data); -} - -inline uint8_t FlashReadByte () { - return shiftIn(miso, sck, MSBFIRST); -} - -void FlashWriteByte (uint32_t *addr, uint8_t data) { - // New page - if (((*addr) & 0xFF) == 0) { - digitalWrite(ssel, 1); - FlashBusy(); - FlashWriteEnable(); - digitalWrite(ssel, 0); - FlashWrite(PAGEPROG); - FlashWrite((*addr)>>16); - FlashWrite((*addr)>>8); - FlashWrite(0); - } - FlashWrite(data); - (*addr)++; -} - -void FlashWriteEnable () { - digitalWrite(ssel, 0); - FlashWrite(WRITEENABLE); - digitalWrite(ssel, 1); -} - -bool FlashCheck () { - uint8_t devID; - digitalWrite(ssel, HIGH); pinMode(ssel, OUTPUT); - pinMode(sck, OUTPUT); - pinMode(mosi, OUTPUT); - pinMode(miso, INPUT); - digitalWrite(sck, LOW); digitalWrite(mosi, HIGH); - digitalWrite(ssel, LOW); - FlashWrite(READID); - for (uint8_t i=0; i<4; i++) FlashReadByte(); - devID = FlashReadByte(); - digitalWrite(ssel, HIGH); - return (devID >= 0x14 && devID <= 0x17); // true = found correct device -} - -void FlashBeginWrite (uint32_t *addr, uint32_t bytes) { - *addr = 0; - uint8_t blocks = (bytes+65535)/65536; - // Erase 64K - for (uint8_t b=0; b>8 & 0xFF); - FlashWriteByte(addr, data>>16 & 0xFF); FlashWriteByte(addr, data>>24 & 0xFF); -} - -inline void FlashEndWrite (uint32_t *addr) { - (void) addr; - digitalWrite(ssel, 1); - FlashBusy(); -} - -void FlashBeginRead (uint32_t *addr) { - *addr = 0; - FlashBusy(); - digitalWrite(ssel, 0); - FlashWrite(READDATA); - FlashWrite(0); FlashWrite(0); FlashWrite(0); -} - -uint32_t FlashRead32 (uint32_t *addr) { - (void) addr; - uint8_t b0 = FlashReadByte(); uint8_t b1 = FlashReadByte(); - uint8_t b2 = FlashReadByte(); uint8_t b3 = FlashReadByte(); - return b0 | b1<<8 | b2<<16 | b3<<24; -} - -inline void FlashEndRead(uint32_t *addr) { - (void) addr; - digitalWrite(ssel, 1); -} - -#elif defined(CPUFLASH) -// For ATSAMD21 -__attribute__((__aligned__(256))) static const uint8_t flash_store[FLASHSIZE] = { }; - -void row_erase (const volatile void *addr) { - NVMCTRL->ADDR.reg = ((uint32_t)addr) / 2; - NVMCTRL->CTRLA.reg = NVMCTRL_CTRLA_CMDEX_KEY | NVMCTRL_CTRLA_CMD_ER; - while (!NVMCTRL->INTFLAG.bit.READY); -} - -void page_clear () { - // Execute "PBC" Page Buffer Clear - NVMCTRL->CTRLA.reg = NVMCTRL_CTRLA_CMDEX_KEY | NVMCTRL_CTRLA_CMD_PBC; - while (NVMCTRL->INTFLAG.bit.READY == 0); -} - -void page_write () { - NVMCTRL->CTRLA.reg = NVMCTRL_CTRLA_CMDEX_KEY | NVMCTRL_CTRLA_CMD_WP; - while (NVMCTRL->INTFLAG.bit.READY == 0); -} - -bool FlashCheck() { - return true; -} - -void FlashBeginWrite(uint32_t *addr, uint32_t bytes) { - (void) bytes; - *addr = (uint32_t)flash_store; - // Disable automatic page write - NVMCTRL->CTRLB.bit.MANW = 1; -} - -void FlashWrite32 (uint32_t *addr, uint32_t data) { - if (((*addr) & 0xFF) == 0) row_erase((const volatile void *)(*addr)); - if (((*addr) & 0x3F) == 0) page_clear(); - *(volatile uint32_t *)(*addr) = data; - (*addr) = (*addr) + 4; - if (((*addr) & 0x3F) == 0) page_write(); -} - -void FlashEndWrite (uint32_t *addr) { - if (((*addr) & 0x3F) != 0) page_write(); -} - -void FlashBeginRead(uint32_t *addr) { - *addr = (uint32_t)flash_store; -} - -uint32_t FlashRead32 (uint32_t *addr) { - uint32_t data = *(volatile const uint32_t *)(*addr); - (*addr) = (*addr) + 4; - return data; -} - -void FlashEndRead (uint32_t *addr) { - (void) addr; -} -#elif defined(EEPROMFLASH) - -bool FlashCheck() { - return (EEPROM.length() == FLASHSIZE); -} - -void FlashBeginWrite(uint32_t *addr, uint32_t bytes) { - (void) bytes; - *addr = 0; -} - -void FlashWrite32 (uint32_t *addr, uint32_t data) { - EEPROM.put(*addr, data); - (*addr) = (*addr) + 4; -} - -void FlashEndWrite (uint32_t *addr) { - (void) addr; -} - -void FlashBeginRead(uint32_t *addr) { - *addr = 0; -} - -uint32_t FlashRead32 (uint32_t *addr) { - uint32_t data; - EEPROM.get(*addr, data); - (*addr) = (*addr) + 4; - return data; -} - -void FlashEndRead (uint32_t *addr) { - (void) addr; -} -#endif - -/* - saveimage - saves an image of the workspace to the persistent storage selected for the platform. -*/ -int saveimage (object *arg) { -#if defined(sdcardsupport) - unsigned int imagesize = compactimage(&arg); - SDBegin(); - File file; - if (stringp(arg)) { - char buffer[BUFFERSIZE]; - file = SD.open(MakeFilename(arg, buffer), O_RDWR | O_CREAT | O_TRUNC); - if (!file) error2("problem saving to SD card or invalid filename"); - arg = NULL; - } else if (arg == NULL || listp(arg)) { - file = SD.open("/ULISP.IMG", O_RDWR | O_CREAT | O_TRUNC); - if (!file) error2("problem saving to SD card"); - } else error(invalidarg, arg); - SDWrite32(file, (uintptr_t)arg); - SDWrite32(file, imagesize); - SDWrite32(file, (uintptr_t)GlobalEnv); - SDWrite32(file, (uintptr_t)GCStack); - for (int i=0; i FLASHSIZE) error("image too large", number(imagesize)); - uint32_t addr; - FlashBeginWrite(&addr, bytesneeded); - FlashWrite32(&addr, (uintptr_t)arg); - FlashWrite32(&addr, imagesize); - FlashWrite32(&addr, (uintptr_t)GlobalEnv); - FlashWrite32(&addr, (uintptr_t)GCStack); - for (int i=0; itype; - 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 <= 10) 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, j = 0; - for (int i=0; i<6; i++) { - x = x * 40 + toradix40(buffer[j]); - if (buffer[j] != 0) j++; - } - return x; -} - -/* - valid40 - returns true if the symbol in buffer can be encoded as six radix40-encoded characters. -*/ -bool valid40 (char *buffer) { - int t = 11; - for (int i=0; i<6; i++) { - if (toradix40(buffer[i]) < t) return false; - if (buffer[i] == 0) break; - t = 0; - } - 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("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 (float)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("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("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("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); -} - -/* - eqlongsymbol - checks whether two long symbols are equal -*/ -bool eqlongsymbol (symbol_t sym1, symbol_t sym2) { - object *arg1 = (object *)sym1; object *arg2 = (object *)sym2; - while ((arg1 != NULL) || (arg2 != NULL)) { - if (arg1 == NULL || arg2 == NULL) return false; - if (arg1->chars != arg2->chars) return false; - arg1 = car(arg1); arg2 = car(arg2); - } - return true; -} - -/* - eqsymbol - checks whether two symbols are equal -*/ -bool eqsymbol (symbol_t sym1, symbol_t sym2) { - if (!longnamep(sym1) && !longnamep(sym2)) return (sym1 == sym2); // Same short symbol - if (longnamep(sym1) && longnamep(sym2)) return eqlongsymbol(sym1, sym2); // Same long symbol - return false; -} - -/* - eq - implements Lisp eq, taking into account PSRAM -*/ -bool eq (object *arg1, object *arg2) { - if (arg1 == arg2) return true; // Same object - if ((arg1 == nil) || (arg2 == nil)) return false; // Not both values - #if !defined(BOARD_HAS_PSRAM) - if (arg1->cdr != arg2->cdr) return false; // Different values - if (symbolp(arg1) && symbolp(arg2)) return true; // Same symbol - #else - if (symbolp(arg1) && symbolp(arg2)) return eqsymbol(arg1->name, arg2->name); // Same symbol? - if (arg1->cdr != arg2->cdr) return false; // Different values - #endif - 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 -*/ -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); -} - -/* - 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; -} - -/* - 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 - -/* - 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); -} - -/* - remmod - implements rem (mod = false) and mod (mod = true). -*/ -object *remmod (object *args, bool mod) { - object *arg1 = first(args); - object *arg2 = second(args); - if (integerp(arg1) && integerp(arg2)) { - int divisor = arg2->integer; - if (divisor == 0) error2(divisionbyzero); - int dividend = arg1->integer; - int remainder = dividend % divisor; - if (mod && (dividend<0) != (divisor<0)) remainder = remainder + divisor; - return number(remainder); - } else { - float fdivisor = checkintfloat(arg2); - if (fdivisor == 0.0) error2(divisionbyzero); - float fdividend = checkintfloat(arg1); - float fremainder = fmod(fdividend , fdivisor); - if (mod && (fdividend<0) != (fdivisor<0)) fremainder = fremainder + fdivisor; - return makefloat(fremainder); - } -} - -/* - 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 - -/* - testargument - handles the :test argument for functions that accept it -*/ -object *testargument (object *args) { - object *test = bsymbol(EQ); - if (args != NULL) { - if (cdr(args) == NULL) error2("unpaired keyword"); - if ((isbuiltin(first(args), TEST))) test = second(args); - else error("unsupported keyword", first(args)); - } - return test; -} - -/* - 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("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("subscript out of range", car(subs)); - size = size * d; - index = index * d + s; - 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); - } - 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("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("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("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 |= ch<<16; return; - } else if (((*tail)->chars & 0xFFFF) == 0) { - (*tail)->chars |= ch<<8; return; - } else if (((*tail)->chars & 0xFF) == 0) { - (*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, bool esc, gfun_t gfun) { - object *obj = newstring(); - object *tail = obj; - int ch = gfun(); - if (ch == -1) return nil; - while ((ch != delim) && (ch != -1)) { - if (esc && 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; -} - -/* - 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 **arg = &cdr(string); - int top; - if (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; ichars)>>((-shift-2)<<3)) & 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. - Returns -1 if the comparison is false, or the index of the first mismatch if it is true. - If lt is true the result is true if the first argument is less than the second argument. - 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) { - object *arg1 = checkstring(first(args)); - 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; - 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 (eq) { m = m - sizeof(int); while (a != 0) { m++; a = a << 8;} return m;} else return -1; -} - -/* - 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) && isbuiltin(car(val), LAMBDA)) pfstring("user function", pserial); - else if (consp(val) && car(val)->type == CODE) pfstring("code", pserial); - else pfstring("user symbol", pserial); - pserial(')'); pln(pserial); - } else { - cdr(ptr) = cons(var, NULL); ptr = cdr(ptr); - } - } - globals = cdr(globals); - testescape(); - } - // 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 = fntype(i); - pbuiltin((builtin_t)i, pserial); pserial(' '); pserial('('); - if (fntype == FUNCTIONS) pfstring("function", pserial); - else if (fntype == SPECIAL_FORMS || fntype == TAIL_FORMS) pfstring("special form", pserial); - else pfstring("symbol/keyword", pserial); - pserial(')'); pln(pserial); - } else { - cdr(ptr) = cons(bsymbol(i), NULL); ptr = cdr(ptr); - } - } - testescape(); - } - 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("no room for string"); - buffer[index++] = ch; - } - } - form = car(form); - } - buffer[index] = '\0'; - return buffer; -} - -/* - 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 *obj = startstring(); - data2 = ip; - for (int i=0; i<4; i++) { - if (i) pstr('.'); - pintbase(u8[i], 10, pstr); - } - return obj; -} - -/* - 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("illegal IP address"); } - else ipbytes[p] = (ipbytes[p] * 10) + ch - '0'; - } - } - form = car(form); - } - return ipaddress; -} - -/* - value - lookup variable in environment, taking into account PSRAM -*/ -object *value (symbol_t n, object *env) { - while (env != NULL) { - object *pair = car(env); - #if !defined(BOARD_HAS_PSRAM) - if (pair != NULL && car(pair)->name == n) return pair; - #else - if (pair != NULL && eqsymbol(car(pair)->name, n)) return pair; - #endif - 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("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 = 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, "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, "illegal optional parameter", var); - } else if (!symbolp(var)) { - errorsym(name, "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) && (fntype(fname) == 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(illegalfn, 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)) { 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)); } - i--; - } - return &car(list); - } - if (sname == sym(CHAR)) { - 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)); } - 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); } - return getarray(array, cddr(args), env, bit); - } - } - error2("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 - -/* - mapcl - handles either mapc when mapl=false, or mapl when mapl=true -*/ -object *mapcl (object *args, object *env, bool mapl) { - object *function = first(args); - args = cdr(args); - object *result = first(args); - protect(result); - object *params = cons(NULL, NULL); - protect(params); - // Make parameters - while (true) { - object *tailp = params; - object *lists = args; - while (lists != NULL) { - object *list = car(lists); - if (list == NULL) { - 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; - lists = cdr(lists); - } - apply(function, cdr(params), env); - } -} - -/* - 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 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 *function = first(args); - args = cdr(args); - object *params = cons(NULL, NULL); - protect(params); - object *head = cons(NULL, NULL); - protect(head); - object *tail = head; - // Make parameters - while (true) { - object *tailp = params; - object *lists = args; - while (lists != NULL) { - object *list = car(lists); - if (list == NULL) { - 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; - lists = cdr(lists); - } - object *result = apply(function, cdr(params), env); - fun(result, &tail); - } -} - -/* - dobody - function used by do when star=false and do* when star=true -*/ -object *dobody (object *args, object *env, bool star) { - object *varlist = first(args), *endlist = second(args); - object *head = cons(NULL, NULL); - protect(head); - object *ptr = head; - object *newenv = env; - while (varlist != NULL) { - object *varform = first(varlist); - object *var, *init = NULL, *step = NULL; - if (atom(varform)) var = varform; - else { - var = first(varform); - varform = cdr(varform); - 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); - varlist = cdr(varlist); - } - env = newenv; - head = cdr(head); - object *endtest = first(endlist), *results = cdr(endlist); - while (eval(endtest, env) == NULL) { - object *forms = cddr(args); - while (forms != NULL) { - object *result = eval(car(forms), env); - if (tstflag(RETURNFLAG)) { - clrflag(RETURNFLAG); - return result; - } - forms = cdr(forms); - } - object *varlist = head; - int count = 0; - while (varlist != NULL) { - object *varform = first(varlist); - object *step = car(varform), *pair = cdr(varform); - if (step != NULL) { - object *val = eval(first(step), env); - if (star) { - cdr(pair) = val; - } else { - push(val, GCStack); - push(pair, GCStack); - count++; - } - } - varlist = cdr(varlist); - } - while (count > 0) { - cdr(car(GCStack)) = car(cdr(GCStack)); - pop(GCStack); pop(GCStack); - count--; - } - } - unprotect(); - return eval(tf_progn(results, env), env); -} - -// I2C interface for up to two ports, using Arduino Wire - -void I2Cinit (TwoWire *port, bool enablePullup) { - (void) enablePullup; - port->begin(); -} - -int I2Cread (TwoWire *port) { - return port->read(); -} - -void I2Cwrite (TwoWire *port, uint8_t data) { - port->write(data); -} - -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); - return ok; -} - -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? - // Release pins - port->end(); -} - -// Streams - -// Simplify board differences -#if defined(ARDUINO_NRF52840_CLUE) || defined(ARDUINO_GRAND_CENTRAL_M4) \ - || defined(ARDUINO_PYBADGE_M4) || defined(ARDUINO_PYGAMER_M4) || defined(ARDUINO_TEENSY40) \ - || defined(ARDUINO_TEENSY41) || defined(ARDUINO_RASPBERRY_PI_PICO) \ - || defined(ARDUINO_RASPBERRY_PI_PICO_W) || defined(ARDUINO_RASPBERRY_PI_PICO_2) \ - || defined(ARDUINO_RASPBERRY_PI_PICO_2W) || defined(ARDUINO_PIMORONI_PICO_PLUS_2) -#define ULISP_SPI1 -#endif -#if defined(ARDUINO_WIO_TERMINAL) || defined(ARDUINO_BBC_MICROBIT_V2) \ - || defined(ARDUINO_TEENSY40) || defined(ARDUINO_TEENSY41) || defined(MAX32620) \ - || defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_W) \ - || defined(ARDUINO_ADAFRUIT_QTPY_RP2040) || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040) \ - || defined(ARDUINO_RASPBERRY_PI_PICO_2) || defined(ARDUINO_RASPBERRY_PI_PICO_2W) \ - || defined(ARDUINO_PIMORONI_PICO_PLUS_2) || defined(ARDUINO_GRAND_CENTRAL_M4) \ - || defined(ARDUINO_NRF52840_CIRCUITPLAY) -#define ULISP_I2C1 -#endif -#if defined(ARDUINO_SAM_DUE) || defined(ARDUINO_TEENSY40) || defined(ARDUINO_TEENSY41) -#define ULISP_SERIAL3 -#elif defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_W) \ - || defined(ARDUINO_RASPBERRY_PI_PICO_2) || defined(ARDUINO_RASPBERRY_PI_PICO_2W) \ - || defined(ARDUINO_PIMORONI_PICO_PLUS_2) -#define ULISP_SERIAL2 -#elif !defined(CPU_NRF51822) && !defined(CPU_NRF52833) && !defined(ARDUINO_FEATHER_F405) -#define ULISP_SERIAL1 -#endif -#if defined(ARDUINO_RASPBERRY_PI_PICO_W) || defined(ARDUINO_RASPBERRY_PI_PICO_2W) \ -|| defined(ARDUINO_UNOWIFIR4) -#define ULISP_WIFI -#endif - -inline int spiread () { return SPI.transfer(0); } -#if defined(ULISP_SPI1) -inline int spi1read () { return SPI1.transfer(0); } -#endif -inline int i2cread () { return I2Cread(&Wire); } -#if defined(ULISP_I2C1) -inline int i2c1read () { return I2Cread(&Wire1); } -#endif -#if defined(ULISP_SERIAL3) -inline int serial3read () { while (!Serial3.available()) testescape(); return Serial3.read(); } -#endif -#if defined(ULISP_SERIAL3) || defined(ULISP_SERIAL2) -inline int serial2read () { while (!Serial2.available()) testescape(); return Serial2.read(); } -#endif -#if defined(ULISP_SERIAL3) || defined(ULISP_SERIAL2) || defined(ULISP_SERIAL1) -inline int serial1read () { while (!Serial1.available()) testescape(); return Serial1.read(); } -#endif -#if defined(sdcardsupport) -File SDpfile, SDgfile; -inline int SDread () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - return SDgfile.read(); -} -#endif - -#if defined(ULISP_WIFI) -WiFiClient client; -WiFiServer server(80); - -inline int WiFiread () { - if (LastChar) { - char temp = LastChar; - LastChar = 0; - return temp; - } - while (!client.available()) testescape(); - return client.read(); -} -#endif - -void serialbegin (int address, int baud) { - #if defined(ULISP_SERIAL3) - if (address == 1) Serial1.begin((long)baud*100); - else if (address == 2) Serial2.begin((long)baud*100); - else if (address == 3) Serial3.begin((long)baud*100); - #elif defined(ULISP_SERIAL2) - if (address == 1) Serial1.begin((long)baud*100); - else if (address == 2) Serial2.begin((long)baud*100); - #elif defined(ULISP_SERIAL1) - if (address == 1) Serial1.begin((long)baud*100); - #else - (void) baud; - if (false); - #endif - else error("port not supported", number(address)); -} - -void serialend (int address) { - #if defined(ULISP_SERIAL3) - if (address == 1) {Serial1.flush(); Serial1.end(); } - else if (address == 2) {Serial2.flush(); Serial2.end(); } - else if (address == 3) {Serial3.flush(); Serial3.end(); } - #elif defined(ULISP_SERIAL2) - if (address == 1) {Serial1.flush(); Serial1.end(); } - else if (address == 2) {Serial2.flush(); Serial2.end(); } - #elif defined(ULISP_SERIAL1) - if (address == 1) {Serial1.flush(); Serial1.end(); } - #else - if (false); - #endif - else error("port not supported", number(address)); -} - -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) { - if (address < 128) gfun = i2cread; - #if defined(ULISP_I2C1) - else gfun = i2c1read; - #endif - } else if (streamtype == SPISTREAM) { - if (address < 128) gfun = spiread; - #if defined(ULISP_SPI1) - else gfun = spi1read; - #endif - } - else if (streamtype == SERIALSTREAM) { - if (address == 0) gfun = gserial; - #if defined(ULISP_SERIAL3) - else if (address == 1) gfun = serial1read; - else if (address == 2) gfun = serial2read; - else if (address == 3) gfun = serial3read; - #elif defined(ULISP_SERIAL2) - else if (address == 1) gfun = serial1read; - else if (address == 2) gfun = serial2read; - #elif defined(ULISP_SERIAL1) - else if (address == 1) gfun = serial1read; - #endif - } - #if defined(sdcardsupport) - else if (streamtype == SDSTREAM) gfun = (gfun_t)SDread; - #endif - #if defined(ULISP_WIFI) - else if (streamtype == WIFISTREAM) gfun = (gfun_t)WiFiread; - #endif - else error2("unknown stream type"); - return gfun; -} - -inline void spiwrite (char c) { SPI.transfer(c); } -#if defined(ULISP_SPI1) -inline void spi1write (char c) { SPI1.transfer(c); } -#endif -inline void i2cwrite (char c) { I2Cwrite(&Wire, c); } -#if defined(ULISP_I2C1) -inline void i2c1write (char c) { I2Cwrite(&Wire1, c); } -#endif -#if defined(ULISP_SERIAL3) -inline void serial1write (char c) { Serial1.write(c); } -inline void serial2write (char c) { Serial2.write(c); } -inline void serial3write (char c) { Serial3.write(c); } -#elif defined(ULISP_SERIAL2) -inline void serial2write (char c) { Serial2.write(c); } -inline void serial1write (char c) { Serial1.write(c); } -#elif defined(ULISP_SERIAL1) -inline void serial1write (char c) { Serial1.write(c); } -#endif -#if defined(sdcardsupport) -inline void SDwrite (char c) { SDpfile.write(uint8_t(c)); } // Fix for RP2040 -#endif -#if defined(ULISP_WIFI) -inline void WiFiwrite (char c) { client.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) { - if (address < 128) pfun = i2cwrite; - #if defined(ULISP_I2C1) - else pfun = i2c1write; - #endif - } else if (streamtype == SPISTREAM) { - if (address < 128) pfun = spiwrite; - #if defined(ULISP_SPI1) - else pfun = spi1write; - #endif - } else if (streamtype == SERIALSTREAM) { - if (address == 0) pfun = pserial; - #if defined(ULISP_SERIAL3) - else if (address == 1) pfun = serial1write; - else if (address == 2) pfun = serial2write; - else if (address == 3) pfun = serial3write; - #elif defined(ULISP_SERIAL2) - else if (address == 1) pfun = serial1write; - else if (address == 2) pfun = serial2write; - #elif defined(ULISP_SERIAL1) - else if (address == 1) pfun = serial1write; - #endif - } - 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 - #if defined(ULISP_WIFI) - else if (streamtype == WIFISTREAM) pfun = (pfun_t)WiFiwrite; - #endif - else error2("unknown stream type"); - return pfun; -} - -// Check pins - these are board-specific not processor-specific - -void checkanalogread (int pin) { -#if defined(ARDUINO_SAM_DUE) - if (!(pin>=54 && pin<=65)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_SAMD_ZERO) - if (!(pin>=14 && pin<=19)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_SAMD_MKRZERO) - if (!(pin>=15 && pin<=21)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_ITSYBITSY_M0) - if (!(pin>=14 && pin<=25)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_NEOTRINKEY_M0) - if (!(pin==1 || pin==2 || pin==6)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_GEMMA_M0) - if (!(pin>=8 && pin<=10)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_QTPY_M0) - if (!((pin>=0 && pin<=3) || (pin>=6 && pin<=10))) error(invalidpin, number(pin)); -#elif defined(ARDUINO_SEEED_XIAO_M0) - if (!(pin>=0 && pin<=10)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_METRO_M4) - if (!(pin>=14 && pin<=21)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_ITSYBITSY_M4) || defined(ARDUINO_FEATHER_M4) - if (!(pin>=14 && pin<=20)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_PYBADGE_M4) - if (!(pin>=14 && pin<=23)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_PYGAMER_M4) - if (!(pin>=14 && pin<=25)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_WIO_TERMINAL) - if (!((pin>=0 && pin<=8))) error(invalidpin, number(pin)); -#elif defined(ARDUINO_GRAND_CENTRAL_M4) - if (!((pin>=67 && pin<=74) || (pin>=54 && pin<=61))) error(invalidpin, number(pin)); -#elif defined(ARDUINO_BBC_MICROBIT) || defined(ARDUINO_SINOBIT) - if (!((pin>=0 && pin<=4) || pin==10)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_BBC_MICROBIT_V2) - if (!((pin>=0 && pin<=4) || pin==10 || pin==29)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_CALLIOPE_MINI) - if (!(pin==1 || pin==2 || (pin>=4 && pin<=6) || pin==21)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_NRF52840_ITSYBITSY) - if (!(pin>=14 && pin<=20)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_Seeed_XIAO_nRF52840) || defined(ARDUINO_Seeed_XIAO_nRF52840_Sense) - if (!(pin>=0 && pin<=5)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_NRF52840_CLUE) - if (!((pin>=0 && pin<=4) || pin==10 || pin==12 || pin==16)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_NRF52840_CIRCUITPLAY) - if (!(pin==0 || (pin>=2 && pin<=3) || pin==6 || (pin>=9 && pin<=10) || (pin>=22 && pin<=23))) error(invalidpin, number(pin)); -#elif defined(MAX32620) - if (!(pin>=49 && pin<=52)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_TEENSY40) - if (!((pin>=14 && pin<=27))) error(invalidpin, number(pin)); -#elif defined(ARDUINO_TEENSY41) - if (!((pin>=14 && pin<=27) || (pin>=38 && pin<=41))) error(invalidpin, number(pin)); -#elif defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_W) \ - || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040) || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040_ADALOGGER) \ - || defined(ARDUINO_ADAFRUIT_QTPY_RP2040) || defined(ARDUINO_SEEED_XIAO_RP2040) \ - || defined(ARDUINO_RASPBERRY_PI_PICO_2) || defined(ARDUINO_RASPBERRY_PI_PICO_2W) \ - || defined(ARDUINO_PIMORONI_PICO_PLUS_2) - if (!(pin>=26 && pin<=29)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_MINIMA) || defined(ARDUINO_UNOWIFIR4) - if (!((pin>=14 && pin<=21))) error(invalidpin, number(pin)); -#endif -} - -void checkanalogwrite (int pin) { -#if defined(ARDUINO_SAM_DUE) - if (!((pin>=2 && pin<=13) || pin==66 || pin==67)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_SAMD_ZERO) - if (!((pin>=3 && pin<=6) || (pin>=8 && pin<=13) || pin==14)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_SAMD_MKRZERO) - if (!((pin>=0 && pin<=8) || pin==10 || pin==18 || pin==19)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_ITSYBITSY_M0) - if (!((pin>=3 && pin<=6) || (pin>=8 && pin<=13) || (pin>=15 && pin<=16) || (pin>=22 && pin<=25))) error(invalidpin, number(pin)); -#elif defined(ARDUINO_NEOTRINKEY_M0) - error2("not supported"); -#elif defined(ARDUINO_GEMMA_M0) - if (!(pin==0 || pin==2 || pin==9 || pin==10)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_QTPY_M0) - if (!(pin==0 || (pin>=2 && pin<=10))) error(invalidpin, number(pin)); -#elif defined(ARDUINO_SEEED_XIAO_M0) - if (!(pin>=0 && pin<=10)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_METRO_M4) - if (!(pin>=0 && pin<=15)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_ITSYBITSY_M4) - if (!(pin==0 || pin==1 || pin==4 || pin==5 || pin==7 || (pin>=9 && pin<=15) || pin==21 || pin==22)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_FEATHER_M4) - if (!(pin==0 || pin==1 || (pin>=4 && pin<=6) || (pin>=9 && pin<=13) || pin==14 || pin==15 || pin==17 || pin==21 || pin==22)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_PYBADGE_M4) - if (!(pin==4 || pin==7 || pin==9 || (pin>=12 && pin<=13) || (pin>=24 && pin<=25) || (pin>=46 && pin<=47))) error(invalidpin, number(pin)); -#elif defined(ARDUINO_PYGAMER_M4) - if (!(pin==4 || pin==7 || pin==9 || (pin>=12 && pin<=13) || (pin>=26 && pin<=27) || (pin>=46 && pin<=47))) error(invalidpin, number(pin)); -#elif defined(ARDUINO_WIO_TERMINAL) - if (!((pin>=0 && pin<=2) || pin==6 || pin==8 || (pin>=12 && pin<=20) || pin==24)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_GRAND_CENTRAL_M4) - if (!((pin>=2 && pin<=9) || pin==11 || (pin>=13 && pin<=45) || pin==48 || (pin>=50 && pin<=53) || pin==58 || pin==61 || pin==68 || pin==69)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_BBC_MICROBIT) || defined(ARDUINO_BBC_MICROBIT_V2) || defined(ARDUINO_SINOBIT) - if (!(pin>=0 && pin<=32)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_CALLIOPE_MINI) - if (!(pin>=0 && pin<=30)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_NRF52840_ITSYBITSY) - if (!(pin>=0 && pin<=25)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_NRF52840_CLUE) - if (!(pin>=0 && pin<=46)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_NRF52840_CIRCUITPLAY) - if (!(pin>=0 && pin<=35)) error(invalidpin, number(pin)); -#elif defined(MAX32620) - if (!((pin>=20 && pin<=29) || pin==32 || (pin>=40 && pin<=48))) error(invalidpin, number(pin)); -#elif defined(ARDUINO_TEENSY40) - if (!((pin>=0 && pin<=15) || (pin>=18 && pin<=19) || (pin>=22 && pin<=25) || (pin>=28 && pin<=29) || (pin>=33 && pin<=39))) error(invalidpin, number(pin)); -#elif defined(ARDUINO_TEENSY41) - if (!((pin>=0 && pin<=15) || (pin>=18 && pin<=19) || (pin>=22 && pin<=25) || (pin>=28 && pin<=29) || pin==33 || (pin>=36 && pin<=37))) error(invalidpin, number(pin)); -#elif defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040) \ - || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040_ADALOGGER) || defined(ARDUINO_ADAFRUIT_QTPY_RP2040) \ - || defined(ARDUINO_SEEED_XIAO_RP2040) || defined(ARDUINO_RASPBERRY_PI_PICO_2) \ - || defined(ARDUINO_PIMORONI_PICO_PLUS_2) - if (!(pin>=0 && pin<=29)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_RASPBERRY_PI_PICO_W) || defined(ARDUINO_RASPBERRY_PI_PICO_2W) - if (!((pin>=0 && pin<=29) || pin == 32)) error(invalidpin, number(pin)); -#elif defined(ARDUINO_MINIMA) || defined(ARDUINO_UNOWIFIR4) - if (!((pin>=0 && pin<=21))) error(invalidpin, number(pin)); -#endif -} - -// Note - -const int scale[] = {4186,4435,4699,4978,5274,5588,5920,6272,6645,7040,7459,7902}; - -void playnote (int pin, int note, int octave) { -#if defined(ARDUINO_NRF52840_CLUE) || defined(ARDUINO_NRF52840_CIRCUITPLAY) \ - || defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_W) \ - || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040) || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040_ADALOGGER) \ - || defined(ARDUINO_ADAFRUIT_QTPY_RP2040) || defined(ARDUINO_SEEED_XIAO_RP2040) \ - || defined(ARDUINO_RASPBERRY_PI_PICO_2) || defined(ARDUINO_RASPBERRY_PI_PICO_2W) \ - || defined(ARDUINO_PIMORONI_PICO_PLUS_2) || defined(ARDUINO_WIO_TERMINAL) - int oct = octave + note/12; - int prescaler = 8 - oct; - if (prescaler<0 || prescaler>8) error("octave out of range", number(oct)); - tone(pin, scale[note%12]>>prescaler); -#else - (void) pin, (void) note, (void) octave; -#endif -} - -void nonote (int pin) { -#if defined(ARDUINO_NRF52840_CLUE) || defined(ARDUINO_NRF52840_CIRCUITPLAY) \ - || defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_W) \ - || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040) || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040_ADALOGGER) \ - || defined(ARDUINO_ADAFRUIT_QTPY_RP2040) || defined(ARDUINO_SEEED_XIAO_RP2040) \ - || defined(ARDUINO_RASPBERRY_PI_PICO_2) || defined(ARDUINO_RASPBERRY_PI_PICO_2W) \ - || defined(ARDUINO_PIMORONI_PICO_PLUS_2) || defined(ARDUINO_WIO_TERMINAL) - noTone(pin); -#else - (void) pin; -#endif -} - -// Sleep - -#if defined(CPU_ATSAMD21) -void WDT_Handler(void) { - // ISR for watchdog early warning - WDT->CTRL.bit.ENABLE = 0; // Disable watchdog - while(WDT->STATUS.bit.SYNCBUSY); // Sync CTRL write - WDT->INTFLAG.bit.EW = 1; // Clear interrupt flag -} -#endif - -void initsleep () { -#if defined(CPU_ATSAMD21) - // One-time initialization of watchdog timer. - - // Generic clock generator 2, divisor = 32 (2^(DIV+1)) - GCLK->GENDIV.reg = GCLK_GENDIV_ID(2) | GCLK_GENDIV_DIV(4); - // Enable clock generator 2 using low-power 32KHz oscillator. - // With /32 divisor above, this yields 1024Hz clock. - GCLK->GENCTRL.reg = GCLK_GENCTRL_ID(2) | - GCLK_GENCTRL_GENEN | - GCLK_GENCTRL_SRC_OSCULP32K | - GCLK_GENCTRL_DIVSEL; - while(GCLK->STATUS.bit.SYNCBUSY); - // WDT clock = clock gen 2 - GCLK->CLKCTRL.reg = GCLK_CLKCTRL_ID_WDT | - GCLK_CLKCTRL_CLKEN | - GCLK_CLKCTRL_GEN_GCLK2; - - // Enable WDT early-warning interrupt - NVIC_DisableIRQ(WDT_IRQn); - NVIC_ClearPendingIRQ(WDT_IRQn); - NVIC_SetPriority(WDT_IRQn, 0); // Top priority - NVIC_EnableIRQ(WDT_IRQn); -#endif -} - -void doze (int secs) { -#if defined(CPU_ATSAMD21) - WDT->CTRL.reg = 0; // Disable watchdog for config - while(WDT->STATUS.bit.SYNCBUSY); - WDT->INTENSET.bit.EW = 1; // Enable early warning interrupt - WDT->CONFIG.bit.PER = 0xB; // Period = max - WDT->CONFIG.bit.WINDOW = 0x7; // Set time of interrupt = 1024 cycles = 1 sec - WDT->CTRL.bit.WEN = 1; // Enable window mode - while(WDT->STATUS.bit.SYNCBUSY); // Sync CTRL write - - SysTick->CTRL = 0; // Stop SysTick interrupts - - while (secs > 0) { - WDT->CLEAR.reg = WDT_CLEAR_CLEAR_KEY;// Clear watchdog interval - while(WDT->STATUS.bit.SYNCBUSY); - WDT->CTRL.bit.ENABLE = 1; // Start watchdog now! - while(WDT->STATUS.bit.SYNCBUSY); - SCB->SCR |= SCB_SCR_SLEEPDEEP_Msk; // Deepest sleep - __DSB(); - __WFI(); // Wait for interrupt - secs--; - } - SysTick->CTRL = 7; // Restart SysTick interrupts -#else - delay(1000*secs); -#endif -} - -// 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; -} - -/* - basewidth - calculates the character width of an integer printed in a given base -*/ -uint8_t basewidth (object *obj, uint8_t base) { - PrintCount = 0; - pintbase(obj->integer, base, pcount); - return PrintCount; -} - -/* - quoted - tests whether an object is quoted -*/ -bool quoted (object *obj) { - return (consp(obj) && car(obj) != NULL && car(obj)->name == sym(QUOTE) && consp(cdr(obj)) && cddr(obj) == NULL); -} - -/* - subwidth - returns the space left from w after printing object -*/ -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); -} - -/* - subwidth - returns the space left from w after printing a list -*/ -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 - handles pretty-printing -*/ -void superprint (object *form, int lm, pfun_t pfun) { - if (atom(form)) { - if (isbuiltin(form, NOTHING)) printsymbol(form, pfun); - else printobject(form, pfun); - } else if (quoted(form)) { - pfun('\''); - superprint(car(cdr(form)), lm + 1, pfun); - } else { - lm = lm + PPINDENT; - bool fits = (subwidth(form, ppwidth - lm - PPINDENT) >= 0); - 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 - 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) { - pfun('('); - separate = false; - } else if (special) { - pfun(' '); - special--; - } else if (fits) { - pfun(' '); - } else { pln(pfun); indent(lm, ' ', pfun); } - superprint(car(form), lm+extra, pfun); - form = cdr(form); - } - 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) { - 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('?'); - } -} - -// Assembler - -object *call (int entry, int nargs, object *args, object *env) { -#if defined(CODESIZE) - (void) env; - int param[4]; - for (int i=0; iinteger; - else param[i] = (uintptr_t)arg; - args = cdr(args); - } - int w = ((intfn_ptr_type)&MyCode[entry])(param[0], param[1], param[2], param[3]); - return number(w); -#else - return nil; -#endif -} - -void putcode (object *arg, int origin, int pc) { -#if defined(CODESIZE) - int code = checkinteger(arg); - MyCode[origin+pc] = code & 0xff; - MyCode[origin+pc+1] = (code>>8) & 0xff; - #if defined(assemblerlist) - printhex4(pc, pserial); - printhex4(code, pserial); - #endif -#endif -} - -int assemble (int pass, int origin, object *entries, object *env, object *pcpair) { - int pc = 0; cdr(pcpair) = number(pc); - while (entries != NULL) { - object *arg = first(entries); - if (symbolp(arg)) { - if (pass == 2) { - #if defined(assemblerlist) - printhex4(pc, pserial); - indent(5, ' ', pserial); - printobject(arg, pserial); pln(pserial); - #endif - } else { - object *pair = findvalue(arg, env); - cdr(pair) = number(pc); - } - } else { - object *argval = eval(arg, env); - if (listp(argval)) { - object *arglist = argval; - while (arglist != NULL) { - if (pass == 2) { - putcode(first(arglist), origin, pc); - #if defined(assemblerlist) - if (arglist == argval) superprint(arg, 0, pserial); - pln(pserial); - #endif - } - pc = pc + 2; - cdr(pcpair) = number(pc); - arglist = cdr(arglist); - } - } else if (integerp(argval)) { - if (pass == 2) { - putcode(argval, origin, pc); - #if defined(assemblerlist) - superprint(arg, 0, pserial); pln(pserial); - #endif - } - pc = pc + 2; - cdr(pcpair) = number(pc); - } else error("illegal entry", arg); - } - entries = cdr(entries); - } - // Round up to multiple of 4 to give code size - if (pc%4 != 0) pc = pc + 4 - pc%4; - return pc; -} - -// Special forms - -object *sp_quote (object *args, object *env) { - (void) env; - 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; - 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) { - 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; builtin_t setq = Context; - while (args != NULL) { - if (cdr(args) == NULL) { Context = setq; 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 (;;) { - args = start; - while (args != NULL) { - object *result = eval(car(args),env); - if (tstflag(RETURNFLAG)) { - clrflag(RETURNFLAG); - return result; - } - args = cdr(args); - } - testescape(); - } -} - -/* - (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; - object *item = eval(first(args), env); - object **loc = place(second(args), env, &bit); - if (bit != -1) error2(invalidarg); - push(item, *loc); - return *loc; -} - -/* - (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) { - int bit; - object *arg = first(args); - if (arg == NULL) error2(invalidarg); - object **loc = place(arg, env, &bit); - if (bit < -1) error(invalidarg, arg); - if (!consp(*loc)) error(notalist, *loc); - 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; - object **loc = place(first(args), env, &bit); - if (bit < -1) error2(notanumber); - 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("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; - object **loc = place(first(args), env, &bit); - if (bit < -1) error2(notanumber); - 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("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; builtin_t setf = Context; - object *arg = nil; - while (args != NULL) { - if (cdr(args) == NULL) { Context = setf; error2(oddargs); } - object **loc = place(first(args), env, &bit); - arg = eval(second(args), env); - 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<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) { - object *param = checkarguments(args, 0, 1); - 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("\nTime: ", pserial); - if (elapsed < 1000) { - pint(elapsed, pserial); - pfstring(" ms\n", pserial); - } else { - elapsed = elapsed+50; - pint(elapsed/1000, pserial); - pserial('.'); pint((elapsed/100)%10, pserial); - pfstring(" 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) { - object *params = checkarguments(args, 1, 1); - object *var = first(params); - object *pair = cons(var, stream(STRINGSTREAM, 0)); - push(pair,env); - object *string = startstring(); - protect(string); - object *forms = cdr(args); - eval(tf_progn(forms,env), env); - unprotect(); - 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 = checkarguments(args, 2, 3); - 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. If port is omitted it defaults to 0, otherwise it specifies the port, 0 or 1. -*/ -object *sp_withi2c (object *args, object *env) { - object *params = checkarguments(args, 2, 4); - object *var = first(params); - int address = checkinteger(eval(second(params), env)); - params = cddr(params); - if ((address == 0 || address == 1) && params != NULL) { - address = address * 128 + checkinteger(eval(first(params), env)); - params = cdr(params); - } - int read = 0; // Write - I2Ccount = 0; - if (params != NULL) { - object *rw = eval(first(params), env); - if (integerp(rw)) I2Ccount = rw->integer; - read = (rw != NULL); - } - // Top bit of address is I2C port - TwoWire *port = &Wire; - #if defined(ULISP_I2C1) - if (address > 127) port = &Wire1; - #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); - object *result = eval(tf_progn(forms,env), env); - I2Cstop(port, read); - return result; -} - -/* - (with-spi (str pin [clock] [bitorder] [mode] [port]) 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), SPI mode (default 0), and port 0 or 1 (default 0). -*/ -object *sp_withspi (object *args, object *env) { - object *params = checkarguments(args, 2, 6); - 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, address = 0; // Defaults - BitOrder 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; - params = cdr(params); - if (params != NULL) { - address = checkinteger(eval(car(params), env)); - } - } - } - } - object *pair = cons(var, stream(SPISTREAM, pin + 128*address)); - push(pair,env); - SPIClass *spiClass = &SPI; - #if defined(ULISP_SPI1) - if (address == 1) spiClass = &SPI1; - #endif - spiClass->begin(); - spiClass->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); - spiClass->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 = checkarguments(args, 2, 3); - object *var = first(params); - params = cdr(params); - if (params == NULL) error2("no filename specified"); - builtin_t temp = Context; - object *filename = eval(first(params), env); - Context = temp; - if (!stringp(filename)) error("filename is not a string", filename); - params = cdr(params); - SDBegin(); - int mode = 0; - if (params != NULL && first(params) != NULL) mode = checkinteger(first(params)); - int oflag = O_READ; - if (mode == 1) oflag = O_RDWR | O_CREAT | O_APPEND; else if (mode == 2) oflag = O_RDWR | O_CREAT | O_TRUNC; - if (mode >= 1) { - char buffer[BUFFERSIZE]; - SDpfile = SD.open(MakeFilename(filename, buffer), oflag); - if (!SDpfile) error2("problem writing to SD card or invalid filename"); - } else { - char buffer[BUFFERSIZE]; - SDgfile = SD.open(MakeFilename(filename, buffer), oflag); - if (!SDgfile) error2("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("not supported"); - return nil; - #endif -} - -// Assembler - -/* - (defcode name (parameters) form*) - Creates a machine-code function called name from a series of 16-bit integers given in the body of the form. - These are written into RAM, and can be executed by calling the function in the same way as a normal Lisp function. -*/ -object *sp_defcode (object *args, object *env) { -#if defined(CODESIZE) - setflag(NOESC); - object *var = first(args); - object *params = second(args); - if (!symbolp(var)) error("not a symbol", var); - - // Make parameters into synonyms for registers r0, r1, etc - int regn = 0; - while (params != NULL) { - if (regn > 3) error("more than 4 parameters", var); - object *regpair = cons(car(params), bsymbol((builtin_t)((toradix40('r')*40+toradix40('0')+regn)*2560000))); // Symbol for r0 etc - push(regpair,env); - regn++; - params = cdr(params); - } - - // Make *pc* a local variable for program counter - object *pcpair = cons(bsymbol(PSTAR), number(0)); - push(pcpair,env); - - args = cdr(args); - - // Make labels into local variables - object *entries = cdr(args); - while (entries != NULL) { - object *arg = first(entries); - if (symbolp(arg)) { - object *pair = cons(arg,number(0)); - push(pair,env); - } - entries = cdr(entries); - } - - // First pass - int origin = 0; - int codesize = assemble(1, origin, cdr(args), env, pcpair); - - // See if it will fit - object *globals = GlobalEnv; - while (globals != NULL) { - object *pair = car(globals); - if (pair != NULL && car(pair) != var && consp(cdr(pair))) { // Exclude me if I already exist - object *codeid = second(pair); - if (codeid->type == CODE) { - codesize = codesize + endblock(codeid) - startblock(codeid); - } - } - globals = cdr(globals); - } - if (codesize > CODESIZE) error("not enough room for code", var); - - // Compact the code block, removing gaps - origin = 0; - object *block; - int smallest; - - do { - smallest = CODESIZE; - globals = GlobalEnv; - while (globals != NULL) { - object *pair = car(globals); - if (pair != NULL && car(pair) != var && consp(cdr(pair))) { // Exclude me if I already exist - object *codeid = second(pair); - if (codeid->type == CODE) { - if (startblock(codeid) < smallest && startblock(codeid) >= origin) { - smallest = startblock(codeid); - block = codeid; - } - } - } - globals = cdr(globals); - } - - // Compact fragmentation if necessary - if (smallest == origin) origin = endblock(block); // No gap - else if (smallest < CODESIZE) { // Slide block down - int target = origin; - for (int i=startblock(block); iinteger = target<<16 | origin; - origin = target; - } - - } while (smallest < CODESIZE); - - // Second pass - origin is first free location - codesize = assemble(2, origin, cdr(args), env, pcpair); - - object *val = cons(codehead((origin+codesize)<<16 | origin), args); - object *pair = value(var->name, GlobalEnv); - if (pair != NULL) cdr(pair) = val; - else push(cons(var, val), GlobalEnv); - clrflag(NOESC); - return var; -#else - error2("not available"); - 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 quote(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 built-in or user-defined keyword. -*/ -object *fn_keywordp (object *args, object *env) { - (void) env; - object *arg = first(args); - if (!symbolp(arg)) return nil; - return (keywordp(arg) || colonp(arg->name)) ? 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("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("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; -} - -/* - (copy-list list) - Returns a copy of a list. -*/ -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 (consp(arg)) { - cdr(ptr) = cons(car(arg), cdr(arg)); - ptr = cdr(ptr); arg = cdr(arg); - } - return cdr(result); -} - -/* - (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("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("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("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 [:test function]) - 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 *key = first(args); - object *list = second(args); - object *test = testargument(cddr(args)); - 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 && apply(test, cons(key, cons(car(pair), NULL)), env) != NULL) return pair; - list = cdr(list); - } - return nil; -} - -/* - (member item list [:test function]) - 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 *item = first(args); - object *list = second(args); - object *test = testargument(cddr(args)); - while (list != NULL) { - if (improperp(list)) error(notproper, list); - if (apply(test, cons(item, cons(car(list), NULL)), env) != NULL) 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) { - return mapcl(args, env, false); -} - -/* - (mapl function list1 [list]*) - 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) { - return mapcl(args, env, true); -} - -/* - (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, false); -} - -/* - (mapcan function list1 [list]*) - Applies the function to each element in one or more lists. The results should be lists, - and these are destructively concatenated together to give the value returned. -*/ -object *fn_mapcan (object *args, object *env) { - return mapcarcan(args, env, mapcanfun, false); -} - -/* - (maplist function list1 [list]*) - 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) { - return mapcarcan(args, env, mapcarfun, true); -} - -/* - (mapcon function list1 [list]*) - 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) { - return mapcarcan(args, env, mapcanfun, true); -} - -// 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(divisionbyzero); - return makefloat(1.0 / f); - } else if (integerp(arg)) { - int i = arg->integer; - if (i == 0) error2(divisionbyzero); - 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(divisionbyzero); - 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; - return remmod(args, true); -} - -/* - (rem number number) - Returns the remainder from dividing the first argument by the second argument. - If both arguments are integers the result is an integer; otherwise it's a floating-point number. -*/ -object *fn_rem (object *args, object *env) { - (void) env; - return remmod(args, false); -} - -/* - (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)))); -} - -/* - (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)))); -} - -/* - (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("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 [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))); -} - -/* - (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(round(checkintfloat(arg) / checkintfloat(first(args)))); - else return number(round(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) - Returns t if the two strings are the same, or nil otherwise. -*/ -object *fn_stringeq (object *args, object *env) { - (void) env; - int m = stringcompare(args, false, false, true); - return m == -1 ? nil : tee; -} - -/* - (string< string string) - 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; - int m = stringcompare(args, true, false, false); - return m == -1 ? nil : number(m); -} - -/* - (string> string string) - 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; - int m = stringcompare(args, false, true, false); - return m == -1 ? nil : number(m); -} - -/* - (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); -} - -/* - (string<= string string) - 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; - int m = stringcompare(args, true, false, true); - return m == -1 ? nil : number(m); -} - -/* - (string>= string string) - 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; - int m = stringcompare(args, false, true, true); - return m == -1 ? nil : number(m); -} - -/* - (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 *arg = first(args); - if (!listp(arg)) error(notalist, arg); - if (arg == NULL) return nil; - object *list = cons(nil, arg); - protect(list); - object *predicate = second(args); - object *compare = cons(NULL, cons(NULL, NULL)); - protect(compare); - 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); - } - unprotect(); unprotect(); - 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("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); -} - -/* - (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. -*/ -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("\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', false, gfun); -} - -/* - (write-byte number [stream]) - Writes a byte to a stream. -*/ -inline void serialwrite (char c) { Serial.write(c); } - -object *fn_writebyte (object *args, object *env) { - (void) env; - int value = checkinteger(first(args)); - pfun_t pfun = pstreamfun(cdr(args)); - if (pfun == pserial) pfun = serialwrite; - (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)); - flags_t 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)); - flags_t 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 = isstream(first(args)); - 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("not an i2c stream"); - TwoWire *port; - if (address < 128) port = &Wire; - #if defined(ULISP_I2C1) - else port = &Wire1; - #endif - return I2Crestart(port, address & 0x7F, read) ? tee : nil; -} - -/* - (gc [print time]) - Forces a garbage collection and prints the number of objects collected, and the time taken. -*/ -object *fn_gc (object *args, object *env) { - if (args == NULL || first(args) != NULL) { - int initial = Freespace; - unsigned long start = micros(); - gc(args, env); - unsigned long elapsed = micros() - start; - pfstring("Space: ", pserial); - pint(Freespace - initial, pserial); - pfstring(" bytes, Time: ", pserial); - pint(elapsed, pserial); - pfstring(" us\n", pserial); - } else gc(args, env); - 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); -} - -/* - (backtrace [on]) - Sets the state of backtrace according to the boolean flag 'on', - or with no argument displays the current state of backtrace. -*/ -object *fn_backtrace (object *args, object *env) { - (void) env; - if (args == NULL) return (tstflag(BACKTRACE)) ? tee : nil; - if (first(args) == NULL) clrflag(BACKTRACE); else setflag(BACKTRACE); - return first(args); -} - -/* - (save-image [symbol]) - Saves the current uLisp image to non-volatile memory or SD card so it can be loaded using load-image. -*/ -object *fn_saveimage (object *args, object *env) { - if (args != NULL) args = eval(first(args), env); - return number(saveimage(args)); -} - -/* - (load-image [filename]) - Loads a saved uLisp image from non-volatile memory or SD card. -*/ -object *fn_loadimage (object *args, object *env) { - (void) env; - if (args != NULL) args = first(args); - return number(loadimage(args)); -} - -/* - (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)); -} - -/* - (analogreference keyword) - Specifies a keyword to set the analogue reference voltage used for analogue input. -*/ -object *fn_analogreference (object *args, object *env) { - (void) env; - object *arg = first(args); - #if defined(ARDUINO_TEENSY40) || defined(ARDUINO_TEENSY41) || defined(MAX32620) \ - || defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_W) \ - || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040) || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040_ADALOGGER) \ - || defined(ARDUINO_ADAFRUIT_QTPY_RP2040) || defined(ARDUINO_SEEED_XIAO_RP2040) \ - || defined(ARDUINO_RASPBERRY_PI_PICO_2) || defined(ARDUINO_RASPBERRY_PI_PICO_2W) \ - || defined(ARDUINO_PIMORONI_PICO_PLUS_2) || defined(ARDUINO_PIMORONI_TINY2350) \ - || defined(ARDUINO_NANO_MATTER) - error2("not supported"); - #else - analogReference((eAnalogReference)checkkeyword(arg)); - #endif - return arg; -} - -/* - (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(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_2) \ - || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040) || defined(ARDUINO_ADAFRUIT_QTPY_RP2040) \ - || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040_ADALOGGER) - error2("not supported"); - #else - analogReadResolution(checkinteger(arg)); - #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; -} - -/* - (analogwrite pin value) - Sets the analogue write resolution. -*/ -object *fn_analogwriteresolution (object *args, object *env) { - (void) env; - object *arg = first(args); - analogWriteResolution(checkinteger(arg)); - return arg; -} - -/* - (delay number) - Delays for a specified number of milliseconds. -*/ -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); - 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. - note represents the note in the well-tempered scale. - The argument octave can specify an octave; default 0. -*/ -object *fn_note (object *args, object *env) { - (void) env; - static int pin = 255; - if (args != NULL) { - pin = checkinteger(first(args)); - int note = 48, octave = 0; - if (cdr(args) != NULL) { - note = checkinteger(second(args)); - 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 if (consp(val) && car(val)->type == CODE) { - superprint(cons(bsymbol(DEFCODE), 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 (!eq(output, tee)) pfun = pstreamfun(args); - object *formatstr = checkstring(second(args)); - object *save = NULL; - args = cddr(args); - int len = stringlength(formatstr); - uint16_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, "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, "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, "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, "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) { - flags_t 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)) { - flags_t temp = Flags; - clrflag(PRINTREADABLY); - pfstring("Error: ", pserial); printstring(message, pserial); - Flags = temp; - pln(pserial); - } - GCStack = NULL; - longjmp(*handler, 1); -} - -// SD Card utilities - -/* - (directory) - Returns a list of the filenames of the files on the SD card. -*/ -object *fn_directory (object *args, object *env) { - (void) args, (void) env; - #if defined(sdcardsupport) - SDBegin(); - File root = SD.open("/"); - if (!root) error2("problem reading from SD card"); - object *result = cons(NULL, NULL); - object *ptr = result; - while (true) { - File entry = root.openNextFile(); - if (!entry) break; - object *filename = lispstring((char*)entry.name()); - cdr(ptr) = cons(filename, NULL); - ptr = cdr(ptr); - entry.close(); - } - root.close(); - return cdr(result); - #else - error2("not supported"); - return nil; - #endif -} - -// 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) { - #if defined(ULISP_WIFI) - object *params = checkarguments(args, 1, 3); - 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("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; - #else - (void) args, (void) env; - error2("not supported"); - return nil; - #endif -} - -/* - (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) { - #if defined (ULISP_WIFI) - (void) env; - if (isstream(first(args))>>8 != WIFISTREAM) error2("invalid stream"); - return number(client.available()); - #else - (void) args, (void) env; - error2("not supported"); - return nil; - #endif -} - -/* - (wifi-server) - Starts a Wi-Fi server running. It returns nil. -*/ -object *fn_wifiserver (object *args, object *env) { - #if defined (ULISP_WIFI) - (void) args, (void) env; - server.begin(); - return nil; - #else - (void) args, (void) env; - error2("not supported"); - return nil; - #endif -} - -/* - (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) { - #if defined (ULISP_WIFI) - (void) env; - char ssid[33], pass[65]; - object *first = first(args); args = cdr(args); - if (args == NULL) WiFi.beginAP(cstring(first, ssid, 33)); - else { - object *second = first(args); - args = cdr(args); - int channel = 1; - if (args != NULL) { - channel = checkinteger(first(args)); - args = cdr(args); - } - WiFi.beginAP(cstring(first, ssid, 33), cstring(second, pass, 65), channel); - } - return iptostring(WiFi.localIP()); - #else - (void) args, (void) env; - error2("not supported"); - return nil; - #endif -} - -/* - (connected stream) - Returns t or nil to indicate if the client on stream is connected. -*/ -object *fn_connected (object *args, object *env) { - #if defined (ULISP_WIFI) - (void) env; - if (isstream(first(args))>>8 != WIFISTREAM) error2("invalid stream"); - return client.connected() ? tee : nil; - #else - (void) args, (void) env; - error2("not supported"); - return nil; - #endif -} - -/* - (wifi-localip) - Returns the IP address of the local network as a string. -*/ -object *fn_wifilocalip (object *args, object *env) { - #if defined (ULISP_WIFI) - (void) args, (void) env; - return iptostring(WiFi.localIP()); - #else - (void) args, (void) env; - error2("not supported"); - return nil; - #endif -} - -/* - (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) { - #if defined (ULISP_WIFI) - (void) env; - char ssid[33], pass[65]; - int result = 0; - if (args == NULL) { WiFi.disconnect(); return nil; } - if (cdr(args) == NULL) WiFi.begin(cstring(first(args), ssid, 33)); - else { - if (cddr(args) != NULL) WiFi.config(ipstring(third(args))); - result = WiFi.begin(cstring(first(args), ssid, 33), cstring(second(args), pass, 65)); - } - if (result == WL_CONNECTED) return iptostring(WiFi.localIP()); - else if (result == WL_NO_SSID_AVAIL) error2("network not found"); - else if (result == WL_CONNECT_FAILED) error2("connection failed"); - else error2("unable to connect"); - return nil; - #else - (void) args, (void) env; - error2("not supported"); - return nil; - #endif -} - -// 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 = checkarguments(args, 1, 1); - 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("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[] = "nil"; -const char string1[] = "t"; -const char string2[] = "nothing"; -const char string3[] = "&optional"; -const char string4[] = "*features*"; -const char string5[] = ":initial-element"; -const char string6[] = ":element-type"; -const char string7[] = ":test"; -const char string8[] = ":a"; -const char string9[] = ":b"; -const char string10[] = ":c"; -const char string11[] = "bit"; -const char string12[] = "&rest"; -const char string13[] = "lambda"; -const char string14[] = "let"; -const char string15[] = "let*"; -const char string16[] = "closure"; -const char string17[] = "*pc*"; -const char string18[] = "quote"; -const char string19[] = "defun"; -const char string20[] = "defvar"; -const char string21[] = "defcode"; -const char string22[] = "eq"; -const char string23[] = "car"; -const char string24[] = "first"; -const char string25[] = "cdr"; -const char string26[] = "rest"; -const char string27[] = "nth"; -const char string28[] = "aref"; -const char string29[] = "char"; -const char string30[] = "string"; -const char string31[] = "pinmode"; -const char string32[] = "digitalwrite"; -const char string33[] = "analogread"; -const char string34[] = "analogreference"; -const char string35[] = "register"; -const char string36[] = "format"; -const char string37[] = "or"; -const char string38[] = "setq"; -const char string39[] = "loop"; -const char string40[] = "push"; -const char string41[] = "pop"; -const char string42[] = "incf"; -const char string43[] = "decf"; -const char string44[] = "setf"; -const char string45[] = "dolist"; -const char string46[] = "dotimes"; -const char string47[] = "do"; -const char string48[] = "do*"; -const char string49[] = "trace"; -const char string50[] = "untrace"; -const char string51[] = "for-millis"; -const char string52[] = "time"; -const char string53[] = "with-output-to-string"; -const char string54[] = "with-serial"; -const char string55[] = "with-i2c"; -const char string56[] = "with-spi"; -const char string57[] = "with-sd-card"; -const char string58[] = "progn"; -const char string59[] = "if"; -const char string60[] = "cond"; -const char string61[] = "when"; -const char string62[] = "unless"; -const char string63[] = "case"; -const char string64[] = "and"; -const char string65[] = "not"; -const char string66[] = "null"; -const char string67[] = "cons"; -const char string68[] = "atom"; -const char string69[] = "listp"; -const char string70[] = "consp"; -const char string71[] = "symbolp"; -const char string72[] = "arrayp"; -const char string73[] = "boundp"; -const char string74[] = "keywordp"; -const char string75[] = "set"; -const char string76[] = "streamp"; -const char string77[] = "equal"; -const char string78[] = "caar"; -const char string79[] = "cadr"; -const char string80[] = "second"; -const char string81[] = "cdar"; -const char string82[] = "cddr"; -const char string83[] = "caaar"; -const char string84[] = "caadr"; -const char string85[] = "cadar"; -const char string86[] = "caddr"; -const char string87[] = "third"; -const char string88[] = "cdaar"; -const char string89[] = "cdadr"; -const char string90[] = "cddar"; -const char string91[] = "cdddr"; -const char string92[] = "length"; -const char string93[] = "array-dimensions"; -const char string94[] = "list"; -const char string95[] = "copy-list"; -const char string96[] = "make-array"; -const char string97[] = "reverse"; -const char string98[] = "assoc"; -const char string99[] = "member"; -const char string100[] = "apply"; -const char string101[] = "funcall"; -const char string102[] = "append"; -const char string103[] = "mapc"; -const char string104[] = "mapl"; -const char string105[] = "mapcar"; -const char string106[] = "mapcan"; -const char string107[] = "maplist"; -const char string108[] = "mapcon"; -const char string109[] = "+"; -const char string110[] = "-"; -const char string111[] = "*"; -const char string112[] = "/"; -const char string113[] = "mod"; -const char string114[] = "rem"; -const char string115[] = "1+"; -const char string116[] = "1-"; -const char string117[] = "abs"; -const char string118[] = "random"; -const char string119[] = "max"; -const char string120[] = "min"; -const char string121[] = "/="; -const char string122[] = "="; -const char string123[] = "<"; -const char string124[] = "<="; -const char string125[] = ">"; -const char string126[] = ">="; -const char string127[] = "plusp"; -const char string128[] = "minusp"; -const char string129[] = "zerop"; -const char string130[] = "oddp"; -const char string131[] = "evenp"; -const char string132[] = "integerp"; -const char string133[] = "numberp"; -const char string134[] = "float"; -const char string135[] = "floatp"; -const char string136[] = "sin"; -const char string137[] = "cos"; -const char string138[] = "tan"; -const char string139[] = "asin"; -const char string140[] = "acos"; -const char string141[] = "atan"; -const char string142[] = "sinh"; -const char string143[] = "cosh"; -const char string144[] = "tanh"; -const char string145[] = "exp"; -const char string146[] = "sqrt"; -const char string147[] = "log"; -const char string148[] = "expt"; -const char string149[] = "ceiling"; -const char string150[] = "floor"; -const char string151[] = "truncate"; -const char string152[] = "round"; -const char string153[] = "char-code"; -const char string154[] = "code-char"; -const char string155[] = "characterp"; -const char string156[] = "stringp"; -const char string157[] = "string="; -const char string158[] = "string<"; -const char string159[] = "string>"; -const char string160[] = "string/="; -const char string161[] = "string<="; -const char string162[] = "string>="; -const char string163[] = "sort"; -const char string164[] = "concatenate"; -const char string165[] = "subseq"; -const char string166[] = "search"; -const char string167[] = "read-from-string"; -const char string168[] = "princ-to-string"; -const char string169[] = "prin1-to-string"; -const char string170[] = "logand"; -const char string171[] = "logior"; -const char string172[] = "logxor"; -const char string173[] = "lognot"; -const char string174[] = "ash"; -const char string175[] = "logbitp"; -const char string176[] = "eval"; -const char string177[] = "return"; -const char string178[] = "globals"; -const char string179[] = "locals"; -const char string180[] = "makunbound"; -const char string181[] = "break"; -const char string182[] = "read"; -const char string183[] = "prin1"; -const char string184[] = "print"; -const char string185[] = "princ"; -const char string186[] = "terpri"; -const char string187[] = "read-byte"; -const char string188[] = "read-line"; -const char string189[] = "write-byte"; -const char string190[] = "write-string"; -const char string191[] = "write-line"; -const char string192[] = "restart-i2c"; -const char string193[] = "gc"; -const char string194[] = "room"; -const char string195[] = "backtrace"; -const char string196[] = "save-image"; -const char string197[] = "load-image"; -const char string198[] = "cls"; -const char string199[] = "digitalread"; -const char string200[] = "analogreadresolution"; -const char string201[] = "analogwrite"; -const char string202[] = "analogwriteresolution"; -const char string203[] = "delay"; -const char string204[] = "millis"; -const char string205[] = "sleep"; -const char string206[] = "note"; -const char string207[] = "edit"; -const char string208[] = "pprint"; -const char string209[] = "pprintall"; -const char string210[] = "require"; -const char string211[] = "list-library"; -const char string212[] = "?"; -const char string213[] = "documentation"; -const char string214[] = "apropos"; -const char string215[] = "apropos-list"; -const char string216[] = "unwind-protect"; -const char string217[] = "ignore-errors"; -const char string218[] = "error"; -const char string219[] = "directory"; -const char string220[] = "with-client"; -const char string221[] = "available"; -const char string222[] = "wifi-server"; -const char string223[] = "wifi-softap"; -const char string224[] = "connected"; -const char string225[] = "wifi-localip"; -const char string226[] = "wifi-connect"; -const char string227[] = "with-gfx"; -const char string228[] = "draw-pixel"; -const char string229[] = "draw-line"; -const char string230[] = "draw-rect"; -const char string231[] = "fill-rect"; -const char string232[] = "draw-circle"; -const char string233[] = "fill-circle"; -const char string234[] = "draw-round-rect"; -const char string235[] = "fill-round-rect"; -const char string236[] = "draw-triangle"; -const char string237[] = "fill-triangle"; -const char string238[] = "draw-char"; -const char string239[] = "set-cursor"; -const char string240[] = "set-text-color"; -const char string241[] = "set-text-size"; -const char string242[] = "set-text-wrap"; -const char string243[] = "fill-screen"; -const char string244[] = "set-rotation"; -const char string245[] = "invert-display"; -const char string246[] = ":led-builtin"; -const char string247[] = ":high"; -const char string248[] = ":low"; -#if defined(CPU_ATSAMD21) -const char string249[] = ":input"; -const char string250[] = ":input-pullup"; -const char string251[] = ":input-pulldown"; -const char string252[] = ":output"; -const char string253[] = ":ar-default"; -const char string254[] = ":ar-internal1v0"; -const char string255[] = ":ar-internal1v65"; -const char string256[] = ":ar-internal2v23"; -const char string257[] = ":ar-external"; -const char string258[] = ":pa-dir"; -const char string259[] = ":pa-dirclr"; -const char string260[] = ":pa-dirset"; -const char string261[] = ":pa-dirtgl"; -const char string262[] = ":pa-out"; -const char string263[] = ":pa-outclr"; -const char string264[] = ":pa-outset"; -const char string265[] = ":pa-outtgl"; -const char string266[] = ":pa-in"; -const char string267[] = ":pb-dir"; -const char string268[] = ":pb-dirclr"; -const char string269[] = ":pb-dirset"; -const char string270[] = ":pb-dirtgl"; -const char string271[] = ":pb-out"; -const char string272[] = ":pb-outclr"; -const char string273[] = ":pb-outset"; -const char string274[] = ":pb-outtgl"; -const char string275[] = ":pb-in"; -#elif defined(CPU_ATSAMD51) -const char string249[] = ":input"; -const char string250[] = ":input-pullup"; -const char string251[] = ":input-pulldown"; -const char string252[] = ":output"; -const char string253[] = ":ar-default"; -const char string254[] = ":ar-internal1v0"; -const char string255[] = ":ar-internal1v1"; -const char string256[] = ":ar-internal1v2"; -const char string257[] = ":ar-internal1v25"; -const char string258[] = ":ar-internal1v65"; -const char string259[] = ":ar-internal2v0"; -const char string260[] = ":ar-internal2v2"; -const char string261[] = ":ar-internal2v23"; -const char string262[] = ":ar-internal2v4"; -const char string263[] = ":ar-internal2v5"; -const char string264[] = ":ar-external"; -const char string265[] = ":pa-dir"; -const char string266[] = ":pa-dirclr"; -const char string267[] = ":pa-dirset"; -const char string268[] = ":pa-dirtgl"; -const char string269[] = ":pa-out"; -const char string270[] = ":pa-outclr"; -const char string271[] = ":pa-outset"; -const char string272[] = ":pa-outtgl"; -const char string273[] = ":pa-in"; -const char string274[] = ":pb-dir"; -const char string275[] = ":pb-dirclr"; -const char string276[] = ":pb-dirset"; -const char string277[] = ":pb-dirtgl"; -const char string278[] = ":pb-out"; -const char string279[] = ":pb-outclr"; -const char string280[] = ":pb-outset"; -const char string281[] = ":pb-outtgl"; -const char string282[] = ":pb-in"; -#elif defined(CPU_NRF51822) -const char string249[] = ":input"; -const char string250[] = ":input-pullup"; -const char string251[] = ":input-pulldown"; -const char string252[] = ":output"; -const char string253[] = ":ar-default"; -const char string254[] = ":ar-vbg"; -const char string255[] = ":ar-supply-one-half"; -const char string256[] = ":ar-supply-one-third"; -const char string257[] = ":ar-ext0"; -const char string258[] = ":ar-ext1"; -const char string259[] = ":p0-out"; -const char string260[] = ":p0-outset"; -const char string261[] = ":p0-outclr"; -const char string262[] = ":p0-in"; -const char string263[] = ":p0-dir"; -const char string264[] = ":p0-dirset"; -const char string265[] = ":p0-dirclr"; -#elif defined(CPU_NRF52840) -const char string249[] = ":input"; -const char string250[] = ":input-pullup"; -const char string251[] = ":input-pulldown"; -const char string252[] = ":output"; -const char string253[] = ":ar-default"; -const char string254[] = ":ar-internal"; -const char string255[] = ":ar-internal-3-0"; -const char string256[] = ":ar-internal-2-4"; -const char string257[] = ":ar-internal-1-8"; -const char string258[] = ":ar-internal-1-2"; -const char string259[] = ":ar-vdd4"; -const char string260[] = ":p0-out"; -const char string261[] = ":p0-outset"; -const char string262[] = ":p0-outclr"; -const char string263[] = ":p0-in"; -const char string264[] = ":p0-dir"; -const char string265[] = ":p0-dirset"; -const char string266[] = ":p0-dirclr"; -const char string267[] = ":p1-out"; -const char string268[] = ":p1-outset"; -const char string269[] = ":p1-outclr"; -const char string270[] = ":p1-in"; -const char string271[] = ":p1-dir"; -const char string272[] = ":p1-dirset"; -const char string273[] = ":p1-dirclr"; -#elif defined(CPU_NRF52833) -const char string249[] = ":input"; -const char string250[] = ":input-pullup"; -const char string251[] = ":input-pulldown"; -const char string252[] = ":output"; -const char string253[] = ":ar-default"; -const char string254[] = ":ar-internal"; -const char string255[] = ":ar-vdd4"; -const char string256[] = ":p0-out"; -const char string257[] = ":p0-outset"; -const char string258[] = ":p0-outclr"; -const char string259[] = ":p0-in"; -const char string260[] = ":p0-dir"; -const char string261[] = ":p0-dirset"; -const char string262[] = ":p0-dirclr"; -const char string263[] = ":p1-out"; -const char string264[] = ":p1-outset"; -const char string265[] = ":p1-outclr"; -const char string266[] = ":p1-in"; -const char string267[] = ":p1-dir"; -const char string268[] = ":p1-dirset"; -const char string269[] = ":p1-dirclr"; -#elif defined(CPU_iMXRT1062) -const char string249[] = ":input"; -const char string250[] = ":input-pullup"; -const char string251[] = ":input-pulldown"; -const char string252[] = ":output"; -const char string253[] = ":output-opendrain"; -#elif defined(CPU_MAX32620) -const char string249[] = ":input"; -const char string250[] = ":input-pullup"; -const char string251[] = ":output"; -const char string252[] = ":default"; -const char string253[] = ":external"; -#elif defined(CPU_RP2040) -const char string249[] = ":input"; -const char string250[] = ":input-pullup"; -const char string251[] = ":input-pulldown"; -const char string252[] = ":output"; -const char string253[] = ":gpio-in"; -const char string254[] = ":gpio-out"; -const char string255[] = ":gpio-out-set"; -const char string256[] = ":gpio-out-clr"; -const char string257[] = ":gpio-out-xor"; -const char string258[] = ":gpio-oe"; -const char string259[] = ":gpio-oe-set"; -const char string260[] = ":gpio-oe-clr"; -const char string261[] = ":gpio-oe-xor"; -#elif defined(CPU_RP2350) -const char string249[] = ":input"; -const char string250[] = ":input-pullup"; -const char string251[] = ":input-pulldown"; -const char string252[] = ":output"; -const char string253[] = ":gpio-in"; -const char string254[] = ":gpio-out"; -const char string255[] = ":gpio-out-set"; -const char string256[] = ":gpio-out-clr"; -const char string257[] = ":gpio-out-xor"; -const char string258[] = ":gpio-oe"; -const char string259[] = ":gpio-oe-set"; -const char string260[] = ":gpio-oe-clr"; -const char string261[] = ":gpio-oe-xor"; -#elif defined(CPU_RA4M1) -const char string249[] = ":input"; -const char string250[] = ":input-pullup"; -const char string251[] = ":output"; -const char string252[] = ":output-opendrain"; -const char string253[] = ":ar-default"; -const char string254[] = ":ar-internal"; -const char string255[] = ":ar-external"; -#endif - -// Documentation strings -const char doc0[] = "nil\n" -"A symbol equivalent to the empty list (). Also represents false."; -const char doc1[] = "t\n" -"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."; -const char doc3[] = "&optional\n" -"Can be followed by one or more optional parameters in a lambda or defun parameter list."; -const char doc4[] = "*features*\n" -"Returns a list of keywords representing features supported by this platform."; -const char doc12[] = "&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 doc13[] = "(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 doc14[] = "(let ((var value) ... ) forms*)\n" -"Declares local variables with values, and evaluates the forms with those local variables."; -const char doc15[] = "(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 doc19[] = "(defun name (parameters) form*)\n" -"Defines a function."; -const char doc20[] = "(defvar variable form)\n" -"Defines a global variable."; -const char doc21[] = "(defcode name (parameters) form*)\n" -"Creates a machine-code function called name from a series of 16-bit integers given in the body of the form.\n" -"These are written into RAM, and can be executed by calling the function in the same way as a normal Lisp function."; -const char doc22[] = "(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 doc23[] = "(car list)\n" -"Returns the first item in a list."; -const char doc24[] = "(first list)\n" -"Returns the first item in a list. Equivalent to car."; -const char doc25[] = "(cdr list)\n" -"Returns a list with the first item removed."; -const char doc26[] = "(rest list)\n" -"Returns a list with the first item removed. Equivalent to cdr."; -const char doc27[] = "(nth number list)\n" -"Returns the nth item in list, counting from zero."; -const char doc28[] = "(aref array index [index*])\n" -"Returns an element from the specified array."; -const char doc29[] = "(char string n)\n" -"Returns the nth character in a string, counting from zero."; -const char doc30[] = "(string item)\n" -"Converts its argument to a string."; -const char doc31[] = "(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 doc32[] = "(digitalwrite pin state)\n" -"Sets the state of the specified Arduino pin number."; -const char doc33[] = "(analogread pin)\n" -"Reads the specified Arduino analogue pin number and returns the value."; -const char doc34[] = "(analogreference keyword)\n" -"Specifies a keyword to set the analogue reference voltage used for analogue input."; -const char doc35[] = "(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 doc36[] = "(format output controlstring [arguments]*)\n" -"Outputs its arguments formatted according to the format directives in controlstring."; -const char doc37[] = "(or item*)\n" -"Evaluates its arguments until one returns non-nil, and returns its value."; -const char doc38[] = "(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 doc39[] = "(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 doc40[] = "(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 doc41[] = "(pop place)\n" -"Modifies the value of place, which should be a non-nil list, to remove its first item,\n" -"and returns that item."; -const char doc42[] = "(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 doc43[] = "(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 doc44[] = "(setf place value [place value]*)\n" -"For each pair of arguments modifies a place to the result of evaluating value."; -const char doc45[] = "(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 doc46[] = "(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 doc47[] = "(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."; -const char doc48[] = "(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."; -const char doc49[] = "(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 doc50[] = "(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 doc51[] = "(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 doc52[] = "(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 doc53[] = "(with-output-to-string (str) form*)\n" -"Returns a string containing the output to the stream variable str."; -const char doc54[] = "(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 doc55[] = "(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. If port is omitted it defaults to 0, otherwise it specifies the port, 0 or 1."; -const char doc56[] = "(with-spi (str pin [clock] [bitorder] [mode] [port]) 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), SPI mode (default 0), and port 0 or 1 (default 0)."; -const char doc57[] = "(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 doc58[] = "(progn form*)\n" -"Evaluates several forms grouped together into a block, and returns the result of evaluating the last form."; -const char doc59[] = "(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 doc60[] = "(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 doc61[] = "(when test form*)\n" -"Evaluates the test. If it's non-nil the forms are evaluated and the last value is returned."; -const char doc62[] = "(unless test form*)\n" -"Evaluates the test. If it's nil the forms are evaluated and the last value is returned."; -const char doc63[] = "(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 doc64[] = "(and item*)\n" -"Evaluates its arguments until one returns nil, and returns the last value."; -const char doc65[] = "(not item)\n" -"Returns t if its argument is nil, or nil otherwise. Equivalent to null."; -const char doc66[] = "(null list)\n" -"Returns t if its argument is nil, or nil otherwise. Equivalent to not."; -const char doc67[] = "(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 doc68[] = "(atom item)\n" -"Returns t if its argument is a single number, symbol, or nil."; -const char doc69[] = "(listp item)\n" -"Returns t if its argument is a list."; -const char doc70[] = "(consp item)\n" -"Returns t if its argument is a non-null list."; -const char doc71[] = "(symbolp item)\n" -"Returns t if its argument is a symbol."; -const char doc72[] = "(arrayp item)\n" -"Returns t if its argument is an array."; -const char doc73[] = "(boundp item)\n" -"Returns t if its argument is a symbol with a value."; -const char doc74[] = "(keywordp item)\n" -"Returns t if its argument is a built-in or user-defined keyword."; -const char doc75[] = "(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 doc76[] = "(streamp item)\n" -"Returns t if its argument is a stream."; -const char doc77[] = "(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 doc78[] = "(caar list)"; -const char doc79[] = "(cadr list)"; -const char doc80[] = "(second list)\n" -"Returns the second item in a list. Equivalent to cadr."; -const char doc81[] = "(cdar list)\n" -"Equivalent to (cdr (car list))."; -const char doc82[] = "(cddr list)\n" -"Equivalent to (cdr (cdr list))."; -const char doc83[] = "(caaar list)\n" -"Equivalent to (car (car (car list)))."; -const char doc84[] = "(caadr list)\n" -"Equivalent to (car (car (cdar list)))."; -const char doc85[] = "(cadar list)\n" -"Equivalent to (car (cdr (car list)))."; -const char doc86[] = "(caddr list)\n" -"Equivalent to (car (cdr (cdr list)))."; -const char doc87[] = "(third list)\n" -"Returns the third item in a list. Equivalent to caddr."; -const char doc88[] = "(cdaar list)\n" -"Equivalent to (cdar (car (car list)))."; -const char doc89[] = "(cdadr list)\n" -"Equivalent to (cdr (car (cdr list)))."; -const char doc90[] = "(cddar list)\n" -"Equivalent to (cdr (cdr (car list)))."; -const char doc91[] = "(cdddr list)\n" -"Equivalent to (cdr (cdr (cdr list)))."; -const char doc92[] = "(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 doc93[] = "(array-dimensions item)\n" -"Returns a list of the dimensions of an array."; -const char doc94[] = "(list item*)\n" -"Returns a list of the values of its arguments."; -const char doc95[] = "(copy-list list)\n" -"Returns a copy of a list."; -const char doc96[] = "(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 doc97[] = "(reverse list)\n" -"Returns a list with the elements of list in reverse order."; -const char doc98[] = "(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."; -const char doc99[] = "(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" -"from the first occurrence of the item, or nil if it is not found."; -const char doc100[] = "(apply function list)\n" -"Returns the result of evaluating function, with the list of arguments specified by the second parameter."; -const char doc101[] = "(funcall function argument*)\n" -"Evaluates function with the specified arguments."; -const char doc102[] = "(append list*)\n" -"Joins its arguments, which should be lists, into a single list."; -const char doc103[] = "(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 doc104[] = "(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."; -const char doc105[] = "(mapcar function list1 [list]*)\n" -"Applies the function to each element in one or more lists, and returns the resulting list."; -const char doc106[] = "(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 concatenated together to give the value returned."; -const char doc107[] = "(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."; -const char doc108[] = "(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."; -const char doc109[] = "(+ 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 doc110[] = "(- 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 doc111[] = "(* 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 doc112[] = "(/ 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 doc113[] = "(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 doc114[] = "(rem number number)\n" -"Returns the remainder from dividing the first argument by the second argument.\n" -"If both arguments are integers the result is an integer; otherwise it's a floating-point number."; -const char doc115[] = "(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 doc116[] = "(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 doc117[] = "(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 doc118[] = "(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 doc119[] = "(max number*)\n" -"Returns the maximum of one or more arguments."; -const char doc120[] = "(min number*)\n" -"Returns the minimum of one or more arguments."; -const char doc121[] = "(/= number*)\n" -"Returns t if none of the arguments are equal, or nil if two or more arguments are equal."; -const char doc122[] = "(= number*)\n" -"Returns t if all the arguments, which must be numbers, are numerically equal, and nil otherwise."; -const char doc123[] = "(< number*)\n" -"Returns t if each argument is less than the next argument, and nil otherwise."; -const char doc124[] = "(<= number*)\n" -"Returns t if each argument is less than or equal to the next argument, and nil otherwise."; -const char doc125[] = "(> number*)\n" -"Returns t if each argument is greater than the next argument, and nil otherwise."; -const char doc126[] = "(>= number*)\n" -"Returns t if each argument is greater than or equal to the next argument, and nil otherwise."; -const char doc127[] = "(plusp number)\n" -"Returns t if the argument is greater than zero, or nil otherwise."; -const char doc128[] = "(minusp number)\n" -"Returns t if the argument is less than zero, or nil otherwise."; -const char doc129[] = "(zerop number)\n" -"Returns t if the argument is zero."; -const char doc130[] = "(oddp number)\n" -"Returns t if the integer argument is odd."; -const char doc131[] = "(evenp number)\n" -"Returns t if the integer argument is even."; -const char doc132[] = "(integerp number)\n" -"Returns t if the argument is an integer."; -const char doc133[] = "(numberp number)\n" -"Returns t if the argument is a number."; -const char doc134[] = "(float number)\n" -"Returns its argument converted to a floating-point number."; -const char doc135[] = "(floatp number)\n" -"Returns t if the argument is a floating-point number."; -const char doc136[] = "(sin number)\n" -"Returns sin(number)."; -const char doc137[] = "(cos number)\n" -"Returns cos(number)."; -const char doc138[] = "(tan number)\n" -"Returns tan(number)."; -const char doc139[] = "(asin number)\n" -"Returns asin(number)."; -const char doc140[] = "(acos number)\n" -"Returns acos(number)."; -const char doc141[] = "(atan number1 [number2])\n" -"Returns the arc tangent of number1/number2, in radians. If number2 is omitted it defaults to 1."; -const char doc142[] = "(sinh number)\n" -"Returns sinh(number)."; -const char doc143[] = "(cosh number)\n" -"Returns cosh(number)."; -const char doc144[] = "(tanh number)\n" -"Returns tanh(number)."; -const char doc145[] = "(exp number)\n" -"Returns exp(number)."; -const char doc146[] = "(sqrt number)\n" -"Returns sqrt(number)."; -const char doc147[] = "(log number [base])\n" -"Returns the logarithm of number to the specified base. If base is omitted it defaults to e."; -const char doc148[] = "(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 doc149[] = "(ceiling number [divisor])\n" -"Returns ceil(number/divisor). If omitted, divisor is 1."; -const char doc150[] = "(floor number [divisor])\n" -"Returns floor(number/divisor). If omitted, divisor is 1."; -const char doc151[] = "(truncate number [divisor])\n" -"Returns the integer part of number/divisor. If divisor is omitted it defaults to 1."; -const char doc152[] = "(round number [divisor])\n" -"Returns the integer closest to number/divisor. If divisor is omitted it defaults to 1."; -const char doc153[] = "(char-code character)\n" -"Returns the ASCII code for a character, as an integer."; -const char doc154[] = "(code-char integer)\n" -"Returns the character for the specified ASCII code."; -const char doc155[] = "(characterp item)\n" -"Returns t if the argument is a character and nil otherwise."; -const char doc156[] = "(stringp item)\n" -"Returns t if the argument is a string and nil otherwise."; -const char doc157[] = "(string= string string)\n" -"Returns t if the two strings are the same, or nil otherwise."; -const char doc158[] = "(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."; -const char doc159[] = "(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."; -const char doc160[] = "(string/= string string)\n" -"Returns the index to the first mismatch if the two strings are not the same, or nil otherwise."; -const char doc161[] = "(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."; -const char doc162[] = "(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."; -const char doc163[] = "(sort list test)\n" -"Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list."; -const char doc164[] = "(concatenate 'string string*)\n" -"Joins together the strings given in the second and subsequent arguments, and returns a single string."; -const char doc165[] = "(subseq seq start [end])\n" -"Returns a subsequence of a list or string from item start to item end-1."; -const char doc166[] = "(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."; -const char doc167[] = "(read-from-string string)\n" -"Reads an atom or list from the specified string and returns it."; -const char doc168[] = "(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 doc169[] = "(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 doc170[] = "(logand [value*])\n" -"Returns the bitwise & of the values."; -const char doc171[] = "(logior [value*])\n" -"Returns the bitwise | of the values."; -const char doc172[] = "(logxor [value*])\n" -"Returns the bitwise ^ of the values."; -const char doc173[] = "(lognot value)\n" -"Returns the bitwise logical NOT of the value."; -const char doc174[] = "(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 doc175[] = "(logbitp bit value)\n" -"Returns t if bit number bit in value is a '1', and nil if it is a '0'."; -const char doc176[] = "(eval form*)\n" -"Evaluates its argument an extra time."; -const char doc177[] = "(return [value])\n" -"Exits from a (dotimes ...), (dolist ...), or (loop ...) loop construct and returns value."; -const char doc178[] = "(globals)\n" -"Returns a list of global variables."; -const char doc179[] = "(locals)\n" -"Returns an association list of local variables and their values."; -const char doc180[] = "(makunbound symbol)\n" -"Removes the value of the symbol from GlobalEnv and returns the symbol."; -const char doc181[] = "(break)\n" -"Inserts a breakpoint in the program. When evaluated prints Break! and reenters the REPL."; -const char doc182[] = "(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 doc183[] = "(prin1 item [stream])\n" -"Prints its argument, and returns its value.\n" -"Strings are printed with quotation marks and escape characters."; -const char doc184[] = "(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 doc185[] = "(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 doc186[] = "(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 doc187[] = "(read-byte stream)\n" -"Reads a byte from a stream and returns it."; -const char doc188[] = "(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 doc189[] = "(write-byte number [stream])\n" -"Writes a byte to a stream."; -const char doc190[] = "(write-string string [stream])\n" -"Writes a string. If stream is specified the string is written to the stream."; -const char doc191[] = "(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 doc192[] = "(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 doc193[] = "(gc [print time])\n" -"Forces a garbage collection and prints the number of objects collected, and the time taken."; -const char doc194[] = "(room)\n" -"Returns the number of free Lisp cells remaining."; -const char doc195[] = "(backtrace [on])\n" -"Sets the state of backtrace according to the boolean flag 'on',\n" -"or with no argument displays the current state of backtrace."; -const char doc196[] = "(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 doc197[] = "(load-image [filename])\n" -"Loads a saved uLisp image from non-volatile memory or SD card."; -const char doc198[] = "(cls)\n" -"Prints a clear-screen character."; -const char doc199[] = "(digitalread pin)\n" -"Reads the state of the specified Arduino pin number and returns t (high) or nil (low)."; -const char doc200[] = "(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 doc201[] = "(analogwrite pin value)\n" -"Writes the value to the specified Arduino pin number."; -const char doc202[] = "(analogwrite pin value)\n" -"Sets the analogue write resolution."; -const char doc203[] = "(delay number)\n" -"Delays for a specified number of milliseconds."; -const char doc204[] = "(millis)\n" -"Returns the time in milliseconds that uLisp has been running."; -const char doc205[] = "(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 doc206[] = "(note [pin] [note] [octave])\n" -"Generates a square wave on pin.\n" -"note represents the note in the well-tempered scale.\n" -"The argument octave can specify an octave; default 0."; -const char doc207[] = "(edit 'function)\n" -"Calls the Lisp tree editor to allow you to edit a function definition."; -const char doc208[] = "(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 doc209[] = "(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 doc210[] = "(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 doc211[] = "(list-library)\n" -"Prints a list of the functions defined in the List Library."; -const char doc212[] = "(? item)\n" -"Prints the documentation string of a built-in or user-defined function."; -const char doc213[] = "(documentation 'symbol [type])\n" -"Returns the documentation string of a built-in or user-defined function. The type argument is ignored."; -const char doc214[] = "(apropos item)\n" -"Prints the user-defined and built-in functions whose names contain the specified string or symbol."; -const char doc215[] = "(apropos-list item)\n" -"Returns a list of user-defined and built-in functions whose names contain the specified string or symbol."; -const char doc216[] = "(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 doc217[] = "(ignore-errors [forms]*)\n" -"Evaluates forms ignoring errors."; -const char doc218[] = "(error controlstring [arguments]*)\n" -"Signals an error. The message is printed by format using the controlstring and arguments."; -const char doc219[] = "(directory)\n" -"Returns a list of the filenames of the files on the SD card."; -const char doc220[] = "(with-client (str [address port]) form*)\n" -"Evaluates the forms with str bound to a wifi-stream."; -const char doc221[] = "(available stream)\n" -"Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available."; -const char doc222[] = "(wifi-server)\n" -"Starts a Wi-Fi server running. It returns nil."; -const char doc223[] = "(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 doc224[] = "(connected stream)\n" -"Returns t or nil to indicate if the client on stream is connected."; -const char doc225[] = "(wifi-localip)\n" -"Returns the IP address of the local network as a string."; -const char doc226[] = "(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 doc227[] = "(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 doc228[] = "(draw-pixel x y [colour])\n" -"Draws a pixel at coordinates (x,y) in colour, or white if omitted."; -const char doc229[] = "(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 doc230[] = "(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 doc231[] = "(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 doc232[] = "(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 doc233[] = "(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 doc234[] = "(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 doc235[] = "(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 doc236[] = "(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 doc237[] = "(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 doc238[] = "(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 doc239[] = "(set-cursor x y)\n" -"Sets the start point for text plotting to (x, y)."; -const char doc240[] = "(set-text-color colour [background])\n" -"Sets the text colour for text plotted using (with-gfx ...)."; -const char doc241[] = "(set-text-size scale)\n" -"Scales text by the specified size, default 1."; -const char doc242[] = "(set-text-wrap boolean)\n" -"Specified whether text wraps at the right-hand edge of the display; the default is t."; -const char doc243[] = "(fill-screen [colour])\n" -"Fills or clears the screen with colour, default black."; -const char doc244[] = "(set-rotation option)\n" -"Sets the display orientation for subsequent graphics commands; values are 0, 1, 2, or 3."; -const char doc245[] = "(invert-display boolean)\n" -"Mirror-images the display."; - -// Built-in symbol lookup table -const tbl_entry_t lookup_table[] = { - { string0, NULL, 0000, doc0 }, - { string1, NULL, 0000, doc1 }, - { string2, NULL, 0000, doc2 }, - { string3, NULL, 0000, doc3 }, - { string4, NULL, 0000, doc4 }, - { string5, NULL, 0000, NULL }, - { string6, NULL, 0000, NULL }, - { string7, NULL, 0000, NULL }, - { string8, NULL, 0000, NULL }, - { string9, NULL, 0000, NULL }, - { string10, NULL, 0000, NULL }, - { string11, NULL, 0000, NULL }, - { string12, NULL, 0000, doc12 }, - { string13, NULL, 0017, doc13 }, - { string14, NULL, 0017, doc14 }, - { string15, NULL, 0017, doc15 }, - { string16, NULL, 0017, NULL }, - { string17, NULL, 0007, NULL }, - { string18, sp_quote, 0311, NULL }, - { string19, sp_defun, 0327, doc19 }, - { string20, sp_defvar, 0313, doc20 }, - { string21, sp_defcode, 0307, doc21 }, - { string22, fn_eq, 0222, doc22 }, - { string23, fn_car, 0211, doc23 }, - { string24, fn_car, 0211, doc24 }, - { string25, fn_cdr, 0211, doc25 }, - { string26, fn_cdr, 0211, doc26 }, - { string27, fn_nth, 0222, doc27 }, - { string28, fn_aref, 0227, doc28 }, - { string29, fn_char, 0222, doc29 }, - { string30, fn_stringfn, 0211, doc30 }, - { string31, fn_pinmode, 0222, doc31 }, - { string32, fn_digitalwrite, 0222, doc32 }, - { string33, fn_analogread, 0211, doc33 }, - { string34, fn_analogreference, 0211, doc34 }, - { string35, fn_register, 0212, doc35 }, - { string36, fn_format, 0227, doc36 }, - { string37, sp_or, 0307, doc37 }, - { string38, sp_setq, 0327, doc38 }, - { string39, sp_loop, 0307, doc39 }, - { string40, sp_push, 0322, doc40 }, - { string41, sp_pop, 0311, doc41 }, - { string42, sp_incf, 0312, doc42 }, - { string43, sp_decf, 0312, doc43 }, - { string44, sp_setf, 0327, doc44 }, - { string45, sp_dolist, 0317, doc45 }, - { string46, sp_dotimes, 0317, doc46 }, - { string47, sp_do, 0327, doc47 }, - { string48, sp_dostar, 0317, doc48 }, - { string49, sp_trace, 0301, doc49 }, - { string50, sp_untrace, 0301, doc50 }, - { string51, sp_formillis, 0317, doc51 }, - { string52, sp_time, 0311, doc52 }, - { string53, sp_withoutputtostring, 0317, doc53 }, - { string54, sp_withserial, 0317, doc54 }, - { string55, sp_withi2c, 0317, doc55 }, - { string56, sp_withspi, 0317, doc56 }, - { string57, sp_withsdcard, 0327, doc57 }, - { string58, tf_progn, 0107, doc58 }, - { string59, tf_if, 0123, doc59 }, - { string60, tf_cond, 0107, doc60 }, - { string61, tf_when, 0117, doc61 }, - { string62, tf_unless, 0117, doc62 }, - { string63, tf_case, 0117, doc63 }, - { string64, tf_and, 0107, doc64 }, - { string65, fn_not, 0211, doc65 }, - { string66, fn_not, 0211, doc66 }, - { string67, fn_cons, 0222, doc67 }, - { string68, fn_atom, 0211, doc68 }, - { string69, fn_listp, 0211, doc69 }, - { string70, fn_consp, 0211, doc70 }, - { string71, fn_symbolp, 0211, doc71 }, - { string72, fn_arrayp, 0211, doc72 }, - { string73, fn_boundp, 0211, doc73 }, - { string74, fn_keywordp, 0211, doc74 }, - { string75, fn_setfn, 0227, doc75 }, - { string76, fn_streamp, 0211, doc76 }, - { string77, fn_equal, 0222, doc77 }, - { string78, fn_caar, 0211, doc78 }, - { string79, fn_cadr, 0211, doc79 }, - { string80, fn_cadr, 0211, doc80 }, - { string81, fn_cdar, 0211, doc81 }, - { string82, fn_cddr, 0211, doc82 }, - { string83, fn_caaar, 0211, doc83 }, - { string84, fn_caadr, 0211, doc84 }, - { string85, fn_cadar, 0211, doc85 }, - { string86, fn_caddr, 0211, doc86 }, - { string87, fn_caddr, 0211, doc87 }, - { string88, fn_cdaar, 0211, doc88 }, - { string89, fn_cdadr, 0211, doc89 }, - { string90, fn_cddar, 0211, doc90 }, - { string91, fn_cdddr, 0211, doc91 }, - { string92, fn_length, 0211, doc92 }, - { string93, fn_arraydimensions, 0211, doc93 }, - { string94, fn_list, 0207, doc94 }, - { string95, fn_copylist, 0211, doc95 }, - { string96, fn_makearray, 0215, doc96 }, - { string97, fn_reverse, 0211, doc97 }, - { string98, fn_assoc, 0224, doc98 }, - { string99, fn_member, 0224, doc99 }, - { string100, fn_apply, 0227, doc100 }, - { string101, fn_funcall, 0217, doc101 }, - { string102, fn_append, 0207, doc102 }, - { string103, fn_mapc, 0227, doc103 }, - { string104, fn_mapl, 0227, doc104 }, - { string105, fn_mapcar, 0227, doc105 }, - { string106, fn_mapcan, 0227, doc106 }, - { string107, fn_maplist, 0227, doc107 }, - { string108, fn_mapcon, 0227, doc108 }, - { string109, fn_add, 0207, doc109 }, - { string110, fn_subtract, 0217, doc110 }, - { string111, fn_multiply, 0207, doc111 }, - { string112, fn_divide, 0217, doc112 }, - { string113, fn_mod, 0222, doc113 }, - { string114, fn_rem, 0222, doc114 }, - { string115, fn_oneplus, 0211, doc115 }, - { string116, fn_oneminus, 0211, doc116 }, - { string117, fn_abs, 0211, doc117 }, - { string118, fn_random, 0211, doc118 }, - { string119, fn_maxfn, 0217, doc119 }, - { string120, fn_minfn, 0217, doc120 }, - { string121, fn_noteq, 0217, doc121 }, - { string122, fn_numeq, 0217, doc122 }, - { string123, fn_less, 0217, doc123 }, - { string124, fn_lesseq, 0217, doc124 }, - { string125, fn_greater, 0217, doc125 }, - { string126, fn_greatereq, 0217, doc126 }, - { string127, fn_plusp, 0211, doc127 }, - { string128, fn_minusp, 0211, doc128 }, - { string129, fn_zerop, 0211, doc129 }, - { string130, fn_oddp, 0211, doc130 }, - { string131, fn_evenp, 0211, doc131 }, - { string132, fn_integerp, 0211, doc132 }, - { string133, fn_numberp, 0211, doc133 }, - { string134, fn_floatfn, 0211, doc134 }, - { string135, fn_floatp, 0211, doc135 }, - { string136, fn_sin, 0211, doc136 }, - { string137, fn_cos, 0211, doc137 }, - { string138, fn_tan, 0211, doc138 }, - { string139, fn_asin, 0211, doc139 }, - { string140, fn_acos, 0211, doc140 }, - { string141, fn_atan, 0212, doc141 }, - { string142, fn_sinh, 0211, doc142 }, - { string143, fn_cosh, 0211, doc143 }, - { string144, fn_tanh, 0211, doc144 }, - { string145, fn_exp, 0211, doc145 }, - { string146, fn_sqrt, 0211, doc146 }, - { string147, fn_log, 0212, doc147 }, - { string148, fn_expt, 0222, doc148 }, - { string149, fn_ceiling, 0212, doc149 }, - { string150, fn_floor, 0212, doc150 }, - { string151, fn_truncate, 0212, doc151 }, - { string152, fn_round, 0212, doc152 }, - { string153, fn_charcode, 0211, doc153 }, - { string154, fn_codechar, 0211, doc154 }, - { string155, fn_characterp, 0211, doc155 }, - { string156, fn_stringp, 0211, doc156 }, - { string157, fn_stringeq, 0222, doc157 }, - { string158, fn_stringless, 0222, doc158 }, - { string159, fn_stringgreater, 0222, doc159 }, - { string160, fn_stringnoteq, 0222, doc160 }, - { string161, fn_stringlesseq, 0222, doc161 }, - { string162, fn_stringgreatereq, 0222, doc162 }, - { string163, fn_sort, 0222, doc163 }, - { string164, fn_concatenate, 0217, doc164 }, - { string165, fn_subseq, 0223, doc165 }, - { string166, fn_search, 0224, doc166 }, - { string167, fn_readfromstring, 0211, doc167 }, - { string168, fn_princtostring, 0211, doc168 }, - { string169, fn_prin1tostring, 0211, doc169 }, - { string170, fn_logand, 0207, doc170 }, - { string171, fn_logior, 0207, doc171 }, - { string172, fn_logxor, 0207, doc172 }, - { string173, fn_lognot, 0211, doc173 }, - { string174, fn_ash, 0222, doc174 }, - { string175, fn_logbitp, 0222, doc175 }, - { string176, fn_eval, 0211, doc176 }, - { string177, fn_return, 0201, doc177 }, - { string178, fn_globals, 0200, doc178 }, - { string179, fn_locals, 0200, doc179 }, - { string180, fn_makunbound, 0211, doc180 }, - { string181, fn_break, 0200, doc181 }, - { string182, fn_read, 0201, doc182 }, - { string183, fn_prin1, 0212, doc183 }, - { string184, fn_print, 0212, doc184 }, - { string185, fn_princ, 0212, doc185 }, - { string186, fn_terpri, 0201, doc186 }, - { string187, fn_readbyte, 0202, doc187 }, - { string188, fn_readline, 0201, doc188 }, - { string189, fn_writebyte, 0212, doc189 }, - { string190, fn_writestring, 0212, doc190 }, - { string191, fn_writeline, 0212, doc191 }, - { string192, fn_restarti2c, 0212, doc192 }, - { string193, fn_gc, 0201, doc193 }, - { string194, fn_room, 0200, doc194 }, - { string195, fn_backtrace, 0201, doc195 }, - { string196, fn_saveimage, 0201, doc196 }, - { string197, fn_loadimage, 0201, doc197 }, - { string198, fn_cls, 0200, doc198 }, - { string199, fn_digitalread, 0211, doc199 }, - { string200, fn_analogreadresolution, 0211, doc200 }, - { string201, fn_analogwrite, 0222, doc201 }, - { string202, fn_analogwriteresolution, 0211, doc202 }, - { string203, fn_delay, 0211, doc203 }, - { string204, fn_millis, 0200, doc204 }, - { string205, fn_sleep, 0201, doc205 }, - { string206, fn_note, 0203, doc206 }, - { string207, fn_edit, 0211, doc207 }, - { string208, fn_pprint, 0212, doc208 }, - { string209, fn_pprintall, 0201, doc209 }, - { string210, fn_require, 0211, doc210 }, - { string211, fn_listlibrary, 0200, doc211 }, - { string212, sp_help, 0311, doc212 }, - { string213, fn_documentation, 0212, doc213 }, - { string214, fn_apropos, 0211, doc214 }, - { string215, fn_aproposlist, 0211, doc215 }, - { string216, sp_unwindprotect, 0307, doc216 }, - { string217, sp_ignoreerrors, 0307, doc217 }, - { string218, sp_error, 0317, doc218 }, - { string219, fn_directory, 0200, doc219 }, - { string220, sp_withclient, 0317, doc220 }, - { string221, fn_available, 0211, doc221 }, - { string222, fn_wifiserver, 0200, doc222 }, - { string223, fn_wifisoftap, 0204, doc223 }, - { string224, fn_connected, 0211, doc224 }, - { string225, fn_wifilocalip, 0200, doc225 }, - { string226, fn_wificonnect, 0203, doc226 }, - { string227, sp_withgfx, 0317, doc227 }, - { string228, fn_drawpixel, 0223, doc228 }, - { string229, fn_drawline, 0245, doc229 }, - { string230, fn_drawrect, 0245, doc230 }, - { string231, fn_fillrect, 0245, doc231 }, - { string232, fn_drawcircle, 0234, doc232 }, - { string233, fn_fillcircle, 0234, doc233 }, - { string234, fn_drawroundrect, 0256, doc234 }, - { string235, fn_fillroundrect, 0256, doc235 }, - { string236, fn_drawtriangle, 0267, doc236 }, - { string237, fn_filltriangle, 0267, doc237 }, - { string238, fn_drawchar, 0236, doc238 }, - { string239, fn_setcursor, 0222, doc239 }, - { string240, fn_settextcolor, 0212, doc240 }, - { string241, fn_settextsize, 0211, doc241 }, - { string242, fn_settextwrap, 0211, doc242 }, - { string243, fn_fillscreen, 0201, doc243 }, - { string244, fn_setrotation, 0211, doc244 }, - { string245, fn_invertdisplay, 0211, doc245 }, - { string246, (fn_ptr_type)LED_BUILTIN, 0, NULL }, - { string247, (fn_ptr_type)HIGH, DIGITALWRITE, NULL }, - { string248, (fn_ptr_type)LOW, DIGITALWRITE, NULL }, -#if defined(CPU_ATSAMD21) - { string249, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string250, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string251, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, - { string252, (fn_ptr_type)OUTPUT, PINMODE, NULL }, - { string253, (fn_ptr_type)AR_DEFAULT, ANALOGREFERENCE, NULL }, - { string254, (fn_ptr_type)AR_INTERNAL1V0, ANALOGREFERENCE, NULL }, - { string255, (fn_ptr_type)AR_INTERNAL1V65, ANALOGREFERENCE, NULL }, - { string256, (fn_ptr_type)AR_INTERNAL2V23, ANALOGREFERENCE, NULL }, - { string257, (fn_ptr_type)AR_EXTERNAL, ANALOGREFERENCE, NULL }, - { string258, (fn_ptr_type)&PORT->Group[0].DIR.reg, REGISTER, NULL }, - { string259, (fn_ptr_type)&PORT->Group[0].DIRCLR.reg, REGISTER, NULL }, - { string260, (fn_ptr_type)&PORT->Group[0].DIRSET.reg, REGISTER, NULL }, - { string261, (fn_ptr_type)&PORT->Group[0].DIRTGL.reg, REGISTER, NULL }, - { string262, (fn_ptr_type)&PORT->Group[0].OUT.reg, REGISTER, NULL }, - { string263, (fn_ptr_type)&PORT->Group[0].OUTCLR.reg, REGISTER, NULL }, - { string264, (fn_ptr_type)&PORT->Group[0].OUTSET.reg, REGISTER, NULL }, - { string265, (fn_ptr_type)&PORT->Group[0].OUTTGL.reg, REGISTER, NULL }, - { string266, (fn_ptr_type)&PORT->Group[0].IN.reg, REGISTER, NULL }, - { string267, (fn_ptr_type)&PORT->Group[1].DIR.reg, REGISTER, NULL }, - { string268, (fn_ptr_type)&PORT->Group[1].DIRCLR.reg, REGISTER, NULL }, - { string269, (fn_ptr_type)&PORT->Group[1].DIRSET.reg, REGISTER, NULL }, - { string270, (fn_ptr_type)&PORT->Group[1].DIRTGL.reg, REGISTER, NULL }, - { string271, (fn_ptr_type)&PORT->Group[1].OUT.reg, REGISTER, NULL }, - { string272, (fn_ptr_type)&PORT->Group[1].OUTCLR.reg, REGISTER, NULL }, - { string273, (fn_ptr_type)&PORT->Group[1].OUTSET.reg, REGISTER, NULL }, - { string274, (fn_ptr_type)&PORT->Group[1].OUTTGL.reg, REGISTER, NULL }, - { string275, (fn_ptr_type)&PORT->Group[1].IN.reg, REGISTER, NULL }, -#elif defined(CPU_ATSAMD51) - { string249, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string250, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string251, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, - { string252, (fn_ptr_type)OUTPUT, PINMODE, NULL }, - { string253, (fn_ptr_type)AR_DEFAULT, ANALOGREFERENCE, NULL }, - { string254, (fn_ptr_type)AR_INTERNAL1V0, ANALOGREFERENCE, NULL }, - { string255, (fn_ptr_type)AR_INTERNAL1V1, ANALOGREFERENCE, NULL }, - { string256, (fn_ptr_type)AR_INTERNAL1V2, ANALOGREFERENCE, NULL }, - { string257, (fn_ptr_type)AR_INTERNAL1V25, ANALOGREFERENCE, NULL }, - { string258, (fn_ptr_type)AR_INTERNAL1V65, ANALOGREFERENCE, NULL }, - { string259, (fn_ptr_type)AR_INTERNAL2V0, ANALOGREFERENCE, NULL }, - { string260, (fn_ptr_type)AR_INTERNAL2V2, ANALOGREFERENCE, NULL }, - { string261, (fn_ptr_type)AR_INTERNAL2V23, ANALOGREFERENCE, NULL }, - { string262, (fn_ptr_type)AR_INTERNAL2V4, ANALOGREFERENCE, NULL }, - { string263, (fn_ptr_type)AR_INTERNAL2V5, ANALOGREFERENCE, NULL }, - { string264, (fn_ptr_type)AR_EXTERNAL, ANALOGREFERENCE, NULL }, - { string265, (fn_ptr_type)&PORT->Group[0].DIR.reg, REGISTER, NULL }, - { string266, (fn_ptr_type)&PORT->Group[0].DIRCLR.reg, REGISTER, NULL }, - { string267, (fn_ptr_type)&PORT->Group[0].DIRSET.reg, REGISTER, NULL }, - { string268, (fn_ptr_type)&PORT->Group[0].DIRTGL.reg, REGISTER, NULL }, - { string269, (fn_ptr_type)&PORT->Group[0].OUT.reg, REGISTER, NULL }, - { string270, (fn_ptr_type)&PORT->Group[0].OUTCLR.reg, REGISTER, NULL }, - { string271, (fn_ptr_type)&PORT->Group[0].OUTSET.reg, REGISTER, NULL }, - { string272, (fn_ptr_type)&PORT->Group[0].OUTTGL.reg, REGISTER, NULL }, - { string273, (fn_ptr_type)&PORT->Group[0].IN.reg, REGISTER, NULL }, - { string274, (fn_ptr_type)&PORT->Group[1].DIR.reg, REGISTER, NULL }, - { string275, (fn_ptr_type)&PORT->Group[1].DIRCLR.reg, REGISTER, NULL }, - { string276, (fn_ptr_type)&PORT->Group[1].DIRSET.reg, REGISTER, NULL }, - { string277, (fn_ptr_type)&PORT->Group[1].DIRTGL.reg, REGISTER, NULL }, - { string278, (fn_ptr_type)&PORT->Group[1].OUT.reg, REGISTER, NULL }, - { string279, (fn_ptr_type)&PORT->Group[1].OUTCLR.reg, REGISTER, NULL }, - { string280, (fn_ptr_type)&PORT->Group[1].OUTSET.reg, REGISTER, NULL }, - { string281, (fn_ptr_type)&PORT->Group[1].OUTTGL.reg, REGISTER, NULL }, - { string282, (fn_ptr_type)&PORT->Group[1].IN.reg, REGISTER, NULL }, -#elif defined(CPU_NRF51822) - { string249, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string250, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string251, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, - { string252, (fn_ptr_type)OUTPUT, PINMODE, NULL }, - { string253, (fn_ptr_type)AR_DEFAULT, ANALOGREFERENCE, NULL }, - { string254, (fn_ptr_type)AR_VBG, ANALOGREFERENCE, NULL }, - { string255, (fn_ptr_type)AR_SUPPLY_ONE_HALF, ANALOGREFERENCE, NULL }, - { string256, (fn_ptr_type)AR_SUPPLY_ONE_THIRD, ANALOGREFERENCE, NULL }, - { string257, (fn_ptr_type)AR_EXT0, ANALOGREFERENCE, NULL }, - { string258, (fn_ptr_type)AR_EXT1, ANALOGREFERENCE, NULL }, - { string259, (fn_ptr_type)&NRF_GPIO->OUT, REGISTER, NULL }, - { string260, (fn_ptr_type)&NRF_GPIO->OUTSET, REGISTER, NULL }, - { string261, (fn_ptr_type)&NRF_GPIO->OUTCLR, REGISTER, NULL }, - { string262, (fn_ptr_type)&NRF_GPIO->IN, REGISTER, NULL }, - { string263, (fn_ptr_type)&NRF_GPIO->DIR, REGISTER, NULL }, - { string264, (fn_ptr_type)&NRF_GPIO->DIRSET, REGISTER, NULL }, - { string265, (fn_ptr_type)&NRF_GPIO->DIRCLR, REGISTER, NULL }, -#elif defined(CPU_NRF52840) - { string249, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string250, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string251, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, - { string252, (fn_ptr_type)OUTPUT, PINMODE, NULL }, - { string253, (fn_ptr_type)AR_DEFAULT, ANALOGREFERENCE, NULL }, - { string254, (fn_ptr_type)AR_INTERNAL, ANALOGREFERENCE, NULL }, - { string255, (fn_ptr_type)AR_INTERNAL_3_0, ANALOGREFERENCE, NULL }, - { string256, (fn_ptr_type)AR_INTERNAL_2_4, ANALOGREFERENCE, NULL }, - { string257, (fn_ptr_type)AR_INTERNAL_1_8, ANALOGREFERENCE, NULL }, - { string258, (fn_ptr_type)AR_INTERNAL_1_2, ANALOGREFERENCE, NULL }, - { string259, (fn_ptr_type)AR_VDD4, ANALOGREFERENCE, NULL }, - { string260, (fn_ptr_type)&NRF_P0->OUT, REGISTER, NULL }, - { string261, (fn_ptr_type)&NRF_P0->OUTSET, REGISTER, NULL }, - { string262, (fn_ptr_type)&NRF_P0->OUTCLR, REGISTER, NULL }, - { string263, (fn_ptr_type)&NRF_P0->IN, REGISTER, NULL }, - { string264, (fn_ptr_type)&NRF_P0->DIR, REGISTER, NULL }, - { string265, (fn_ptr_type)&NRF_P0->DIRSET, REGISTER, NULL }, - { string266, (fn_ptr_type)&NRF_P0->DIRCLR, REGISTER, NULL }, - { string267, (fn_ptr_type)&NRF_P1->OUT, REGISTER, NULL }, - { string268, (fn_ptr_type)&NRF_P1->OUTSET, REGISTER, NULL }, - { string269, (fn_ptr_type)&NRF_P1->OUTCLR, REGISTER, NULL }, - { string270, (fn_ptr_type)&NRF_P1->IN, REGISTER, NULL }, - { string271, (fn_ptr_type)&NRF_P1->DIR, REGISTER, NULL }, - { string272, (fn_ptr_type)&NRF_P1->DIRSET, REGISTER, NULL }, - { string273, (fn_ptr_type)&NRF_P1->DIRCLR, REGISTER, NULL }, -#elif defined(CPU_NRF52833) - { string249, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string250, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string251, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, - { string252, (fn_ptr_type)OUTPUT, PINMODE, NULL }, - { string253, (fn_ptr_type)AR_DEFAULT, ANALOGREFERENCE, NULL }, - { string254, (fn_ptr_type)AR_INTERNAL, ANALOGREFERENCE, NULL }, - { string255, (fn_ptr_type)AR_VDD4, ANALOGREFERENCE, NULL }, - { string256, (fn_ptr_type)&NRF_P0->OUT, REGISTER, NULL }, - { string257, (fn_ptr_type)&NRF_P0->OUTSET, REGISTER, NULL }, - { string258, (fn_ptr_type)&NRF_P0->OUTCLR, REGISTER, NULL }, - { string259, (fn_ptr_type)&NRF_P0->IN, REGISTER, NULL }, - { string260, (fn_ptr_type)&NRF_P0->DIR, REGISTER, NULL }, - { string261, (fn_ptr_type)&NRF_P0->DIRSET, REGISTER, NULL }, - { string262, (fn_ptr_type)&NRF_P0->DIRCLR, REGISTER, NULL }, - { string263, (fn_ptr_type)&NRF_P1->OUT, REGISTER, NULL }, - { string264, (fn_ptr_type)&NRF_P1->OUTSET, REGISTER, NULL }, - { string265, (fn_ptr_type)&NRF_P1->OUTCLR, REGISTER, NULL }, - { string266, (fn_ptr_type)&NRF_P1->IN, REGISTER, NULL }, - { string267, (fn_ptr_type)&NRF_P1->DIR, REGISTER, NULL }, - { string268, (fn_ptr_type)&NRF_P1->DIRSET, REGISTER, NULL }, - { string269, (fn_ptr_type)&NRF_P1->DIRCLR, REGISTER, NULL }, -#elif defined(CPU_iMXRT1062) - { string249, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string250, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string251, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, - { string252, (fn_ptr_type)OUTPUT, PINMODE, NULL }, - { string253, (fn_ptr_type)OUTPUT_OPENDRAIN, PINMODE, NULL }, -#elif defined(CPU_MAX32620) - { string249, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string250, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string251, (fn_ptr_type)OUTPUT, PINMODE, NULL }, - { string252, (fn_ptr_type)DEFAULT, ANALOGREFERENCE, NULL }, - { string253, (fn_ptr_type)EXTERNAL, ANALOGREFERENCE, NULL }, -#elif defined(CPU_RP2040) - { string249, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string250, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string251, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, - { string252, (fn_ptr_type)OUTPUT, PINMODE, NULL }, - { string253, (fn_ptr_type)(SIO_BASE+SIO_GPIO_IN_OFFSET), REGISTER, NULL }, - { string254, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OUT_OFFSET), REGISTER, NULL }, - { string255, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OUT_SET_OFFSET), REGISTER, NULL }, - { string256, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OUT_CLR_OFFSET), REGISTER, NULL }, - { string257, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OUT_XOR_OFFSET), REGISTER, NULL }, - { string258, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OE_OFFSET), REGISTER, NULL }, - { string259, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OE_SET_OFFSET), REGISTER, NULL }, - { string260, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OE_CLR_OFFSET), REGISTER, NULL }, - { string261, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OE_XOR_OFFSET), REGISTER, NULL }, -#elif defined(CPU_RP2350) - { string249, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string250, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string251, (fn_ptr_type)INPUT_PULLDOWN, PINMODE, NULL }, - { string252, (fn_ptr_type)OUTPUT, PINMODE, NULL }, - { string253, (fn_ptr_type)(SIO_BASE+SIO_GPIO_IN_OFFSET), REGISTER, NULL }, - { string254, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OUT_OFFSET), REGISTER, NULL }, - { string255, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OUT_SET_OFFSET), REGISTER, NULL }, - { string256, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OUT_CLR_OFFSET), REGISTER, NULL }, - { string257, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OUT_XOR_OFFSET), REGISTER, NULL }, - { string258, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OE_OFFSET), REGISTER, NULL }, - { string259, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OE_SET_OFFSET), REGISTER, NULL }, - { string260, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OE_CLR_OFFSET), REGISTER, NULL }, - { string261, (fn_ptr_type)(SIO_BASE+SIO_GPIO_OE_XOR_OFFSET), REGISTER, NULL }, -#elif defined(CPU_RA4M1) - { string249, (fn_ptr_type)INPUT, PINMODE, NULL }, - { string250, (fn_ptr_type)INPUT_PULLUP, PINMODE, NULL }, - { string251, (fn_ptr_type)OUTPUT, PINMODE, NULL }, - { string252, (fn_ptr_type)OUTPUT_OPENDRAIN, PINMODE, NULL }, - { string253, (fn_ptr_type)AR_DEFAULT, ANALOGREFERENCE, NULL }, - { string254, (fn_ptr_type)AR_INTERNAL, ANALOGREFERENCE, NULL }, - { string255, (fn_ptr_type)AR_EXTERNAL, ANALOGREFERENCE, 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 - -/* - lookupbuiltin - looks up a string in lookup_table[], and returns the index of its entry, or ENDFUNCTIONS - if no match is found. Allows definitions in an extension file to override the built-in functions. -*/ -builtin_t lookupbuiltin (char* c) { - unsigned int start = tablesize(0); - for (int n=1; n>=0; n--) { - int entries = tablesize(n); - 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) { - bool n = namechars)>>((sizeof(int)-1)*8) & 0xFF) == ':'); -} - -/* - keywordp - check that obj is a keyword -*/ -bool keywordp (object *obj) { - if (!(symbolp(obj) && builtinp(obj->name))) return false; - builtin_t name = builtin(obj->name); - bool n = name>4) gc(form, env); // GC when 1/16 of workspace left - // Escape - if (tstflag(ESCAPE)) { clrflag(ESCAPE); error2("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; - if (colonp(name)) return form; // Keyword - 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)) { - if (name == sym(FEATURES)) return features(); - return form; - } - Context = NIL; - error("undefined", form); - } - - #if defined(CODESIZE) - if (form->type == CODE) error2("can't evaluate CODE header"); - #endif - - // It's a list - object *function = car(form); - object *args = cdr(form); - - if (function == NULL) error(illegalfn, function); - if (!listp(args)) error("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)) { - if (args == NULL) error2(noargument); - object *assigns = first(args); - if (!listp(assigns)) error(notalist, assigns); - object *forms = cdr(args); - object *newenv = 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); - car(GCStack) = newenv; - if (name == LETSTAR) env = newenv; - assigns = cdr(assigns); - } - env = newenv; - unprotect(); - form = tf_progn(forms,env); - 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)); - } - - switch(fntype(name)) { - case SPECIAL_FORMS: - Context = name; - checkargs(args); - return ((fn_ptr_type)lookupfn(name))(args, env); - - case TAIL_FORMS: - Context = name; - checkargs(args); - form = ((fn_ptr_type)lookupfn(name))(args, env); - TC = 1; - goto EVAL; - - case OTHER_FORMS: error(illegalfn, function); - } - } - - // Evaluate the parameters - result in head - int TCstart = TC; - object *head; - if (consp(function) && !(isbuiltin(car(function), LAMBDA) || isbuiltin(car(function), CLOSURE) - || car(function)->type == CODE)) { Context = NIL; error(illegalfn, function); } - if (symbolp(function)) { - object *pair = findpair(function, env); - if (pair != NULL) head = cons(cdr(pair), NULL); else head = cons(function, NULL); - } else head = cons(eval(function, env), NULL); - protect(head); // 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++; - } - - object *fname = function; - function = car(head); - args = cdr(head); - - if (symbolp(function)) { - if (!builtinp(function->name)) { Context = NIL; error(illegalfn, function); } - builtin_t bname = builtin(function->name); - Context = bname; - checkminmax(bname, nargs); - object *result = ((fn_ptr_type)lookupfn(bname))(args, env); - unprotect(); - return result; - } - - if (consp(function)) { - symbol_t name = sym(NIL); - if (!listp(fname)) name = fname->name; - - if (isbuiltin(car(function), LAMBDA)) { - if (tstflag(BACKTRACE)) backtrace(name); - form = closure(TCstart, name, function, args, &env); - unprotect(); - int trace = tracing(name); - if (trace || tstflag(BACKTRACE)) { - object *result = eval(form, env); - if (trace) { - indent((--(TraceDepth[trace-1]))<<1, ' ', pserial); - pint(TraceDepth[trace-1], pserial); - pserial(':'); pserial(' '); - printobject(fname, pserial); pfstring(" returned ", pserial); - printobject(result, pserial); pln(pserial); - } - if (tstflag(BACKTRACE)) TraceTop = modbacktrace(TraceTop-1); - return result; - } else { - TC = 1; - goto EVAL; - } - } - - if (isbuiltin(car(function), CLOSURE)) { - function = cdr(function); - if (tstflag(BACKTRACE)) backtrace(name); - form = closure(TCstart, name, function, args, &env); - unprotect(); - if (tstflag(BACKTRACE)) { - object *result = eval(form, env); - TraceTop = modbacktrace(TraceTop-1); - return result; - } else { - TC = 1; - goto EVAL; - } - } - - if (car(function)->type == CODE) { - int n = listlength(second(function)); - if (nargsname, toofewargs); - if (nargs>n) errorsym2(fname->name, toomanyargs); - uint32_t entry = startblock(car(function)) + 1; - unprotect(); - return call(entry, n, args, env); - } - - } - error(illegalfn, 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[] = "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) { - const char *p = ControlCodes; - while (c > 0) {p = p + strlen(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 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 (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 pradix40(name, pfun); - } -} - -/* - pfstring - prints a string from flash memory to the specified stream -*/ -void pfstring (const char *s, pfun_t pfun) { - while (1) { - char c = *s++; - 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; - } -} - -/* - pinthex4 - prints a four-digit hexadecimal number with leading zeros to the specified stream -*/ -void printhex4 (int i, pfun_t pfun) { - int p = 0x1000; - for (int d=p; d>0; d=d/16) { - int j = i/d; - pfun((j<10) ? j+'0' : j + 'W'); - i = i - j*d; - } - pfun(' '); -} - -/* - 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("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 - 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(" . ", pfun); - printobject(form, pfun); - } - pfun(')'); -} - -/* - pstream - prints a stream name to the specified stream -*/ -void pstream (object *form, pfun_t pfun) { - pfun('<'); - pfstring(streamname[(form->integer)>>8], pfun); - pfstring("-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("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 (characterp(form)) pcharacter(form->chars, pfun); - else if (stringp(form)) printstring(form, pfun); - else if (arrayp(form)) printarray(form, pfun); - else if (form->type == CODE) pfstring("code", pfun); - else if (streamp(form)) pstream(form, pfun); - else error2("error in print"); -} - -/* - prin1object - prints any Lisp object to the specified stream escaping special characters -*/ -void prin1object (object *form, pfun_t pfun) { - flags_t 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 = 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) { - protect(line); - eval(line, env); - unprotect(); - line = read(glibrary); - } -} - -// For line editor -const int TerminalWidth = 80; -volatile int WritePtr = 0, ReadPtr = 0, LastWritePtr = 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; LastWritePtr = WritePtr; - 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 (c == 9) { // tab or ctrl-I - for (int i = 0; i < LastWritePtr; i++) Serial.write(KybdBuf[i]); - WritePtr = LastWritePtr; - } 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 -*/ -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()) 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('"', true, 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("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]); - const char *p = ControlCodes; char c = 0; - while (c < 33) { - if (strcasecmp(buffer, p) == 0) return character(c); - p = p + strlen(p) + 1; c++; - } - if (index == 3) return character((buffer[0]*10+buffer[1])*10+buffer[2]-5328); - error2("unknown character"); - } - - builtin_t x = lookupbuiltin(buffer); - if (x == NIL) return nil; - if (x != ENDFUNCTIONS) return bsymbol(x); - if (index <= 6 && valid40(buffer)) return intern(twist(pack40(buffer))); - 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("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("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) - #if defined(ARDUINO_PYBADGE_M4) || defined(ARDUINO_PYGAMER_M4) - tft.initR(INITR_BLACKTAB); - tft.setRotation(1); - pinMode(TFT_BACKLIGHT, OUTPUT); - digitalWrite(TFT_BACKLIGHT, HIGH); - tft.fillScreen(0); - #elif defined(ARDUINO_WIO_TERMINAL) - tft.init(); - tft.setRotation(3); - tft.fillScreen(TFT_BLACK); - #elif defined(ARDUINO_NRF52840_CLUE) - tft.init(240, 240); - tft.setRotation(1); - tft.fillScreen(0); - pinMode(34, OUTPUT); // Backlight - digitalWrite(34, HIGH); - #elif defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_2) - tft.init(135, 240); - pinMode(TFT_I2C_POWER, OUTPUT); - digitalWrite(TFT_I2C_POWER, HIGH); - tft.setRotation(1); - tft.fillScreen(ST77XX_BLACK); - pinMode(TFT_BACKLIGHT, OUTPUT); - digitalWrite(TFT_BACKLIGHT, HIGH); - #endif - #endif -} - -void setup () { - Serial.begin(9600); - int start = millis(); - while ((millis() - start) < 5000) { if (Serial) break; } - initworkspace(); - initenv(); - initsleep(); - initgfx(); - pfstring(PSTR("uLisp 4.7b "), pserial); pln(pserial); -} - -// Read/Evaluate/Print loop - -/* - repl - the Lisp Read/Evaluate/Print loop -*/ -void repl (object *env) { - for (;;) { - randomSeed(micros()); - #if defined(printfreespace) - if (!tstflag(NOECHO)) gc(NULL, env); - pint(Freespace+1, pserial); - #endif - if (BreakLevel) { - pfstring(" : ", pserial); - pint(BreakLevel, pserial); - } - pserial('>'); pserial(' '); - Context = NIL; - object *line = read(gserial); - #if defined(CPU_NRF52840) - Serial.flush(); - #endif - // Break handling - if (BreakLevel) { - if (line == nil || line == bsymbol(COLONC)) { - pln(pserial); return; - } else if (line == bsymbol(COLONA)) { - pln(pserial); pln(pserial); - GCStack = NULL; - longjmp(*handler, 1); - } else if (line == bsymbol(COLONB)) { - pln(pserial); printbacktrace(); - line = bsymbol(NOTHING); - } - } - if (line == (object *)KET) error2("unmatched right bracket"); - protect(line); - pfl(pserial); - line = eval(line, env); - pfl(pserial); - printobject(line, pserial); - unprotect(); - pfl(pserial); - pln(pserial); - } -} - -/* - loop - the Arduino IDE main execution loop -*/ -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(); - } - ulisperror(); - repl(NULL); -} - -void ulisperror () { - // Come here after error - delay(100); while (Serial.available()) Serial.read(); - clrflag(NOESC); BreakLevel = 0; TraceStart = 0; TraceTop = 0; - for (int i=0; i #include #include #include #if defined(sdcardsupport) +#if defined(ARDUINO_RASPBERRY_PI_PICO) || defined (ARDUINO_RASPBERRY_PI_PICO_2W) + #include +#endif #include #define SDSIZE 720 #else @@ -213,22 +221,39 @@ const char LispLibrary[] = ""; #elif defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_ADAFRUIT_QTPY_RP2040) \ || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040) || defined(ARDUINO_SEEED_XIAO_RP2040) #define WORKSPACESIZE (23000-SDSIZE) /* Objects (8*bytes) */ - #define CODESIZE 256 /* Bytes */ - #define STACKDIFF 480 - #define LITTLEFS - #include - #define FS_FILE_WRITE "w" - #define FS_FILE_READ "r" - #define CPU_RP2040 - #if defined(gfxsupport) - const int COLOR_WHITE = 0xffff, COLOR_BLACK = 0; - #include // Core graphics library - #include // Hardware-specific library for ST7789 - Adafruit_ST7789 tft = Adafruit_ST7789(5, 1, 3, 2, 0); // TTGO RP2040 TFT - #define TFT_BACKLIGHT 4 - #define TFT_I2C_POWER 22 + + #if defined(sdcardsupport) + #define SDCARD_SS_PIN 17 + #else + #define LITTLEFS + #include + #define FILE_WRITE_BEGIN "w" + #define FILE_READ "r" #endif + #define CODESIZE 256 /* Bytes */ + #define STACKDIFF 320 + #define CPU_RP2040 + #if defined(gfxsupport) + const int COLOR_WHITE = 0xffff, COLOR_BLACK = 0; + /* + #include // Core graphics library + #include // Hardware-specific library for ST7789 + Adafruit_ST7789 tft = Adafruit_ST7789(5, 1, 3, 2, 0); // TTGO RP2040 TFT + #define TFT_BACKLIGHT 4 + #define TFT_I2C_POWER 22 + */ + + #include // Hardware-specific library + #if defined(CPI_PICOCALC) + #include + PCKeyboard pc_kbd; + TFT_eSPI tft = TFT_eSPI(320,320); + #else + TFT_eSPI tft = TFT_eSPI(); + #endif + #endif + #elif defined(ARDUINO_ADAFRUIT_FEATHER_RP2040_ADALOGGER) #define WORKSPACESIZE 23000 /* Objects (8*bytes) */ #define CODESIZE 256 /* Bytes */ @@ -279,10 +304,35 @@ const char LispLibrary[] = ""; #define CODESIZE 256 /* Bytes */ #define LITTLEFS #include - #include + // #include + #if defined(sdcardsupport) + #define SDCARD_SS_PIN 17 + #else + #define LITTLEFS + #include + #define FILE_WRITE_BEGIN "w" + #define FILE_READ "r" + #endif #define FS_FILE_WRITE "w" #define FS_FILE_READ "r" - #define CPU_RP2350 + #define CPU_RP2350j + #if defined(gfxsupport) + const int COLOR_WHITE = 0xffff, COLOR_BLACK = 0; + // #include // Core graphics library + // #include // Hardware-specific library for ST7789 + // Adafruit_ST7789 tft = Adafruit_ST7789(5, 1, 3, 2, 0); // TTGO RP2040 TFT + // #define TFT_BACKLIGHT 4 + // #define TFT_I2C_POWER 22 + #include // Hardware-specific library + #if defined(CPI_PICOCALC) + #include + PCKeyboard pc_kbd; + TFT_eSPI tft = TFT_eSPI(320,320); + #else + TFT_eSPI tft = TFT_eSPI(); + #endif + #endif + #elif defined(ARDUINO_PIMORONI_PICO_PLUS_2) //#define BOARD_HAS_PSRAM /* Uncomment to use PSRAM */ @@ -466,6 +516,7 @@ FORMAT, }; // Global variables +HardwareSerial *seriell;//pointer to which serial to use according the real board type object Workspace[WORKSPACESIZE] WORDALIGNED MEMBANK; #if defined(CODESIZE) @@ -509,6 +560,9 @@ int modbacktrace (int n) { return (n+BACKTRACESIZE) % BACKTRACESIZE; } +/* + printbacktrace - prints a call backtrace for error messages and break. +*/ void printbacktrace () { if (TraceStart != TraceTop) pserial('['); int tracesize = modbacktrace(TraceTop-TraceStart); @@ -519,6 +573,10 @@ void printbacktrace () { if (TraceStart != TraceTop) pserial(']'); } +/* + 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, const char *string) { pfl(pserial); pfstring("Error", pserial); if (TraceStart != TraceTop) pserial(' '); @@ -534,6 +592,11 @@ void errorsub (symbol_t fname, const char *string) { 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, const char *string, object *symbol) { if (!tstflag(MUFFLEERRORS)) { errorsub(fname, string); @@ -544,6 +607,10 @@ void errorsym (symbol_t fname, const char *string, object *symbol) { 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, const char *string) { if (!tstflag(MUFFLEERRORS)) { errorsub(fname, string); @@ -552,14 +619,26 @@ void errorsym2 (symbol_t fname, const char *string) { 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 (const char *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 (const char *string) { errorsym2(sym(Context), string); } +/* + formaterr - displays a format error with a ^ pointing to the error +*/ 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('^'); @@ -595,6 +674,9 @@ const char unknownstreamtype[] = "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--) { @@ -606,6 +688,9 @@ void initworkspace () { } } +/* + myalloc - returns the first object from the linked list of free objects +*/ object *myalloc () { if (Freespace == 0) { Context = NIL; error2("no room"); } object *temp = Freelist; @@ -614,6 +699,10 @@ object *myalloc () { 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; @@ -623,6 +712,9 @@ inline void myfree (object *obj) { // 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; @@ -630,6 +722,9 @@ object *number (int 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; @@ -637,6 +732,9 @@ object *makefloat (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; @@ -644,6 +742,9 @@ object *character (uint8_t 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; @@ -651,6 +752,9 @@ object *cons (object *arg1, object *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; @@ -658,10 +762,16 @@ object *symbol (symbol_t name) { return ptr; } +/* + bsymbol - make a built-in symbol +*/ inline object *bsymbol (builtin_t name) { return intern(twist(name+BUILTINS)); } +/* + codehead - make a code header object with value entry and return it +*/ object *codehead (int entry) { object *ptr = myalloc(); ptr->type = CODE; @@ -669,6 +779,10 @@ object *codehead (int entry) { return ptr; } +/* + intern - unless PSRAM: 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) { #if !defined(BOARD_HAS_PSRAM) for (int i=0; itype = STREAM; @@ -715,6 +839,9 @@ object *stream (uint8_t streamtype, uint8_t address) { return ptr; } +/* + newstring - makes an empty string object and returns it +*/ object *newstring () { object *ptr = myalloc(); ptr->type = STRING; @@ -757,6 +884,9 @@ object *features () { // Garbage collection +/* + markobject - recursively marks reachable objects, starting from obj +*/ void markobject (object *obj) { MARK: if (obj == NULL) return; @@ -787,6 +917,10 @@ void markobject (object *obj) { } } +/* + sweep - goes through the workspace freeing objects that have not been marked, + and unmarks marked objects +*/ void sweep () { Freelist = NULL; Freespace = 0; @@ -796,6 +930,10 @@ 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) int start = Freespace; @@ -813,6 +951,10 @@ void gc (object *form, object *env) { // Compact image +/* + movepointer - Corrects pointers to an object that has been moved from 'from' to 'to'. + Only need to scan addresses below 'from' as there are no accessible objects above that. +*/ void movepointer (object *from, object *to) { uintptr_t limit = ((uintptr_t)(from) - (uintptr_t)(Workspace))/sizeof(uintptr_t); for (uintptr_t i=0; itype; 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) { @@ -1373,14 +1588,23 @@ object *quote (object *arg) { // 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; @@ -1390,6 +1614,9 @@ int8_t toradix40 (char ch) { return -1; // Invalid } +/* + fromradix40 - returns the character encoded by the number n. +*/ char fromradix40 (char n) { if (n >= 1 && n <= 10) return '0'+n-1; if (n >= 11 && n <= 36) return 'a'+n-11; @@ -1397,6 +1624,9 @@ char fromradix40 (char n) { 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, j = 0; for (int i=0; i<6; i++) { @@ -1406,6 +1636,9 @@ uint32_t pack40 (char *buffer) { return x; } +/* + valid40 - returns true if the symbol in buffer can be encoded as six radix40-encoded characters. +*/ bool valid40 (char *buffer) { int t = 11; for (int i=0; i<6; i++) { @@ -1416,6 +1649,9 @@ bool valid40 (char *buffer) { 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; @@ -1423,11 +1659,17 @@ int8_t digitvalue (char d) { 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; @@ -1435,17 +1677,26 @@ int checkbitvalue (object *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 (float)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("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; @@ -1472,11 +1723,18 @@ int checkkeyword (object *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); } +/* + eqlongsymbol - checks whether two long symbols are equal +*/ bool eqlongsymbol (symbol_t sym1, symbol_t sym2) { object *arg1 = (object *)sym1; object *arg2 = (object *)sym2; while ((arg1 != NULL) || (arg2 != NULL)) { @@ -1487,12 +1745,18 @@ bool eqlongsymbol (symbol_t sym1, symbol_t sym2) { return true; } +/* + eqsymbol - checks whether two symbols are equal +*/ bool eqsymbol (symbol_t sym1, symbol_t sym2) { if (!longnamep(sym1) && !longnamep(sym2)) return (sym1 == sym2); // Same short symbol if (longnamep(sym1) && longnamep(sym2)) return eqlongsymbol(sym1, sym2); // Same long symbol return false; } +/* + eq - implements Lisp eq, taking into account PSRAM +*/ bool eq (object *arg1, object *arg2) { if (arg1 == arg2) return true; // Same object if ((arg1 == nil) || (arg2 == nil)) return false; // Not both values @@ -1509,12 +1773,18 @@ bool eq (object *arg1, object *arg2) { return false; } +/* + equal - implements Lisp equal +*/ 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); } +/* + listlength - returns the length of a list +*/ int listlength (object *list) { int length = 0; while (list != NULL) { @@ -1525,6 +1795,10 @@ 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); @@ -1537,6 +1811,10 @@ object *checkarguments (object *args, int min, int max) { // 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); @@ -1546,6 +1824,10 @@ object *add_floats (object *args, float fresult) { 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); @@ -1555,6 +1837,11 @@ object *subtract_floats (object *args, float fresult) { 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; @@ -1565,6 +1852,10 @@ object *negate (object *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); @@ -1574,6 +1865,10 @@ object *multiply_floats (object *args, float fresult) { 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); @@ -1585,6 +1880,9 @@ object *divide_floats (object *args, float fresult) { return makefloat(fresult); } +/* + remmod - implements rem (mod = false) and mod (mod = true). +*/ object *remmod (object *args, bool mod) { object *arg1 = first(args); object *arg2 = second(args); @@ -1605,6 +1903,13 @@ object *remmod (object *args, bool mod) { } } +/* + 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); @@ -1625,6 +1930,9 @@ object *compare (object *args, bool lt, bool gt, bool eq) { return tee; } +/* + intpower - calculates base to the power exp as an integer +*/ int intpower (int base, int exp) { int result = 1; while (exp) { @@ -1637,6 +1945,9 @@ int intpower (int base, int exp) { // Association lists +/* + testargument - handles the :test argument for functions that accept it +*/ object *testargument (object *args) { object *test = bsymbol(EQ); if (args != NULL) { @@ -1647,6 +1958,9 @@ object *testargument (object *args) { return test; } +/* + 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; @@ -1665,12 +1979,19 @@ object *delassoc (object *key, object **alist) { // 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) { @@ -1703,6 +2024,9 @@ object *makearray (object *dims, object *def, bool bitp) { 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)); @@ -1713,6 +2037,10 @@ object **arrayref (object *array, int index, int size) { 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; @@ -1737,6 +2065,9 @@ object **getarray (object *array, object *subs, object *env, int *bit) { 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++) { @@ -1750,6 +2081,10 @@ 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; @@ -1767,6 +2102,10 @@ object *readarray (int d, object *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; @@ -1794,6 +2133,9 @@ object *readbitarray (gfun_t gfun) { return array; } +/* + pslice - prints a slice of an array recursively +*/ 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; } @@ -1810,6 +2152,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; @@ -1836,6 +2181,9 @@ void indent (uint8_t spaces, char ch, pfun_t pfun) { for (uint8_t i=0; ichars = ch<<24; *tail = cell; } +/* + copystring - returns a copy of a Lisp string +*/ object *copystring (object *arg) { object *obj = newstring(); object *ptr = obj; @@ -1879,6 +2237,10 @@ object *copystring (object *arg) { return obj; } +/* + readstring - reads characters from an input stream up to delimiter delim + and returns a Lisp string +*/ object *readstring (uint8_t delim, bool esc, gfun_t gfun) { object *obj = newstring(); object *tail = obj; @@ -1892,6 +2254,10 @@ object *readstring (uint8_t delim, bool esc, gfun_t 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); @@ -1905,6 +2271,10 @@ int stringlength (object *form) { return length; } +/* + 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 **arg = &cdr(string); int top; @@ -1918,6 +2288,9 @@ object **getcharplace (object *string, int n, int *shift) { return arg; } +/* + nthchar - returns the nth character from a Lisp string +*/ uint8_t nthchar (object *string, int n) { int shift; object **arg = getcharplace(string, n, &shift); @@ -1925,6 +2298,9 @@ uint8_t nthchar (object *string, int n) { return (((*arg)->chars)>>((-shift-2)<<3)) & 0xFF; } +/* + gstr - reads a character from a string stream +*/ int gstr () { if (LastChar) { char temp = LastChar; @@ -1936,10 +2312,16 @@ int gstr () { 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; @@ -1952,6 +2334,14 @@ object *lispstring (char *s) { return obj; } +/* + stringcompare - a generic string compare function + Used to implement the other string comparison functions. + Returns -1 if the comparison is false, or the index of the first mismatch if it is true. + If lt is true the result is true if the first argument is less than the second argument. + 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) { object *arg1 = checkstring(first(args)); object *arg2 = checkstring(second(args)); @@ -1969,6 +2359,9 @@ int stringcompare (object *args, bool lt, bool gt, bool eq) { if (eq) { m = m - sizeof(int); while (a != 0) { m++; a = a << 8;} return m;} else return -1; } +/* + 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); @@ -1988,6 +2381,10 @@ object *documentation (object *arg, object *env) { 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); @@ -2034,6 +2431,10 @@ object *apropos (object *arg, bool print) { 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; @@ -2052,6 +2453,9 @@ char *cstring (object *form, char *buffer, int buflen) { return buffer; } +/* + 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 *obj = startstring(); @@ -2063,6 +2467,10 @@ object *iptostring (uint32_t ip) { return obj; } +/* + 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; @@ -2082,6 +2490,9 @@ uint32_t ipstring (object *form) { return ipaddress; } +/* + value - lookup variable in environment, taking into account PSRAM +*/ object *value (symbol_t n, object *env) { while (env != NULL) { object *pair = car(env); @@ -2095,6 +2506,9 @@ object *value (symbol_t n, object *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); @@ -2102,11 +2516,17 @@ object *findpair (object *var, object *env) { 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("unknown variable", var); @@ -2202,6 +2622,10 @@ object *apply (object *function, object *args, object *env) { // 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)); @@ -2249,18 +2673,28 @@ object **place (object *args, object *env, int *bit) { // 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) { @@ -2272,6 +2706,9 @@ object *cxxxr (object *args, uint8_t pattern) { // Mapping helper functions +/* + mapcl - handles either mapc when mapl=false, or mapl when mapl=true +*/ object *mapcl (object *args, object *env, bool mapl) { object *function = first(args); args = cdr(args); @@ -2300,11 +2737,17 @@ 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; } +/* + 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)) { @@ -2313,6 +2756,10 @@ 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 *function = first(args); args = cdr(args); @@ -2343,6 +2790,9 @@ 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 *varlist = first(args), *endlist = second(args); object *head = cons(NULL, NULL); @@ -2409,22 +2859,31 @@ object *dobody (object *args, object *env, bool star) { return eval(tf_progn(results, env), env); } -// I2C interface for up to two ports, using Arduino Wire - +// I2C interface for up to two ports, using Arduino Wire: in +// picocalc, i2c0 is for keyboard. void I2Cinit (TwoWire *port, bool enablePullup) { (void) enablePullup; + #if defined(ULISP_I2C1) port->begin(); + #endif } int I2Cread (TwoWire *port) { + #if defined(ULISP_I2C1) return port->read(); + #else + return 0; + #endif } void I2Cwrite (TwoWire *port, uint8_t data) { + #if defined(ULISP_I2C1) port->write(data); + #endif } bool I2Cstart (TwoWire *port, uint8_t address, uint8_t read) { + #if defined(ULISP_I2C1) int ok = true; if (read == 0) { port->beginTransmission(address); @@ -2433,19 +2892,28 @@ bool I2Cstart (TwoWire *port, uint8_t address, uint8_t read) { } else port->requestFrom(address, I2Ccount); return ok; + #else + return false; + #endif } bool I2Crestart (TwoWire *port, uint8_t address, uint8_t read) { + #if defined(ULISP_I2C1) int error = (port->endTransmission(false) != 0); if (read == 0) port->beginTransmission(address); else port->requestFrom(address, I2Ccount); return error ? false : true; + #else + return false; + #endif } void I2Cstop (TwoWire *port, uint8_t read) { - if (read == 0) port->endTransmission(); // Check for error? - // Release pins - port->end(); + #if defined(ULISP_I2C1) + if (read == 0) port->endTransmission(); // Check for error? + // Release pins + port->end(); + #endif } // Streams @@ -2472,7 +2940,8 @@ void I2Cstop (TwoWire *port, uint8_t read) { #elif defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_W) \ || defined(ARDUINO_RASPBERRY_PI_PICO_2) || defined(ARDUINO_RASPBERRY_PI_PICO_2W) \ || defined(ARDUINO_PIMORONI_PICO_PLUS_2) -#define ULISP_SERIAL2 +#define ULISP_SPI1 +#define ULISP_SERIAL1 #elif !defined(CPU_NRF51822) && !defined(CPU_NRF52833) && !defined(ARDUINO_FEATHER_F405) #define ULISP_SERIAL1 #endif @@ -2534,7 +3003,12 @@ void serialbegin (int address, int baud) { if (address == 1) Serial1.begin((long)baud*100); else if (address == 2) Serial2.begin((long)baud*100); #elif defined(ULISP_SERIAL1) - if (address == 1) Serial1.begin((long)baud*100); + #if defined(CPI_PICOCALC) + // Waveshare uses Serial1 for default. + if (address == 1) {} + #else + if (address == 1) Serial1.begin((long)baud*100); + #endif #else (void) baud; if (false); @@ -2551,7 +3025,12 @@ void serialend (int address) { if (address == 1) {Serial1.flush(); Serial1.end(); } else if (address == 2) {Serial2.flush(); Serial2.end(); } #elif defined(ULISP_SERIAL1) - if (address == 1) {Serial1.flush(); Serial1.end(); } + #if defined(CPI_PICOCALC) + if (address == 1) {Serial1.flush();} + #else + if (address == 1) {Serial1.flush(); Serial1.end(); } + #endif + #else if (false); #endif @@ -2906,28 +3385,43 @@ void pcount (char c) { PrintCount++; } +/* + atomwidth - calculates the character width of an atom +*/ uint8_t atomwidth (object *obj) { PrintCount = 0; printobject(obj, pcount); return PrintCount; } +/* + basewidth - calculates the character width of an integer printed in a given base +*/ uint8_t basewidth (object *obj, uint8_t base) { PrintCount = 0; pintbase(obj->integer, base, pcount); return PrintCount; } +/* + quoted - tests whether an object is quoted +*/ bool quoted (object *obj) { return (consp(obj) && car(obj) != NULL && car(obj)->name == sym(QUOTE) && consp(cdr(obj)) && cddr(obj) == NULL); } +/* + subwidth - returns the space left from w after printing object +*/ 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); } +/* + subwidth - returns the space left from w after printing a list +*/ int subwidthlist (object *form, int w) { while (form != NULL && w >= 0) { if (atom(form)) return w - (2 + atomwidth(form)); @@ -2937,6 +3431,9 @@ int subwidthlist (object *form, int w) { return w; } +/* + superprint - handles pretty-printing +*/ void superprint (object *form, int lm, pfun_t pfun) { if (atom(form)) { if (isbuiltin(form, NOTHING)) printsymbol(form, pfun); @@ -2972,6 +3469,10 @@ 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) { while (1) { if (tstflag(EXITEDITOR)) return fun; @@ -3076,6 +3577,10 @@ object *sp_quote (object *args, object *env) { 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); @@ -3085,6 +3590,10 @@ object *sp_or (object *args, object *env) { return nil; } +/* + (defun name (parameters) form*) + Defines a function. +*/ object *sp_defun (object *args, object *env) { (void) env; object *var = first(args); @@ -3096,6 +3605,10 @@ object *sp_defun (object *args, object *env) { return var; } +/* + (defvar variable form) + Defines a global variable. +*/ object *sp_defvar (object *args, object *env) { object *var = first(args); if (!symbolp(var)) error(notasymbol, var); @@ -3108,6 +3621,11 @@ object *sp_defvar (object *args, object *env) { 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; builtin_t setq = Context; while (args != NULL) { @@ -3120,6 +3638,11 @@ object *sp_setq (object *args, object *env) { 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 (;;) { @@ -3136,6 +3659,11 @@ object *sp_loop (object *args, object *env) { } } +/* + (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; object *item = eval(first(args), env); @@ -3145,6 +3673,11 @@ object *sp_push (object *args, object *env) { return *loc; } +/* + (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) { int bit; object *arg = first(args); @@ -3159,6 +3692,11 @@ object *sp_pop (object *args, object *env) { // 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; object **loc = place(first(args), env, &bit); @@ -3202,6 +3740,11 @@ object *sp_incf (object *args, object *env) { 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; object **loc = place(first(args), env, &bit); @@ -3245,6 +3788,10 @@ object *sp_decf (object *args, object *env) { 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; builtin_t setf = Context; object *arg = nil; @@ -3262,6 +3809,11 @@ object *sp_setf (object *args, object *env) { // Other special forms +/* + (dolist (var list [result]) form*) + 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 *params = checkarguments(args, 2, 3); object *var = first(params); @@ -3292,6 +3844,11 @@ object *sp_dolist (object *args, object *env) { return eval(car(params), env); } +/* + (dotimes (var number [result]) form*) + 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 *params = checkarguments(args, 2, 3); object *var = first(params); @@ -3319,14 +3876,29 @@ object *sp_dotimes (object *args, object *env) { return eval(car(params), env); } +/* + (do ((var [init [step]])*) (end-test result*) form*) + 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) { return dobody(args, env, false); } +/* + (do* ((var [init [step]])*) (end-test result*) form*) + 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) { return dobody(args, env, true); } +/* + (trace [function]*) + 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; while (args != NULL) { @@ -3343,6 +3915,11 @@ object *sp_trace (object *args, object *env) { 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) { @@ -3363,6 +3940,11 @@ object *sp_untrace (object *args, object *env) { 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) { object *param = checkarguments(args, 0, 1); unsigned long start = millis(); @@ -3377,6 +3959,11 @@ object *sp_formillis (object *args, object *env) { 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); @@ -3395,6 +3982,10 @@ object *sp_time (object *args, object *env) { 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) { object *params = checkarguments(args, 1, 1); object *var = first(params); @@ -3408,12 +3999,17 @@ object *sp_withoutputtostring (object *args, object *env) { 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 = checkarguments(args, 2, 3); object *var = first(params); int address = checkinteger(eval(second(params), env)); params = cddr(params); - int baud = 96; + int baud = BAUDRATE; if (params != NULL) baud = checkinteger(eval(first(params), env)); object *pair = cons(var, stream(SERIALSTREAM, address)); push(pair,env); @@ -3424,6 +4020,12 @@ object *sp_withserial (object *args, object *env) { 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. If port is omitted it defaults to 0, otherwise it specifies the port, 0 or 1. +*/ object *sp_withi2c (object *args, object *env) { object *params = checkarguments(args, 2, 4); object *var = first(params); @@ -3454,6 +4056,12 @@ object *sp_withi2c (object *args, object *env) { return result; } +/* + (with-spi (str pin [clock] [bitorder] [mode] [port]) 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), SPI mode (default 0), and port 0 or 1 (default 0). +*/ object *sp_withspi (object *args, object *env) { object *params = checkarguments(args, 2, 6); object *var = first(params); @@ -3497,6 +4105,11 @@ object *sp_withspi (object *args, object *env) { 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 = checkarguments(args, 2, 3); @@ -3508,7 +4121,18 @@ object *sp_withsdcard (object *args, object *env) { Context = temp; if (!stringp(filename)) error("filename is not a string", filename); params = cdr(params); - SDBegin(); + #if defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_2W) + #if defined(CPI_PICOCALC) + if(!SD.begin(SDCARD_SS_PIN,(uint32_t) SPI_HALF_SPEED, SPI )){ + error2(PSTR("problem init SD card")); + return nil; + } + #else + SD.begin(SDCARD_SS_PIN,(uint32_t) SPI_HALF_SPEED, SPI1); + #endif + #else + SD.begin(SDCARD_SS_PIN); + #endif int mode = 0; if (params != NULL && first(params) != NULL) mode = checkinteger(first(params)); int oflag = O_READ; @@ -3537,6 +4161,11 @@ object *sp_withsdcard (object *args, object *env) { // Assembler +/* + (defcode name (parameters) form*) + Creates a machine-code function called name from a series of 16-bit integers given in the body of the form. + These are written into RAM, and can be executed by calling the function in the same way as a normal Lisp function. +*/ object *sp_defcode (object *args, object *env) { #if defined(CODESIZE) setflag(NOESC); @@ -3642,6 +4271,10 @@ object *sp_defcode (object *args, object *env) { // 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); @@ -3654,6 +4287,11 @@ object *tf_progn (object *args, object *env) { 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); @@ -3661,6 +4299,12 @@ object *tf_if (object *args, object *env) { 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); @@ -3675,18 +4319,31 @@ object *tf_cond (object *args, object *env) { 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); @@ -3706,6 +4363,10 @@ object *tf_case (object *args, object *env) { 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); @@ -3719,46 +4380,83 @@ object *tf_and (object *args, object *env) { // 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 built-in or user-defined keyword. +*/ object *fn_keywordp (object *args, object *env) { (void) env; object *arg = first(args); @@ -3766,6 +4464,10 @@ object *fn_keywordp (object *args, object *env) { return (keywordp(arg) || colonp(arg->name)) ? 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) { @@ -3778,17 +4480,31 @@ object *fn_setfn (object *args, object *env) { 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; @@ -3796,76 +4512,134 @@ object *fn_equal (object *args, object *env) { // 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); @@ -3875,6 +4649,10 @@ object *fn_length (object *args, object *env) { 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); @@ -3883,11 +4661,19 @@ object *fn_arraydimensions (object *args, object *env) { 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; } +/* + (copy-list list) + Returns a copy of a list. +*/ object *fn_copylist (object *args, object *env) { (void) env; object *arg = first(args); @@ -3901,6 +4687,12 @@ object *fn_copylist (object *args, object *env) { return cdr(result); } +/* + (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; @@ -3923,6 +4715,10 @@ object *fn_makearray (object *args, object *env) { 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); @@ -3935,6 +4731,10 @@ object *fn_reverse (object *args, object *env) { 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)); @@ -3949,6 +4749,10 @@ object *fn_nth (object *args, object *env) { return nil; } +/* + (aref array index [index*]) + Returns an element from the specified array. +*/ object *fn_aref (object *args, object *env) { (void) env; int bit; @@ -3959,6 +4763,11 @@ object *fn_aref (object *args, object *env) { else return number((loc->integer)>>bit & 1); } +/* + (assoc key list [:test function]) + 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 *key = first(args); @@ -3974,6 +4783,11 @@ object *fn_assoc (object *args, object *env) { return nil; } +/* + (member item list [:test function]) + 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 *item = first(args); @@ -3987,6 +4801,10 @@ object *fn_member (object *args, object *env) { 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; @@ -4000,10 +4818,18 @@ object *fn_apply (object *args, object *env) { 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; @@ -4024,32 +4850,67 @@ object *fn_append (object *args, object *env) { 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) { return mapcl(args, env, false); } +/* + (mapl function list1 [list]*) + 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) { return mapcl(args, env, true); } +/* + (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, false); } +/* + (mapcan function list1 [list]*) + Applies the function to each element in one or more lists. The results should be lists, + and these are destructively concatenated together to give the value returned. +*/ object *fn_mapcan (object *args, object *env) { return mapcarcan(args, env, mapcanfun, false); } +/* + (maplist function list1 [list]*) + 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) { return mapcarcan(args, env, mapcarfun, true); } +/* + (mapcon function list1 [list]*) + 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) { return mapcarcan(args, env, mapcanfun, true); } // 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; @@ -4067,6 +4928,13 @@ object *fn_add (object *args, object *env) { 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); @@ -4091,6 +4959,12 @@ object *fn_subtract (object *args, object *env) { 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; @@ -4107,6 +4981,12 @@ object *fn_multiply (object *args, object *env) { 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); @@ -4146,16 +5026,32 @@ object *fn_divide (object *args, object *env) { 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; return remmod(args, true); } +/* + (rem number number) + Returns the remainder from dividing the first argument by the second argument. + If both arguments are integers the result is an integer; otherwise it's a floating-point number. +*/ object *fn_rem (object *args, object *env) { (void) env; return remmod(args, false); } +/* + (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); @@ -4168,6 +5064,12 @@ object *fn_oneplus (object *args, object *env) { 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); @@ -4180,6 +5082,12 @@ object *fn_oneminus (object *args, object *env) { 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); @@ -4192,6 +5100,11 @@ object *fn_abs (object *args, object *env) { 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); @@ -4201,6 +5114,10 @@ object *fn_random (object *args, object *env) { 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); @@ -4215,6 +5132,10 @@ object *fn_maxfn (object *args, object *env) { 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); @@ -4231,6 +5152,10 @@ object *fn_minfn (object *args, object *env) { // 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) { @@ -4249,31 +5174,55 @@ object *fn_noteq (object *args, object *env) { 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); @@ -4283,6 +5232,10 @@ object *fn_plusp (object *args, object *env) { 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); @@ -4292,6 +5245,10 @@ object *fn_minusp (object *args, object *env) { return nil; } +/* + (zerop number) + Returns t if the argument is zero. +*/ object *fn_zerop (object *args, object *env) { (void) env; object *arg = first(args); @@ -4301,12 +5258,20 @@ object *fn_zerop (object *args, object *env) { 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)); @@ -4315,11 +5280,19 @@ object *fn_evenp (object *args, object *env) { // 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); @@ -4328,42 +5301,74 @@ object *fn_numberp (object *args, object *env) { // 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); @@ -4373,31 +5378,55 @@ object *fn_atan (object *args, object *env) { 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)))); } +/* + (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); @@ -4407,6 +5436,12 @@ object *fn_log (object *args, object *env) { 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); @@ -4421,6 +5456,10 @@ object *fn_expt (object *args, object *env) { 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); @@ -4429,6 +5468,10 @@ object *fn_ceiling (object *args, object *env) { 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); @@ -4437,6 +5480,10 @@ object *fn_floor (object *args, object *env) { else return number(floor(checkintfloat(arg))); } +/* + (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); @@ -4445,6 +5492,10 @@ object *fn_truncate (object *args, object *env) { else return number((int)(checkintfloat(arg))); } +/* + (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); @@ -4455,6 +5506,10 @@ object *fn_round (object *args, object *env) { // 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); @@ -4465,16 +5520,28 @@ object *fn_char (object *args, object *env) { 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; @@ -4482,47 +5549,83 @@ object *fn_characterp (object *args, object *env) { // 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) + Returns t if the two strings are the same, or nil otherwise. +*/ object *fn_stringeq (object *args, object *env) { (void) env; int m = stringcompare(args, false, false, true); return m == -1 ? nil : tee; } +/* + (string< string string) + 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; int m = stringcompare(args, true, false, false); return m == -1 ? nil : number(m); } +/* + (string> string string) + 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; int m = stringcompare(args, false, true, false); return m == -1 ? nil : number(m); } +/* + (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); } +/* + (string<= string string) + 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; int m = stringcompare(args, true, false, true); return m == -1 ? nil : number(m); } +/* + (string>= string string) + 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; int m = stringcompare(args, false, true, true); return m == -1 ? nil : number(m); } +/* + (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 *arg = first(args); if (!listp(arg)) error(notalist, arg); @@ -4552,10 +5655,18 @@ object *fn_sort (object *args, object *env) { 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); @@ -4580,6 +5691,10 @@ object *fn_concatenate (object *args, object *env) { 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); @@ -4612,6 +5727,11 @@ object *fn_subseq (object *args, object *env) { return nil; } +/* + (search pattern target [:test function]) + Returns the index of the first occurrence of pattern in target, or nil if it's not found. + The target can be a list or string. If it's a list a test function can be specified; default eq. +*/ object *fn_search (object *args, object *env) { (void) env; object *pattern = first(args); @@ -4648,6 +5768,10 @@ object *fn_search (object *args, object *env) { return nil; } +/* + (read-from-string string) + Reads an atom or list from the specified string and returns it. +*/ object *fn_readfromstring (object *args, object *env) { (void) env; object *arg = checkstring(first(args)); @@ -4658,11 +5782,22 @@ object *fn_readfromstring (object *args, object *env) { return val; } +/* + (princ-to-string item) + Prints its argument to a string, and returns the string. + Characters and strings are printed without quotation marks or escape characters. +*/ object *fn_princtostring (object *args, object *env) { (void) env; return princtostring(first(args)); } +/* + (prin1-to-string item [stream]) + Prints its argument to a string, and returns the string. + Characters and strings are printed with quotation marks and escape characters, + in a format that will be suitable for read-from-string. +*/ object *fn_prin1tostring (object *args, object *env) { (void) env; object *arg = first(args); @@ -4673,6 +5808,10 @@ object *fn_prin1tostring (object *args, object *env) { // Bitwise operators +/* + (logand [value*]) + Returns the bitwise & of the values. +*/ object *fn_logand (object *args, object *env) { (void) env; int result = -1; @@ -4683,6 +5822,10 @@ object *fn_logand (object *args, object *env) { return number(result); } +/* + (logior [value*]) + Returns the bitwise | of the values. +*/ object *fn_logior (object *args, object *env) { (void) env; int result = 0; @@ -4693,6 +5836,10 @@ object *fn_logior (object *args, object *env) { return number(result); } +/* + (logxor [value*]) + Returns the bitwise ^ of the values. +*/ object *fn_logxor (object *args, object *env) { (void) env; int result = 0; @@ -4703,12 +5850,20 @@ object *fn_logxor (object *args, object *env) { return number(result); } +/* + (lognot value) + Returns the bitwise logical NOT of the value. +*/ object *fn_lognot (object *args, object *env) { (void) env; int result = checkinteger(car(args)); return number(~result); } +/* + (ash value shift) + Returns the result of bitwise shifting value by shift bits. If shift is positive, value is shifted to the left. +*/ object *fn_ash (object *args, object *env) { (void) env; int value = checkinteger(first(args)); @@ -4717,6 +5872,10 @@ object *fn_ash (object *args, object *env) { 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)); @@ -4726,16 +5885,28 @@ object *fn_logbitp (object *args, object *env) { // System functions +/* + (eval form*) + Evaluates its argument an extra time. +*/ 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. +*/ object *fn_globals (object *args, object *env) { (void) args, (void) env; object *result = cons(NULL, NULL); @@ -4748,11 +5919,19 @@ object *fn_globals (object *args, object *env) { 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); @@ -4761,6 +5940,10 @@ object *fn_makunbound (object *args, object *env) { 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("\nBreak!\n", pserial); @@ -4770,12 +5953,22 @@ object *fn_break (object *args, object *env) { 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); @@ -4784,6 +5977,11 @@ object *fn_prin1 (object *args, object *env) { 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); @@ -4794,6 +5992,11 @@ object *fn_print (object *args, object *env) { 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); @@ -4802,6 +6005,11 @@ object *fn_princ (object *args, object *env) { 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); @@ -4809,6 +6017,10 @@ object *fn_terpri (object *args, object *env) { 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); @@ -4816,12 +6028,21 @@ object *fn_readbyte (object *args, object *env) { 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', false, gfun); } +/* + (write-byte number [stream]) + Writes a byte to a stream. +*/ inline void serialwrite (char c) { Serial.write(c); } object *fn_writebyte (object *args, object *env) { @@ -4833,6 +6054,10 @@ object *fn_writebyte (object *args, object *env) { 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); @@ -4844,6 +6069,10 @@ object *fn_writestring (object *args, object *env) { 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); @@ -4856,6 +6085,12 @@ object *fn_writeline (object *args, object *env) { 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 = isstream(first(args)); @@ -4877,6 +6112,10 @@ object *fn_restarti2c (object *args, object *env) { return I2Crestart(port, address & 0x7F, read) ? tee : nil; } +/* + (gc [print time]) + Forces a garbage collection and prints the number of objects collected, and the time taken. +*/ object *fn_gc (object *args, object *env) { if (args == NULL || first(args) != NULL) { int initial = Freespace; @@ -4892,11 +6131,20 @@ object *fn_gc (object *args, object *env) { 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); } +/* + (backtrace [on]) + Sets the state of backtrace according to the boolean flag 'on', + or with no argument displays the current state of backtrace. +*/ object *fn_backtrace (object *args, object *env) { (void) env; if (args == NULL) return (tstflag(BACKTRACE)) ? tee : nil; @@ -4904,17 +6152,29 @@ object *fn_backtrace (object *args, object *env) { return first(args); } +/* + (save-image [symbol]) + Saves the current uLisp image to non-volatile memory or SD card so it can be loaded using load-image. +*/ object *fn_saveimage (object *args, object *env) { if (args != NULL) args = eval(first(args), env); return number(saveimage(args)); } +/* + (load-image [filename]) + Loads a saved uLisp image from non-volatile memory or SD card. +*/ object *fn_loadimage (object *args, object *env) { (void) env; if (args != NULL) args = first(args); return number(loadimage(args)); } +/* + (cls) + Prints a clear-screen character. +*/ object *fn_cls (object *args, object *env) { (void) args, (void) env; pserial(12); @@ -4923,6 +6183,11 @@ object *fn_cls (object *args, object *env) { // 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); @@ -4942,6 +6207,10 @@ object *fn_pinmode (object *args, object *env) { 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; @@ -4951,6 +6220,10 @@ object *fn_digitalread (object *args, object *env) { 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; @@ -4966,6 +6239,10 @@ object *fn_digitalwrite (object *args, object *env) { 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; @@ -4978,6 +6255,10 @@ object *fn_analogread (object *args, object *env) { return number(analogRead(pin)); } +/* + (analogreference keyword) + Specifies a keyword to set the analogue reference voltage used for analogue input. +*/ object *fn_analogreference (object *args, object *env) { (void) env; object *arg = first(args); @@ -4995,6 +6276,11 @@ object *fn_analogreference (object *args, object *env) { return arg; } +/* + (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); @@ -5008,6 +6294,10 @@ object *fn_analogreadresolution (object *args, object *env) { 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; @@ -5020,6 +6310,10 @@ object *fn_analogwrite (object *args, object *env) { return value; } +/* + (analogwrite pin value) + Sets the analogue write resolution. +*/ object *fn_analogwriteresolution (object *args, object *env) { (void) env; object *arg = first(args); @@ -5027,6 +6321,10 @@ object *fn_analogwriteresolution (object *args, object *env) { return arg; } +/* + (delay number) + Delays for a specified number of milliseconds. +*/ object *fn_delay (object *args, object *env) { (void) env; object *arg1 = first(args); @@ -5037,11 +6335,20 @@ object *fn_delay (object *args, object *env) { 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); @@ -5049,6 +6356,12 @@ object *fn_sleep (object *args, object *env) { return arg1; } +/* + (note [pin] [note] [octave]) + Generates a square wave on pin. + note represents the note in the well-tempered scale. + The argument octave can specify an octave; default 0. +*/ object *fn_note (object *args, object *env) { (void) env; static int pin = 255; @@ -5064,6 +6377,12 @@ object *fn_note (object *args, object *env) { 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); @@ -5077,6 +6396,10 @@ object *fn_register (object *args, object *env) { // 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); @@ -5088,6 +6411,11 @@ object *fn_edit (object *args, object *env) { // 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); @@ -5101,6 +6429,11 @@ object *fn_pprint (object *args, object *env) { 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); @@ -5130,6 +6463,10 @@ object *fn_pprintall (object *args, object *env) { // 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; @@ -5208,6 +6545,11 @@ object *fn_format (object *args, object *env) { // 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; @@ -5232,6 +6574,10 @@ object *fn_require (object *args, object *env) { 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; @@ -5248,6 +6594,10 @@ object *fn_listlibrary (object *args, object *env) { // 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); @@ -5260,16 +6610,28 @@ object *sp_help (object *args, object *env) { 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); @@ -5277,6 +6639,11 @@ object *fn_aproposlist (object *args, object *env) { // 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; @@ -5307,6 +6674,10 @@ object *sp_unwindprotect (object *args, object *env) { 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; @@ -5334,6 +6705,10 @@ object *sp_ignoreerrors (object *args, object *env) { 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)) { @@ -5349,6 +6724,10 @@ object *sp_error (object *args, object *env) { // SD Card utilities +/* + (directory) + Returns a list of the filenames of the files on the SD card. +*/ object *fn_directory (object *args, object *env) { (void) args, (void) env; #if defined(sdcardsupport) @@ -5375,6 +6754,10 @@ object *fn_directory (object *args, object *env) { // 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) { #if defined(ULISP_WIFI) object *params = checkarguments(args, 1, 3); @@ -5409,6 +6792,10 @@ object *sp_withclient (object *args, object *env) { #endif } +/* + (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) { #if defined (ULISP_WIFI) (void) env; @@ -5421,6 +6808,10 @@ object *fn_available (object *args, object *env) { #endif } +/* + (wifi-server) + Starts a Wi-Fi server running. It returns nil. +*/ object *fn_wifiserver (object *args, object *env) { #if defined (ULISP_WIFI) (void) args, (void) env; @@ -5433,6 +6824,11 @@ object *fn_wifiserver (object *args, object *env) { #endif } +/* + (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) { #if defined (ULISP_WIFI) (void) env; @@ -5457,6 +6853,10 @@ object *fn_wifisoftap (object *args, object *env) { #endif } +/* + (connected stream) + Returns t or nil to indicate if the client on stream is connected. +*/ object *fn_connected (object *args, object *env) { #if defined (ULISP_WIFI) (void) env; @@ -5469,6 +6869,10 @@ object *fn_connected (object *args, object *env) { #endif } +/* + (wifi-localip) + Returns the IP address of the local network as a string. +*/ object *fn_wifilocalip (object *args, object *env) { #if defined (ULISP_WIFI) (void) args, (void) env; @@ -5480,6 +6884,10 @@ object *fn_wifilocalip (object *args, object *env) { #endif } +/* + (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) { #if defined (ULISP_WIFI) (void) env; @@ -5505,6 +6913,11 @@ object *fn_wificonnect (object *args, object *env) { // 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 = checkarguments(args, 1, 1); @@ -5521,6 +6934,10 @@ object *sp_withgfx (object *args, object *env) { #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) @@ -5533,6 +6950,10 @@ object *fn_drawpixel (object *args, object *env) { 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) @@ -5546,6 +6967,11 @@ object *fn_drawline (object *args, object *env) { 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) @@ -5559,6 +6985,11 @@ object *fn_drawrect (object *args, object *env) { 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) @@ -5572,6 +7003,11 @@ object *fn_fillrect (object *args, object *env) { 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) @@ -5585,6 +7021,11 @@ object *fn_drawcircle (object *args, object *env) { 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) @@ -5598,6 +7039,11 @@ object *fn_fillcircle (object *args, object *env) { 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) @@ -5611,6 +7057,11 @@ object *fn_drawroundrect (object *args, object *env) { 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) @@ -5624,6 +7075,11 @@ object *fn_fillroundrect (object *args, object *env) { 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) @@ -5637,6 +7093,11 @@ object *fn_drawtriangle (object *args, object *env) { 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) @@ -5650,6 +7111,13 @@ object *fn_filltriangle (object *args, object *env) { 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) @@ -5672,6 +7140,10 @@ object *fn_drawchar (object *args, object *env) { 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) @@ -5682,6 +7154,10 @@ object *fn_setcursor (object *args, object *env) { 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) @@ -5693,6 +7169,10 @@ object *fn_settextcolor (object *args, object *env) { 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) @@ -5703,6 +7183,10 @@ object *fn_settextsize (object *args, object *env) { 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) @@ -5713,6 +7197,10 @@ object *fn_settextwrap (object *args, object *env) { 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) @@ -5725,6 +7213,10 @@ object *fn_fillscreen (object *args, object *env) { 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) @@ -5735,6 +7227,10 @@ object *fn_setrotation (object *args, object *env) { return nil; } +/* + (invert-display boolean) + Mirror-images the display. +*/ object *fn_invertdisplay (object *args, object *env) { (void) env; #if defined(gfxsupport) @@ -7196,6 +8692,10 @@ unsigned int tablesize (int n) { // 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. Allows definitions in an extension file to override the built-in functions. +*/ builtin_t lookupbuiltin (char* c) { unsigned int start = tablesize(0); for (int n=1; n>=0; n--) { @@ -7209,16 +8709,26 @@ builtin_t lookupbuiltin (char* c) { return ENDFUNCTIONS; } +/* + lookupfn - looks up the entry for name in lookup_table[], and returns the function entry point +*/ intptr_t lookupfn (builtin_t name) { bool n = name(minmax & 0x07)) error2(toomanyargs); } +/* + lookupdoc - looks up the documentation string for the built-in function name +*/ char *lookupdoc (builtin_t name) { bool n = nameavailable() && seriell->read() == '~') { error2(PSTR("escape!")); } } +/* + colonp - check that a user-defined symbol starts with a colon and is therefore a keyword +*/ bool colonp (symbol_t name) { if (!longnamep(name)) return false; object *form = (object *)name; @@ -7247,6 +8767,9 @@ bool colonp (symbol_t name) { return (((form->chars)>>((sizeof(int)-1)*8) & 0xFF) == ':'); } +/* + keywordp - check that obj is a keyword +*/ bool keywordp (object *obj) { if (!(symbolp(obj) && builtinp(obj->name))) return false; builtin_t name = builtin(obj->name); @@ -7256,6 +8779,9 @@ bool keywordp (object *obj) { return (c == ':'); } +/* + backtrace - store symbol for backtrace +*/ void backtrace (symbol_t name) { Backtrace[TraceTop] = (name == sym(NIL)) ? sym(LAMBDA) : name; TraceTop = modbacktrace(TraceTop+1); @@ -7272,12 +8798,17 @@ void backtrace (symbol_t name) { extern uint32_t ENDSTACK; // Bottom of stack +/* + eval - the main Lisp evaluator +*/ object *eval (object *form, object *env) { register int *sp asm ("sp"); int TC=0; EVAL: // Enough space? // Serial.println((uint32_t)sp - (uint32_t)&ENDSTACK); // Find best STACKDIFF value + // seriell->println((uint32_t)sp - (uint32_t)&ENDSTACK); // Find best STACKDIFF value + if (((uint32_t)sp - (uint32_t)&ENDSTACK) < STACKDIFF) { Context = NIL; error2("stack overflow"); } if (Freespace <= WORKSPACESIZE>>4) gc(form, env); // GC when 1/16 of workspace left // Escape @@ -7460,15 +8991,25 @@ object *eval (object *form, object *env) { // 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); + if (!tstflag(NOECHO)) Display(c); // Don't display on T-Deck when paste in listing + if (c == '\n') seriell->write('\r'); + seriell->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"; +/* + 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 { @@ -7482,14 +9023,23 @@ void pcharacter (uint8_t c, pfun_t 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) { @@ -7503,12 +9053,19 @@ 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) { 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 n = name0; d = d/40) { @@ -7529,10 +9089,16 @@ 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) { 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 (longnamep(name)) plispstr(name, pfun); else { @@ -7543,6 +9109,9 @@ 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) { while (1) { char c = *s++; @@ -7551,12 +9120,18 @@ 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) { 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; @@ -7567,6 +9142,9 @@ void pintbase (uint32_t i, uint8_t base, pfun_t pfun) { } } +/* + pinthex4 - prints a four-digit hexadecimal number with leading zeros to the specified stream +*/ void printhex4 (int i, pfun_t pfun) { int p = 0x1000; for (int d=p; d>0; d=d/16) { @@ -7577,6 +9155,9 @@ void printhex4 (int i, pfun_t pfun) { pfun(' '); } +/* + 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); @@ -7604,6 +9185,9 @@ 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; } @@ -7625,14 +9209,23 @@ void pfloat (float f, pfun_t 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); @@ -7649,6 +9242,9 @@ void plist (object *form, pfun_t pfun) { pfun(')'); } +/* + pstream - prints a stream name to the specified stream +*/ void pstream (object *form, pfun_t pfun) { pfun('<'); pfstring(streamname[(form->integer)>>8], pfun); @@ -7657,6 +9253,9 @@ void pstream (object *form, pfun_t pfun) { pfun('>'); } +/* + printobject - prints any Lisp object to the specified stream +*/ void printobject (object *form, pfun_t pfun) { if (form == NULL) pfstring("nil", pfun); else if (listp(form) && isbuiltin(car(form), CLOSURE)) pfstring("", pfun); @@ -7672,6 +9271,9 @@ void printobject (object *form, pfun_t pfun) { else error2("error in print"); } +/* + prin1object - prints any Lisp object to the specified stream escaping special characters +*/ void prin1object (object *form, pfun_t pfun) { flags_t temp = Flags; clrflag(PRINTREADABLY); @@ -7681,6 +9283,9 @@ void prin1object (object *form, pfun_t pfun) { // Read functions +/* + glibrary - reads a character from the Lisp Library +*/ int glibrary () { if (LastChar) { char temp = LastChar; @@ -7691,6 +9296,9 @@ int glibrary () { 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); @@ -7702,26 +9310,39 @@ void loadfromlibrary (object *env) { } } +// PicoCalc terminal and keyboard support +const int Columns = 53; +const int Leading = 10; // Between 8 and 10 +const int Lines = 320/Leading; +const int LastColumn = Columns-1; +const int LastLine = Lines-1; +const char Cursor = 0x5f; + +uint8_t Scroll = 0; + // For line editor const int TerminalWidth = 80; volatile int WritePtr = 0, ReadPtr = 0, LastWritePtr = 0; -const int KybdBufSize = 333; // 42*8 - 3 -char KybdBuf[KybdBufSize]; +const int KybdBufSize = Columns*Lines; +char KybdBuf[KybdBufSize], ScrollBuf[Columns][Lines]; 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); + seriell->write('\e'); seriell->write('['); + seriell->write((char)('0'+ p/100)); + seriell->write((char)('0'+ (p/10) % 10)); + seriell->write((char)('0'+ p % 10)); + seriell->write(c); } void hilight (char c) { - Serial.write('\e'); Serial.write('['); Serial.write(c); Serial.write('m'); + seriell->write('\e'); seriell->write('['); seriell->write(c); seriell->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) @@ -7737,15 +9358,18 @@ void Highlight (int p, int wp, uint8_t invert) { if (up) esc(up, 'A'); if (col > targetcol) esc(left, 'D'); else esc(-left, 'C'); if (invert) hilight('7'); - Serial.write('('); Serial.write('\b'); + seriell->write('('); seriell->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(')'); + seriell->write('\b'); seriell->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) @@ -7764,7 +9388,7 @@ void processkey (char c) { if (c == 8 || c == 0x7f) { // Backspace key if (WritePtr > 0) { WritePtr--; - Serial.write(8); Serial.write(' '); Serial.write(8); + seriell->write(8); seriell->write(' '); seriell->write(8); if (WritePtr) c = KybdBuf[WritePtr-1]; } } else if (c == 9) { // tab or ctrl-I @@ -7772,7 +9396,7 @@ void processkey (char c) { WritePtr = LastWritePtr; } else if (WritePtr < KybdBufSize) { KybdBuf[WritePtr++] = c; - Serial.write(c); + seriell->write(c); } #if defined(vt100) // Do new parenthesis highlight @@ -7792,6 +9416,9 @@ void processkey (char c) { return; } +/* + gserial - gets a character from the serial port +*/ int gserial () { if (LastChar) { char temp = LastChar; @@ -7800,9 +9427,21 @@ int gserial () { } #if defined(lineeditor) while (!KybdAvailable) { - while (!Serial.available()); - char temp = Serial.read(); - processkey(temp); + if (seriell->available()) { + char temp = seriell->read(); + processkey(temp); + } + #if defined(i2ckbd) + if (pc_kbd.keyCount() > 0) { + const PCKeyboard::KeyEvent key = pc_kbd.keyEvent(); + if (key.state == PCKeyboard::StatePress) { + char temp = key.key; + if ((temp != 0) && (temp !=255) && (temp != 0xA1) && (temp != 0xA2) && (temp != 0xA3) && (temp != 0xA4) && (temp != 0xA5)) { + ProcessKey(temp); + } + } + } + #endif } if (ReadPtr != WritePtr) return KybdBuf[ReadPtr++]; KybdAvailable = 0; @@ -7810,13 +9449,16 @@ int gserial () { return '\n'; #else unsigned long start = millis(); - while (!Serial.available()) if (millis() - start > 1000) clrflag(NOECHO); - char temp = Serial.read(); + while (!seriell->available()) if (millis() - start > 1000) clrflag(NOECHO); + char temp = seriell->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(); @@ -7942,6 +9584,9 @@ object *nextitem (gfun_t gfun) { return internlong(buffer); } +/* + readrest - reads the remaining tokens from the specified stream +*/ object *readrest (gfun_t gfun) { object *item = nextitem(gfun); object *head = NULL; @@ -7967,6 +9612,9 @@ object *readrest (gfun_t 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("incomplete list"); @@ -7976,13 +9624,196 @@ object *read (gfun_t gfun) { return item; } +// Terminal ********************************************************************************** + +// Plot character at absolute character cell position +void PlotChar (uint8_t ch, uint8_t line, uint8_t column) { + #if defined(gfxsupport) + uint16_t y = line*Leading; + uint16_t x = column*6; + ScrollBuf[column][(line+Scroll) % Lines] = ch; + if (ch & 0x80) { + tft.drawChar(x, y, ch & 0x7f, TFT_BLACK, TFT_GREEN, 1); + } else { + tft.drawChar(x, y, ch & 0x7f, TFT_WHITE, TFT_BLACK, 1); + } +#endif +} + +// Clears the bottom line and then scrolls the display up by one line +void ScrollDisplay () { + #if defined(gfxsupport) + tft.fillRect(0, 320-Leading, 320, 10, TFT_BLACK); + for (uint8_t x = 0; x < Columns; x++) { + char c = ScrollBuf[x][Scroll]; + for (uint8_t y = 0; y < Lines-1; y++) { + char c2 = ScrollBuf[x][(y+Scroll+1) % Lines]; + if (c != c2) { + if (c2 & 0x80) { + tft.drawChar(x*6, y*Leading, c2 & 0x7f, TFT_BLACK, TFT_GREEN, 1); + } else { + tft.drawChar(x*6, y*Leading, c2 & 0x7f, TFT_WHITE, TFT_BLACK, 1); + } + c = c2; + } + } + } + // Tidy up graphics + for (uint8_t y = 0; y < Lines-1; y++) tft.fillRect(0, y*Leading+8, 320, 2, TFT_BLACK); + tft.fillRect(318, 0, 3, 320, TFT_BLACK); + for (int x=0; x= 17) && (c <= 20)) { // Parentheses + if (c == 17) PlotChar('(', line, column); + else if (c == 18) PlotChar('(' | 0x80, line, column); + else if (c == 19) PlotChar(')', line, column); + else PlotChar(')' | 0x80, line, column); + return; + } + if (c == STX) { invert = true; return; } + if (c == ETX) { invert = false; return; } + // Hide cursor + PlotChar(' ', line, column); + if (c == 0x7F) { // DEL + if (column == 0) { + line--; column = LastColumn; + } else column--; + } else if ((c & 0x7f) >= 32) { // Normal character + if (invert) PlotChar(c | 0x80, line, column++); else PlotChar(c, line, column++); + if (column > LastColumn) { + column = 0; + if (line == LastLine) ScrollDisplay(); else line++; + } + // Control characters + } else if (c == 12) { // Clear display + tft.fillScreen(COLOR_BLACK); line = 0; column = 0; Scroll = 0; + for (int col = 0; col < Columns; col++) { + for (int row = 0; row < Lines; row++) { + ScrollBuf[col][row] = 0; + } + } + } else if (c == '\n') { // Newline + column = 0; + if (line == LastLine) ScrollDisplay(); else line++; + } else if (c == VT) { + column = 0; Scroll = 0; line = LastLine - 2; + } else if (c == BEEP) tone(0, 440, 125); // Beep + // Show cursor + PlotChar(Cursor, line, column); + #endif +} + +// Keyboard ********************************************************************************** + +void initkybd () { +#ifdef ULISP_I2C1 + Wire1.setSDA(6); + Wire1.setSCL(7); + Wire1.begin(); + Wire1.setClock(10000); + pc_kbd.begin(0x1f,&Wire1); + #else + Wire.setSDA(4); + Wire.setSCL(5); + Wire.begin(); + Wire.setClock(10000); + pc_kbd.begin(); + #endif +} + + +// Parenthesis highlighting +void HighLight(int p, uint8_t invert) { + if (p) { + for (int n=0; n < p; n++) Display(8); + Display(17 + invert); + for (int n=1; n < p; n++) Display(9); + Display(19 + invert); + Display(9); + } +} +void ProcessKey (char c) { + static int parenthesis = 0; + if (c == 27) { setflag(ESCAPE); return; } // Escape key + // Undo previous parenthesis highlight + HighLight(parenthesis, 0); + parenthesis = 0; + // 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--; + Display(0x7F); + if (WritePtr) c = KybdBuf[WritePtr-1]; + } + } else if (WritePtr < KybdBufSize) { + KybdBuf[WritePtr++] = c; + Display(c); + } + // 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; + } + } + HighLight(parenthesis, 1); + } + return; +} + + + // Setup +/* + initenv - initialises the uLisp environment +*/ void initenv () { GlobalEnv = NULL; tee = bsymbol(TEE); } +/* + initgfx - initialises the graphics +*/ void initgfx () { #if defined(gfxsupport) #if defined(ARDUINO_PYBADGE_M4) || defined(ARDUINO_PYGAMER_M4) @@ -8001,31 +9832,61 @@ void initgfx () { tft.fillScreen(0); pinMode(34, OUTPUT); // Backlight digitalWrite(34, HIGH); - #elif defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_2) - tft.init(135, 240); - pinMode(TFT_I2C_POWER, OUTPUT); - digitalWrite(TFT_I2C_POWER, HIGH); - tft.setRotation(1); - tft.fillScreen(ST77XX_BLACK); - pinMode(TFT_BACKLIGHT, OUTPUT); - digitalWrite(TFT_BACKLIGHT, HIGH); + #elif defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_2) || defined(ARDUINO_RASPBERRY_PI_PICO_2W) + tft.init(); + #if defined(CPI_PICOCALC) + tft.setRotation(0); + tft.invertDisplay(1); + #endif + tft.fillScreen(TFT_BLACK); #endif #endif } void setup () { Serial.begin(9600); + #ifdef ULISP_SERIAL1 + seriell = &Serial1; + #else + seriell = &Serial; + #endif + + seriell->begin(BAUDRATE*100); + int start = millis(); - while ((millis() - start) < 5000) { if (Serial) break; } + + while ((millis() - start) < 5000) { + #ifdef ULISP_SERIAL1 + if (Serial1) break; + #else + if (Serial) break; + #endif + } + +#if defined(ARDUINO_RASPBERRY_PI_PICO) || defined(ARDUINO_RASPBERRY_PI_PICO_2W) +#if defined(sdcardsupport) && defined(CPI_PICOCALC) + // picocalc doesn't have touch screen + pinMode(SDCARD_SS_PIN,OUTPUT); + digitalWrite(SDCARD_SS_PIN,1); +#endif +#endif + + initworkspace(); initenv(); initsleep(); initgfx(); +#if defined(i2ckbd) + initkybd(); +#endif pfstring(PSTR("uLisp 4.7b "), pserial); pln(pserial); } // Read/Evaluate/Print loop +/* + repl - the Lisp Read/Evaluate/Print loop +*/ void repl (object *env) { for (;;) { randomSeed(micros()); @@ -8041,7 +9902,7 @@ void repl (object *env) { Context = NIL; object *line = read(gserial); #if defined(CPU_NRF52840) - Serial.flush(); + seriell->flush(); #endif // Break handling if (BreakLevel) { @@ -8068,6 +9929,9 @@ void repl (object *env) { } } +/* + loop - the Arduino IDE main execution loop +*/ void loop () { if (!setjmp(toplevel_handler)) { #if defined(resetautorun) @@ -8083,7 +9947,7 @@ void loop () { void ulisperror () { // Come here after error - delay(100); while (Serial.available()) Serial.read(); + delay(100); while (seriell->available()) seriell->read(); clrflag(NOESC); BreakLevel = 0; TraceStart = 0; TraceTop = 0; for (int i=0; i 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))); +} + +// 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)."; + +// Symbol lookup table +const tbl_entry_t lookup_table2[] 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]; +}