From 3198c2ff6f13f14f378a83b00d86b1ed86b35bef Mon Sep 17 00:00:00 2001 From: Kyle Isom Date: Mon, 7 Apr 2025 14:40:01 -0700 Subject: [PATCH] add symboldef and clean up lib --- LispLibrary.h | 95 ++++++++++++++++++--------- ulisp-extensions.ino | 151 ++++++++++++++++++++++++++----------------- 2 files changed, 155 insertions(+), 91 deletions(-) diff --git a/LispLibrary.h b/LispLibrary.h index bff5e2a..1e0aa33 100644 --- a/LispLibrary.h +++ b/LispLibrary.h @@ -13,11 +13,13 @@ Returns t if tst is true for every item in lst, or nil on the first false item." "(load filename) Open the Lisp file on the SD card and load the contents into the workspace." (with-sd-card (str filename) - (loop - (let ((form (read str))) - (unless form (return)) - (print (second form)) - (eval form))))) + (let ((lst nil)) + (loop + (let ((form (read str))) + (unless form (return)) + (setf lst (cons (quote (second form)) lst)) + (eval form))) + (reverse lst)))) (defun rgb (r g b) "(rgb r g b) @@ -172,33 +174,66 @@ Returns a list with all items for which tst is true removed from lst." Returns a list with all items for which tst is false removed from lst." (mapcan #'(lambda (x) (when (funcall tst x) (list x))) lst)) -(defvar *rtc-port* 1) -(defun rtc-set (hr min) - "(rtc-set hr min) -Set the time on a DS3231 RTC. Times are in BCD, so use -the appropriate reader macro, e.g. (rtc-set #x12 #x34) -for 12:34. Assumes seconds are zero." - (with-i2c (str *rtc-port* #x68) - (write-byte 0 str) - (write-byte 0 str) - (write-byte min str) - (write-byte hr str))) +(defvar *packages* nil) -(defun rtc-get () - (with-i2c (str *rtc-port* #x68) - (write-byte 0 str) - (restart-i2c str 3) - (reverse - (list - (read-byte str) - (read-byte str) - (read-byte str))))) +(defun load-package (filename ) + (let* ((filename (concatenate 'string filename ".pkg")) + (forms (load filename))) + (setf *packages* -(defun rtc-now () - "(rtc-now) -Set the time using the RTC." - (now (rtc-get))) +(defun save-package (filename lst) + (with-sd-card (str filename 2) + (dolist (f lst) + (symbol-def f str)))) + +(defun add-to-package (filename list) + (with-sd-card (str filename 1) + (dolist (f lst) + (symbol-def f str)))) + +(defun %edit (fun) + (cond + ((null *cmds*) fun) + ((eq (car *cmds*) #\b) (pop *cmds*) fun) + ((eq (car *cmds*) #\e) (pop *cmds*) (%edit (list fun))) + ((eq (car *cmds*) #\h) (pop *cmds*) (%edit (cons 'highlight (list fun)))) + ((consp (car *cmds*)) + (let ((val (cdar *cmds*))) + (case (caar *cmds*) + (#\r (pop *cmds*) (%edit val)) + ((#\c #\i) (pop *cmds*) (%edit (cons val fun))) + (#\f (cond + ((null fun) nil) + ((equal val fun) (pop *cmds*) (%edit fun)) + ((atom fun) fun) + (t (cons (%edit (car fun)) (%edit (cdr fun))))))))) + ((atom fun) (pop *cmds*) (%edit fun)) + ((eq (car *cmds*) #\d) (pop *cmds*) (%edit (cons (car fun) (%edit (cdr fun))))) + ((eq (car *cmds*) #\a) (pop *cmds*) (%edit (cons (%edit (car fun)) (cdr fun)))) + ((eq (car *cmds*) #\x) (pop *cmds*) (%edit (cdr fun))) + (t fun))) + +(defun edit (name) + (let ((fun (eval name)) + cc) + (setq *cmds* nil) + (loop + (write-byte 12) + (setq cc (append cc (list #\h))) + (setq *cmds* cc) + (pprint (%edit fun)) + (setq cc (butlast cc)) + (let ((c (get-key))) + (case c + (#\q (set name fun) (return name)) + (#\s (setq *cmds* cc) (set name (%edit fun)) (return name)) + (#\z (when cc (setq cc (butlast cc)))) + ((#\r #\c #\i #\f #\e) + (write-byte 11) (princ c) (princ #\:) + (setq cc (append cc (list (cons c (read)))))) + ((#\d #\a #\x #\b) + (setq cc (append cc (list c)))) + (t (write-byte 7))))))) )lisplibrary"; - diff --git a/ulisp-extensions.ino b/ulisp-extensions.ino index c3734b9..ee14925 100644 --- a/ulisp-extensions.ino +++ b/ulisp-extensions.ino @@ -49,6 +49,87 @@ fn_now(object *args, object *env) return cons(hours, cons(minutes, cons(seconds, NULL))); } + +void +hyperprint(object *form, int lm, pfun_t pfun) +{ + if (atom(form)) { + if (isbuiltin(form, NOTHING)) { + printsymbol(form, pfun); + } else { + printobject(form, pfun); + } + } else if (quoted(form)) { + pfun('\''); + hyperprint(car(cdr(form)), lm + 1, pfun); + } else { + lm = lm + PPINDENT; + bool fits = (subwidth(form, PPWIDTH - lm - PPINDENT) >= 0); + int special = 0, extra = 0; bool separate = true; + object *arg = car(form); + + if (symbolp(arg) && builtinp(arg->name)) { + uint8_t minmax = getminmax(builtin(arg->name)); + if (minmax == 0327 || minmax == 0313) { + special = 2; // defun, setq, setf, defvar + } else if (minmax == 0317 || minmax == 0017 || + minmax == 0117 || minmax == 0123) { + special = 1; + } + } + + while (form != NULL) { + if (atom(form)) { + pfstring(PSTR(" . "), pfun); + printobject(form, pfun); + pfun(')'); + return; + } else if (separate) { + pfun('('); + separate = false; + } else if (special) { + pfun(' '); + special--; + } else if (fits) { + pfun(' '); + } else { + pln(pfun); + indent(lm, ' ', pfun); + } + + hyperprint(car(form), lm+extra, pfun); + form = cdr(form); + } + pfun(')'); + } +} + +object * +fn_sym_def(object *args, object *env) +{ + (void) env; + + object *obj = first(args); + pfun_t pfun = pstreamfun(cdr(args)); +#if defined(gfxsupport) + if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; +#endif + object *pair = findvalue(obj, env); + object *var = car(pair); + object *val = cdr(pair); + pln(pfun); + + if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) { + hyperprint(cons(bsymbol(DEFUN), cons(var, cdr(val))), 0, pfun); + } else { + hyperprint(cons(bsymbol(DEFVAR), cons(var, cons(quote(val), NULL))), 0, pfun); + } + + pln(pfun); + ppwidth = PPWIDTH; + return bsymbol(NOTHING); +} + object * fn_lambdap(object *arg, object *env) { @@ -65,70 +146,11 @@ fn_lambdap(object *arg, object *env) return nil; } -object * -sp_pform(object *args, object *env) -{ - pfun_t pfun = pserial; - object *sym = car(args); - object *str = car(cdr(args)); - object *obj; - - if (!boundp(sym, env)) { - error2(PSTR("symbol isn't bound")); - } - - if (str == nil) { - obj = startstring(); - pfun = pstr; - } else if (!eq(str, tee)) { - pfun = pstreamfun(args); - } - -#if defined(gfxsupport) - if (pfun == gfxwrite) ppwidth = GFXPPWIDTH; -#endif - - pln(pfun); - - object *pair = eval(sym, env); - object *var = car(pair); - object *val = cdr(pair); - - if (consp(val)) { - pfstring(PSTR("consp val"), pfun); pln(pfun); - } - - if (var->name == LAMBDA) { - pfstring(PSTR("var->name == LAMBDA"), pfun); pln(pfun); - } - - if (builtin(val->name) == LAMBDA) { - pfstring(PSTR("builtin -> LAMBDA"), pfun); 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 if (consp(val) && var->name == LAMBDA) { - // superprint(cons(bsymbol(DEFUN), cons(sym, val)), 0, pfun); - // } else { - // superprint(cons(bsymbol(DEFVAR), cons(var, cons(quote(val), NULL))), 0, pfun); - // } - - pln(pfun); - ppwidth = PPWIDTH; - - if (str == nil) { - return obj; - } - return nil; -} // Symbol names const char stringlambdap[] PROGMEM = "lambdap"; const char stringnow[] PROGMEM = "now"; -const char stringpform[] PROGMEM = "pform"; +const char string_sym_def[] PROGMEM = "symbol-def"; // Documentation strings @@ -142,11 +164,18 @@ const char docnow[] PROGMEM = "(now [hh mm ss])\n" const char docpform[] PROGMEM = "(pform form str)\n" "Print a form to a stream in a manner suitable for writing to storage."; +const char doc_sym_def[] PROGMEM = "(symbol-def symbol [str])\n" +"Prints the definition of a symbol (variable or function) defined in\n" +"ulisp using the pretty printer." +"If str is specified it prints to the specified stream.\n" +"It returns no value."; + + // Symbol lookup table const tbl_entry_t lookup_table2[] PROGMEM = { { stringlambdap, fn_lambdap, 0211, doclambdap }, { stringnow, fn_now, 0203, docnow }, - { stringpform, sp_pform, 0322, docpform }, + { string_sym_def, fn_sym_def, 0212, doc_sym_def }, }; // Table cross-reference functions