symbol-def (#1)

Started branch to add `pform`, ended up pulling in `symbol-def` from the forums. Also adds the editor code from the T-Deck.

Reviewed-on: kyle/ulisp-picocalc#1
Co-authored-by: Kyle Isom <kyle@imap.cc>
Co-committed-by: Kyle Isom <kyle@imap.cc>

.gitignore

@@ -1,2 +1,3 @@
 build
 *.uf2
+*.patch

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 ((lst nil))
-      (let ((form  (read str)))
+      (loop
-	(unless form (return))
+        (let ((form  (read str)))
-	(print (second form))
+           (unless form (return))
-	(eval form)))))
+           (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 ()
+(defvar *packages* nil)
-  (with-i2c (str #x68)
-    (write-byte 0 str)
-    (restart-i2c str 3)
-    (reverse
-      (list
-        (read-byte str)
-        (read-byte str)
-        (read-byte str)))))
 
-(defun rtc-now ()
+(defun load-package (filename )
- "(rtc-now)
+  (let* ((filename (concatenate 'string filename ".pkg"))
-Set the time using the RTC."
+	 (forms    (load filename)))
-  (now (rtc-get)))
+   (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";
-

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))
+

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

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"

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

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

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