altos/lisp: Character consts. String and assoc builtins.

Also add back escaped characters in strings.

Signed-off-by: Keith Packard <keithp@keithp.com>

5 files changed, 256 insertions, 80 deletions

diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c
index 2c5608e7..b2941d58 100644
--- a/src/lisp/ao_lisp_builtin.c
+++ b/src/lisp/ao_lisp_builtin.c
@@ -211,7 +211,7 @@ ao_poly
 ao_lisp_do_setq(struct ao_lisp_cons *cons)
 {
 	ao_poly	name;
-	if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2))
+	if (!ao_lisp_check_argc(_ao_lisp_atom_set21, cons, 2, 2))
 		return AO_LISP_NIL;
 	name = cons->car;
 	if (ao_lisp_poly_type(name) != AO_LISP_ATOM)
@@ -510,21 +510,21 @@ ao_lisp_do_greater_equal(struct ao_lisp_cons *cons)
 }
 
 ao_poly
-ao_lisp_do_pack(struct ao_lisp_cons *cons)
+ao_lisp_do_list_to_string(struct ao_lisp_cons *cons)
 {
-	if (!ao_lisp_check_argc(_ao_lisp_atom_pack, cons, 1, 1))
+	if (!ao_lisp_check_argc(_ao_lisp_atom_list2d3estring, cons, 1, 1))
 		return AO_LISP_NIL;
-	if (!ao_lisp_check_argt(_ao_lisp_atom_pack, cons, 0, AO_LISP_CONS, 1))
+	if (!ao_lisp_check_argt(_ao_lisp_atom_list2d3estring, cons, 0, AO_LISP_CONS, 1))
 		return AO_LISP_NIL;
 	return ao_lisp_string_pack(ao_lisp_poly_cons(ao_lisp_arg(cons, 0)));
 }
 
 ao_poly
-ao_lisp_do_unpack(struct ao_lisp_cons *cons)
+ao_lisp_do_string_to_list(struct ao_lisp_cons *cons)
 {
-	if (!ao_lisp_check_argc(_ao_lisp_atom_unpack, cons, 1, 1))
+	if (!ao_lisp_check_argc(_ao_lisp_atom_string2d3elist, cons, 1, 1))
 		return AO_LISP_NIL;
-	if (!ao_lisp_check_argt(_ao_lisp_atom_unpack, cons, 0, AO_LISP_STRING, 0))
+	if (!ao_lisp_check_argt(_ao_lisp_atom_string2d3elist, cons, 0, AO_LISP_STRING, 0))
 		return AO_LISP_NIL;
 	return ao_lisp_string_unpack(ao_lisp_poly_string(ao_lisp_arg(cons, 0)));
 }
@@ -612,52 +612,63 @@ ao_lisp_do_not(struct ao_lisp_cons *cons)
 		return _ao_lisp_bool_false;
 }
 
-ao_poly
-ao_lisp_do_listp(struct ao_lisp_cons *cons)
+static ao_poly
+ao_lisp_do_typep(int type, struct ao_lisp_cons *cons)
 {
-	ao_poly	v;
 	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 		return AO_LISP_NIL;
-	v = ao_lisp_arg(cons, 0);
-	for (;;) {
-		if (v == AO_LISP_NIL)
-			return _ao_lisp_bool_true;
-		if (ao_lisp_poly_type(v) != AO_LISP_CONS)
-			return _ao_lisp_bool_false;
-		v = ao_lisp_poly_cons(v)->cdr;
-	}
+	if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == type)
+		return _ao_lisp_bool_true;
+	return _ao_lisp_bool_false;
 }
 
 ao_poly
 ao_lisp_do_pairp(struct ao_lisp_cons *cons)
 {
-	ao_poly	v;
-	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
-		return AO_LISP_NIL;
-	v = ao_lisp_arg(cons, 0);
-	if (ao_lisp_poly_type(v) == AO_LISP_CONS)
-		return _ao_lisp_bool_true;
-	return _ao_lisp_bool_false;
+	return ao_lisp_do_typep(AO_LISP_CONS, cons);
 }
 
 ao_poly
 ao_lisp_do_numberp(struct ao_lisp_cons *cons)
 {
-	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
-		return AO_LISP_NIL;
-	if (AO_LISP_IS_INT(ao_lisp_arg(cons, 0)))
-		return _ao_lisp_bool_true;
-	return _ao_lisp_bool_false;
+	return ao_lisp_do_typep(AO_LISP_INT, cons);
+}
+
+ao_poly
+ao_lisp_do_stringp(struct ao_lisp_cons *cons)
+{
+	return ao_lisp_do_typep(AO_LISP_STRING, cons);
+}
+
+ao_poly
+ao_lisp_do_symbolp(struct ao_lisp_cons *cons)
+{
+	return ao_lisp_do_typep(AO_LISP_ATOM, cons);
 }
 
 ao_poly
 ao_lisp_do_booleanp(struct ao_lisp_cons *cons)
 {
+	return ao_lisp_do_typep(AO_LISP_BOOL, cons);
+}
+
+/* This one is special -- a list is either nil or
+ * a 'proper' list with only cons cells
+ */
+ao_poly
+ao_lisp_do_listp(struct ao_lisp_cons *cons)
+{
+	ao_poly	v;
 	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 		return AO_LISP_NIL;
-	if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == AO_LISP_BOOL)
-		return _ao_lisp_bool_true;
-	return _ao_lisp_bool_false;
+	v = ao_lisp_arg(cons, 0);
+	for (;;) {
+		if (v == AO_LISP_NIL)
+			return _ao_lisp_bool_true;
+		if (ao_lisp_poly_type(v) != AO_LISP_CONS)
+			return _ao_lisp_bool_false;
+		v = ao_lisp_poly_cons(v)->cdr;
+	}
 }
 
 ao_poly
@@ -680,5 +691,26 @@ ao_lisp_do_set_cdr(struct ao_lisp_cons *cons)
 	return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->cdr = ao_lisp_arg(cons, 1);
 }
 
+ao_poly
+ao_lisp_do_symbol_to_string(struct ao_lisp_cons *cons)
+{
+	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
+		return AO_LISP_NIL;
+	if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_ATOM, 0))
+		return AO_LISP_NIL;
+	return ao_lisp_string_poly(ao_lisp_string_copy(ao_lisp_poly_atom(ao_lisp_arg(cons, 0))->name));
+}
+
+ao_poly
+ao_lisp_do_string_to_symbol(struct ao_lisp_cons *cons)
+{
+	if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
+		return AO_LISP_NIL;
+	if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_STRING, 0))
+		return AO_LISP_NIL;
+
+	return ao_lisp_atom_poly(ao_lisp_atom_intern(ao_lisp_poly_string(ao_lisp_arg(cons, 0))));
+}
+
 #define AO_LISP_BUILTIN_FUNCS
 #include "ao_lisp_builtin.h"
diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt
index b27985ff..6cb4fdae 100644
--- a/src/lisp/ao_lisp_builtin.txt
+++ b/src/lisp/ao_lisp_builtin.txt
@@ -29,8 +29,8 @@ lexpr	less		<
 lexpr	greater		>
 lexpr	less_equal	<=
 lexpr	greater_equal	>=
-lambda	pack
-lambda	unpack
+lambda	list_to_string		list->string
+lambda	string_to_list		string->list
 lambda	flush
 lambda	delay
 lexpr	led
@@ -46,3 +46,7 @@ lambda	numberp		number?	integer?
 lambda	booleanp	boolean?
 lambda	set_car		set-car!
 lambda	set_cdr		set-cdr!
+lambda	symbolp		symbol?
+lambda	symbol_to_string	symbol->string
+lambda	string_to_symbol	string->symbol
+lambda	stringp		string?
diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp
index 3ba6aaf5..17509044 100644
--- a/src/lisp/ao_lisp_const.lisp
+++ b/src/lisp/ao_lisp_const.lisp
@@ -54,6 +54,8 @@
 					; basic list accessors
 
 
+(defun caar (l) (car (car l)))
+
 (defun cadr (l) (car (cdr l)))
 
 (defun caddr (l) (car (cdr (cdr l))))
@@ -336,6 +338,12 @@
       (list-tail (cdr x) (- k 1)))))
 
 (list-tail '(1 2 3) 2)
+
+(defun list-ref (x k) (car (list-tail x k)))
+
+(list-ref '(1 2 3) 2)
+
+    
 					; recursive equality
 
 (defun equal? (a b)
@@ -351,6 +359,108 @@
 (equal? '(a b c) '(a b c))
 (equal? '(a b c) '(a b b))
 
+(defun _member (obj list test?)
+  (if (null? list)
+      #f
+    (if (test? obj (car list))
+	list
+      (memq obj (cdr list)))))
+
+(defun memq (obj list) (_member obj list eq?))
+
+(memq 2 '(1 2 3))
+
+(memq 4 '(1 2 3))
+
+(defun memv (obj list) (_member obj list eqv?))
+
+(memv 2 '(1 2 3))
+
+(memv 4 '(1 2 3))
+
+(defun member (obj list) (_member obj list equal?))
+
+(member '(2) '((1) (2) (3)))
+
+(member '(4) '((1) (2) (3)))
+
+(defun _assoc (obj list test?)
+  (if (null? list)
+      #f
+    (if (test? obj (caar list))
+	(car list)
+      (_assoc obj (cdr list) test?)
+      )
+    )
+  )
+
+(defun assq (obj list) (_assoc obj list eq?))
+(defun assv (obj list) (_assoc obj list eqv?))
+(defun assoc (obj list) (_assoc obj list equal?))
+
+(assq 'a '((a 1) (b 2) (c 3)))
+(assv 'b '((a 1) (b 2) (c 3)))
+(assoc '(c) '((a 1) (b 2) ((c) 3)))
+
+(define char? integer?)
+
+(char? #\q)
+(char? "h")
+
+(defun char-upper-case? (c) (<= #\A c #\Z))
+
+(char-upper-case? #\a)
+(char-upper-case? #\B)
+(char-upper-case? #\0)
+(char-upper-case? #\space)
+
+(defun char-lower-case? (c) (<= #\a c #\a))
+
+(char-lower-case? #\a)
+(char-lower-case? #\B)
+(char-lower-case? #\0)
+(char-lower-case? #\space)
+
+(defun char-alphabetic? (c) (or (char-upper-case? c) (char-lower-case? c)))
+
+(char-alphabetic? #\a)
+(char-alphabetic? #\B)
+(char-alphabetic? #\0)
+(char-alphabetic? #\space)
+
+(defun char-numeric? (c) (<= #\0 c #\9))
+
+(char-numeric? #\a)
+(char-numeric? #\B)
+(char-numeric? #\0)
+(char-numeric? #\space)
+
+(defun char-whitespace? (c) (or (<= #\tab c #\return) (= #\space c)))
+
+(char-whitespace? #\a)
+(char-whitespace? #\B)
+(char-whitespace? #\0)
+(char-whitespace? #\space)
+
+(defun char->integer (c) c)
+(defun integer->char (c) char-integer)
+
+(defun char-upcase (c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
+
+(char-upcase #\a)
+(char-upcase #\B)
+(char-upcase #\0)
+(char-upcase #\space)
+
+(defun char-downcase (c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
+
+(char-downcase #\a)
+(char-downcase #\B)
+(char-downcase #\0)
+(char-downcase #\space)
+
+(define string (lexpr (chars) (list->string chars)))
+
 ;(define number->string (lexpr (arg opt)
 ;			      (let ((base (if (null? opt) 10 (car opt)))
 					;
diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c
index 508d16b4..bcd23ce1 100644
--- a/src/lisp/ao_lisp_read.c
+++ b/src/lisp/ao_lisp_read.c
@@ -142,7 +142,7 @@ static const uint16_t	lex_classes[128] = {
 	PRINTABLE,		/*  { */
 	PRINTABLE|VBAR,		/*  | */
 	PRINTABLE,		/*  } */
-	PRINTABLE|TWIDDLE,	/*  ~ */
+	PRINTABLE,		/*  ~ */
 	IGNORE,			/*  ^? */
 };
 
@@ -168,16 +168,38 @@ lex_unget(int c)
 		lex_unget_c = c;
 }
 
+static uint16_t	lex_class;
+
+static int
+lexc(void)
+{
+	int	c;
+	do {
+		c = lex_get();
+		if (c == EOF) {
+			c = 0;
+			lex_class = ENDOFFILE;
+		} else {
+			c &= 0x7f;
+			lex_class = lex_classes[c];
+		}
+	} while (lex_class & IGNORE);
+	return c;
+}
+
 static int
-lex_quoted (void)
+lex_quoted(void)
 {
 	int	c;
 	int	v;
 	int	count;
 
 	c = lex_get();
-	if (c == EOF)
-		return EOF;
+	if (c == EOF) {
+		lex_class = ENDOFFILE;
+		return 0;
+	}
+	lex_class = 0;
 	c &= 0x7f;
  	switch (c) {
 	case 'n':
@@ -220,32 +242,6 @@ lex_quoted (void)
 	}
 }
 
-static uint16_t	lex_class;
-
-static int
-lexc(void)
-{
-	int	c;
-	do {
-		c = lex_get();
-		if (c == EOF) {
-			lex_class = ENDOFFILE;
-			c = 0;
-		} else {
-			c &= 0x7f;
-			lex_class = lex_classes[c];
-			if (lex_class & BACKSLASH) {
-				c = lex_quoted();
-				if (c == EOF)
-					lex_class = ENDOFFILE;
-				else
-					lex_class = PRINTABLE;
-			}
-		}
-	} while (lex_class & IGNORE);
-	return c;
-}
-
 #define AO_LISP_TOKEN_MAX	32
 
 static char	token_string[AO_LISP_TOKEN_MAX];
@@ -299,25 +295,60 @@ _lex(void)
 				return DOT;
 			}
 		}
-		if (lex_class & TWIDDLE) {
-			token_int = lexc();
-			return NUM;
-		}
 		if (lex_class & POUND) {
-			for (;;) {
-				c = lexc();
+			c = lexc();
+			switch (c) {
+			case 't':
 				add_token(c);
-				switch (c) {
-				case 't':
-					return BOOL;
-				case 'f':
-					return BOOL;
+				end_token();
+				return BOOL;
+			case 'f':
+				add_token(c);
+				end_token();
+				return BOOL;
+			case '\\':
+				for (;;) {
+					int alphabetic;
+					c = lexc();
+					alphabetic = (('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z'));
+					if (token_len == 0) {
+						add_token(c);
+						if (!alphabetic)
+							break;
+					} else {
+						if (alphabetic)
+							add_token(c);
+						else {
+							lex_unget(c);
+							break;
+						}
+					}
+				}
+				end_token();
+				if (token_len == 1)
+					token_int = token_string[0];
+				else if (!strcmp(token_string, "space"))
+					token_int = ' ';
+				else if (!strcmp(token_string, "newline"))
+					token_int = '\n';
+				else if (!strcmp(token_string, "tab"))
+					token_int = '\t';
+				else if (!strcmp(token_string, "return"))
+					token_int = '\r';
+				else if (!strcmp(token_string, "formfeed"))
+					token_int = '\f';
+				else {
+					ao_lisp_error(AO_LISP_INVALID, "invalid character token #\\%s", token_string);
+					continue;
 				}
+				return NUM;
 			}
 		}
 		if (lex_class & STRINGC) {
 			for (;;) {
 				c = lexc();
+				if (lex_class & BACKSLASH)
+					c = lex_quoted();
 				if (lex_class & (STRINGC|ENDOFFILE)) {
 					end_token();
 					return STRING;
diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h
index f8bcd195..fc74a8e4 100644
--- a/src/lisp/ao_lisp_read.h
+++ b/src/lisp/ao_lisp_read.h
@@ -44,11 +44,10 @@
 # define IGNORE		0x0100	/* \0 - ' ' */
 # define BACKSLASH	0x0200	/* \ */
 # define VBAR		0x0400	/* | */
-# define TWIDDLE	0x0800	/* ~ */
-# define STRINGC	0x1000	/* " */
-# define POUND		0x2000	/* # */
+# define STRINGC	0x0800	/* " */
+# define POUND		0x1000	/* # */
 
-# define NOTNAME	(STRINGC|TWIDDLE|VBAR|COMMENT|ENDOFFILE|WHITE|SPECIAL)
+# define NOTNAME	(STRINGC|VBAR|COMMENT|ENDOFFILE|WHITE|SPECIAL)
 # define NUMBER		(DIGIT|SIGN)
 
 #endif /* _AO_LISP_READ_H_ */