diff --git a/.gitignore b/.gitignore index 0b1d7f1..fedd24f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ build *.uf2 +*.patch diff --git a/LispLibrary.h b/LispLibrary.h index b23d6f7..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,31 +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)) -(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 #x68) - (write-byte 0 str) - (write-byte 0 str) - (write-byte min str) - (write-byte hr str))) -(defun rtc-get () - (with-i2c (str #x68) - (write-byte 0 str) - (restart-i2c str 3) - (reverse - (list - (read-byte str) - (read-byte str) - (read-byte str))))) +(defvar *packages* nil) -(defun rtc-now () - "(rtc-now) -Set the time using the RTC." - (now (rtc-get))) +(defun load-package (filename ) + (let* ((filename (concatenate 'string filename ".pkg")) + (forms (load filename))) + (setf *packages* + +(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/lisp/bels.lsp b/lisp/bels.lsp new file mode 100644 index 0000000..b5f7e60 --- /dev/null +++ b/lisp/bels.lsp @@ -0,0 +1,38 @@ +; +; Ringing the changes +; see http://www.ulisp.com/show?1G42 +; + +(defvar *bell-pin* 3) + +(defun fnd (x lst) + (cond + ((null lst) nil) + ((< x (car lst)) (car lst)) + (t (fnd x (cdr lst))))) + +(defun sub (new old lst) + (cond + ((null lst) nil) + ((eq old (car lst)) (cons new (cdr lst))) + (t (cons (car lst) (sub new old (cdr lst)))))) + +(defun nxt (lst) + (cond + ((not (apply > (cdr lst))) (cons (car lst) (nxt (cdr lst)))) + ((> (car lst) (cadr lst)) nil) + (t (let* ((rest (reverse (cdr lst))) + (old (fnd (car lst) rest))) + (cons old (sub (car lst) old rest)))))) + +(defun all (fun lst) + (when lst + (funcall fun lst) + (all fun (nxt lst)))) + +(defun bel (lis) + (mapc + (lambda (x) (note *bell-pin* x 4) (delay 500) (note) (delay 125)) + lis) + (delay 500)) + diff --git a/lisp/rtc.lsp b/lisp/rtc.lsp new file mode 100644 index 0000000..3f4d7a5 --- /dev/null +++ b/lisp/rtc.lsp @@ -0,0 +1,57 @@ +(defvar *rtc-port* 0) + +(defun bcd-to-dec (x) + "(bcd-to-dec x) +Convert the BCD-encoded number x to a decimal value." + (+ + (* 10 (ash x -4)) + (logand x #xf))) + +(defun dec-to-bcd (x) + "(dec-to-bcd x) +Converts the decimal value to a BCD-encoded number. +Number must be in the range 0 to 99." + (+ + (ash (floor x 10) 4) + (logand (rem x 10) #xf))) + +(defun rtc-p () + "(rtc-p) +Returns t if the RTC is connected." + (with-i2c (str *rtc-port* #x68) + (streamp str))) + +(defun rtc-set (h m s) + "(rtc-set hr min sec) +Set the time on a DS3231 RTC. Times are in BCD, so use +the appropriate reader macro, e.g. (rtc-set #x12 #x34 #x00) +for 12:34:00." + (let ((h (dec-to-bcd h)) + (m (dec-to-bcd m)) + (s (dec-to-bcd s))) + (with-i2c (str *rtc-port* #x68) + (write-byte 0 str) + (write-byte s str) + (write-byte m str) + (write-byte h str)))) + +(defun rtc-get () + (with-i2c (str *rtc-port* #x68) + (write-byte 0 str) + (restart-i2c str 3) + (mapcar bcd-to-dec + (reverse + (list + (read-byte str) + (read-byte str) + (read-byte str)))))) + +(defun rtc-now () + "(rtc-now) +Set the time using the RTC." + (apply now (rtc-get))) + +(defun now-rtc () + "(now-rtc) +Sets the RTC time using the now function." + (apply rtc-set (now))) diff --git a/lisp/sync.sh b/lisp/sync.sh new file mode 100755 index 0000000..dee2379 --- /dev/null +++ b/lisp/sync.sh @@ -0,0 +1,22 @@ +#!/bin/sh + +if [ "$(uname -s)" = "Linux" ] +then + DEFAULT_MOUNT="/media/kyle/ULISP" +else + DEFAULT_MOUNT="/Volumes/ULISP" +fi + +MEDIA="${1:-${DEFAULT_MOUNT}}" + +if [ ! -d "${MEDIA}" ] +then + echo "[!] ${MEDIA} isn't mounted!" + exit 1 +fi + +echo "[+] transferring lisp files to ${MEDIA}..." +cp *.lsp "$MEDIA" +echo "[+] unmounting ${MEDIA}" +umount "$MEDIA" +echo "[+] transfer complete" diff --git a/lisp/tools.lsp b/lisp/tools.lsp new file mode 100644 index 0000000..c5132f6 --- /dev/null +++ b/lisp/tools.lsp @@ -0,0 +1,30 @@ +(defun pprintf (sym str) + "(pprintf sym str) +Pretty-print the function pointed to by sym to +the stream, which follows the 'format directives." + (let ((form (eval sym))) + (format str "(defun ~a ~a~%~{ ~a~^~%~})" + (string sym) + (cadr form) + (cddr form)))) + +(defun copy-file (source dest) + (with-sd-card (writer dest 2) + (with-sd-card (reader source) + (loop + (let ((data (read-byte reader))) + (when (null data) + (return)) + (write-byte data writer)))))) + +(defun i2c-scan (port) + (dotimes (addr 127) + (with-i2c (str port addr) + (when str (print addr))))) + +(defun i2c-scan2 (port) + (dotimes (addr 127) + (with-i2c (str port addr) + (format t "~2,0'x: " addr) + (if str (print t) + (print nil))))) diff --git a/ulisp-arm.ino b/ulisp-arm.ino index 4b4b4e2..a30d512 100644 --- a/ulisp-arm.ino +++ b/ulisp-arm.ino @@ -10493,6 +10493,7 @@ void setup () { initkybd(); #endif pfstring(PSTR("uLisp 4.7b "), pserial); pln(pserial); + loadimage(NULL); } // Read/Evaluate/Print loop diff --git a/ulisp-extensions.ino b/ulisp-extensions.ino index 2da59f3..ee14925 100644 --- a/ulisp-extensions.ino +++ b/ulisp-extensions.ino @@ -2,6 +2,26 @@ User Extensions */ +// Utility functions +uint8_t +dec_to_bcd(uint8_t n) +{ + uint8_t bcd = 0; + uint8_t tens = n / 10; + + bcd = tens << 4; + tens *= 10; + bcd += (n - tens) & 0x0f; + return bcd; +} + + +uint8_t +bcd_to_dec(uint8_t n) +{ + return ((n>>4) * 10) + (n&0x0f); +} + // Definitions object * fn_now(object *args, object *env) @@ -29,17 +49,133 @@ 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) +{ + (void) env; + + if (consp(arg)) { + arg = car(arg); + } + + if (builtin(arg->name) == LAMBDA) { + return tee; + } + + return nil; +} + + // Symbol names -const char stringnow[] PROGMEM = "now"; +const char stringlambdap[] PROGMEM = "lambdap"; +const char stringnow[] PROGMEM = "now"; +const char string_sym_def[] PROGMEM = "symbol-def"; // Documentation strings + +const char doclambdap[] PROGMEM = "(lambdap x)" +"Returns t if the form passed in is a lambda."; + const char docnow[] PROGMEM = "(now [hh mm ss])\n" "Sets the current time, or with no arguments returns the current time\n" "as a list of three integers (hh mm ss)."; +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 }, + { string_sym_def, fn_sym_def, 0212, doc_sym_def }, }; // Table cross-reference functions