;;;-*- Mode: Lisp; Package: cl-user -*- (in-package :cl-user) ; Function definitions (defparameter *definitions* '((nil ;; Symbols ((NIL "nil" 0 0 #" /* nil A symbol equivalent to the empty list (). Also represents false. */"#) (TEE "t" 0 0 #" /* t A symbol representing true. */"#) (NOTHING nil 0 0 #" /* nothing A symbol with no value. It is useful if you want to suppress printing the result of evaluating a function. */"#) (OPTIONAL "&optional" 0 0 #" /* &optional Can be followed by one or more optional parameters in a lambda or defun parameter list. */"#) #-avr-nano (FEATURES "*features*" 0 0 #" /* *features* Returns a list of keywords representing features supported by this platform. */"#) #+arrays (INITIALELEMENT ":initial-element" 0 0 nil) #+arrays (ELEMENTTYPE ":element-type" 0 0 nil) #-avr-nano (TEST ":test" 0 0 nil) #-avr-nano (COLONA ":a" 0 0 nil) #-avr-nano (COLONB ":b" 0 0 nil) #-avr-nano (COLONC ":c" 0 0 nil) #+arrays (BIT nil 0 0 nil) (AMPREST "&rest" 0 0 #" /* &rest Can be followed by a parameter in a lambda or defun parameter list, and is assigned a list of the corresponding arguments. */"#) (LAMBDA nil 1 127 #" /* (lambda (parameter*) form*) Creates an unnamed function with parameters. The body is evaluated with the parameters as local variables whose initial values are defined by the values of the forms after the lambda form. */"#) (LET "let" 1 127 #" /* (let ((var value) ... ) forms*) Declares local variables with values, and evaluates the forms with those local variables. */"#) (LETSTAR "let*" 1 127 #" /* (let* ((var value) ... ) forms*) Declares local variables with values, and evaluates the forms with those local variables. Each declaration can refer to local variables that have been defined earlier in the let*. */"#) (CLOSURE nil 1 127 nil) #+avr (PSTAR "*p*" 0 127 nil) #-(or avr avr-nano) (PSTAR "*pc*" 0 127 nil)) "sy") ("Special forms" ((QUOTE nil 1 1 " object *sp_quote (object *args, object *env) { (void) env; return first(args); }") (OR nil 0 127 " /* (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; }") #+ignore (LAMBDA nil 0 127 " object *sp_lambda (object *args, object *env) { return cons(symbol(CLOSURE), (cons(env,args))); }") (DEFUN nil 2 127 #" /* (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 nil 1 3 #" /* (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 nil 2 126 #" /* (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; }"#) #-esp (LOOP nil 0 127 " /* (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(); } }") #+esp (LOOP nil 0 127 " /* (loop forms*) Executes its arguments repeatedly until one of the arguments calls (return), which then causes an exit from the loop. */ object *sp_loop (object *args, object *env) { object *start = args; for (;;) { yield(); args = start; while (args != NULL) { object *result = eval(car(args),env); if (tstflag(RETURNFLAG)) { clrflag(RETURNFLAG); return result; } args = cdr(args); } testescape(); } }") #+avr-nano (PUSH nil 2 2 " /* (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) { object *item = eval(first(args), env); object **loc = place(second(args), env); push(item, *loc); return *loc; }") #-avr-nano (PUSH nil 2 2 " /* (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; }") #+avr-nano (POP nil 1 1 " /* (pop place) Modifies the value of place, which should be a non-nil list, to remove its first item, and returns that item. */ object *sp_pop (object *args, object *env) { object *arg = first(args); if (arg == NULL) error2(invalidarg); object **loc = place(arg, env); if (!consp(*loc)) error(notalist, *loc); object *result = car(*loc); pop(*loc); return result; }") #-avr-nano (POP nil 1 1 " /* (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; }")) "sp") ("Accessors" ( #-float (INCF nil 1 2 #" /* (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) { return incfdecf(args, 1, env); }"#) #+float (INCF nil 1 2 #" /* (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(PSTR("result is not a bit value")); *loc = number((((*loc)->integer) & ~(1<integer; if (inc == NULL) increment = 1; else increment = inc->integer; if (increment < 1) { if (INT_MIN - increment > value) *loc = makefloat((float)value + (float)increment); else *loc = number(value + increment); } else { if (INT_MAX - increment < value) *loc = makefloat((float)value + (float)increment); else *loc = number(value + increment); } } else error2(notanumber); return *loc; }"#) #-float (DECF nil 1 2 #" /* (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) { return incfdecf(args, -1, env); }"#) #+float (DECF nil 1 2 #" /* (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(PSTR("result is not a bit value")); *loc = number((((*loc)->integer) & ~(1<integer; if (dec == NULL) decrement = 1; else decrement = dec->integer; if (decrement < 1) { if (INT_MAX + decrement < value) *loc = makefloat((float)value - (float)decrement); else *loc = number(value - decrement); } else { if (INT_MIN + decrement > value) *loc = makefloat((float)value - (float)decrement); else *loc = number(value - decrement); } } else error2(notanumber); return *loc; }"#) #+avr-nano (SETF nil 2 126 #" /* (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) { builtin_t setf = Context; object *arg = nil; while (args != NULL) { if (cdr(args) == NULL) { Context = setf; error2(oddargs); } object **loc = place(first(args), env); arg = eval(second(args), env); *loc = arg; args = cddr(args); } return arg; }"#) #-avr-nano (SETF nil 2 126 #" /* (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 nil 0 1 #" /* (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; }"#) (FORMILLIS "for-millis" 1 127 " /* (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 nil 1 1 #" /* (time form) Prints the value returned by the form, and the time taken to evaluate the form in milliseconds or seconds. */ object *sp_time (object *args, object *env) { unsigned long start = millis(); object *result = eval(first(args), env); unsigned long elapsed = millis() - start; printobject(result, pserial); pfstring(PSTR("\nTime: "), pserial); if (elapsed < 1000) { pint(elapsed, pserial); pfstring(PSTR(" ms\n"), pserial); } else { elapsed = elapsed+50; pint(elapsed/1000, pserial); pserial('.'); pint((elapsed/100)%10, pserial); pfstring(PSTR(" s\n"), pserial); } return bsymbol(NOTHING); }"#) (WITHOUTPUTTOSTRING "with-output-to-string" 1 127 " /* (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; }") (WITHSERIAL "with-serial" 1 127 " /* (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; }") #-(or arm esp) (WITHI2C "with-i2c" 1 127 " /* (with-i2c (str [port] address [read-p]) form*) Evaluates the forms with str bound to an i2c-stream defined by address. If read-p is nil or omitted the stream is written to, otherwise it specifies the number of bytes to be read from the stream. The port if specified is ignored. */ object *sp_withi2c (object *args, object *env) { object *params = checkarguments(args, 2, 4); object *var = first(params); int address = checkinteger(eval(second(params), env)); params = cddr(params); if (address == 0 && params != NULL) params = cdr(params); // Ignore port int read = 0; // Write I2Ccount = 0; if (params != NULL) { object *rw = eval(first(params), env); if (integerp(rw)) I2Ccount = rw->integer; read = (rw != NULL); } I2Cinit(1); // Pullups object *pair = cons(var, (I2Cstart(address, read)) ? stream(I2CSTREAM, address) : nil); push(pair,env); object *forms = cdr(args); object *result = eval(tf_progn(forms,env), env); I2Cstop(read); return result; }") #+(or arm esp) (WITHI2C "with-i2c" 1 127 " /* (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; }") #+(or avr avr-nano esp) (WITHSPI "with-spi" 1 127 #" /* (with-spi (str pin [clock] [bitorder] [mode]) form*) Evaluates the forms with str bound to an spi-stream. The parameters specify the enable pin, clock in kHz (default 4000), bitorder 0 for LSBFIRST and 1 for MSBFIRST (default 1), and SPI mode (default 0). */ object *sp_withspi (object *args, object *env) { object *params = 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; // Defaults int bitorder = MSBFIRST; if (params != NULL) { clock = checkinteger(eval(car(params), env)); params = cdr(params); if (params != NULL) { bitorder = (checkinteger(eval(car(params), env)) == 0) ? LSBFIRST : MSBFIRST; params = cdr(params); if (params != NULL) { int modeval = checkinteger(eval(car(params), env)); mode = (modeval == 3) ? SPI_MODE3 : (modeval == 2) ? SPI_MODE2 : (modeval == 1) ? SPI_MODE1 : SPI_MODE0; } } } object *pair = cons(var, stream(SPISTREAM, pin)); push(pair,env); SPI.begin(); SPI.beginTransaction(SPISettings(((unsigned long)clock * 1000), bitorder, mode)); digitalWrite(pin, LOW); object *forms = cdr(args); object *result = eval(tf_progn(forms,env), env); digitalWrite(pin, HIGH); SPI.endTransaction(); return result; }"#) #+arm (WITHSPI "with-spi" 1 127 #" /* (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; }"#) #+riscv (WITHSPI "with-spi" 1 127 #" /* (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; (*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; }"#) #+arm (WITHSDCARD "with-sd-card" 2 127 #" /* (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(PSTR("no filename specified")); builtin_t temp = Context; object *filename = eval(first(params), env); Context = temp; if (!stringp(filename)) error(PSTR("filename is not a string"), filename); params = cdr(params); 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(PSTR("problem writing to SD card or invalid filename")); } else { char buffer[BUFFERSIZE]; SDgfile = SD.open(MakeFilename(filename, buffer), oflag); if (!SDgfile) error2(PSTR("problem reading from SD card or invalid filename")); } object *pair = cons(var, stream(SDSTREAM, 1)); push(pair,env); object *forms = cdr(args); object *result = eval(tf_progn(forms,env), env); if (mode >= 1) SDpfile.close(); else SDgfile.close(); return result; #else (void) args, (void) env; error2(PSTR("not supported")); return nil; #endif }"#) #+esp (WITHSDCARD "with-sd-card" 2 127 #" /* (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(PSTR("no filename specified")); builtin_t temp = Context; object *filename = eval(first(params), env); Context = temp; if (!stringp(filename)) error(PSTR("filename is not a string"), filename); params = cdr(params); SDBegin(); int mode = 0; if (params != NULL && first(params) != NULL) mode = checkinteger(first(params)); const char *oflag = FILE_READ; if (mode == 1) oflag = FILE_APPEND; else if (mode == 2) oflag = FILE_WRITE; if (mode >= 1) { char buffer[BUFFERSIZE]; SDpfile = SD.open(MakeFilename(filename, buffer), oflag); if (!SDpfile) error2(PSTR("problem writing to SD card or invalid filename")); } else { char buffer[BUFFERSIZE]; SDgfile = SD.open(MakeFilename(filename, buffer), oflag); if (!SDgfile) error2(PSTR("problem reading from SD card or invalid filename")); } object *pair = cons(var, stream(SDSTREAM, 1)); push(pair,env); object *forms = cdr(args); object *result = eval(tf_progn(forms,env), env); if (mode >= 1) SDpfile.close(); else SDgfile.close(); return result; #else (void) args, (void) env; error2(PSTR("not supported")); return nil; #endif }"#) #+(or avr avr-nano) (WITHSDCARD "with-sd-card" 2 127 #" /* (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(PSTR("no filename specified")); builtin_t temp = Context; object *filename = eval(first(params), env); Context = temp; if (!stringp(filename)) error(PSTR("filename is not a string"), filename); params = cdr(params); SD.begin(SDCARD_SS_PIN); 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(PSTR("problem writing to SD card or invalid filename")); } else { char buffer[BUFFERSIZE]; SDgfile = SD.open(MakeFilename(filename, buffer), oflag); if (!SDgfile) error2(PSTR("problem reading from SD card or invalid filename")); } object *pair = cons(var, stream(SDSTREAM, 1)); push(pair,env); object *forms = cdr(args); object *result = eval(tf_progn(forms,env), env); if (mode >= 1) SDpfile.close(); else SDgfile.close(); return result; #else (void) args, (void) env; error2(PSTR("not supported")); return nil; #endif }"#) #+riscv (WITHSDCARD "with-sd-card" 2 127 #" /* (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(PSTR("no filename specified")); builtin_t temp = Context; object *filename = eval(first(params), env); Context = temp; if (!stringp(filename)) error(PSTR("filename is not a string"), filename); params = cdr(params); if (!SD.begin(SS)) error2("problem initialising SD card"); 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(PSTR("problem writing to SD card or invalid filename")); } else { char buffer[BUFFERSIZE]; SDgfile = SD.open(MakeFilename(filename, buffer), oflag); if (!SDgfile) error2(PSTR("problem reading from SD card or invalid filename")); } object *pair = cons(var, stream(SDSTREAM, 1)); push(pair,env); object *forms = cdr(args); object *result = eval(tf_progn(forms,env), env); if (mode >= 1) SDpfile.close(); else SDgfile.close(); return result; #else (void) args, (void) env; error2(PSTR("not supported")); return nil; #endif }"#) #+msp430 (WITHLCD "with-lcd" 1 127 #" object *sp_withlcd (object *args, object *env) { #if defined(__MSP430FR6989__) myLCD.init(); object *params = first(args); object *var = first(params); object *pair = cons(var, stream(LCDSTREAM, 1)); push(pair,env); object *forms = cdr(args); object *result = eval(tf_progn(forms,env), env); return result; #else (void) args, (void) env; error(PSTR("with-lcd not supported")); return nil; #endif }"#)) "sp") #+(or avr arm stm32 riscv) ("Assembler" ( #+avr (DEFCODE nil 0 127 #" /* (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); if (!symbolp(var)) error(PSTR("not a symbol"), var); // Make *p* 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(PSTR("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<<8 | 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)<<8 | origin), args); object *pair = value(var->name, GlobalEnv); if (pair != NULL) cdr(pair) = val; else push(cons(var, val), GlobalEnv); #if defined(CPU_ATmega1284P) // Use Optiboot Flasher in MightyCore with 256 byte page from CODE_ADDRESS 0x1bb00 to 0x1bbff optiboot_page_erase(CODE_ADDRESS); for (unsigned int i=0; i 3) error(PSTR("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(PSTR("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(PSTR("not available")); return nil; #endif }"#) #+riscv (DEFCODE nil 0 127 #" /* (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) { setflag(NOESC); object *var = first(args); object *params = second(args); if (!symbolp(var)) error(PSTR("not a symbol"), var); // Make parameters into synonyms for registers a0, a1, etc int regn = 0; while (params != NULL) { if (regn > 3) error(PSTR("more than 4 parameters"), var); object *regpair = cons(car(params), bsymbol((builtin_t)((toradix40('a')*40+toradix40('0')+regn)*2560000))); // Symbol for a0 etc push(regpair,env); regn++; params = cdr(params); } // Make *pc* a local variable 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(PSTR("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; }"#)) "sp") ("Tail-recursive forms" ((PROGN nil 0 127 " /* (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 nil 2 3 #" /* (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 nil 0 127 #" /* (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 nil 1 127 #" /* (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 nil 1 127 #" /* (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 nil 1 127 #" /* (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 nil 0 127 " /* (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); }")) "tf") ("Core functions" ((NOT nil 1 1 " /* (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; }") (NULLFN "null" 1 1 (not)) (CONS nil 2 2 " /* (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 nil 1 1 " /* (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 nil 1 1 " /* (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 nil 1 1 " /* (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 nil 1 1 #" /* (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; }"#) #-avr-nano (ARRAYP nil 1 1 #" /* (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 nil 1 1 #" /* (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; }"#) #+avr-nano (KEYWORDP nil 1 1 #" /* (keywordp item) Returns t if its argument is a keyword. */ object *fn_keywordp (object *args, object *env) { (void) env; return keywordp(first(args)) ? tee : nil; }"#) #-avr-nano (KEYWORDP nil 1 1 #" /* (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; }"#) #-avr-nano (SETFN "set" 2 126 #" /* (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 nil 1 1 #" /* (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 nil 2 2 " /* (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 nil 2 2 " /* (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 nil 1 1 #" /* (car list) Returns the first item in a list. */ object *fn_car (object *args, object *env) { (void) env; return carx(first(args)); }"#) (FIRST nil 1 1 (car)) (CDR nil 1 1 #" /* (cdr list) Returns a list with the first item removed. */ object *fn_cdr (object *args, object *env) { (void) env; return cdrx(first(args)); }"#) (REST nil 1 1 (cdr)) (CAAR nil 1 1 #" /* (caar list) */ object *fn_caar (object *args, object *env) { (void) env; return cxxxr(args, 0b100); }"#) (CADR nil 1 1 #" /* (cadr list) */ object *fn_cadr (object *args, object *env) { (void) env; return cxxxr(args, 0b101); }"#) (SECOND nil 1 1 (cadr)) (CDAR nil 1 1 #" /* (cdar list) Equivalent to (cdr (car list)). */ object *fn_cdar (object *args, object *env) { (void) env; return cxxxr(args, 0b110); }"#) (CDDR nil 1 1 #" /* (cddr list) Equivalent to (cdr (cdr list)). */ object *fn_cddr (object *args, object *env) { (void) env; return cxxxr(args, 0b111); }"#) (CAAAR nil 1 1 #" /* (caaar list) Equivalent to (car (car (car list))). */ object *fn_caaar (object *args, object *env) { (void) env; return cxxxr(args, 0b1000); }"#) (CAADR nil 1 1 #" /* (caadr list) Equivalent to (car (car (cdar list))). */ object *fn_caadr (object *args, object *env) { (void) env; return cxxxr(args, 0b1001);; }"#) (CADAR nil 1 1 #" /* (cadar list) Equivalent to (car (cdr (car list))). */ object *fn_cadar (object *args, object *env) { (void) env; return cxxxr(args, 0b1010); }"#) (CADDR nil 1 1 #" /* (caddr list) Equivalent to (car (cdr (cdr list))). */ object *fn_caddr (object *args, object *env) { (void) env; return cxxxr(args, 0b1011); }"#) (THIRD nil 1 1 (caddr)) (CDAAR nil 1 1 #" /* (cdaar list) Equivalent to (cdar (car (car list))). */ object *fn_cdaar (object *args, object *env) { (void) env; return cxxxr(args, 0b1100); }"#) (CDADR nil 1 1 #" /* (cdadr list) Equivalent to (cdr (car (cdr list))). */ object *fn_cdadr (object *args, object *env) { (void) env; return cxxxr(args, 0b1101); }"#) (CDDAR nil 1 1 #" /* (cddar list) Equivalent to (cdr (cdr (car list))). */ object *fn_cddar (object *args, object *env) { (void) env; return cxxxr(args, 0b1110); }"#) (CDDDR nil 1 1 #" /* (cdddr list) Equivalent to (cdr (cdr (cdr list))). */ object *fn_cdddr (object *args, object *env) { (void) env; return cxxxr(args, 0b1111); }"#) #-arrays (LENGTH nil 1 1 #" /* (length item) Returns the number of items in a list, or the length of a string. */ object *fn_length (object *args, object *env) { (void) env; object *arg = first(args); if (listp(arg)) return number(listlength(arg)); if (!stringp(arg)) error(invalidarg, arg); return number(stringlength(arg)); }"#) #+arrays (LENGTH nil 1 1 #" /* (length item) Returns the number of items in a list, the length of a string, or the length of a one-dimensional array. */ object *fn_length (object *args, object *env) { (void) env; object *arg = first(args); if (listp(arg)) return number(listlength(arg)); if (stringp(arg)) return number(stringlength(arg)); if (!(arrayp(arg) && cdr(cddr(arg)) == NULL)) error(PSTR("argument is not a list, 1d array, or string"), arg); return number(abs(first(cddr(arg))->integer)); }"#) #+arrays (ARRAYDIMENSIONS "array-dimensions" 1 1 #" /* (array-dimensions item) Returns a list of the dimensions of an array. */ object *fn_arraydimensions (object *args, object *env) { (void) env; object *array = first(args); if (!arrayp(array)) error(PSTR("argument is not an array"), array); object *dimensions = cddr(array); return (first(dimensions)->integer < 0) ? cons(number(-(first(dimensions)->integer)), cdr(dimensions)) : dimensions; }"#) (LIST nil 0 127 " /* (list item*) Returns a list of the values of its arguments. */ object *fn_list (object *args, object *env) { (void) env; return args; }") #-avr-nano (COPYLIST "copy-list" 1 1 " /* (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 (arg != NULL) { cdr(ptr) = cons(car(arg), NULL); ptr = cdr(ptr); arg = cdr(arg); } return cdr(result); }") #+arrays (MAKEARRAY "make-array" 1 5 #" /* (make-array size [:initial-element element] [:element-type 'bit]) If size is an integer it creates a one-dimensional array with elements from 0 to size-1. If size is a list of n integers it creates an n-dimensional array with those dimensions. If :element-type 'bit is specified the array is a bit array. */ object *fn_makearray (object *args, object *env) { (void) env; object *def = nil; bool bitp = false; object *dims = first(args); if (dims == NULL) error2(PSTR("dimensions can't be nil")); else if (atom(dims)) dims = cons(dims, NULL); args = cdr(args); while (args != NULL && cdr(args) != NULL) { object *var = first(args); if (isbuiltin(first(args), INITIALELEMENT)) def = second(args); else if (isbuiltin(first(args), ELEMENTTYPE) && isbuiltin(second(args), BIT)) bitp = true; else error(PSTR("argument not recognised"), var); args = cddr(args); } if (bitp) { if (def == nil) def = number(0); else def = number(-checkbitvalue(def)); // 1 becomes all ones } return makearray(dims, def, bitp); }"#) (REVERSE nil 1 1 #" /* (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 nil 2 2 #" /* (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; }"#) #+arrays (AREF nil 2 127 #" /* (aref array index [index*]) Returns an element from the specified array. */ object *fn_aref (object *args, object *env) { (void) env; int bit; object *array = first(args); if (!arrayp(array)) error(PSTR("first argument is not an array"), array); object *loc = *getarray(array, cdr(args), 0, &bit); if (bit == -1) return loc; else return number((loc->integer)>>bit & 1); }"#) #+avr-nano (ASSOC nil 2 4 #" /* (assoc key list) Looks up a key in an association list of (key . value) pairs, and returns the matching pair, or nil if no pair is found. */ object *fn_assoc (object *args, object *env) { (void) env; object *key = first(args); object *list = second(args); while (list != NULL) { if (improperp(list)) error(notproper, list); object *pair = first(list); if (!listp(pair)) error(PSTR("element is not a list"), pair); if (pair != NULL && eq(key,car(pair))) return pair; list = cdr(list); } return nil; }"#) #-avr-nano (ASSOC nil 2 4 #" /* (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(PSTR("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; }"#) #+avr-nano (MEMBER nil 2 4 #" /* (member item list) Searches for an item in a list, using eq, and returns the list starting from the first occurrence of the item, or nil if it is not found. */ object *fn_member (object *args, object *env) { (void) env; object *item = first(args); object *list = second(args); while (list != NULL) { if (improperp(list)) error(notproper, list); if (eq(item,car(list))) return list; list = cdr(list); } return nil; }"#) #-avr-nano (MEMBER nil 2 4 #" /* (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 nil 2 127 #" /* (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 nil 1 127 " /* (funcall function argument*) Evaluates function with the specified arguments. */ object *fn_funcall (object *args, object *env) { return apply(first(args), cdr(args), env); }") (APPEND nil 0 127 #" /* (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; }"#) #+avr-nano (MAPC nil 2 127 #" /* (mapc function list1 [list]*) Applies the function to each element in one or more lists, ignoring the results. It returns the first list argument. */ object *fn_mapc (object *args, object *env) { object *function = first(args); args = cdr(args); object *result = first(args); push(result,GCStack); object *params = cons(NULL, NULL); push(params,GCStack); // Make parameters while (true) { object *tailp = params; object *lists = args; while (lists != NULL) { object *list = car(lists); if (list == NULL) { pop(GCStack); pop(GCStack); return result; } if (improperp(list)) error(notproper, list); object *obj = cons(first(list),NULL); car(lists) = cdr(list); cdr(tailp) = obj; tailp = obj; lists = cdr(lists); } apply(function, cdr(params), env); } }"#) #-avr-nano (MAPC nil 2 127 #" /* (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); }"#) #-avr-nano (MAPL nil 2 127 #" /* (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); }"#) #+avr-nano (MAPCAR nil 2 127 #" /* (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); }"#) #-avr-nano (MAPCAR nil 2 127 #" /* (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); }"#) #+avr-nano (MAPCAN nil 2 127 #" /* (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); }"#) #-avr-nano (MAPCAN nil 2 127 #" /* (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); }"#) #-avr-nano (MAPLIST nil 2 127 #" /* (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); }"#) #-avr-nano (MAPCON nil 2 127 #" /* (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" ( #-float (ADD "+" 0 127 #" /* (+ number*) Adds its arguments together. */ object *fn_add (object *args, object *env) { (void) env; int result = 0; while (args != NULL) { int temp = checkinteger(car(args)); #if defined(checkoverflow) if (temp < 1) { if (INT_MIN - temp > result) error2(overflow); } else { if (INT_MAX - temp < result) error2(overflow); } #endif result = result + temp; args = cdr(args); } return number(result); }"#) #+float (ADD "+" 0 127 #" /* (+ 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); }"#) #-float (SUBTRACT "-" 1 127 #" /* (- 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. */ object *fn_subtract (object *args, object *env) { (void) env; int result = checkinteger(car(args)); args = cdr(args); if (args == NULL) { #if defined(checkoverflow) if (result == INT_MIN) error2(overflow); #endif return number(-result); } while (args != NULL) { int temp = checkinteger(car(args)); #if defined(checkoverflow) if (temp < 1) { if (INT_MAX + temp < result) error2(overflow); } else { if (INT_MIN + temp > result) error2(overflow); } #endif result = result - temp; args = cdr(args); } return number(result); }"#) #+float (SUBTRACT "-" 1 127 #" /* (- 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; }"#) #-float (MULTIPLY "*" 0 127 #" /* (* number*) Multiplies its arguments together. */ object *fn_multiply (object *args, object *env) { (void) env; int result = 1; while (args != NULL){ #if defined(checkoverflow) signed long temp = (signed long) result * checkinteger(car(args)); if ((temp > INT_MAX) || (temp < INT_MIN)) error2(overflow); result = temp; #else result = result * checkinteger(car(args)); #endif args = cdr(args); } return number(result); }"#) #+float (MULTIPLY "*" 0 127 #" /* (* 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); }"#) #-float (DIVIDE "/" 2 127 #" /* (/ number*) Divides the first argument by the second and subsequent arguments. */ object *fn_divide (object *args, object *env) { (void) env; int result = checkinteger(first(args)); args = cdr(args); while (args != NULL) { int arg = checkinteger(car(args)); if (arg == 0) error2(divisionbyzero); #if defined(checkoverflow) if ((result == INT_MIN) && (arg == -1)) error2(overflow); #endif result = result / arg; args = cdr(args); } return number(result); }"#) #-float (TRUNCATE nil 1 2 (divide)) #+float (DIVIDE "/" 1 127 #" /* (/ 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; }"#) #+avr-nano (MOD nil 2 2 #" /* (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; int arg1 = checkinteger(first(args)); int arg2 = checkinteger(second(args)); if (arg2 == 0) error2(divisionbyzero); int r = arg1 % arg2; if ((arg1<0) != (arg2<0)) r = r + arg2; return number(r); }"#) #-avr-nano (MOD nil 2 2 #" /* (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); }"#) #-avr-nano (REM nil 2 2 #" /* (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); }"#) #-float (ONEPLUS "1+" 1 1 #" /* (1+ number) Adds one to its argument and returns it. */ object *fn_oneplus (object *args, object *env) { (void) env; int result = checkinteger(first(args)); #if defined(checkoverflow) if (result == INT_MAX) error2(overflow); #endif return number(result + 1); }"#) #+float (ONEPLUS "1+" 1 1 #" /* (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; }"#) #-float (ONEMINUS "1-" 1 1 #" /* (1- number) Subtracts one from its argument and returns it. */ object *fn_oneminus (object *args, object *env) { (void) env; int result = checkinteger(first(args)); #if defined(checkoverflow) if (result == INT_MIN) error2(overflow); #endif return number(result - 1); }"#) #+float (ONEMINUS "1-" 1 1 #" /* (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; }"#) #-float (ABS nil 1 1 #" /* (abs number) Returns the absolute, positive value of its argument. */ object *fn_abs (object *args, object *env) { (void) env; int result = checkinteger(first(args)); #if defined(checkoverflow) if (result == INT_MIN) error2(overflow); #endif return number(abs(result)); }"#) #+float (ABS nil 1 1 #" /* (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; }"#) #-float (RANDOM nil 1 1 #" /* (random number) Returns a random number between 0 and one less than its argument. */ object *fn_random (object *args, object *env) { (void) env; int arg = checkinteger(first(args)); return number(pseudoRandom(arg)); }"#) #+float (RANDOM nil 1 1 #" /* (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; }"#) #-float (MAXFN "max" 1 127 #" /* (max number*) Returns the maximum of one or more arguments. */ object *fn_maxfn (object *args, object *env) { (void) env; int result = checkinteger(first(args)); args = cdr(args); while (args != NULL) { int next = checkinteger(car(args)); if (next > result) result = next; args = cdr(args); } return number(result); }"#) #+float (MAXFN "max" 1 127 #" /* (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; }"#) #-float (MINFN "min" 1 127 #" /* (min number*) Returns the minimum of one or more arguments. */ object *fn_minfn (object *args, object *env) { (void) env; int result = checkinteger(first(args)); args = cdr(args); while (args != NULL) { int next = checkinteger(car(args)); if (next < result) result = next; args = cdr(args); } return number(result); }"#) #+float (MINFN "min" 1 127 #" /* (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" ( #-float (NOTEQ "/=" 1 127 #" /* (/= 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; int arg1 = checkinteger(first(nargs)); nargs = cdr(nargs); while (nargs != NULL) { int arg2 = checkinteger(first(nargs)); if (arg1 == arg2) return nil; nargs = cdr(nargs); } args = cdr(args); } return tee; }"#) #+float (NOTEQ "/=" 1 127 #" /* (/= 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; }"#) (NUMEQ "=" 1 127 #" /* (= 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); }"#) (LESS "<" 1 127 #" /* (< 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); }"#) (LESSEQ "<=" 1 127 #" /* (<= 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); }"#) (GREATER ">" 1 127 #" /* (> 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); }"#) (GREATEREQ ">=" 1 127 #" /* (>= 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); }"#) #-float (PLUSP nil 1 1 " /* (plusp number) Returns t if the argument is greater than zero, or nil otherwise. */ object *fn_plusp (object *args, object *env) { (void) env; int arg = checkinteger(first(args)); if (arg > 0) return tee; else return nil; }") #+float (PLUSP nil 1 1 " /* (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; }") #-float (MINUSP nil 1 1 " object *fn_minusp (object *args, object *env) { (void) env; int arg = checkinteger(first(args)); if (arg < 0) return tee; else return nil; }") #+float (MINUSP nil 1 1 " /* (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; }") #-float (ZEROP nil 1 1 " /* (zerop number) Returns t if the argument is zero. */ object *fn_zerop (object *args, object *env) { (void) env; int arg = checkinteger(first(args)); return (arg == 0) ? tee : nil; }") #+float (ZEROP nil 1 1 " /* (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 nil 1 1 " /* (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 nil 1 1 " /* (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 nil 1 1 #" /* (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; }"#) #-float (NUMBERP nil 1 1 (integerp)) #+float (NUMBERP nil 1 1 #" /* (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; }"#))) #+float ("Floating-point functions" ((FLOATFN "float" 1 1 #" /* (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 nil 1 1 #" /* (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 nil 1 1 float-function) (COS nil 1 1 float-function) (TAN nil 1 1 float-function) (ASIN nil 1 1 float-function) (ACOS nil 1 1 float-function) (ATAN nil 1 2 #" /* (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 nil 1 1 float-function) (COSH nil 1 1 float-function) (TANH nil 1 1 float-function) (EXP nil 1 1 float-function) (SQRT nil 1 1 float-function) (LOG nil 1 2 #" /* (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 nil 2 2 #" /* (expt number power) Returns number raised to the specified power. Returns the result as an integer if the arguments are integers and the result will be within range, otherwise a floating-point number. */ object *fn_expt (object *args, object *env) { (void) env; object *arg1 = first(args); object *arg2 = second(args); float float1 = checkintfloat(arg1); float value = log(abs(float1)) * checkintfloat(arg2); if (integerp(arg1) && integerp(arg2) && ((arg2->integer) >= 0) && (abs(value) < 21.4875)) return number(intpower(arg1->integer, arg2->integer)); if (float1 < 0) { if (integerp(arg2)) return makefloat((arg2->integer & 1) ? -exp(value) : exp(value)); else error2(PSTR("invalid result")); } return makefloat(exp(value)); }"#) (CEILING nil 1 2 truncate-function) (FLOOR nil 1 2 truncate-function) (TRUNCATE nil 1 2 #" /* (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 nil 1 2 #" /* (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 "char" 2 2 #" /* (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); }"#) (CHARCODE "char-code" 1 1 #" /* (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))); }"#) (CODECHAR "code-char" 1 1 #" /* (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 nil 1 1 #" /* (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 nil 1 1 " /* (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; }") #+avr-nano (STRINGEQ "string=" 2 2 #" /* (string= string string) Returns t if the two strings are the same, or nil otherwise. */ object *fn_stringeq (object *args, object *env) { (void) env; return stringcompare(args, false, false, true) ? tee : nil; }"#) #-avr-nano (STRINGEQ "string=" 2 2 #" /* (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; }"#) #+avr-nano (STRINGLESS "string<" 2 2 #" /* (string< string string) Returns t if the first string is alphabetically less than the second string, or nil otherwise. */ object *fn_stringless (object *args, object *env) { (void) env; return stringcompare(args, true, false, false) ? tee : nil; }"#) #-avr-nano (STRINGLESS "string<" 2 2 #" /* (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); }"#) #+avr-nano (STRINGGREATER "string>" 2 2 #" /* (string> string string) Returns t if the first string is alphabetically greater than the second string, or nil otherwise. */ object *fn_stringgreater (object *args, object *env) { (void) env; return stringcompare(args, false, true, false) ? tee : nil; }"#) #-avr-nano (STRINGGREATER "string>" 2 2 #" /* (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); }"#) #-avr-nano (STRINGNOTEQ "string/=" 2 2 #" /* (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); }"#) #-avr-nano (STRINGLESSEQ "string<=" 2 2 #" /* (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); }"#) #-avr-nano (STRINGGREATEREQ "string>=" 2 2 #" /* (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 "sort" 2 2 #" /* (sort list test) Destructively sorts list according to the test function, using an insertion sort, and returns the sorted list. */ object *fn_sort (object *args, object *env) { if (first(args) == NULL) return nil; object *list = cons(nil,first(args)); 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); }"#) (STRINGFN "string" 1 1 #" /* (string item) Converts its argument to a string. */ object *fn_stringfn (object *args, object *env) { return fn_princtostring(args, env); }"#) (CONCATENATE nil 1 127 #" /* (concatenate 'string string*) Joins together the strings given in the second and subsequent arguments, and returns a single string. */ object *fn_concatenate (object *args, object *env) { (void) env; object *arg = first(args); if (builtin(arg->name) != STRINGFN) error2(PSTR("only supports strings")); args = cdr(args); object *result = newstring(); object *tail = result; while (args != NULL) { object *obj = checkstring(first(args)); obj = cdr(obj); while (obj != NULL) { int quad = obj->chars; while (quad != 0) { char ch = quad>>((sizeof(int)-1)*8) & 0xFF; buildstring(ch, &tail); quad = quad<<8; } obj = car(obj); } args = cdr(args); } return result; }"#) (SUBSEQ nil 2 3 #" /* (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 nil 2 2 " /* (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 nil 1 1 " /* (eval form*) Evaluates its argument an extra time. */ object *fn_eval (object *args, object *env) { return eval(first(args), env); }") (RETURN nil 0 1 " /* (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 nil 0 0 " /* (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 nil 0 0 " /* (locals) Returns an association list of local variables and their values. */ object *fn_locals (object *args, object *env) { (void) args; return env; }") (MAKUNBOUND nil 1 1 #" /* (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 nil 0 0 #" /* (break) Inserts a breakpoint in the program. When evaluated prints Break! and reenters the REPL. */ object *fn_break (object *args, object *env) { (void) args; pfstring(PSTR("\nBreak!\n"), pserial); BreakLevel++; repl(env); BreakLevel--; return nil; }"#) (READ nil 0 1 " /* (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 nil 1 2 " /* (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 nil 1 2 " /* (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 nil 1 2 " /* (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 nil 0 1 " /* (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; }") (READBYTE "read-byte" 0 2 #" /* (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); }"#) (READLINE "read-line" 0 1 #" /* (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); }"#) (WRITEBYTE "write-byte" 1 2 #" /* (write-byte number [stream]) Writes a byte to a stream. */ object *fn_writebyte (object *args, object *env) { (void) env; int value = checkinteger(first(args)); pfun_t pfun = pstreamfun(cdr(args)); (pfun)(value); return nil; }"#) (WRITESTRING "write-string" 1 2 #" /* (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; }"#) (WRITELINE "write-line" 1 2 #" /* (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; }"#) #+(or arm esp) (RESTARTI2C "restart-i2c" 1 2 #" /* (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(PSTR("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; }"#) #-(or arm esp) (RESTARTI2C "restart-i2c" 1 2 #" /* (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(PSTR("not an i2c stream")); return I2Crestart(address, read) ? tee : nil; }"#) #+(or avr avr-nano) (GC nil 0 1 #" /* (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(PSTR("Space: "), pserial); pint(Freespace - initial, pserial); pfstring(PSTR(" bytes, Time: "), pserial); pint(elapsed, pserial); pfstring(PSTR(" us\n"), pserial); } else gc(args, env); return nil; }"#) #-(or avr avr-nano) (GC nil 0 1 #" /* (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 nil 0 0 #" /* (room) Returns the number of free Lisp cells remaining. */ object *fn_room (object *args, object *env) { (void) args, (void) env; return number(Freespace); }"#) #-avr-nano (BACKTRACE nil 0 1 #" /* (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); }"#) (SAVEIMAGE "save-image" 0 1 " /* (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)); }") (LOADIMAGE "load-image" 0 1 " /* (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)); }") #+ignore (DUMPIMAGE "dump-image" 0 0 #" object *fn_dumpimage(object *args, object *env) { (void) args, (void) env; int imagesize = workspacesize; // compactimage(NULL); char tmp[16]; Serial.println(); sprintf(tmp, "freelist: %04x, ", (int)freelist); Serial.print(tmp); sprintf(tmp, "GlobalEnv: %04x, ", (int)GlobalEnv); Serial.print(tmp); sprintf(tmp, "GCStack: %04x, ", (int)GCStack); Serial.print(tmp); for (int i=0; iinteger; 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; }") #+stm32 (PINMODE nil 2 2 " /* (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 = checkinteger(first(args)); int pm = INPUT; object *mode = second(args); if (integerp(mode)) { int nmode = checkinteger(mode); if (nmode == 1) pm = OUTPUT; else if (nmode == 2) pm = INPUT_PULLUP; #if defined(INPUT_PULLDOWN) else if (nmode == 4) pm = INPUT_PULLDOWN; #endif } else if (mode != nil) pm = OUTPUT; pinMode(pin, (WiringPinMode)pm); return nil; }") (DIGITALREAD nil 1 1 " /* (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 nil 2 2 " /* (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 nil 1 1 #" /* (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)); }"#) #+(or avr avr-nano) (ANALOGREFERENCE nil 1 1 #" /* (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); analogReference(checkkeyword(arg)); return arg; }"#) #+arm (ANALOGREFERENCE nil 1 1 #" /* (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_RASPBERRY_PI_PICO_2) || defined(ARDUINO_PIMORONI_PICO_PLUS_2) \ || defined(ARDUINO_PIMORONI_TINY2350) || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040) \ || defined(ARDUINO_ADAFRUIT_QTPY_RP2040) || defined(ARDUINO_NANO_MATTER) \ || defined(ARDUINO_ADAFRUIT_FEATHER_RP2040_ADALOGGER) error2("not supported"); #else analogReference((eAnalogReference)checkkeyword(arg)); #endif return arg; }"#) #+(or avr avr-nano) (ANALOGREADRESOLUTION nil 1 1 #" /* (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(CPU_AVR128DX48) uint8_t res = checkinteger(arg); if (res == 10) analogReadResolution(10); else if (res == 12) analogReadResolution(12); else error(PSTR("invalid resolution"), arg); #else error2(PSTR("not supported")); #endif return arg; }"#) #+arm (ANALOGREADRESOLUTION nil 1 1 #" /* (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; }"#) #+esp (ANALOGREADRESOLUTION nil 1 1 #" /* (analogreadresolution bits) Specifies the resolution for the analogue inputs on platforms that support it. The default resolution on all platforms is 10 bits. */ object *fn_analogreadresolution (object *args, object *env) { (void) env; object *arg = first(args); #if defined(ESP32) analogReadResolution(checkinteger(arg)); #else error2(PSTR("not supported")); #endif return arg; }"#) #+riscv (ANALOGREADRESOLUTION nil 1 1 #" /* (analogreadresolution bits) Specifies the resolution for the analogue inputs on platforms that support it. The default resolution on all platforms is 10 bits. */ object *fn_analogreadresolution (object *args, object *env) { (void) env; object *arg = first(args); analogReadResolution(checkinteger(arg)); return arg; }"#) (ANALOGWRITE nil 2 2 #" /* (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; }"#) #+(or arm riscv) (ANALOGWRITERESOLUTION nil 1 1 #" /* (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; }"#) #+(or avr avr-nano) (DACREFERENCE nil 1 1 #" /* (dacreference value) Sets the DAC voltage reference. AVR128DX48 only. */ object *fn_dacreference (object *args, object *env) { (void) env; object *arg = first(args); #if defined(CPU_AVR128DX48) int ref = checkinteger(arg); DACReference(ref); #endif return arg; }"#) (DELAY nil 1 1 " /* (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 nil 0 0 #" /* (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()); }"#) #+(or avr avr-nano) (SLEEP nil 0 1 #" /* (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; if (args == NULL || first(args) == NULL) { sleep(); return nil; } object *arg1 = first(args); doze(checkinteger(arg1)); return arg1; }"#) #-(or avr avr-nano) (SLEEP nil 0 1 #" /* (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; }"#) #+ignore (SHIFTOUT nil 4 4 " object *fn_shiftout (object *args, object *env) { (void) env; int datapin = integer(first(args)); int clockpin = integer(second(args)); int order = (third(args) != nil); object *value = fourth(args); shiftOut(datapin, clockpin, order, integer(value)); return value; }") #+ignore (SHIFTIN nil 3 3 " object *fn_shiftin (object *args, object *env) { (void) env; int datapin = integer(first(args)); int clockpin = integer(second(args)); int order = (third(args) != nil); int value = shiftIn(datapin, clockpin, order); return number(value); }") (NOTE nil 0 3 #" /* (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; }"#) #+(or avr avr-nano) (REGISTER nil 1 2 #" /* (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(*(volatile uint8_t *)addr); (*(volatile uint8_t *)addr) = checkinteger(second(args)); return second(args); }"#) #+(or arm esp riscv) (REGISTER nil 1 2 #" /* (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); }"#) #+interrupts (ATTACHINTERRUPT "attach-interrupt" 1 3 #" object *fn_attachinterrupt (object *args, object *env) { (void) env; object *number = first(args); if (number == NULL) { int n = NINTERRUPTS; args = cdr(args); delassoc(number,&Events); push(cons(number,first(args)),Events); InterruptCount[n] = 0; TCCR1A = 0; // CTC mode TCCR1B = 1<=NINTERRUPTS-1) error3(ATTACHINTERRUPT, PSTR("invalid interrupt")); args = cdr(args); delassoc(number,&Events); if (args == NULL || first(args) == NULL) { EIMSK &= ~(1<3) error3(ATTACHINTERRUPT, PSTR("invalid mode")); EIMSK |= 1< 4 else { n = n & 0x03; EICRB = (EICRB & ~(3<name) == LAMBDA) { superprint(cons(bsymbol(DEFUN), cons(var, cdr(val))), 0, pfun); #if defined(CODESIZE) } else if (consp(val) && car(val)->type == CODE) { superprint(cons(bsymbol(DEFCODE), cons(var, cdr(val))), 0, pfun); #endif } else { superprint(cons(bsymbol(DEFVAR), cons(var, cons(quote(val), NULL))), 0, pfun); } pln(pfun); testescape(); globals = cdr(globals); } return bsymbol(NOTHING); }"#) #+ignore (PPRINTALL nil 0 1 #" /* (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); 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)) && car(val)->name == LAMBDA) { superprint(cons(symbol(DEFUN), cons(var, cdr(val))), 0, pfun); } else if (consp(val) && car(val)->type == CODE) { superprint(cons(symbol(DEFCODE), cons(var, cdr(val))), 0, pfun); } else { superprint(cons(symbol(DEFVAR), cons(var, cons(quote(val), NULL))), 0, pfun); } pln(pfun); testescape(); globals = cdr(globals); } return symbol(NOTHING); }"#) #+esp (PPRINTALL nil 0 1 #" /* (pprintall [str]) Pretty-prints the definition of every function and variable defined in the uLisp workspace. If str is specified it prints to the specified stream. It returns no value. */ object *fn_pprintall (object *args, object *env) { (void) env; pfun_t pfun = pstreamfun(args); #if defined(gfxsupport) if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; #endif object *globals = GlobalEnv; while (globals != NULL) { object *pair = first(globals); object *var = car(pair); object *val = cdr(pair); pln(pfun); if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) { superprint(cons(bsymbol(DEFUN), cons(var, cdr(val))), 0, pfun); } else { superprint(cons(bsymbol(DEFVAR), cons(var, cons(quote(val), NULL))), 0, pfun); } pln(pfun); testescape(); globals = cdr(globals); } ppwidth = PPWIDTH; return bsymbol(NOTHING); }"#) #+(or riscv arm) (PPRINTALL nil 0 1 #" /* (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 nil 2 127 #" /* (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); uint8_t n = 0, width = 0, w, bra = 0; char pad = ' '; bool tilde = false, mute = false, comma = false, quote = false; while (n < len) { char ch = nthchar(formatstr, n); char ch2 = ch & ~0x20; // force to upper case if (tilde) { if (ch == '}') { if (save == NULL) formaterr(formatstr, PSTR("no matching ~{"), n); if (args == NULL) { args = cdr(save); save = NULL; } else n = bra; mute = false; tilde = false; } else if (!mute) { if (comma && quote) { pad = ch; comma = false, quote = false; } else if (ch == '\'') { if (comma) quote = true; else formaterr(formatstr, PSTR("quote not valid"), n); } else if (ch == '~') { pfun('~'); tilde = false; } else if (ch >= '0' && ch <= '9') width = width*10 + ch - '0'; else if (ch == ',') comma = true; else if (ch == '%') { pln(pfun); tilde = false; } else if (ch == '&') { pfl(pfun); tilde = false; } else if (ch == '^') { if (save != NULL && args == NULL) mute = true; tilde = false; } else if (ch == '{') { if (save != NULL) formaterr(formatstr, PSTR("can't nest ~{"), n); if (args == NULL) formaterr(formatstr, noargument, n); if (!listp(first(args))) formaterr(formatstr, notalist, n); save = args; args = first(args); bra = n; tilde = false; if (args == NULL) mute = true; } else if (ch2 == 'A' || ch2 == 'S' || ch2 == 'D' || ch2 == 'G' || ch2 == 'X' || ch2 == 'B') { if (args == NULL) formaterr(formatstr, noargument, n); object *arg = first(args); args = cdr(args); uint8_t aw = atomwidth(arg); if (width < aw) w = 0; else w = width-aw; tilde = false; if (ch2 == 'A') { prin1object(arg, pfun); indent(w, pad, pfun); } else if (ch2 == 'S') { printobject(arg, pfun); indent(w, pad, pfun); } else if (ch2 == 'D' || ch2 == 'G') { indent(w, pad, pfun); prin1object(arg, pfun); } else if (ch2 == 'X' || ch2 == 'B') { if (integerp(arg)) { uint8_t base = (ch2 == 'B') ? 2 : 16; uint8_t hw = basewidth(arg, base); if (width < hw) w = 0; else w = width-hw; indent(w, pad, pfun); pintbase(arg->integer, base, pfun); } else { indent(w, pad, pfun); prin1object(arg, pfun); } } tilde = false; } else formaterr(formatstr, PSTR("invalid directive"), n); } } else { if (ch == '~') { tilde = true; pad = ' '; width = 0; comma = false; quote = false; } else if (!mute) pfun(ch); } n++; } if (output == nil) return obj; else return nil; }"#))) ("LispLibrary" ( (REQUIRE nil 1 1 #" /* (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; }"#) (LISTLIBRARY "list-library" 0 0 #" /* (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); }"#))) #+doc ("Documentation" ((HELP "?" 1 1 #" /* (? 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); }"#)) "sp") #+doc (nil ((DOCUMENTATION nil 1 2 #" /* (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 nil 1 1 #" /* (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); }"#) (APROPOSLIST "apropos-list" 1 1 #" /* (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); }"#))) #+errors ("Error handling" ((UNWINDPROTECT "unwind-protect" 0 127 #" /* (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); }"#) (IGNOREERRORS "ignore-errors" 0 127 #" /* (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 nil 1 127 #" /* (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(PSTR("Error: "), pserial); printstring(message, pserial); Flags = temp; pln(pserial); } GCStack = NULL; longjmp(*handler, 1); }"#)) "sp") #+(or arm esp riscv avr) ("SD Card utilities" ( (DIRECTORY nil 0 0 #" /* (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 }"#))) #+wifi ("Wi-Fi" ( #+arm (WITHCLIENT "with-client" 1 127 #" /* (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(PSTR("invalid address")); if (!success) return nil; n = 1; } object *pair = cons(var, stream(WIFISTREAM, n)); push(pair,env); object *forms = cdr(args); object *result = eval(tf_progn(forms,env), env); client.stop(); return result; #else (void) args, (void) env; error2(PSTR("not supported")); return nil; #endif }"#) #+esp (WITHCLIENT "with-client" 1 127 #" /* (with-client (str [address port]) form*) Evaluates the forms with str bound to a wifi-stream. */ object *sp_withclient (object *args, object *env) { object *params = 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(PSTR("invalid address")); if (!success) return nil; n = 1; } object *pair = cons(var, stream(WIFISTREAM, n)); push(pair,env); object *forms = cdr(args); object *result = eval(tf_progn(forms,env), env); client.stop(); return result; }"#)) "sp") #+wifi (nil ( #+esp (AVAILABLE nil 1 1 #" /* (available stream) Returns the number of bytes available for reading from the wifi-stream, or zero if no bytes are available. */ object *fn_available (object *args, object *env) { (void) env; if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); return number(client.available()); }"#) #+arm (AVAILABLE nil 1 1 #" /* (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(PSTR("invalid stream")); return number(client.available()); #else (void) args, (void) env; error2(PSTR("not supported")); return nil; #endif }"#) #+esp (WIFISERVER "wifi-server" 0 0 #" /* (wifi-server) Starts a Wi-Fi server running. It returns nil. */ object *fn_wifiserver (object *args, object *env) { (void) args, (void) env; server.begin(); return nil; }"#) #+arm (WIFISERVER "wifi-server" 0 0 #" /* (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(PSTR("not supported")); return nil; #endif }"#) #+esp (WIFISOFTAP "wifi-softap" 0 4 #" /* (wifi-softap ssid [password channel hidden]) Set up a soft access point to establish a Wi-Fi network. Returns the IP address as a string or nil if unsuccessful. */ object *fn_wifisoftap (object *args, object *env) { (void) env; char ssid[33], pass[65]; if (args == NULL) return WiFi.softAPdisconnect(true) ? tee : nil; object *first = first(args); args = cdr(args); if (args == NULL) WiFi.softAP(cstring(first, ssid, 33)); else { object *second = first(args); args = cdr(args); int channel = 1; bool hidden = false; if (args != NULL) { channel = checkinteger(first(args)); args = cdr(args); if (args != NULL) hidden = (first(args) != nil); } WiFi.softAP(cstring(first, ssid, 33), cstring(second, pass, 65), channel, hidden); } return iptostring(WiFi.softAPIP()); }"#) #+arm (WIFISOFTAP "wifi-softap" 0 4 #" /* (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(PSTR("not supported")); return nil; #endif }"#) #+esp (CONNECTED nil 1 1 #" /* (connected stream) Returns t or nil to indicate if the client on stream is connected. */ object *fn_connected (object *args, object *env) { (void) env; if (isstream(first(args))>>8 != WIFISTREAM) error2(PSTR("invalid stream")); return client.connected() ? tee : nil; }"#) #+arm (CONNECTED nil 1 1 #" /* (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(PSTR("invalid stream")); return client.connected() ? tee : nil; #else (void) args, (void) env; error2(PSTR("not supported")); return nil; #endif }"#) #+esp (WIFILOCALIP "wifi-localip" 0 0 #" /* (wifi-localip) Returns the IP address of the local network as a string. */ object *fn_wifilocalip (object *args, object *env) { (void) args, (void) env; return iptostring(WiFi.localIP()); }"#) #+arm (WIFILOCALIP "wifi-localip" 0 0 #" /* (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(PSTR("not supported")); return nil; #endif }"#) #+riscv (WIFILOCALIP "wifi-localip" 0 0 #" /* (wifi-localip) Returns the IP address of the local network as a string. */ object *fn_wifilocalip (object *args, object *env) { (void) args, (void) env; return iptostring(WiFi.localIP()); }"#) #+esp (WIFICONNECT "wifi-connect" 0 3 #" /* (wifi-connect [ssid pass]) Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string. */ object *fn_wificonnect (object *args, object *env) { (void) env; char ssid[33], pass[65]; if (args == NULL) { WiFi.disconnect(true); return nil; } if (cdr(args) == NULL) WiFi.begin(cstring(first(args), ssid, 33)); else WiFi.begin(cstring(first(args), ssid, 33), cstring(second(args), pass, 65)); int result = WiFi.waitForConnectResult(); if (result == WL_CONNECTED) return iptostring(WiFi.localIP()); else if (result == WL_NO_SSID_AVAIL) error2(PSTR("network not found")); else if (result == WL_CONNECT_FAILED) error2(PSTR("connection failed")); else error2(PSTR("unable to connect")); return nil; }"#) #+arm (WIFICONNECT "wifi-connect" 0 3 #" /* (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(PSTR("network not found")); else if (result == WL_CONNECT_FAILED) error2(PSTR("connection failed")); else error2(PSTR("unable to connect")); return nil; #else (void) args, (void) env; error2(PSTR("not supported")); return nil; #endif }"#) #+riscv (WIFICONNECT "wifi-connect" 0 2 #" /* (wifi-connect [ssid pass]) Connects to the Wi-Fi network ssid using password pass. It returns the IP address as a string. */ object *fn_wificonnect (object *args, object *env) { (void) env; char ssid[33], pass[65]; int status = WL_IDLE_STATUS; // the Wifi radio's status // if (args == NULL) { WiFi.disconnect(true); return nil; } // if (cdr(args) == NULL) WiFi.begin(cstring(first(args), ssid, 33)); while ( status != WL_CONNECTED) { status = WiFi.begin(cstring(first(args), ssid, 33), cstring(second(args), pass, 65)); // int result = WiFi.waitForConnectResult(); } return nil; }"#))) #+gfx ("Graphics functions" ((WITHGFX "with-gfx" 1 127 #" /* (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(PSTR("not supported")); return nil; #endif }"#)) "sp" ) #+gfx (nil ((DRAWPIXEL "draw-pixel" 2 3 #" /* (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; }"#) (DRAWLINE "draw-line" 4 5 #" /* (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; }"#) (DRAWRECT "draw-rect" 4 5 #" /* (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; }"#) (FILLRECT "fill-rect" 4 5 #" /* (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; }"#) (DRAWCIRCLE "draw-circle" 3 4 #" /* (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; }"#) (FILLCIRCLE "fill-circle" 3 4 #" /* (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; }"#) (DRAWROUNDRECT "draw-round-rect" 5 6 #" /* (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; }"#) (FILLROUNDRECT "fill-round-rect" 5 6 #" /* (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; }"#) (DRAWTRIANGLE "draw-triangle" 6 7 #" /* (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; }"#) (FILLTRIANGLE "fill-triangle" 6 7 #" /* (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; }"#) (DRAWCHAR "draw-char" 3 6 #" /* (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; }"#) (SETCURSOR "set-cursor" 2 2 #" /* (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; }"#) (SETTEXTCOLOR "set-text-color" 1 2 #" /* (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; }"#) (SETTEXTSIZE "set-text-size" 1 1 #" /* (set-text-size scale) Scales text by the specified size, default 1. */ object *fn_settextsize (object *args, object *env) { (void) env; #if defined(gfxsupport) tft.setTextSize(checkinteger(first(args))); #else (void) args; #endif return nil; }"#) (SETTEXTWRAP "set-text-wrap" 1 1 #" /* (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; }"#) (FILLSCREEN "fill-screen" 0 1 #" /* (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; }"#) (SETROTATION "set-rotation" 1 1 #" /* (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; }"#) (INVERTDISPLAY "invert-display" 1 1 #" /* (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; }"#) #+ignore (GETPIXEL "get-pixel" 2 2 #" #if defined(gfxsupport) uint16_t Technoblogy_ST7735::getPixel (uint16_t x, uint16_t y) { uint32_t ret = 0; startWrite(); setAddrWindow(x, y, 1, 1); writeCommand(ST77XX_RAMRD); pinMode(TFT_MOSI, INPUT); pinMode(TFT_SCLK, OUTPUT); for (int i=0; i<33; i++) { digitalWrite(TFT_SCLK, HIGH); ret = ret<<1 | digitalRead(TFT_MOSI); digitalWrite(TFT_SCLK, LOW); } pinMode(TFT_MOSI, OUTPUT); endWrite(); return ((ret & 0xf80000)>>8 | (ret & 0xfc00)>>5 | (ret & 0xf8)>>3); } #endif object *fn_getpixel (object *args, object *env) { #if defined(gfxsupport) (void) env; return number(tft.getPixel(checkinteger(first(args)), checkinteger(second(args)))); #endif }"#) #+ignore (GETPIXEL "get-pixel" 2 2 #" object *fn_getpixel (object *args, object *env) { #if defined(gfxsupport) (void) args, (void) env; error2(PSTR("not supported")); #endif return nil; }"#) #+ignore (XORPIXEL "xor-pixel" 2 3 #" #if defined(gfxsupport) void Technoblogy_ST7735::xorPixel (uint16_t x, uint16_t y, uint16_t color) { uint16_t lastcolor = getPixel(x, y); if ((x >= 0) && (x < _width) && (y >= 0) && (y < _height)) { startWrite(); writeCommand(ST77XX_RAMWR); SPI_WRITE16(color ^ lastcolor); endWrite(); } } #endif object *fn_xorpixel (object *args, object *env) { #if defined(gfxsupport) (void) env; uint16_t colour = COLOR_WHITE; if (cddr(args) != NULL) colour = checkinteger(third(args)); tft.xorPixel(checkinteger(first(args)), checkinteger(second(args)), colour); #endif return nil; }"#) #+ignore (XORPIXEL "xor-pixel" 2 3 #" object *fn_xorpixel (object *args, object *env) { #if defined(gfxsupport) (void) args, (void) env; error2(PSTR("not supported")); #endif return nil; }"#) #+ignore (XORSPRITE "xor-sprite" 4 5 #" #if defined(gfxsupport) void Technoblogy_ST7735::xorSprite (uint16_t x, uint16_t y, uint32_t top, uint32_t bottom, uint16_t color) { uint16_t row[8]; uint32_t col = 0; bool bit; if ((x >= 0) && (x+7 < _width) && (y >= 0) && (y+7 < _height)) { for (int yd=0; yd<8; yd++) { startWrite(); setAddrWindow(x, y+yd, 8, 1); writeCommand(ST77XX_RAMRD); pinMode(TFT_MOSI, INPUT); pinMode(TFT_SCLK, OUTPUT); for (int i=0; i<9; i++) { digitalWrite(TFT_SCLK, HIGH); digitalWrite(TFT_SCLK, LOW); } for (int xd=0; xd<8; xd++) { for (int i=0; i<24; i++) { digitalWrite(TFT_SCLK, HIGH); col = col<<1 | digitalRead(TFT_MOSI); digitalWrite(TFT_SCLK, LOW); } row[xd] = ((col & 0xf80000)>>8 | (col & 0xfc00)>>5 | (col & 0xf8)>>3); } pinMode(TFT_MOSI, OUTPUT); endWrite(); startWrite(); writeCommand(ST77XX_RAMWR); for (int xd=0; xd<8; xd++) { if (yd < 4) bit = top>>(31 - xd - yd*8) & 1; else bit = bottom>>(31 - xd - (yd-4)*8) & 1; if (bit) SPI_WRITE16(row[xd] ^ color); else SPI_WRITE16(row[xd]); } endWrite(); } } } #endif object *fn_xorsprite (object *args, object *env) { #if defined(gfxsupport) (void) env; uint32_t params[4]; uint16_t 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.xorSprite(params[0], params[1], params[2], params[3], colour); #endif return nil; }"#) #+ignore (XORSPRITE "xor-sprite" 4 5 #" object *fn_xorsprite (object *args, object *env) { #if defined(gfxsupport) (void) args, (void) env; error2(PSTR("not supported")); #endif return nil; }"#))) #+ignore ("Graphics functions" ((DRAWPIXEL "draw-pixel" 2 3 #" /* (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) { #if defined(gfxsupport) (void) env; uint16_t colour = COLOR_WHITE; if (cddr(args) != NULL) colour = checkinteger(third(args)); tft.drawPixel(checkinteger(first(args)), checkinteger(second(args)), colour); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (DRAWLINE "draw-line" 4 5 #" /* (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) { #if defined(gfxsupport) (void) env; 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); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (DRAWRECT "draw-rect" 4 5 #" /* (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) { #if defined(gfxsupport) (void) env; 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); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (FILLRECT "fill-rect" 4 5 #" /* (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) { #if defined(gfxsupport) (void) env; 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); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (DRAWCIRCLE "draw-circle" 3 4 #" /* (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) { #if defined(gfxsupport) (void) env; 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); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (FILLCIRCLE "fill-circle" 3 4 #" /* (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) { #if defined(gfxsupport) (void) env; 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); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (DRAWROUNDRECT "draw-round-rect" 5 6 #" /* (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) { #if defined(gfxsupport) (void) env; 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); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (FILLROUNDRECT "fill-round-rect" 5 6 #" /* (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) { #if defined(gfxsupport) (void) env; 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); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (DRAWTRIANGLE "draw-triangle" 6 7 #" /* (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) { #if defined(gfxsupport) (void) env; 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); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (FILLTRIANGLE "fill-triangle" 6 7 #" /* (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) { #if defined(gfxsupport) (void) env; 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); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (DRAWCHAR "draw-char" 3 6 #" /* (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) { #if defined(gfxsupport) (void) env; 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(DRAWCHAR, third(args)), colour, bg, size); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (SETCURSOR "set-cursor" 2 2 #" /* (set-cursor x y) Sets the start point for text plotting to (x, y). */ object *fn_setcursor (object *args, object *env) { #if defined(gfxsupport) (void) env; tft.setCursor(checkinteger(first(args)), checkinteger(second(args))); #endif return nil; }"#) (SETTEXTCOLOR "set-text-color" 1 2 #" /* (set-text-color colour [background]) Sets the text colour for text plotted using (with-gfx ...). */ object *fn_settextcolor (object *args, object *env) { #if defined(gfxsupport) (void) env; if (cdr(args) != NULL) tft.setTextColor(checkinteger(first(args)), checkinteger(second(args))); else tft.setTextColor(checkinteger(first(args))); #else (void) args, (void) env; #endif return nil; }"#) (SETTEXTSIZE "set-text-size" 1 1 #" /* (set-text-size scale) Scales text by the specified size, default 1. */ object *fn_settextsize (object *args, object *env) { #if defined(gfxsupport) (void) env; tft.setTextSize(checkinteger(first(args))); #else (void) args, (void) env; #endif return nil; }"#) (SETTEXTWRAP "set-text-wrap" 1 1 #" /* (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) { #if defined(gfxsupport) (void) env; tft.setTextWrap(first(args) != NULL); #else (void) args, (void) env; #endif return nil; }"#) (FILLSCREEN "fill-screen" 0 1 #" /* (fill-screen [colour]) Fills or clears the screen with colour, default black. */ object *fn_fillscreen (object *args, object *env) { #if defined(gfxsupport) (void) env; uint16_t colour = COLOR_BLACK; if (args != NULL) colour = checkinteger(first(args)); tft.fillScreen(colour); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (SETROTATION "set-rotation" 1 1 #" /* (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) { #if defined(gfxsupport) (void) env; tft.setRotation(checkinteger(first(args))); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) (INVERTDISPLAY "invert-display" 1 1 #" /* (invert-display boolean) Mirror-images the display. */ object *fn_invertdisplay (object *args, object *env) { #if defined(gfxsupport) (void) env; tft.invertDisplay(first(args) != NULL); tft.display(); #else (void) args, (void) env; #endif return nil; }"#) #+ignore (GETPIXEL "get-pixel" 2 2 #" #if defined(gfxsupport) uint16_t Technoblogy_ST7735::getPixel (uint16_t x, uint16_t y) { uint32_t ret = 0; startWrite(); setAddrWindow(x, y, 1, 1); writeCommand(ST77XX_RAMRD); pinMode(TFT_MOSI, INPUT); pinMode(TFT_SCLK, OUTPUT); for (int i=0; i<33; i++) { digitalWrite(TFT_SCLK, HIGH); ret = ret<<1 | digitalRead(TFT_MOSI); digitalWrite(TFT_SCLK, LOW); } pinMode(TFT_MOSI, OUTPUT); endWrite(); return ((ret & 0xf80000)>>8 | (ret & 0xfc00)>>5 | (ret & 0xf8)>>3); } #endif object *fn_getpixel (object *args, object *env) { #if defined(gfxsupport) (void) env; return number(tft.getPixel(checkinteger(first(args)), checkinteger(second(args)))); #endif }"#) #+ignore (GETPIXEL "get-pixel" 2 2 #" object *fn_getpixel (object *args, object *env) { #if defined(gfxsupport) (void) args, (void) env; error2(PSTR("not supported")); return nil; #endif }"#) #+ignore (XORPIXEL "xor-pixel" 2 3 #" #if defined(gfxsupport) void Technoblogy_ST7735::xorPixel (uint16_t x, uint16_t y, uint16_t color) { uint16_t lastcolor = getPixel(x, y); if ((x >= 0) && (x < _width) && (y >= 0) && (y < _height)) { startWrite(); writeCommand(ST77XX_RAMWR); SPI_WRITE16(color ^ lastcolor); endWrite(); } } #endif object *fn_xorpixel (object *args, object *env) { #if defined(gfxsupport) (void) env; uint16_t colour = COLOR_WHITE; if (cddr(args) != NULL) colour = checkinteger(third(args)); tft.xorPixel(checkinteger(first(args)), checkinteger(second(args)), colour); #endif return nil; }"#) #+ignore (XORPIXEL "xor-pixel" 2 3 #" object *fn_xorpixel (object *args, object *env) { #if defined(gfxsupport) (void) args, (void) env; error2(PSTR("not supported")); return nil; #endif }"#) #+ignore (XORSPRITE "xor-sprite" 4 5 #" #if defined(gfxsupport) void Technoblogy_ST7735::xorSprite (uint16_t x, uint16_t y, uint32_t top, uint32_t bottom, uint16_t color) { uint16_t row[8]; uint32_t col = 0; bool bit; if ((x >= 0) && (x+7 < _width) && (y >= 0) && (y+7 < _height)) { for (int yd=0; yd<8; yd++) { startWrite(); setAddrWindow(x, y+yd, 8, 1); writeCommand(ST77XX_RAMRD); pinMode(TFT_MOSI, INPUT); pinMode(TFT_SCLK, OUTPUT); for (int i=0; i<9; i++) { digitalWrite(TFT_SCLK, HIGH); digitalWrite(TFT_SCLK, LOW); } for (int xd=0; xd<8; xd++) { for (int i=0; i<24; i++) { digitalWrite(TFT_SCLK, HIGH); col = col<<1 | digitalRead(TFT_MOSI); digitalWrite(TFT_SCLK, LOW); } row[xd] = ((col & 0xf80000)>>8 | (col & 0xfc00)>>5 | (col & 0xf8)>>3); } pinMode(TFT_MOSI, OUTPUT); endWrite(); startWrite(); writeCommand(ST77XX_RAMWR); for (int xd=0; xd<8; xd++) { if (yd < 4) bit = top>>(31 - xd - yd*8) & 1; else bit = bottom>>(31 - xd - (yd-4)*8) & 1; if (bit) SPI_WRITE16(row[xd] ^ color); else SPI_WRITE16(row[xd]); } endWrite(); } } } #endif object *fn_xorsprite (object *args, object *env) { #if defined(gfxsupport) (void) env; uint32_t params[4]; uint16_t 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.xorSprite(params[0], params[1], params[2], params[3], colour); return nil; #endif }"#) #+ignore (XORSPRITE "xor-sprite" 4 5 #" object *fn_xorsprite (object *args, object *env) { #if defined(gfxsupport) (void) args, (void) env; error2(PSTR("not supported")); #endif return nil; }"#))) #+badge ("Lisp Badge plotting" ((PLOT nil 0 6 #" void plotsub (uint8_t x, uint8_t y, uint8_t n, int ys[5]) { if (y<64) { uint8_t grey = 0x0F-n*3; uint8_t blob = grey; if ((x&1) == 0) { blob = grey<<4; ys[n] = y; } else { for (int i=0; i<5; i++) { if (y == ys[i]) blob = (0x0F-i*3)<<4 | grey; } } PlotByte(x>>1, y, blob); } } object *fn_plot (object *args, object *env) { int ys[5] = {-1, -1, -1, -1, -1}; int xaxis = -1, yaxis = -1; delay(20); ClearDisplay(0); // Clear display if (args != NULL && integerp(first(args))) { xaxis = checkinteger(first(args)); args = cdr(args); } if (args != NULL && integerp(first(args))) { yaxis = checkinteger(first(args)); args = cdr(args); } int nargs = min(listlength(args),4); for (int x=0; x<256; x++) { object *rest = args; for (int n=0; n>1, y, blob); } } } while (!tstflag(ESCAPE)); clrflag(ESCAPE); return symbol(NOTHING); }"#) (GLYPHPIXEL "glyph-pixel" 3 3 #" extern const uint8_t CharMap[96][6] PROGMEM; object *fn_glyphpixel (object *args, object *env) { (void) env; uint8_t c = 0, x = 6, y = 8; c = checkchar(GLYPHPIXEL, first(args)); x = checkinteger(second(args)); y = checkinteger(third(args)); if (x > 5 || y > 7) return number(0); return pgm_read_byte(&CharMap[(c & 0x7f) - 32][x]) & 1 << (7 - y) ? number(15) : number(0); }"#) (PLOTPIXEL "plot-pixel" 2 3 #" object *fn_plotpixel (object *args, object *env) { (void) env; int x = checkinteger(first(args)); int y = checkinteger(second(args)); args = cddr(args); uint8_t grey = 0xff; if (args != NULL) grey = checkinteger(first(args)); PlotByte(x, y, grey); return nil; }"#) (FILLSCREEN "fill-screen" 0 1 #" object *fn_fillscreen (object *args, object *env) { (void) env; uint8_t grey = 0; if (args != NULL) grey = checkinteger(first(args)); ClearDisplay(grey); return nil; }"#))) ))