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)
}
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)));
}
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
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"
; basic list accessors
+(defun caar (l) (car (car l)))
+
(defun cadr (l) (car (cdr l)))
(defun caddr (l) (car (cdr (cdr l))))
(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)
(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)))
;
PRINTABLE, /* { */
PRINTABLE|VBAR, /* | */
PRINTABLE, /* } */
- PRINTABLE|TWIDDLE, /* ~ */
+ PRINTABLE, /* ~ */
IGNORE, /* ^? */
};
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':
}
}
-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];
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;
projects / fw / altos / commitdiff