kyle
/
ulisp-picocalc
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

symbol-def #1

Merged
kyle merged 8 commits from kyle/pform into master 2025-04-07 21:41:44 +00:00
Conversation 0 Commits 8 Files Changed 8 +155 -91
2 changed files with 155 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files
Showing only changes of commit 3198c2ff6f - Show all commits

89
LispLibrary.h
View File

@ -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)
(let ((lst nil))
(loop
(let ((form (read str)))
(unless form (return))
(print (second form))
(eval form)))))
(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";

151
ulisp-extensions.ino
View File

@ -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