From f281e198e5aed19782990b697208cd167bdf7fc3 Mon Sep 17 00:00:00 2001 From: Lars Rustand Date: Mon, 19 Feb 2024 19:26:27 +0100 Subject: [PATCH] Add macro support from dragoncoder047 --- ulisp-arm.ino | 231 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 222 insertions(+), 9 deletions(-) diff --git a/ulisp-arm.ino b/ulisp-arm.ino index c499c66..82e3991 100644 --- a/ulisp-arm.ino +++ b/ulisp-arm.ino @@ -9,8 +9,8 @@ // Compile options -#define resetautorun -#define printfreespace +// #define resetautorun +// #define printfreespace // #define printgcs // #define sdcardsupport // #define gfxsupport @@ -292,15 +292,27 @@ #define BUILTINS 0xF4240000 #define ENDFUNCTIONS 1536 +#define fntype(x) (((uint8_t)(x))>>6) +#define getminargs(x) ((((uint8_t)(x))>>3)&7) +#define getmaxargs(x) (((uint8_t)(x))&7) +#define unlimitedp(x) (getmaxargs(x)==UNLIMITED) +#define UNLIMITED 7 + +// let's hope the compiler can do constant folding!! +#define MINMAX(fntype, min, max) (((fntype)<<6)|((min)<<3)|(max)) + + // Code marker stores start and end of code block #define startblock(x) ((x->integer) & 0xFFFF) #define endblock(x) ((x->integer) >> 16 & 0xFFFF) // Constants +#define MAX_STACK 10000 +void* StackBottom; const int TRACEMAX = 3; // Number of traced functions enum type { ZZERO=0, SYMBOL=2, CODE=4, NUMBER=6, STREAM=8, CHARACTER=10, FLOAT=12, ARRAY=14, STRING=16, PAIR=18 }; // ARRAY STRING and PAIR must be last -enum token { UNUSED, BRA, KET, QUO, DOT }; +enum token { UNUSED, BRA, KET, QUO, DOT, BACKQUO, UNQUO, UNSPLICE }; enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM, SDSTREAM, WIFISTREAM, STRINGSTREAM, GFXSTREAM }; enum fntypes_t { OTHER_FORMS, TAIL_FORMS, FUNCTIONS, SPECIAL_FORMS }; @@ -352,9 +364,11 @@ typedef void (*pfun_t)(char); typedef uint16_t builtin_t; -enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, LET, LETSTAR, -CLOSURE, PSTAR, QUOTE, DEFUN, DEFVAR, DEFCODE, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, -DIGITALWRITE, ANALOGREAD, ANALOGREFERENCE, REGISTER, FORMAT, +enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, MACRO, LET, LETSTAR, +CLOSURE, PSTAR, QUOTE, +CONS, APPEND, BACKQUOTE, UNQUOTE, UNQUOTE_SPLICING, +DEFUN, DEFVAR, DEFMACRO, DEFCODE, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, +DIGITALWRITE, ANALOGREAD, ANALOGREFERENCE, REGISTER, FORMAT, }; // Global variables @@ -1976,6 +1990,7 @@ object *apply (object *function, object *args, object *env) { // In-place operations object **place (object *args, object *env, int *bit) { + PLACE: *bit = -1; if (atom(args)) return &cdr(findvalue(args, env)); object* function = first(args); @@ -2008,6 +2023,10 @@ object **place (object *args, object *env, int *bit) { return getarray(array, cddr(args), env, bit); } } + else if (is_macro_call(args, env)) { + function = eval(function, env); + goto PLACE; + } error2(PSTR("illegal place")); return nil; } @@ -5293,6 +5312,168 @@ object *fn_invertdisplay (object *args, object *env) { return nil; } +/* + quoteit - quote a symbol with the specified type of quote +*/ + +object* quoteit (builtin_t q, object* it) { + return cons(bsymbol(q), cons(it, nil)); +} + +// see https://github.com/kanaka/mal/blob/master/process/guide.md#step-7-quoting +// and https://github.com/kanaka/mal/issues/103#issuecomment-159047401 + +object* reverse (object* what) { + object* result = NULL; + for (; what != NULL; what = cdr(what)) { + push(car(what), result); + } + return result; +} + +object* process_backquote (object* arg, size_t level = 0) { + + // "If ast is a map or a symbol, return a list containing: the "quote" symbol, then ast." + if (arg == NULL || atom(arg)) + { + return quoteit(QUOTE, arg); + } + // "If ast is a list starting with the "unquote" symbol, return its second element." + if (listp(arg) && symbolp(first(arg))) { + switch (builtin(first(arg)->name)) { + case BACKQUOTE: return process_backquote(second(arg), level + 1); + case UNQUOTE: return level == 0 ? second(arg) : process_backquote(second(arg), level - 1); + default: break; + } + } + // "If ast is a list failing previous test, the result will be a list populated by the following process." + // "The result is initially an empty list. Iterate over each element elt of ast in reverse order:" + object* result = NULL; + object* rev_arg = reverse(arg); + for (; rev_arg != NULL; rev_arg = cdr(rev_arg)) { + object* element = car(rev_arg); + // "If elt is a list starting with the "splice-unquote" symbol, + // replace the current result with a list containing: the "concat" symbol, + // the second element of elt, then the previous result." + if (listp(element) && symbolp(first(element)) && builtin(first(element)->name) == UNQUOTE_SPLICING) { + object* x = second(element); + if (level > 0) x = process_backquote(x, level - 1); + result = cons(bsymbol(APPEND), cons(x, cons(result, nil))); + } + // "Else replace the current result with a list containing: + // the "cons" symbol, the result of calling quasiquote with + // elt as argument, then the previous result." + else result = cons(bsymbol(CONS), cons(process_backquote(element, level), cons(result, nil))); + } + return result; +} + +// "Add the quasiquote special form. This form does the same than quasiquoteexpand, +// but evaluates the result in the current environment before returning it, either by +// recursively calling EVAL with the result and env, or by assigning ast with the result +// and continuing execution at the top of the loop (TCO)." +object* tf_backquote (object* args, object* env) { + object* result = process_backquote(first(args)); + // Tail call + return result; +} + +object* bq_invalid (object* args, object* env) { + (void)args, (void)env; + error2(PSTR("not valid outside backquote")); + // unreachable + return NULL; +} + +bool is_macro_call (object* form, object* env) { + if (form == nil) return false; + CHECK: + if (symbolp(car(form))) { + object* pair = findpair(car(form), env); + if (pair == NULL) return false; + form = cons(cdr(pair), cdr(form)); + goto CHECK; + } + if (!consp(form)) return false; + object* lambda = first(form); + if (!consp(lambda)) return false; + return isbuiltin(first(lambda), MACRO); +} + +object* macroexpand1 (object* form, object* env, bool* done) { + if (!is_macro_call(form, env)) { + *done = true; + return form; + } + while (symbolp(car(form))) form = cons(cdr(findvalue(car(form), env)), cdr(form)); + push(form, GCStack); + form = closure(0, sym(NIL), car(form), cdr(form), &env); + object* result = eval(form, env); + pop(GCStack); + return result; +} + +object* fn_macroexpand1 (object* args, object* env) { + bool dummy; + return macroexpand1(first(args), env, &dummy); +} + +object* macroexpand (object* form, object* env) { + bool done = false; + push(form, GCStack); + while (!done) { + form = macroexpand1(form, env, &done); + car(GCStack) = form; + } + pop(GCStack); + return form; +} + +object* fn_macroexpand (object* args, object* env) { + return macroexpand(first(args), env); +} +/* + (defmacro name (parameters) form*) + Defines a syntactic macro. +*/ +object* sp_defmacro (object* args, object* env) { + (void) env; + object* var = first(args); + if (!symbolp(var)) error(notasymbol, var); + object* val = cons(bsymbol(MACRO), cdr(args)); + object* pair = value(var->name, GlobalEnv); + if (pair != NULL) cdr(pair) = val; + else push(cons(var, val), GlobalEnv); + return var; +} + +const char stringmacro[] PROGMEM = "macro"; +const char stringdefmacro[] PROGMEM = "defmacro"; +const char stringmacroexpand1[] PROGMEM = "macroexpand-1"; +const char stringmacroexpand[] PROGMEM = "macroexpand"; +const char stringbackquote[] PROGMEM = "backquote"; +const char stringunquote[] PROGMEM = "unquote"; +const char stringuqsplicing[] PROGMEM = "unquote-splicing"; +const char docbackquote[] PROGMEM = "(backquote form) or `form\n" +"Expands the unquotes present in the form as a syntactic template. Most commonly used in macros."; +const char docunquote[] PROGMEM = "(unquote form) or ,form\n" +"Marks a form to be evaluated and the value inserted when (backquote) expands the template."; +const char docunquotesplicing[] PROGMEM = "(unquote-splicing form) or ,@form\n" +"Marks a form to be evaluated and the value spliced in when (backquote) expands the template.\n" +"If the value returned when evaluating form is not a proper list (backquote) will bork very badly."; +const char docmacro[] PROGMEM = "(macro (parameter*) form*)\n" +"Creates an unnamed lambda-macro with parameters. The body is evaluated with the parameters as local variables\n" +"whose initial values are defined by the values of the forms after the macro form;\n" +"the resultant Lisp code returned is then evaluated again, this time in the scope of where the macro was called."; +const char docdefmacro[] PROGMEM = "(defmacro name (parameters) form*)\n" +"Defines a syntactic macro."; +const char docmacroexpand1[] PROGMEM = "(macroexpand-1 'form)\n" +"If the form represents a call to a macro, expands the macro once and returns the expanded code."; +const char docmacroexpand[] PROGMEM = "(macroexpand 'form)\n" +"Repeatedly applies (macroexpand-1) until the form no longer represents a call to a macro,\n" +"then returns the new form."; + + // Built-in symbol names const char string0[] PROGMEM = "nil"; const char string1[] PROGMEM = "t"; @@ -6229,13 +6410,20 @@ const tbl_entry_t lookup_table[] PROGMEM = { { string6, NULL, 0000, NULL }, { string7, NULL, 0000, doc7 }, { string8, NULL, 0017, doc8 }, + { stringmacro, NULL, 0017, docmacro }, { string9, NULL, 0017, doc9 }, { string10, NULL, 0017, doc10 }, { string11, NULL, 0017, NULL }, { string12, NULL, 0007, NULL }, { string13, sp_quote, 0311, NULL }, + { string59, fn_cons, 0222, doc59 }, + { string94, fn_append, 0207, doc94 }, + { stringbackquote, tf_backquote, 0111, docbackquote }, + { stringunquote, bq_invalid, 0311, docunquote }, + { stringuqsplicing, bq_invalid, 0311, docunquotesplicing }, { string14, sp_defun, 0327, doc14 }, { string15, sp_defvar, 0313, doc15 }, + { stringdefmacro, sp_defmacro, 0327, docdefmacro }, { string16, sp_defcode, 0307, doc16 }, { string17, fn_car, 0211, doc17 }, { string18, fn_car, 0211, NULL }, @@ -6279,7 +6467,6 @@ const tbl_entry_t lookup_table[] PROGMEM = { { string56, tf_and, 0107, doc56 }, { string57, fn_not, 0211, doc57 }, { string58, fn_not, 0211, NULL }, - { string59, fn_cons, 0222, doc59 }, { string60, fn_atom, 0211, doc60 }, { string61, fn_listp, 0211, doc61 }, { string62, fn_consp, 0211, doc62 }, @@ -6314,7 +6501,6 @@ const tbl_entry_t lookup_table[] PROGMEM = { { string91, fn_member, 0222, doc91 }, { string92, fn_apply, 0227, doc92 }, { string93, fn_funcall, 0217, doc93 }, - { string94, fn_append, 0207, doc94 }, { string95, fn_mapc, 0227, doc95 }, { string96, fn_mapcar, 0227, doc96 }, { string97, fn_mapcan, 0227, doc97 }, @@ -6616,6 +6802,9 @@ const tbl_entry_t lookup_table[] PROGMEM = { { string237, (fn_ptr_type)AR_INTERNAL, ANALOGREFERENCE, NULL }, { string238, (fn_ptr_type)AR_EXTERNAL, ANALOGREFERENCE, NULL }, #endif + { stringmacroexpand1, fn_macroexpand1, MINMAX(FUNCTIONS, 1, 1), docmacroexpand1 }, + { stringmacroexpand, fn_macroexpand, MINMAX(FUNCTIONS, 1, 1), docmacroexpand }, + }; #if !defined(extensions) @@ -6710,6 +6899,8 @@ object *eval (object *form, object *env) { // Escape if (tstflag(ESCAPE)) { clrflag(ESCAPE); error2(PSTR("escape!"));} if (!tstflag(NOESC)) testescape(); + // Stack overflow check + if (abs(static_cast(StackBottom) - &TC) > MAX_STACK) error(PSTR("C stack overflow"), form); if (form == NULL) return nil; @@ -6726,6 +6917,9 @@ object *eval (object *form, object *env) { error(PSTR("undefined"), form); } + // Expand macros + form = macroexpand(form, env); + #if defined(CODESIZE) if (form->type == CODE) error2(PSTR("can't evaluate CODE header")); #endif @@ -7243,6 +7437,16 @@ object *nextitem (gfun_t gfun) { if (ch == ')') return (object *)KET; if (ch == '(') return (object *)BRA; if (ch == '\'') return (object *)QUO; + if (ch == '`') return (object*)BACKQUO; + if (ch == '@') return (object*)UNSPLICE; // maintain compatibility with old Dave Astels code + if (ch == ',') { + ch = gfun(); + if (ch == '@') return (object *)UNSPLICE; + else { + LastChar = ch; + return (object *)UNQUO; + } + } // Parse string if (ch == '"') return readstring('"', true, gfun); @@ -7365,7 +7569,11 @@ object *readrest (gfun_t gfun) { item = readrest(gfun); } else if (item == (object *)QUO) { item = cons(bsymbol(QUOTE), cons(read(gfun), NULL)); - } else if (item == (object *)DOT) { + } + else if (item == (object*)BACKQUO) item = cons(bsymbol(BACKQUOTE), cons(read(gfun), NULL)); + else if (item == (object*)UNQUO) item = cons(bsymbol(UNQUOTE), cons(read(gfun), NULL)); + else if (item == (object*)UNSPLICE) item = cons(bsymbol(UNQUOTE_SPLICING), cons(read(gfun), NULL)); + else if (item == (object *)DOT) { tail->cdr = read(gfun); if (readrest(gfun) != NULL) error2(PSTR("malformed list")); return head; @@ -7386,6 +7594,9 @@ object *read (gfun_t gfun) { if (item == (object *)BRA) return readrest(gfun); if (item == (object *)DOT) return read(gfun); if (item == (object *)QUO) return cons(bsymbol(QUOTE), cons(read(gfun), NULL)); + if (item == (object*)BACKQUO) return cons(bsymbol(BACKQUOTE), cons(read(gfun), NULL)); + if (item == (object*)UNQUO) return cons(bsymbol(UNQUOTE), cons(read(gfun), NULL)); + if (item == (object*)UNSPLICE) return cons(bsymbol(UNQUOTE_SPLICING), cons(read(gfun), NULL)); return item; } @@ -7435,6 +7646,8 @@ void setup () { delay(2000); int start = millis(); while ((millis() - start) < 5000) { if (Serial) break; } + int foo = 0; + StackBottom = &foo; initworkspace(); initenv(); initsleep();