From a4e18a13029cc7b16b2ed9da84d6e606bc725ac3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 08:50:50 -0800 Subject: [PATCH] altos/lisp: Character consts. String and assoc builtins. Also add back escaped characters in strings. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.c | 98 ++++++++++++++++++++---------- src/lisp/ao_lisp_builtin.txt | 8 ++- src/lisp/ao_lisp_const.lisp | 110 ++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_read.c | 113 ++++++++++++++++++++++------------- src/lisp/ao_lisp_read.h | 7 +-- 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_ */ -- 2.30.2