From b3b4731fcb89cb404433f37a7704a503567c43bd Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 17:49:47 -0800 Subject: altos/lisp: Add scheme-style bools (#t and #f) Cond and while compare against #f, just like scheme says to. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_poly.c | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index fb3b06fe..160734b1 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -52,6 +52,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .print = ao_lisp_stack_print, .patom = ao_lisp_stack_print, }, + [AO_LISP_BOOL] = { + .print = ao_lisp_bool_print, + .patom = ao_lisp_bool_print, + }, }; static const struct ao_lisp_funcs * -- cgit v1.2.3 From cf5729a0bae51172f12fc9ec4339d4e975a45fcc Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 23:23:50 -0800 Subject: altos/lisp: Finish first pass through r7rs * print -> write, patom -> display * Add read-char, write-char * Add exit, current-jiffy, current-second, jiffies-per-second * Add for-each and string-for-each * Avoid duplicate builtins with different atoms Signed-off-by: Keith Packard --- src/lisp/README | 11 +++++++ src/lisp/ao_lisp.h | 33 +++++++++---------- src/lisp/ao_lisp_atom.c | 2 +- src/lisp/ao_lisp_bool.c | 2 +- src/lisp/ao_lisp_builtin.c | 74 +++++++++++++++++++++++++++++++++++++++---- src/lisp/ao_lisp_builtin.txt | 10 ++++-- src/lisp/ao_lisp_cons.c | 10 +++--- src/lisp/ao_lisp_const.lisp | 26 +++++++-------- src/lisp/ao_lisp_error.c | 14 ++++---- src/lisp/ao_lisp_eval.c | 2 +- src/lisp/ao_lisp_frame.c | 8 ++--- src/lisp/ao_lisp_int.c | 2 +- src/lisp/ao_lisp_lambda.c | 4 +-- src/lisp/ao_lisp_make_builtin | 4 ++- src/lisp/ao_lisp_make_const.c | 19 ++++++----- src/lisp/ao_lisp_os.h | 16 ++++++++-- src/lisp/ao_lisp_poly.c | 52 +++++++++++++++--------------- src/lisp/ao_lisp_rep.c | 4 ++- src/lisp/ao_lisp_save.c | 1 + src/lisp/ao_lisp_stack.c | 4 +-- src/lisp/ao_lisp_string.c | 4 +-- 21 files changed, 199 insertions(+), 103 deletions(-) create mode 100644 src/lisp/README (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/lisp/README b/src/lisp/README new file mode 100644 index 00000000..c1e84475 --- /dev/null +++ b/src/lisp/README @@ -0,0 +1,11 @@ +This follows the R7RS with the following known exceptions: + +* No vectors or bytevectors +* Characters are just numbers +* No dynamic-wind or exceptions +* No environments +* No ports +* No syntax-rules; we have macros instead +* define inside of lambda does not add name to lambda scope +* No record types +* No libraries diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index a445dddd..a10ccc43 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -106,6 +106,7 @@ extern uint16_t ao_lisp_top; #define AO_LISP_INVALID 0x04 #define AO_LISP_UNDEFINED 0x08 #define AO_LISP_EOF 0x10 +#define AO_LISP_EXIT 0x20 extern uint8_t ao_lisp_exception; @@ -463,7 +464,7 @@ ao_lisp_stack_fetch(int id) { extern const struct ao_lisp_type ao_lisp_bool_type; void -ao_lisp_bool_print(ao_poly v); +ao_lisp_bool_write(ao_poly v); #ifdef AO_LISP_MAKE_CONST struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; @@ -487,10 +488,10 @@ void ao_lisp_cons_free(struct ao_lisp_cons *cons); void -ao_lisp_cons_print(ao_poly); +ao_lisp_cons_write(ao_poly); void -ao_lisp_cons_patom(ao_poly); +ao_lisp_cons_display(ao_poly); int ao_lisp_cons_length(struct ao_lisp_cons *cons); @@ -511,10 +512,10 @@ ao_poly ao_lisp_string_unpack(char *a); void -ao_lisp_string_print(ao_poly s); +ao_lisp_string_write(ao_poly s); void -ao_lisp_string_patom(ao_poly s); +ao_lisp_string_display(ao_poly s); /* atom */ extern const struct ao_lisp_type ao_lisp_atom_type; @@ -524,7 +525,7 @@ extern struct ao_lisp_frame *ao_lisp_frame_global; extern struct ao_lisp_frame *ao_lisp_frame_current; void -ao_lisp_atom_print(ao_poly a); +ao_lisp_atom_write(ao_poly a); struct ao_lisp_atom * ao_lisp_atom_intern(char *name); @@ -540,14 +541,14 @@ ao_lisp_atom_set(ao_poly atom, ao_poly val); /* int */ void -ao_lisp_int_print(ao_poly i); +ao_lisp_int_write(ao_poly i); /* prim */ void -ao_lisp_poly_print(ao_poly p); +ao_lisp_poly_write(ao_poly p); void -ao_lisp_poly_patom(ao_poly p); +ao_lisp_poly_display(ao_poly p); int ao_lisp_poly_mark(ao_poly p, uint8_t note_cons); @@ -572,7 +573,7 @@ ao_lisp_set_cond(struct ao_lisp_cons *cons); /* builtin */ void -ao_lisp_builtin_print(ao_poly b); +ao_lisp_builtin_write(ao_poly b); extern const struct ao_lisp_type ao_lisp_builtin_type; @@ -629,7 +630,7 @@ int ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); void -ao_lisp_frame_print(ao_poly p); +ao_lisp_frame_write(ao_poly p); /* lambda */ extern const struct ao_lisp_type ao_lisp_lambda_type; @@ -640,7 +641,7 @@ struct ao_lisp_lambda * ao_lisp_lambda_new(ao_poly cons); void -ao_lisp_lambda_print(ao_poly lambda); +ao_lisp_lambda_write(ao_poly lambda); ao_poly ao_lisp_lambda_eval(void); @@ -664,7 +665,7 @@ void ao_lisp_stack_clear(void); void -ao_lisp_stack_print(ao_poly stack); +ao_lisp_stack_write(ao_poly stack); ao_poly ao_lisp_stack_eval(void); @@ -697,10 +698,10 @@ int ao_lisp_stack_depth; #define DBG_RESET() (ao_lisp_stack_depth = 0) #define DBG(...) printf(__VA_ARGS__) #define DBGI(...) do { DBG("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a)) -#define DBG_POLY(a) ao_lisp_poly_print(a) +#define DBG_CONS(a) ao_lisp_cons_write(ao_lisp_cons_poly(a)) +#define DBG_POLY(a) ao_lisp_poly_write(a) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) -#define DBG_STACK() ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)) +#define DBG_STACK() ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)) static inline void ao_lisp_frames_dump(void) { diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 8c9e8ed1..ede13567 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -158,7 +158,7 @@ ao_lisp_atom_set(ao_poly atom, ao_poly val) } void -ao_lisp_atom_print(ao_poly a) +ao_lisp_atom_write(ao_poly a) { struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); printf("%s", atom->name); diff --git a/src/lisp/ao_lisp_bool.c b/src/lisp/ao_lisp_bool.c index ad25afba..391a7f78 100644 --- a/src/lisp/ao_lisp_bool.c +++ b/src/lisp/ao_lisp_bool.c @@ -38,7 +38,7 @@ const struct ao_lisp_type ao_lisp_bool_type = { }; void -ao_lisp_bool_print(ao_poly v) +ao_lisp_bool_write(ao_poly v) { struct ao_lisp_bool *b = ao_lisp_poly_bool(v); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index d37d0284..6dd4d5e6 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -85,7 +85,7 @@ ao_lisp_args_name(uint8_t args) #endif void -ao_lisp_builtin_print(ao_poly b) +ao_lisp_builtin_write(ao_poly b) { struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); printf("%s", ao_lisp_builtin_name(builtin->func)); @@ -247,30 +247,30 @@ ao_lisp_do_while(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_print(struct ao_lisp_cons *cons) +ao_lisp_do_write(struct ao_lisp_cons *cons) { ao_poly val = AO_LISP_NIL; while (cons) { val = cons->car; - ao_lisp_poly_print(val); + ao_lisp_poly_write(val); cons = ao_lisp_poly_cons(cons->cdr); if (cons) printf(" "); } printf("\n"); - return val; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_do_patom(struct ao_lisp_cons *cons) +ao_lisp_do_display(struct ao_lisp_cons *cons) { ao_poly val = AO_LISP_NIL; while (cons) { val = cons->car; - ao_lisp_poly_patom(val); + ao_lisp_poly_display(val); cons = ao_lisp_poly_cons(cons->cdr); } - return val; + return _ao_lisp_bool_true; } ao_poly @@ -738,5 +738,65 @@ ao_lisp_do_string_to_symbol(struct ao_lisp_cons *cons) return ao_lisp_atom_poly(ao_lisp_atom_intern(ao_lisp_poly_string(ao_lisp_arg(cons, 0)))); } +ao_poly +ao_lisp_do_read_char(struct ao_lisp_cons *cons) +{ + int c; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + c = getchar(); + return ao_lisp_int_poly(c); +} + +ao_poly +ao_lisp_do_write_char(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_INT, 0)) + return AO_LISP_NIL; + putchar(ao_lisp_poly_int(ao_lisp_arg(cons, 0))); + return _ao_lisp_bool_true; +} + +ao_poly +ao_lisp_do_exit(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + ao_lisp_exception |= AO_LISP_EXIT; + return _ao_lisp_bool_true; +} + +ao_poly +ao_lisp_do_current_jiffy(struct ao_lisp_cons *cons) +{ + int jiffy; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + jiffy = ao_lisp_os_jiffy(); + return (ao_lisp_int_poly(jiffy)); +} + +ao_poly +ao_lisp_do_current_second(struct ao_lisp_cons *cons) +{ + int second; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + second = ao_lisp_os_jiffy() / AO_LISP_JIFFIES_PER_SECOND; + return (ao_lisp_int_poly(second)); +} + +ao_poly +ao_lisp_do_jiffies_per_second(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + return (ao_lisp_int_poly(AO_LISP_JIFFIES_PER_SECOND)); +} + #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 ba6455ab..4c484337 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -15,8 +15,8 @@ macro setq set! nlambda cond nlambda progn nlambda while -f_lexpr print -f_lexpr patom +f_lexpr write +f_lexpr display f_lexpr plus + f_lexpr minus - f_lexpr times * @@ -52,3 +52,9 @@ f_lambda string_to_symbol string->symbol f_lambda stringp string? f_lambda procedurep procedure? lexpr apply +f_lambda read_char read-char +f_lambda write_char write-char +f_lambda exit +f_lambda current_jiffy current-jiffy +f_lambda current_second current-second +f_lambda jiffies_per_second jiffies-per-second diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 8d607372..9379597c 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -123,7 +123,7 @@ ao_lisp_cons_free(struct ao_lisp_cons *cons) } void -ao_lisp_cons_print(ao_poly c) +ao_lisp_cons_write(ao_poly c) { struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); int first = 1; @@ -131,14 +131,14 @@ ao_lisp_cons_print(ao_poly c) while (cons) { if (!first) printf(" "); - ao_lisp_poly_print(cons->car); + ao_lisp_poly_write(cons->car); c = cons->cdr; if (ao_lisp_poly_type(c) == AO_LISP_CONS) { cons = ao_lisp_poly_cons(c); first = 0; } else { printf(" . "); - ao_lisp_poly_print(c); + ao_lisp_poly_write(c); cons = NULL; } } @@ -146,12 +146,12 @@ ao_lisp_cons_print(ao_poly c) } void -ao_lisp_cons_patom(ao_poly c) +ao_lisp_cons_display(ao_poly c) { struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); while (cons) { - ao_lisp_poly_patom(cons->car); + ao_lisp_poly_display(cons->car); cons = ao_lisp_poly_cons(cons->cdr); } } diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index d9b1c1f2..191ef005 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -463,11 +463,9 @@ (define string (lexpr (chars) (list->string chars))) -(patom "apply\n") +(display "apply\n") (apply cons '(a b)) -(define save ()) - (define map (lexpr (proc lists) (let ((args (lambda (lists) (if (null? lists) () @@ -488,28 +486,30 @@ (apply map proc lists) #t)) -(for-each patom '("hello" " " "world" "\n")) +(for-each display '("hello" " " "world" "\n")) + +(define -string-ml (lambda (strings) + (if (null? strings) () + (cons (string->list (car strings)) (-string-ml (cdr strings)))))) (define string-map (lexpr (proc strings) - (let ((make-lists (lambda (strings) - (if (null? strings) () - (cons (string->list (car strings)) (make-lists (cdr strings)))))) - ) - (list->string (apply map proc (make-lists strings)))))) + (list->string (apply map proc (-string-ml strings)))))) (string-map 1+ "HAL") (define string-for-each (lexpr (proc strings) - (apply string-map proc strings) - #t)) + (apply for-each proc (-string-ml strings)))) + +(string-for-each write-char "IBM\n") -(string-for-each patom "IBM") +(define newline (lambda () (write-char #\newline))) +(newline) (call-with-current-continuation (lambda (exit) (for-each (lambda (x) - (print "test" x) + (write "test" x) (if (negative? x) (exit x))) '(54 0 37 -3 245 19)) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index 54a9be10..d1c9b941 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -28,7 +28,7 @@ ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) printf("\t\t "); else first = 0; - ao_lisp_poly_print(cons->car); + ao_lisp_poly_write(cons->car); printf("\n"); if (poly == last) break; @@ -38,7 +38,7 @@ ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) } else printf(")\n"); } else { - ao_lisp_poly_print(poly); + ao_lisp_poly_write(poly); printf("\n"); } } @@ -66,9 +66,9 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf(" "); } - ao_lisp_poly_print(frame->vals[f].atom); + ao_lisp_poly_write(frame->vals[f].atom); printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); + ao_lisp_poly_write(frame->vals[f].val); printf("\n"); } if (frame->prev) @@ -92,11 +92,11 @@ ao_lisp_error(int error, char *format, ...) vprintf(format, args); va_end(args); printf("\n"); - printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); + printf("Value: "); ao_lisp_poly_write(ao_lisp_v); printf("\n"); printf("Stack:\n"); - ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)); + ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)); printf("Globals:\n\t"); - ao_lisp_frame_print(ao_lisp_frame_poly(ao_lisp_frame_global)); + ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global)); printf("\n"); return AO_LISP_NIL; } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 844e7ce7..758a9232 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -270,7 +270,7 @@ ao_lisp_eval_exec(void) DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) + if (builtin && builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); ao_lisp_v = v; diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 05f6d253..ebdb7757 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -102,7 +102,7 @@ const struct ao_lisp_type ao_lisp_frame_type = { }; void -ao_lisp_frame_print(ao_poly p) +ao_lisp_frame_write(ao_poly p) { struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); int f; @@ -116,12 +116,12 @@ ao_lisp_frame_print(ao_poly p) for (f = 0; f < frame->num; f++) { if (f != 0) printf(", "); - ao_lisp_poly_print(frame->vals[f].atom); + ao_lisp_poly_write(frame->vals[f].atom); printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); + ao_lisp_poly_write(frame->vals[f].val); } if (frame->prev) - ao_lisp_poly_print(frame->prev); + ao_lisp_poly_write(frame->prev); frame->type &= ~AO_LISP_FRAME_PRINT; } } diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c index 77f65e95..3b5341bd 100644 --- a/src/lisp/ao_lisp_int.c +++ b/src/lisp/ao_lisp_int.c @@ -15,7 +15,7 @@ #include "ao_lisp.h" void -ao_lisp_int_print(ao_poly p) +ao_lisp_int_write(ao_poly p) { int i = ao_lisp_poly_int(p); printf("%d", i); diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index cc333d6f..71aebed0 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -50,7 +50,7 @@ const struct ao_lisp_type ao_lisp_lambda_type = { }; void -ao_lisp_lambda_print(ao_poly poly) +ao_lisp_lambda_write(ao_poly poly) { struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(poly); struct ao_lisp_cons *cons = ao_lisp_poly_cons(lambda->code); @@ -59,7 +59,7 @@ ao_lisp_lambda_print(ao_poly poly) printf("%s", ao_lisp_args_name(lambda->args)); while (cons) { printf(" "); - ao_lisp_poly_print(cons->car); + ao_lisp_poly_write(cons->car); cons = ao_lisp_poly_cons(cons->cdr); } printf(")"); diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index 11838e33..531e388d 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -137,7 +137,9 @@ dump_consts(builtin_t[*] builtins) { for (int i = 0; i < dim(builtins); i++) { for (int j = 0; j < dim(builtins[i].lisp_names); j++) { printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", - builtins[i].lisp_names[j], builtins[i].type, builtins[i].c_name); + builtins[i].lisp_names[j], + builtins[i].type, + builtins[i].c_name); } } printf("};\n"); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 826c98b9..f23d34db 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -31,7 +31,7 @@ ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { struct builtin_func { char *name; int args; - int func; + enum ao_lisp_builtin_id func; }; #define AO_LISP_BUILTIN_CONSTS @@ -146,7 +146,7 @@ ao_is_macro(ao_poly p) struct ao_lisp_lambda *lambda; ao_poly ret; - MACRO_DEBUG(indent(); printf ("is macro "); ao_lisp_poly_print(p); printf("\n"); ++macro_scan_depth); + MACRO_DEBUG(indent(); printf ("is macro "); ao_lisp_poly_write(p); printf("\n"); ++macro_scan_depth); switch (ao_lisp_poly_type(p)) { case AO_LISP_ATOM: if (ao_lisp_macro_push(p)) @@ -181,7 +181,7 @@ ao_is_macro(ao_poly p) ret = AO_LISP_NIL; break; } - MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_lisp_poly_print(ret); printf("\n")); + MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_lisp_poly_write(ret); printf("\n")); return ret; } @@ -195,7 +195,7 @@ ao_has_macro(ao_poly p) if (p == AO_LISP_NIL) return AO_LISP_NIL; - MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_print(p); printf("\n"); ++macro_scan_depth); + MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_write(p); printf("\n"); ++macro_scan_depth); switch (ao_lisp_poly_type(p)) { case AO_LISP_LAMBDA: lambda = ao_lisp_poly_lambda(p); @@ -222,7 +222,7 @@ ao_has_macro(ao_poly p) p = AO_LISP_NIL; break; } - MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_lisp_poly_print(p); printf("\n")); + MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_lisp_poly_write(p); printf("\n")); return p; } @@ -237,7 +237,7 @@ ao_lisp_read_eval_abort(void) out = ao_lisp_eval(in); if (ao_lisp_exception) return 0; - ao_lisp_poly_print(out); + ao_lisp_poly_write(out); putchar ('\n'); } return 1; @@ -273,6 +273,7 @@ main(int argc, char **argv) int in_atom = 0; char *out_name = NULL; int c; + enum ao_lisp_builtin_id prev_func; in = stdin; out = stdout; @@ -292,8 +293,10 @@ main(int argc, char **argv) ao_lisp_bool_get(0); ao_lisp_bool_get(1); + prev_func = _builtin_last; for (f = 0; f < (int) N_FUNC; f++) { - b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); + if (funcs[f].func != prev_func) + b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); a = ao_lisp_atom_intern(funcs[f].name); ao_lisp_atom_set(ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); @@ -327,7 +330,7 @@ main(int argc, char **argv) if (val != AO_LISP_NIL) { printf("error: function %s contains unresolved macro: ", ao_lisp_poly_atom(ao_lisp_frame_global->vals[f].atom)->name); - ao_lisp_poly_print(val); + ao_lisp_poly_write(val); printf("\n"); exit(1); } diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h index 5fa3686b..4285cb8c 100644 --- a/src/lisp/ao_lisp_os.h +++ b/src/lisp/ao_lisp_os.h @@ -41,13 +41,23 @@ ao_lisp_os_led(int led) printf("leds set to 0x%x\n", led); } +#define AO_LISP_JIFFIES_PER_SECOND 100 + static inline void -ao_lisp_os_delay(int delay) +ao_lisp_os_delay(int jiffies) { struct timespec ts = { - .tv_sec = delay / 1000, - .tv_nsec = (delay % 1000) * 1000000, + .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) }; nanosleep(&ts, NULL); } + +static inline int +ao_lisp_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); +} #endif diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 160734b1..7e4c98d2 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -15,46 +15,46 @@ #include "ao_lisp.h" struct ao_lisp_funcs { - void (*print)(ao_poly); - void (*patom)(ao_poly); + void (*write)(ao_poly); + void (*display)(ao_poly); }; static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { [AO_LISP_CONS] = { - .print = ao_lisp_cons_print, - .patom = ao_lisp_cons_patom, + .write = ao_lisp_cons_write, + .display = ao_lisp_cons_display, }, [AO_LISP_STRING] = { - .print = ao_lisp_string_print, - .patom = ao_lisp_string_patom, + .write = ao_lisp_string_write, + .display = ao_lisp_string_display, }, [AO_LISP_INT] = { - .print = ao_lisp_int_print, - .patom = ao_lisp_int_print, + .write = ao_lisp_int_write, + .display = ao_lisp_int_write, }, [AO_LISP_ATOM] = { - .print = ao_lisp_atom_print, - .patom = ao_lisp_atom_print, + .write = ao_lisp_atom_write, + .display = ao_lisp_atom_write, }, [AO_LISP_BUILTIN] = { - .print = ao_lisp_builtin_print, - .patom = ao_lisp_builtin_print, + .write = ao_lisp_builtin_write, + .display = ao_lisp_builtin_write, }, [AO_LISP_FRAME] = { - .print = ao_lisp_frame_print, - .patom = ao_lisp_frame_print, + .write = ao_lisp_frame_write, + .display = ao_lisp_frame_write, }, [AO_LISP_LAMBDA] = { - .print = ao_lisp_lambda_print, - .patom = ao_lisp_lambda_print, + .write = ao_lisp_lambda_write, + .display = ao_lisp_lambda_write, }, [AO_LISP_STACK] = { - .print = ao_lisp_stack_print, - .patom = ao_lisp_stack_print, + .write = ao_lisp_stack_write, + .display = ao_lisp_stack_write, }, [AO_LISP_BOOL] = { - .print = ao_lisp_bool_print, - .patom = ao_lisp_bool_print, + .write = ao_lisp_bool_write, + .display = ao_lisp_bool_write, }, }; @@ -69,21 +69,21 @@ funcs(ao_poly p) } void -ao_lisp_poly_print(ao_poly p) +ao_lisp_poly_write(ao_poly p) { const struct ao_lisp_funcs *f = funcs(p); - if (f && f->print) - f->print(p); + if (f && f->write) + f->write(p); } void -ao_lisp_poly_patom(ao_poly p) +ao_lisp_poly_display(ao_poly p) { const struct ao_lisp_funcs *f = funcs(p); - if (f && f->patom) - f->patom(p); + if (f && f->display) + f->display(p); } void * diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index ef7dbaf2..43cc387f 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -24,9 +24,11 @@ ao_lisp_read_eval_print(void) break; out = ao_lisp_eval(in); if (ao_lisp_exception) { + if (ao_lisp_exception & AO_LISP_EXIT) + break; ao_lisp_exception = 0; } else { - ao_lisp_poly_print(out); + ao_lisp_poly_write(out); putchar ('\n'); } } diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c index cbc8e925..c990e9c6 100644 --- a/src/lisp/ao_lisp_save.c +++ b/src/lisp/ao_lisp_save.c @@ -69,6 +69,7 @@ ao_lisp_do_restore(struct ao_lisp_cons *cons) /* Re-create the evaluator stack */ if (!ao_lisp_eval_restart()) return _ao_lisp_bool_false; + return _ao_lisp_bool_true; } #endif diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c index 729a63ba..af68b656 100644 --- a/src/lisp/ao_lisp_stack.c +++ b/src/lisp/ao_lisp_stack.c @@ -156,7 +156,7 @@ ao_lisp_stack_clear(void) } void -ao_lisp_stack_print(ao_poly poly) +ao_lisp_stack_write(ao_poly poly) { struct ao_lisp_stack *s = ao_lisp_poly_stack(poly); @@ -167,7 +167,7 @@ ao_lisp_stack_print(ao_poly poly) } s->type |= AO_LISP_STACK_PRINT; printf("\t[\n"); - printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); + printf("\t\texpr: "); ao_lisp_poly_write(s->list); printf("\n"); printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]); ao_lisp_error_poly ("values: ", s->values, s->values_tail); ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL); diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index af23f7b3..87f9289c 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -122,7 +122,7 @@ ao_lisp_string_unpack(char *a) } void -ao_lisp_string_print(ao_poly p) +ao_lisp_string_write(ao_poly p) { char *s = ao_lisp_poly_string(p); char c; @@ -148,7 +148,7 @@ ao_lisp_string_print(ao_poly p) } void -ao_lisp_string_patom(ao_poly p) +ao_lisp_string_display(ao_poly p) { char *s = ao_lisp_poly_string(p); char c; -- cgit v1.2.3 From 5f8f0ed5cd5d4b4f793c602ed09f9b4bdb98f7e8 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 18 Nov 2017 20:38:15 -0800 Subject: altos/lisp: Add 'big' ints -- 24 bits wide With the default ints being only 14 bits, having a larger type with more precision seems useful. This is not exposed to the application. Signed-off-by: Keith Packard --- src/cortexelf-v1/ao_lisp_os.h | 6 ++++ src/lisp/ao_lisp.h | 69 ++++++++++++++++++++++++++++++++++++++++--- src/lisp/ao_lisp_builtin.c | 30 ++++++++++++------- src/lisp/ao_lisp_eval.c | 1 + src/lisp/ao_lisp_int.c | 57 +++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_mem.c | 1 + src/lisp/ao_lisp_poly.c | 4 +++ src/lisp/ao_lisp_read.c | 4 +-- src/lisp/ao_lisp_string.c | 4 +-- 9 files changed, 157 insertions(+), 19 deletions(-) (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/cortexelf-v1/ao_lisp_os.h b/src/cortexelf-v1/ao_lisp_os.h index 50c9d40f..27ea7806 100644 --- a/src/cortexelf-v1/ao_lisp_os.h +++ b/src/cortexelf-v1/ao_lisp_os.h @@ -23,6 +23,12 @@ #define AO_LISP_POOL_TOTAL 16384 #define AO_LISP_SAVE 1 +#ifndef __BYTE_ORDER +#define __LITTLE_ENDIAN 1234 +#define __BIG_ENDIAN 4321 +#define __BYTE_ORDER __LITTLE_ENDIAN +#endif + static inline int ao_lisp_getc() { static uint8_t at_eol; diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index a10ccc43..08278fe7 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -21,6 +21,9 @@ #include #include #include +#ifndef __BYTE_ORDER +#include +#endif typedef uint16_t ao_poly; typedef int16_t ao_signed_poly; @@ -92,7 +95,8 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((a #define AO_LISP_LAMBDA 7 #define AO_LISP_STACK 8 #define AO_LISP_BOOL 9 -#define AO_LISP_NUM_TYPE 10 +#define AO_LISP_BIGINT 10 +#define AO_LISP_NUM_TYPE 11 /* Leave two bits for types to use as they please */ #define AO_LISP_OTHER_TYPE_MASK 0x3f @@ -162,6 +166,35 @@ struct ao_lisp_bool { uint16_t pad; }; +struct ao_lisp_bigint { + uint32_t value; +}; + +#if __BYTE_ORDER == __LITTLE_ENDIAN +static inline uint32_t +ao_lisp_int_bigint(int32_t i) { + return AO_LISP_BIGINT | (i << 8); +} +static inline int32_t +ao_lisp_bigint_int(uint32_t bi) { + return (int32_t) bi >> 8; +} +#else +static inline uint32_t +ao_lisp_int_bigint(int32_t i) { + return (uint32_t) (i & 0xffffff) | (AO_LISP_BIGINT << 24); +} +static inlint int32_t +ao_lisp_bigint_int(uint32_t bi) { + return (int32_t) (bi << 8) >> 8; +} +#endif + +#define AO_LISP_MIN_INT (-(1 << (15 - AO_LISP_TYPE_SHIFT))) +#define AO_LISP_MAX_INT ((1 << (15 - AO_LISP_TYPE_SHIFT)) - 1) + +#define AO_LISP_NOT_INTEGER 0x7fffffff + /* Set on type when the frame escapes the lambda */ #define AO_LISP_FRAME_MARK 0x80 #define AO_LISP_FRAME_PRINT 0x40 @@ -338,18 +371,30 @@ ao_lisp_cons_poly(struct ao_lisp_cons *cons) return ao_lisp_poly(cons, AO_LISP_CONS); } -static inline int +static inline int32_t ao_lisp_poly_int(ao_poly poly) { - return (int) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); + return (int32_t) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); } static inline ao_poly -ao_lisp_int_poly(int i) +ao_lisp_int_poly(int32_t i) { return ((ao_poly) i << 2) | AO_LISP_INT; } +static inline struct ao_lisp_bigint * +ao_lisp_poly_bigint(ao_poly poly) +{ + return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_bigint_poly(struct ao_lisp_bigint *bi) +{ + return ao_lisp_poly(bi, AO_LISP_OTHER); +} + static inline char * ao_lisp_poly_string(ao_poly poly) { @@ -543,6 +588,22 @@ ao_lisp_atom_set(ao_poly atom, ao_poly val); void ao_lisp_int_write(ao_poly i); +int32_t +ao_lisp_poly_integer(ao_poly p); + +ao_poly +ao_lisp_integer_poly(int32_t i); + +static inline int +ao_lisp_integer_typep(uint8_t t) +{ + return (t == AO_LISP_INT) || (t == AO_LISP_BIGINT); +} + +void +ao_lisp_bigint_write(ao_poly i); + +extern const struct ao_lisp_type ao_lisp_bigint_type; /* prim */ void ao_lisp_poly_write(ao_poly p); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 6dd4d5e6..ccd13d07 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -290,10 +290,10 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) if (cons->cdr == AO_LISP_NIL && ct == AO_LISP_INT) { switch (op) { case builtin_minus: - ret = ao_lisp_int_poly(-ao_lisp_poly_int(ret)); + ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); break; case builtin_divide: - switch (ao_lisp_poly_int(ret)) { + switch (ao_lisp_poly_integer(ret)) { case 0: return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); case 1: @@ -307,9 +307,9 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) break; } } - } else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { - int r = ao_lisp_poly_int(ret); - int c = ao_lisp_poly_int(car); + } else if (ao_lisp_integer_typep(rt) && ao_lisp_integer_typep(ct)) { + int32_t r = ao_lisp_poly_integer(ret); + int32_t c = ao_lisp_poly_integer(car); switch(op) { case builtin_plus: @@ -349,7 +349,7 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) default: break; } - ret = ao_lisp_int_poly(r); + ret = ao_lisp_integer_poly(r); } else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) @@ -427,9 +427,9 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) } else { uint8_t lt = ao_lisp_poly_type(left); uint8_t rt = ao_lisp_poly_type(right); - if (lt == AO_LISP_INT && rt == AO_LISP_INT) { - int l = ao_lisp_poly_int(left); - int r = ao_lisp_poly_int(right); + if (ao_lisp_integer_typep(lt) && ao_lisp_integer_typep(rt)) { + int32_t l = ao_lisp_poly_integer(left); + int32_t r = ao_lisp_poly_integer(right); switch (op) { case builtin_less: @@ -643,7 +643,15 @@ ao_lisp_do_pairp(struct ao_lisp_cons *cons) ao_poly ao_lisp_do_numberp(struct ao_lisp_cons *cons) { - return ao_lisp_do_typep(AO_LISP_INT, cons); + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + return _ao_lisp_bool_true; + default: + return _ao_lisp_bool_false; + } } ao_poly @@ -755,7 +763,7 @@ ao_lisp_do_write_char(struct ao_lisp_cons *cons) return AO_LISP_NIL; if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) return AO_LISP_NIL; - putchar(ao_lisp_poly_int(ao_lisp_arg(cons, 0))); + putchar(ao_lisp_poly_integer(ao_lisp_arg(cons, 0))); return _ao_lisp_bool_true; } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 758a9232..8fa488e2 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -110,6 +110,7 @@ ao_lisp_eval_sexpr(void) /* fall through */ case AO_LISP_BOOL: case AO_LISP_INT: + case AO_LISP_BIGINT: case AO_LISP_STRING: case AO_LISP_BUILTIN: case AO_LISP_LAMBDA: diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c index 3b5341bd..8e467755 100644 --- a/src/lisp/ao_lisp_int.c +++ b/src/lisp/ao_lisp_int.c @@ -20,3 +20,60 @@ ao_lisp_int_write(ao_poly p) int i = ao_lisp_poly_int(p); printf("%d", i); } + +int32_t +ao_lisp_poly_integer(ao_poly p) +{ + switch (ao_lisp_poly_base_type(p)) { + case AO_LISP_INT: + return ao_lisp_poly_int(p); + case AO_LISP_OTHER: + if (ao_lisp_other_type(ao_lisp_poly_other(p)) == AO_LISP_BIGINT) + return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); + } + return AO_LISP_NOT_INTEGER; +} + +ao_poly +ao_lisp_integer_poly(int32_t p) +{ + struct ao_lisp_bigint *bi; + + if (AO_LISP_MIN_INT <= p && p <= AO_LISP_MAX_INT) + return ao_lisp_int_poly(p); + bi = ao_lisp_alloc(sizeof (struct ao_lisp_bigint)); + bi->value = ao_lisp_int_bigint(p); + return ao_lisp_bigint_poly(bi); +} + +static void bigint_mark(void *addr) +{ + (void) addr; +} + +static int bigint_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_lisp_bigint); +} + +static void bigint_move(void *addr) +{ + (void) addr; +} + +const struct ao_lisp_type ao_lisp_bigint_type = { + .mark = bigint_mark, + .size = bigint_size, + .move = bigint_move, + .name = "bigint", +}; + +void +ao_lisp_bigint_write(ao_poly p) +{ + struct ao_lisp_bigint *bi = ao_lisp_poly_bigint(p); + + printf("%d", ao_lisp_bigint_int(bi->value)); +} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 156221e8..f333073a 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -458,6 +458,7 @@ static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, [AO_LISP_STACK] = &ao_lisp_stack_type, [AO_LISP_BOOL] = &ao_lisp_bool_type, + [AO_LISP_BIGINT] = &ao_lisp_bigint_type, }; static int diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 7e4c98d2..94ecd042 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -56,6 +56,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .write = ao_lisp_bool_write, .display = ao_lisp_bool_write, }, + [AO_LISP_BIGINT] = { + .write = ao_lisp_bigint_write, + .display = ao_lisp_bigint_write, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 8c06e198..5115f46e 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -245,7 +245,7 @@ lex_quoted(void) #define AO_LISP_TOKEN_MAX 32 static char token_string[AO_LISP_TOKEN_MAX]; -static int token_int; +static int32_t token_int; static int token_len; static inline void add_token(int c) { @@ -497,7 +497,7 @@ ao_lisp_read(void) v = AO_LISP_NIL; break; case NUM: - v = ao_lisp_int_poly(token_int); + v = ao_lisp_integer_poly(token_int); break; case BOOL: if (token_string[0] == 't') diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 87f9289c..fff218df 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -83,9 +83,9 @@ ao_lisp_string_pack(struct ao_lisp_cons *cons) char *s = r; while (cons) { - if (ao_lisp_poly_type(cons->car) != AO_LISP_INT) + if (!ao_lisp_integer_typep(ao_lisp_poly_type(cons->car))) return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); - *s++ = ao_lisp_poly_int(cons->car); + *s++ = ao_lisp_poly_integer(cons->car); cons = ao_lisp_poly_cons(cons->cdr); } *s++ = 0; -- cgit v1.2.3 From 6d2f271a45759bd792d299f04a424d3382ef4798 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 19 Nov 2017 21:07:00 -0800 Subject: altos/lisp: Add floats Signed-off-by: Keith Packard --- src/lisp/Makefile | 2 +- src/lisp/Makefile-inc | 1 + src/lisp/ao_lisp.h | 48 +++++++++++++- src/lisp/ao_lisp_builtin.c | 119 ++++++++++++++++++++++++---------- src/lisp/ao_lisp_builtin.txt | 7 +- src/lisp/ao_lisp_cons.c | 13 ++++ src/lisp/ao_lisp_const.lisp | 3 - src/lisp/ao_lisp_eval.c | 1 + src/lisp/ao_lisp_float.c | 148 +++++++++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_mem.c | 1 + src/lisp/ao_lisp_poly.c | 4 ++ src/lisp/ao_lisp_read.c | 77 ++++++++++++++++++---- src/lisp/ao_lisp_read.h | 24 +++---- 13 files changed, 384 insertions(+), 64 deletions(-) create mode 100644 src/lisp/ao_lisp_float.c (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 4563dad3..05f54550 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -19,6 +19,6 @@ OBJS=$(SRCS:.c=.o) CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra -no-pie ao_lisp_make_const: $(OBJS) - $(CC) $(CFLAGS) -o $@ $(OBJS) + $(CC) $(CFLAGS) -o $@ $(OBJS) -lm $(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc index 6c8702fb..a097f1be 100644 --- a/src/lisp/Makefile-inc +++ b/src/lisp/Makefile-inc @@ -6,6 +6,7 @@ LISP_SRCS=\ ao_lisp_int.c \ ao_lisp_poly.c \ ao_lisp_bool.c \ + ao_lisp_float.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_frame.c \ diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 08278fe7..cbbbe9a4 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -96,7 +96,8 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((a #define AO_LISP_STACK 8 #define AO_LISP_BOOL 9 #define AO_LISP_BIGINT 10 -#define AO_LISP_NUM_TYPE 11 +#define AO_LISP_FLOAT 11 +#define AO_LISP_NUM_TYPE 12 /* Leave two bits for types to use as they please */ #define AO_LISP_OTHER_TYPE_MASK 0x3f @@ -170,6 +171,13 @@ struct ao_lisp_bigint { uint32_t value; }; +struct ao_lisp_float { + uint8_t type; + uint8_t pad1; + uint16_t pad2; + float value; +}; + #if __BYTE_ORDER == __LITTLE_ENDIAN static inline uint32_t ao_lisp_int_bigint(int32_t i) { @@ -442,6 +450,22 @@ ao_lisp_poly_bool(ao_poly poly) { return ao_lisp_ref(poly); } + +static inline ao_poly +ao_lisp_float_poly(struct ao_lisp_float *f) +{ + return ao_lisp_poly(f, AO_LISP_OTHER); +} + +static inline struct ao_lisp_float * +ao_lisp_poly_float(ao_poly poly) +{ + return ao_lisp_ref(poly); +} + +float +ao_lisp_poly_number(ao_poly p); + /* memory functions */ extern int ao_lisp_collects[2]; @@ -524,6 +548,10 @@ extern const struct ao_lisp_type ao_lisp_cons_type; struct ao_lisp_cons * ao_lisp_cons_cons(ao_poly car, ao_poly cdr); +/* Return a cons or NULL for a proper list, else error */ +struct ao_lisp_cons * +ao_lisp_cons_cdr(struct ao_lisp_cons *cons); + ao_poly ao_lisp__cons(ao_poly car, ao_poly cdr); @@ -632,6 +660,24 @@ ao_lisp_eval(ao_poly p); ao_poly ao_lisp_set_cond(struct ao_lisp_cons *cons); +/* float */ +extern const struct ao_lisp_type ao_lisp_float_type; + +void +ao_lisp_float_write(ao_poly p); + +ao_poly +ao_lisp_float_get(float value); + +static inline uint8_t +ao_lisp_number_typep(uint8_t t) +{ + return ao_lisp_integer_typep(t) || (t == AO_LISP_FLOAT); +} + +float +ao_lisp_poly_number(ao_poly p); + /* builtin */ void ao_lisp_builtin_write(ao_poly b); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index e5370f90..d4dc8a86 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -14,6 +14,7 @@ #include "ao_lisp.h" #include +#include static int builtin_size(void *addr) @@ -98,7 +99,7 @@ ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) while (cons && argc <= max) { argc++; - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } if (argc < min || argc > max) return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); @@ -113,7 +114,7 @@ ao_lisp_arg(struct ao_lisp_cons *cons, int argc) while (argc--) { if (!cons) return AO_LISP_NIL; - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } return cons->car; } @@ -162,17 +163,17 @@ ao_lisp_do_cons(struct ao_lisp_cons *cons) ao_poly ao_lisp_do_last(struct ao_lisp_cons *cons) { - ao_poly l; + struct ao_lisp_cons *list; if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) return AO_LISP_NIL; if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) return AO_LISP_NIL; - l = ao_lisp_arg(cons, 0); - while (l) { - struct ao_lisp_cons *list = ao_lisp_poly_cons(l); + for (list = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); + list; + list = ao_lisp_cons_cdr(list)) + { if (!list->cdr) return list->car; - l = list->cdr; } return AO_LISP_NIL; } @@ -253,7 +254,7 @@ ao_lisp_do_write(struct ao_lisp_cons *cons) while (cons) { val = cons->car; ao_lisp_poly_write(val); - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); if (cons) printf(" "); } @@ -268,39 +269,38 @@ ao_lisp_do_display(struct ao_lisp_cons *cons) while (cons) { val = cons->car; ao_lisp_poly_display(val); - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } return _ao_lisp_bool_true; } ao_poly -ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) +ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) { - struct ao_lisp_cons *orig_cons = cons; + struct ao_lisp_cons *cons = cons; ao_poly ret = AO_LISP_NIL; - while (cons) { + for (cons = orig_cons; cons; cons = ao_lisp_cons_cdr(cons)) { ao_poly car = cons->car; - ao_poly cdr; uint8_t rt = ao_lisp_poly_type(ret); uint8_t ct = ao_lisp_poly_type(car); if (cons == orig_cons) { ret = car; - if (cons->cdr == AO_LISP_NIL && ct == AO_LISP_INT) { + if (cons->cdr == AO_LISP_NIL) { switch (op) { case builtin_minus: - ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); + if (ao_lisp_integer_typep(ct)) + ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); + else if (ct == AO_LISP_FLOAT) + ret = ao_lisp_float_get(-ao_lisp_poly_number(ret)); break; case builtin_divide: - switch (ao_lisp_poly_integer(ret)) { - case 0: - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); - case 1: - break; - default: - ret = ao_lisp_int_poly(0); - break; + if (ao_lisp_integer_typep(ct) && ao_lisp_poly_integer(ret) == 1) + ; + else if (ao_lisp_number_typep(ct)) { + float v = ao_lisp_poly_number(ret); + ret = ao_lisp_float_get(1/v); } break; default: @@ -322,10 +322,54 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) r *= c; break; case builtin_divide: + if (c != 0 && (r % c) == 0) + r /= c; + else { + ret = ao_lisp_float_get((float) r / (float) c); + continue; + } + break; + case builtin_quotient: + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); + if (r % c != 0 && (c < 0) != (r < 0)) + r = r / c - 1; + else + r = r / c; + break; + case builtin_remainder: if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); + r %= c; + break; + case builtin_modulo: + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); + r %= c; + if ((r < 0) != (c < 0)) + r += c; + break; + default: + break; + } + ret = ao_lisp_integer_poly(r); + } else if (ao_lisp_number_typep(rt) && ao_lisp_number_typep(ct)) { + float r = ao_lisp_poly_number(ret); + float c = ao_lisp_poly_number(car); + switch(op) { + case builtin_plus: + r += c; + break; + case builtin_minus: + r -= c; + break; + case builtin_times: + r *= c; + break; + case builtin_divide: r /= c; break; +#if 0 case builtin_quotient: if (c == 0) return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); @@ -346,10 +390,11 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) if ((r < 0) != (c < 0)) r += c; break; +#endif default: break; } - ret = ao_lisp_integer_poly(r); + ret = ao_lisp_float_get(r); } else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) @@ -357,11 +402,6 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) ao_lisp_poly_string(car))); else return ao_lisp_error(AO_LISP_INVALID, "invalid args"); - - cdr = cons->cdr; - if (cdr != AO_LISP_NIL && ao_lisp_poly_type(cdr) != AO_LISP_CONS) - return ao_lisp_error(AO_LISP_INVALID, "improper list"); - cons = ao_lisp_poly_cons(cdr); } return ret; } @@ -417,8 +457,7 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) return _ao_lisp_bool_true; left = cons->car; - cons = ao_lisp_poly_cons(cons->cdr); - while (cons) { + for (cons = ao_lisp_cons_cdr(cons); cons; cons = ao_lisp_cons_cdr(cons)) { ao_poly right = cons->car; if (op == builtin_equal) { @@ -477,7 +516,6 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) } } left = right; - cons = ao_lisp_poly_cons(cons->cdr); } return _ao_lisp_bool_true; } @@ -640,6 +678,20 @@ ao_lisp_do_pairp(struct ao_lisp_cons *cons) return ao_lisp_do_typep(AO_LISP_CONS, cons); } +ao_poly +ao_lisp_do_integerp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + return _ao_lisp_bool_true; + default: + return _ao_lisp_bool_false; + } +} + ao_poly ao_lisp_do_numberp(struct ao_lisp_cons *cons) { @@ -648,6 +700,7 @@ ao_lisp_do_numberp(struct ao_lisp_cons *cons) switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { case AO_LISP_INT: case AO_LISP_BIGINT: + case AO_LISP_FLOAT: return _ao_lisp_bool_true; default: return _ao_lisp_bool_false; diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index c324ca67..2e11bdad 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -42,7 +42,8 @@ f_lambda nullp null? f_lambda not f_lambda listp list? f_lambda pairp pair? -f_lambda numberp number? integer? +f_lambda integerp integer? exact? exact-integer? +f_lambda numberp number? real? f_lambda booleanp boolean? f_lambda set_car set-car! f_lambda set_cdr set-cdr! @@ -58,3 +59,7 @@ f_lambda exit f_lambda current_jiffy current-jiffy f_lambda current_second current-second f_lambda jiffies_per_second jiffies-per-second +f_lambda finitep finite? +f_lambda infinitep infinite? +f_lambda inexactp inexact? +f_lambda sqrt diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 9379597c..c70aa1ca 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -105,6 +105,19 @@ ao_lisp_cons_cons(ao_poly car, ao_poly cdr) return cons; } +struct ao_lisp_cons * +ao_lisp_cons_cdr(struct ao_lisp_cons *cons) +{ + ao_poly cdr = cons->cdr; + if (cdr == AO_LISP_NIL) + return NULL; + if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { + (void) ao_lisp_error(AO_LISP_INVALID, "improper list"); + return NULL; + } + return ao_lisp_poly_cons(cdr); +} + ao_poly ao_lisp__cons(ao_poly car, ao_poly cdr) { diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 861a4fc8..9fb7634c 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -159,9 +159,6 @@ (odd? 3) (odd? -1) -(define exact? number?) -(defun inexact? (x) #f) - ; (if ) ; (if + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_lisp.h" +#include + +static void float_mark(void *addr) +{ + (void) addr; +} + +static int float_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_lisp_float); +} + +static void float_move(void *addr) +{ + (void) addr; +} + +const struct ao_lisp_type ao_lisp_float_type = { + .mark = float_mark, + .size = float_size, + .move = float_move, + .name = "float", +}; + +void +ao_lisp_float_write(ao_poly p) +{ + struct ao_lisp_float *f = ao_lisp_poly_float(p); + float v = f->value; + + if (isnanf(v)) + printf("+nan.0"); + else if (isinff(v)) { + if (v < 0) + printf("-"); + else + printf("+"); + printf("inf.0"); + } else + printf ("%g", f->value); +} + +float +ao_lisp_poly_number(ao_poly p) +{ + switch (ao_lisp_poly_base_type(p)) { + case AO_LISP_INT: + return ao_lisp_poly_int(p); + case AO_LISP_OTHER: + switch (ao_lisp_other_type(ao_lisp_poly_other(p))) { + case AO_LISP_BIGINT: + return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); + case AO_LISP_FLOAT: + return ao_lisp_poly_float(p)->value; + } + } + return NAN; +} + +ao_poly +ao_lisp_float_get(float value) +{ + struct ao_lisp_float *f; + + f = ao_lisp_alloc(sizeof (struct ao_lisp_float)); + f->type = AO_LISP_FLOAT; + f->value = value; + return ao_lisp_float_poly(f); +} + +ao_poly +ao_lisp_do_inexactp(struct ao_lisp_cons *cons) +{ + 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_FLOAT) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_finitep(struct ao_lisp_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + value = ao_lisp_arg(cons, 0); + switch (ao_lisp_poly_type(value)) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + return _ao_lisp_bool_true; + case AO_LISP_FLOAT: + f = ao_lisp_poly_float(value)->value; + if (!isnan(f) && !isinf(f)) + return _ao_lisp_bool_true; + } + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_infinitep(struct ao_lisp_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + value = ao_lisp_arg(cons, 0); + switch (ao_lisp_poly_type(value)) { + case AO_LISP_FLOAT: + f = ao_lisp_poly_float(value)->value; + if (isinf(f)) + return _ao_lisp_bool_true; + } + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_sqrt(struct ao_lisp_cons *cons) +{ + ao_poly value; + + if (!ao_lisp_check_argc(_ao_lisp_atom_sqrt, cons, 1, 1)) + return AO_LISP_NIL; + value = ao_lisp_arg(cons, 0); + if (!ao_lisp_number_typep(ao_lisp_poly_type(value))) + return ao_lisp_error(AO_LISP_INVALID, "%s: non-numeric", ao_lisp_poly_atom(_ao_lisp_atom_sqrt)->name); + return ao_lisp_float_get(sqrtf(ao_lisp_poly_number(value))); +} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index f333073a..dc0008c4 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -459,6 +459,7 @@ static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_STACK] = &ao_lisp_stack_type, [AO_LISP_BOOL] = &ao_lisp_bool_type, [AO_LISP_BIGINT] = &ao_lisp_bigint_type, + [AO_LISP_FLOAT] = &ao_lisp_float_type, }; static int diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 94ecd042..e93e1192 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -60,6 +60,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .write = ao_lisp_bigint_write, .display = ao_lisp_bigint_write, }, + [AO_LISP_FLOAT] = { + .write = ao_lisp_float_write, + .display = ao_lisp_float_write, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 5115f46e..c5a238cc 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -14,6 +14,7 @@ #include "ao_lisp.h" #include "ao_lisp_read.h" +#include static const uint16_t lex_classes[128] = { IGNORE, /* ^@ */ @@ -62,7 +63,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE|SIGN, /* + */ PRINTABLE, /* , */ PRINTABLE|SIGN, /* - */ - PRINTABLE|SPECIAL, /* . */ + PRINTABLE|DOTC|FLOATC, /* . */ PRINTABLE, /* / */ PRINTABLE|DIGIT, /* 0 */ PRINTABLE|DIGIT, /* 1 */ @@ -85,7 +86,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* B */ PRINTABLE, /* C */ PRINTABLE, /* D */ - PRINTABLE, /* E */ + PRINTABLE|FLOATC, /* E */ PRINTABLE, /* F */ PRINTABLE, /* G */ PRINTABLE, /* H */ @@ -117,7 +118,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* b */ PRINTABLE, /* c */ PRINTABLE, /* d */ - PRINTABLE, /* e */ + PRINTABLE|FLOATC, /* e */ PRINTABLE, /* f */ PRINTABLE, /* g */ PRINTABLE, /* h */ @@ -140,7 +141,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* y */ PRINTABLE, /* z */ PRINTABLE, /* { */ - PRINTABLE|VBAR, /* | */ + PRINTABLE, /* | */ PRINTABLE, /* } */ PRINTABLE, /* ~ */ IGNORE, /* ^? */ @@ -247,16 +248,36 @@ lex_quoted(void) static char token_string[AO_LISP_TOKEN_MAX]; static int32_t token_int; static int token_len; +static float token_float; static inline void add_token(int c) { if (c && token_len < AO_LISP_TOKEN_MAX - 1) token_string[token_len++] = c; } +static inline void del_token(void) { + if (token_len > 0) + token_len--; +} + static inline void end_token(void) { token_string[token_len] = '\0'; } +struct namedfloat { + const char *name; + float value; +}; + +static const struct namedfloat namedfloats[] = { + { .name = "+inf.0", .value = INFINITY }, + { .name = "-inf.0", .value = -INFINITY }, + { .name = "+nan.0", .value = NAN }, + { .name = "-nan.0", .value = NAN }, +}; + +#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) + static int _lex(void) { @@ -279,7 +300,7 @@ _lex(void) continue; } - if (lex_class & SPECIAL) { + if (lex_class & (SPECIAL|DOTC)) { add_token(c); end_token(); switch (c) { @@ -357,47 +378,72 @@ _lex(void) } } if (lex_class & PRINTABLE) { - int isnum; + int isfloat; int hasdigit; int isneg; + int isint; + int epos; - isnum = 1; + isfloat = 1; + isint = 1; hasdigit = 0; token_int = 0; isneg = 0; + epos = 0; for (;;) { if (!(lex_class & NUMBER)) { - isnum = 0; + isint = 0; + isfloat = 0; } else { - if (token_len != 0 && + if (!(lex_class & INTEGER)) + isint = 0; + if (token_len != epos && (lex_class & SIGN)) { - isnum = 0; + isint = 0; + isfloat = 0; } if (c == '-') isneg = 1; + if (c == '.' && epos != 0) + isfloat = 0; + if (c == 'e' || c == 'E') { + if (token_len == 0) + isfloat = 0; + else + epos = token_len + 1; + } if (lex_class & DIGIT) { hasdigit = 1; - if (isnum) + if (isint) token_int = token_int * 10 + c - '0'; } } add_token (c); c = lexc (); - if (lex_class & (NOTNAME)) { + if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { + unsigned int u; // if (lex_class & ENDOFFILE) // clearerr (f); lex_unget(c); end_token (); - if (isnum && hasdigit) { + if (isint && hasdigit) { if (isneg) token_int = -token_int; return NUM; } + if (isfloat && hasdigit) { + token_float = atof(token_string); + return FLOAT; + } + for (u = 0; u < NUM_NAMED_FLOATS; u++) + if (!strcmp(namedfloats[u].name, token_string)) { + token_float = namedfloats[u].value; + return FLOAT; + } return NAME; } } - } } } @@ -499,6 +545,9 @@ ao_lisp_read(void) case NUM: v = ao_lisp_integer_poly(token_int); break; + case FLOAT: + v = ao_lisp_float_get(token_float); + break; case BOOL: if (token_string[0] == 't') v = _ao_lisp_bool_true; diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h index fc74a8e4..20c9c18a 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -26,28 +26,30 @@ # define QUOTE 4 # define STRING 5 # define NUM 6 -# define DOT 7 -# define BOOL 8 +# define FLOAT 7 +# define DOT 8 +# define BOOL 9 /* * character classes */ # define PRINTABLE 0x0001 /* \t \n ' ' - '~' */ -# define QUOTED 0x0002 /* \ anything */ -# define SPECIAL 0x0004 /* ( [ { ) ] } ' . */ +# define SPECIAL 0x0002 /* ( [ { ) ] } ' */ +# define DOTC 0x0004 /* . */ # define WHITE 0x0008 /* ' ' \t \n */ # define DIGIT 0x0010 /* [0-9] */ # define SIGN 0x0020 /* +- */ -# define ENDOFFILE 0x0040 /* end of file */ -# define COMMENT 0x0080 /* ; */ -# define IGNORE 0x0100 /* \0 - ' ' */ -# define BACKSLASH 0x0200 /* \ */ -# define VBAR 0x0400 /* | */ +# define FLOATC 0x0040 /* . e E */ +# define ENDOFFILE 0x0080 /* end of file */ +# define COMMENT 0x0100 /* ; */ +# define IGNORE 0x0200 /* \0 - ' ' */ +# define BACKSLASH 0x0400 /* \ */ # define STRINGC 0x0800 /* " */ # define POUND 0x1000 /* # */ -# define NOTNAME (STRINGC|VBAR|COMMENT|ENDOFFILE|WHITE|SPECIAL) -# define NUMBER (DIGIT|SIGN) +# define NOTNAME (STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) +# define INTEGER (DIGIT|SIGN) +# define NUMBER (INTEGER|FLOATC) #endif /* _AO_LISP_READ_H_ */ -- cgit v1.2.3 From 98923ae1189f062b8b94120d47a56892db25493f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 18:28:16 +0100 Subject: altos/lisp: Split out frame vals from frame struct This lets the frame be resized without moving the base structure. The plan is to allow all frames to be resized, not just the global frame. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 38 ++++++-- src/lisp/ao_lisp_error.c | 5 +- src/lisp/ao_lisp_frame.c | 207 ++++++++++++++++++++++++------------------ src/lisp/ao_lisp_make_const.c | 5 +- src/lisp/ao_lisp_mem.c | 42 +++++++++ src/lisp/ao_lisp_poly.c | 4 + 6 files changed, 200 insertions(+), 101 deletions(-) (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 858212dd..96a7a05f 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -92,12 +92,13 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((a #define AO_LISP_ATOM 4 #define AO_LISP_BUILTIN 5 #define AO_LISP_FRAME 6 -#define AO_LISP_LAMBDA 7 -#define AO_LISP_STACK 8 -#define AO_LISP_BOOL 9 -#define AO_LISP_BIGINT 10 -#define AO_LISP_FLOAT 11 -#define AO_LISP_NUM_TYPE 12 +#define AO_LISP_FRAME_VALS 7 +#define AO_LISP_LAMBDA 8 +#define AO_LISP_STACK 9 +#define AO_LISP_BOOL 10 +#define AO_LISP_BIGINT 11 +#define AO_LISP_FLOAT 12 +#define AO_LISP_NUM_TYPE 13 /* Leave two bits for types to use as they please */ #define AO_LISP_OTHER_TYPE_MASK 0x3f @@ -154,11 +155,17 @@ struct ao_lisp_val { ao_poly val; }; +struct ao_lisp_frame_vals { + uint8_t type; + uint8_t size; + struct ao_lisp_val vals[]; +}; + struct ao_lisp_frame { uint8_t type; uint8_t num; ao_poly prev; - struct ao_lisp_val vals[]; + ao_poly vals; }; struct ao_lisp_bool { @@ -221,6 +228,16 @@ ao_lisp_frame_poly(struct ao_lisp_frame *frame) { return ao_lisp_poly(frame, AO_LISP_OTHER); } +static inline struct ao_lisp_frame_vals * +ao_lisp_poly_frame_vals(ao_poly poly) { + return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_frame_vals_poly(struct ao_lisp_frame_vals *vals) { + return ao_lisp_poly(vals, AO_LISP_OTHER); +} + enum eval_state { eval_sexpr, /* Evaluate an sexpr */ eval_val, /* Value computed */ @@ -528,6 +545,12 @@ ao_lisp_stack_fetch(int id) { return ao_lisp_poly_stack(ao_lisp_poly_fetch(id)); } +void +ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame); + +struct ao_lisp_frame * +ao_lisp_frame_fetch(int id); + /* bool */ extern const struct ao_lisp_type ao_lisp_bool_type; @@ -713,6 +736,7 @@ ao_lisp_read_eval_print(void); /* frame */ extern const struct ao_lisp_type ao_lisp_frame_type; +extern const struct ao_lisp_type ao_lisp_frame_vals_type; #define AO_LISP_FRAME_FREE 6 diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index d1c9b941..ba135834 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -57,6 +57,7 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf ("%s{", name); if (frame) { + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); if (frame->type & AO_LISP_FRAME_PRINT) printf("recurse..."); else { @@ -66,9 +67,9 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf(" "); } - ao_lisp_poly_write(frame->vals[f].atom); + ao_lisp_poly_write(vals->vals[f].atom); printf(" = "); - ao_lisp_poly_write(frame->vals[f].val); + ao_lisp_poly_write(vals->vals[f].val); printf("\n"); } if (frame->prev) diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index ebdb7757..dd29e079 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -15,37 +15,77 @@ #include "ao_lisp.h" static inline int -frame_num_size(int num) +frame_vals_num_size(int num) { - return sizeof (struct ao_lisp_frame) + num * sizeof (struct ao_lisp_val); + return sizeof (struct ao_lisp_frame_vals) + num * sizeof (struct ao_lisp_val); } +static int +frame_vals_size(void *addr) +{ + struct ao_lisp_frame_vals *vals = addr; + return frame_vals_num_size(vals->size); +} + +static void +frame_vals_mark(void *addr) +{ + struct ao_lisp_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_lisp_val *v = &vals->vals[f]; + + ao_lisp_poly_mark(v->val, 0); + MDBG_MOVE("frame mark atom %s %d val %d at %d\n", + ao_lisp_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_lisp_ref(v->atom)), + MDBG_OFFSET(ao_lisp_ref(v->val)), f); + } +} + +static void +frame_vals_move(void *addr) +{ + struct ao_lisp_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_lisp_val *v = &vals->vals[f]; + + ao_lisp_poly_move(&v->atom, 0); + ao_lisp_poly_move(&v->val, 0); + MDBG_MOVE("frame move atom %s %d val %d at %d\n", + ao_lisp_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_lisp_ref(v->atom)), + MDBG_OFFSET(ao_lisp_ref(v->val)), f); + } +} + +const struct ao_lisp_type ao_lisp_frame_vals_type = { + .mark = frame_vals_mark, + .size = frame_vals_size, + .move = frame_vals_move, + .name = "frame_vals" +}; + static int frame_size(void *addr) { - struct ao_lisp_frame *frame = addr; - return frame_num_size(frame->num); + (void) addr; + return sizeof (struct ao_lisp_frame); } static void frame_mark(void *addr) { struct ao_lisp_frame *frame = addr; - int f; for (;;) { MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < frame->num; f++) { - struct ao_lisp_val *v = &frame->vals[f]; - - ao_lisp_poly_mark(v->val, 0); - MDBG_MOVE("frame mark atom %s %d val %d at %d\n", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - } + ao_lisp_poly_mark(frame->vals, 0); frame = ao_lisp_poly_frame(frame->prev); MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); if (!frame) @@ -59,7 +99,6 @@ static void frame_move(void *addr) { struct ao_lisp_frame *frame = addr; - int f; for (;;) { struct ao_lisp_frame *prev; @@ -68,16 +107,7 @@ frame_move(void *addr) MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < frame->num; f++) { - struct ao_lisp_val *v = &frame->vals[f]; - - ao_lisp_poly_move(&v->atom, 0); - ao_lisp_poly_move(&v->val, 0); - MDBG_MOVE("frame move atom %s %d val %d at %d\n", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - } + ao_lisp_poly_move(&frame->vals, 0); prev = ao_lisp_poly_frame(frame->prev); if (!prev) break; @@ -104,8 +134,9 @@ const struct ao_lisp_type ao_lisp_frame_type = { void ao_lisp_frame_write(ao_poly p) { - struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); - int f; + struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); + int f; printf ("{"); if (frame) { @@ -116,9 +147,9 @@ ao_lisp_frame_write(ao_poly p) for (f = 0; f < frame->num; f++) { if (f != 0) printf(", "); - ao_lisp_poly_write(frame->vals[f].atom); + ao_lisp_poly_write(vals->vals[f].atom); printf(" = "); - ao_lisp_poly_write(frame->vals[f].val); + ao_lisp_poly_write(vals->vals[f].val); } if (frame->prev) ao_lisp_poly_write(frame->prev); @@ -131,11 +162,13 @@ ao_lisp_frame_write(ao_poly p) static int ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) { - int l = 0; - int r = top - 1; + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); + int l = 0; + int r = top - 1; + while (l <= r) { int m = (l + r) >> 1; - if (frame->vals[m].atom < atom) + if (vals->vals[m].atom < atom) l = m + 1; else r = m - 1; @@ -146,62 +179,57 @@ ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { - int l = ao_lisp_frame_find(frame, frame->num, atom); + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); + int l = ao_lisp_frame_find(frame, frame->num, atom); if (l >= frame->num) return NULL; - if (frame->vals[l].atom != atom) + if (vals->vals[l].atom != atom) return NULL; - return &frame->vals[l].val; + return &vals->vals[l].val; } -int -ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) -{ - while (frame) { - if (!AO_LISP_IS_CONST(frame)) { - ao_poly *ref = ao_lisp_frame_ref(frame, atom); - if (ref) { - *ref = val; - return 1; - } - } - frame = ao_lisp_poly_frame(frame->prev); - } - return 0; -} +struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; -ao_poly -ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) +static struct ao_lisp_frame_vals * +ao_lisp_frame_vals_new(int num) { - while (frame) { - ao_poly *ref = ao_lisp_frame_ref(frame, atom); - if (ref) - return *ref; - frame = ao_lisp_poly_frame(frame->prev); - } - return AO_LISP_NIL; -} + struct ao_lisp_frame_vals *vals; -struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; + vals = ao_lisp_alloc(frame_vals_num_size(num)); + if (!vals) + return NULL; + vals->type = AO_LISP_FRAME_VALS; + vals->size = num; + return vals; +} struct ao_lisp_frame * ao_lisp_frame_new(int num) { - struct ao_lisp_frame *frame; + struct ao_lisp_frame *frame; + struct ao_lisp_frame_vals *vals; - if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) + if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) { ao_lisp_frame_free_list[num] = ao_lisp_poly_frame(frame->prev); - else { - frame = ao_lisp_alloc(frame_num_size(num)); + vals = ao_lisp_poly_frame_vals(frame->vals); + } else { + frame = ao_lisp_alloc(sizeof (struct ao_lisp_frame)); if (!frame) return NULL; + frame->type = AO_LISP_FRAME; + frame->num = 0; + frame->prev = AO_LISP_NIL; + frame->vals = AO_LISP_NIL; + ao_lisp_poly_stash(0, ao_lisp_frame_poly(frame)); + vals = ao_lisp_frame_vals_new(num); + frame = ao_lisp_poly_frame(ao_lisp_poly_fetch(0)); + frame->vals = ao_lisp_frame_vals_poly(vals); } - frame->type = AO_LISP_FRAME; frame->num = num; frame->prev = AO_LISP_NIL; - memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); + memset(vals, '\0', vals->size * sizeof (struct ao_lisp_val)); return frame; } @@ -227,47 +255,46 @@ ao_lisp_frame_free(struct ao_lisp_frame *frame) } static struct ao_lisp_frame * -ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) +ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) { - struct ao_lisp_frame *frame = *frame_ref; - struct ao_lisp_frame *new; - int copy; + struct ao_lisp_frame_vals *vals; + struct ao_lisp_frame_vals *new_vals; + int copy; if (new_num == frame->num) return frame; - new = ao_lisp_frame_new(new_num); - if (!new) + ao_lisp_frame_stash(0, frame); + new_vals = ao_lisp_frame_vals_new(new_num); + if (!new_vals) return NULL; - /* - * Re-fetch the frame as it may have moved - * during the allocation - */ - frame = *frame_ref; + frame = ao_lisp_frame_fetch(0); + vals = ao_lisp_poly_frame_vals(frame->vals); copy = new_num; if (copy > frame->num) copy = frame->num; - memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); - new->prev = frame->prev; - ao_lisp_frame_free(frame); - return new; + memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_lisp_val)); + frame->vals = ao_lisp_frame_vals_poly(new_vals); + frame->num = new_num; + return frame; } void ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val) { - int l = ao_lisp_frame_find(frame, num, atom); + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); + int l = ao_lisp_frame_find(frame, num, atom); - memmove(&frame->vals[l+1], - &frame->vals[l], + memmove(&vals->vals[l+1], + &vals->vals[l], (num - l) * sizeof (struct ao_lisp_val)); - frame->vals[l].atom = atom; - frame->vals[l].val = val; + vals->vals[l].atom = atom; + vals->vals[l].val = val; } int ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) { - struct ao_lisp_frame *frame = *frame_ref; + struct ao_lisp_frame *frame = *frame_ref; ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; if (!ref) { @@ -276,14 +303,14 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) ao_lisp_poly_stash(1, val); if (frame) { f = frame->num; - frame = ao_lisp_frame_realloc(frame_ref, f + 1); + frame = ao_lisp_frame_realloc(frame, f + 1); } else { f = 0; frame = ao_lisp_frame_new(1); + *frame_ref = frame; } if (!frame) return 0; - *frame_ref = frame; atom = ao_lisp_poly_fetch(0); val = ao_lisp_poly_fetch(1); ao_lisp_frame_bind(frame, frame->num - 1, atom, val); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index f23d34db..f9bb5452 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -326,10 +326,11 @@ main(int argc, char **argv) ao_lisp_collect(AO_LISP_COLLECT_FULL); for (f = 0; f < ao_lisp_frame_global->num; f++) { - val = ao_has_macro(ao_lisp_frame_global->vals[f].val); + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(ao_lisp_frame_global->vals); + val = ao_has_macro(vals->vals[f].val); if (val != AO_LISP_NIL) { printf("error: function %s contains unresolved macro: ", - ao_lisp_poly_atom(ao_lisp_frame_global->vals[f].atom)->name); + ao_lisp_poly_atom(vals->vals[f].atom)->name); ao_lisp_poly_write(val); printf("\n"); exit(1); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index dc0008c4..890eba1b 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -148,6 +148,7 @@ struct ao_lisp_root { static struct ao_lisp_cons *save_cons[2]; static char *save_string[2]; +static struct ao_lisp_frame *save_frame[1]; static ao_poly save_poly[3]; static const struct ao_lisp_root ao_lisp_root[] = { @@ -167,6 +168,10 @@ static const struct ao_lisp_root ao_lisp_root[] = { .type = &ao_lisp_string_type, .addr = (void **) &save_string[1], }, + { + .type = &ao_lisp_frame_type, + .addr = (void **) &save_frame[0], + }, { .type = NULL, .addr = (void **) (void *) &save_poly[0] @@ -455,6 +460,7 @@ static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_ATOM] = &ao_lisp_atom_type, [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, [AO_LISP_FRAME] = &ao_lisp_frame_type, + [AO_LISP_FRAME_VALS] = &ao_lisp_frame_vals_type, [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, [AO_LISP_STACK] = &ao_lisp_stack_type, [AO_LISP_BOOL] = &ao_lisp_bool_type, @@ -620,6 +626,29 @@ ao_lisp_collect(uint8_t style) * Mark interfaces for objects */ + +/* + * Mark a block of memory with an explicit size + */ + +int +ao_lisp_mark_block(void *addr, int size) +{ + int offset; + if (!AO_LISP_IS_POOL(addr)) + return 1; + + offset = pool_offset(addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (busy(ao_lisp_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; + } + mark(ao_lisp_busy, offset); + note_chunk(offset, size); + return 0; +} + /* * Note a reference to memory and collect information about a few * object sizes at a time @@ -891,3 +920,16 @@ ao_lisp_string_fetch(int id) return string; } +void +ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame) +{ + save_frame[id] = frame; +} + +struct ao_lisp_frame * +ao_lisp_frame_fetch(int id) +{ + struct ao_lisp_frame *frame = save_frame[id]; + save_frame[id] = NULL; + return frame; +} diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index e93e1192..d14f4151 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -44,6 +44,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .write = ao_lisp_frame_write, .display = ao_lisp_frame_write, }, + [AO_LISP_FRAME_VALS] = { + .write = NULL, + .display = NULL, + }, [AO_LISP_LAMBDA] = { .write = ao_lisp_lambda_write, .display = ao_lisp_lambda_write, -- cgit v1.2.3 From 195cbeec19a6a44f309a9040d727d37fe4e2ec97 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 10:29:13 -0800 Subject: altos/scheme: Rename to 'scheme', clean up build Constant block is now built in a subdir to avoid messing up source directory. Renamed to ao_scheme to reflect language target. Signed-off-by: Keith Packard --- src/lisp/.gitignore | 3 - src/lisp/Makefile | 24 - src/lisp/Makefile-inc | 24 - src/lisp/Makefile-lisp | 4 - src/lisp/README | 11 - src/lisp/ao_lisp.h | 928 --------------------------------- src/lisp/ao_lisp_atom.c | 159 ------ src/lisp/ao_lisp_bool.c | 73 --- src/lisp/ao_lisp_builtin.c | 868 ------------------------------- src/lisp/ao_lisp_builtin.txt | 68 --- src/lisp/ao_lisp_cons.c | 184 ------- src/lisp/ao_lisp_const.lisp | 813 ----------------------------- src/lisp/ao_lisp_error.c | 139 ----- src/lisp/ao_lisp_eval.c | 578 --------------------- src/lisp/ao_lisp_float.c | 148 ------ src/lisp/ao_lisp_frame.c | 330 ------------ src/lisp/ao_lisp_int.c | 79 --- src/lisp/ao_lisp_lambda.c | 208 -------- src/lisp/ao_lisp_lex.c | 16 - src/lisp/ao_lisp_make_builtin | 190 ------- src/lisp/ao_lisp_make_const.c | 395 -------------- src/lisp/ao_lisp_mem.c | 968 ----------------------------------- src/lisp/ao_lisp_os.h | 63 --- src/lisp/ao_lisp_poly.c | 118 ----- src/lisp/ao_lisp_read.c | 655 ------------------------ src/lisp/ao_lisp_read.h | 58 --- src/lisp/ao_lisp_rep.c | 36 -- src/lisp/ao_lisp_save.c | 77 --- src/lisp/ao_lisp_stack.c | 280 ---------- src/lisp/ao_lisp_string.c | 161 ------ src/scheme/.gitignore | 2 + src/scheme/Makefile | 16 + src/scheme/Makefile-inc | 24 + src/scheme/Makefile-scheme | 4 + src/scheme/README | 10 + src/scheme/ao_scheme.h | 928 +++++++++++++++++++++++++++++++++ src/scheme/ao_scheme_atom.c | 167 ++++++ src/scheme/ao_scheme_bool.c | 73 +++ src/scheme/ao_scheme_builtin.c | 868 +++++++++++++++++++++++++++++++ src/scheme/ao_scheme_builtin.txt | 68 +++ src/scheme/ao_scheme_cons.c | 201 ++++++++ src/scheme/ao_scheme_const.lisp | 813 +++++++++++++++++++++++++++++ src/scheme/ao_scheme_error.c | 139 +++++ src/scheme/ao_scheme_eval.c | 578 +++++++++++++++++++++ src/scheme/ao_scheme_float.c | 148 ++++++ src/scheme/ao_scheme_frame.c | 330 ++++++++++++ src/scheme/ao_scheme_int.c | 79 +++ src/scheme/ao_scheme_lambda.c | 208 ++++++++ src/scheme/ao_scheme_lex.c | 16 + src/scheme/ao_scheme_make_builtin | 190 +++++++ src/scheme/ao_scheme_make_const.c | 395 ++++++++++++++ src/scheme/ao_scheme_mem.c | 968 +++++++++++++++++++++++++++++++++++ src/scheme/ao_scheme_poly.c | 118 +++++ src/scheme/ao_scheme_read.c | 655 ++++++++++++++++++++++++ src/scheme/ao_scheme_read.h | 58 +++ src/scheme/ao_scheme_rep.c | 36 ++ src/scheme/ao_scheme_save.c | 77 +++ src/scheme/ao_scheme_stack.c | 280 ++++++++++ src/scheme/ao_scheme_string.c | 161 ++++++ src/scheme/make-const/.gitignore | 1 + src/scheme/make-const/Makefile | 26 + src/scheme/make-const/ao_scheme_os.h | 63 +++ src/test/ao_lisp_os.h | 68 --- src/test/ao_lisp_test.c | 134 ----- src/test/ao_scheme_os.h | 68 +++ src/test/ao_scheme_test.c | 134 +++++ 66 files changed, 7902 insertions(+), 7860 deletions(-) delete mode 100644 src/lisp/.gitignore delete mode 100644 src/lisp/Makefile delete mode 100644 src/lisp/Makefile-inc delete mode 100644 src/lisp/Makefile-lisp delete mode 100644 src/lisp/README delete mode 100644 src/lisp/ao_lisp.h delete mode 100644 src/lisp/ao_lisp_atom.c delete mode 100644 src/lisp/ao_lisp_bool.c delete mode 100644 src/lisp/ao_lisp_builtin.c delete mode 100644 src/lisp/ao_lisp_builtin.txt delete mode 100644 src/lisp/ao_lisp_cons.c delete mode 100644 src/lisp/ao_lisp_const.lisp delete mode 100644 src/lisp/ao_lisp_error.c delete mode 100644 src/lisp/ao_lisp_eval.c delete mode 100644 src/lisp/ao_lisp_float.c delete mode 100644 src/lisp/ao_lisp_frame.c delete mode 100644 src/lisp/ao_lisp_int.c delete mode 100644 src/lisp/ao_lisp_lambda.c delete mode 100644 src/lisp/ao_lisp_lex.c delete mode 100644 src/lisp/ao_lisp_make_builtin delete mode 100644 src/lisp/ao_lisp_make_const.c delete mode 100644 src/lisp/ao_lisp_mem.c delete mode 100644 src/lisp/ao_lisp_os.h delete mode 100644 src/lisp/ao_lisp_poly.c delete mode 100644 src/lisp/ao_lisp_read.c delete mode 100644 src/lisp/ao_lisp_read.h delete mode 100644 src/lisp/ao_lisp_rep.c delete mode 100644 src/lisp/ao_lisp_save.c delete mode 100644 src/lisp/ao_lisp_stack.c delete mode 100644 src/lisp/ao_lisp_string.c create mode 100644 src/scheme/.gitignore create mode 100644 src/scheme/Makefile create mode 100644 src/scheme/Makefile-inc create mode 100644 src/scheme/Makefile-scheme create mode 100644 src/scheme/README create mode 100644 src/scheme/ao_scheme.h create mode 100644 src/scheme/ao_scheme_atom.c create mode 100644 src/scheme/ao_scheme_bool.c create mode 100644 src/scheme/ao_scheme_builtin.c create mode 100644 src/scheme/ao_scheme_builtin.txt create mode 100644 src/scheme/ao_scheme_cons.c create mode 100644 src/scheme/ao_scheme_const.lisp create mode 100644 src/scheme/ao_scheme_error.c create mode 100644 src/scheme/ao_scheme_eval.c create mode 100644 src/scheme/ao_scheme_float.c create mode 100644 src/scheme/ao_scheme_frame.c create mode 100644 src/scheme/ao_scheme_int.c create mode 100644 src/scheme/ao_scheme_lambda.c create mode 100644 src/scheme/ao_scheme_lex.c create mode 100644 src/scheme/ao_scheme_make_builtin create mode 100644 src/scheme/ao_scheme_make_const.c create mode 100644 src/scheme/ao_scheme_mem.c create mode 100644 src/scheme/ao_scheme_poly.c create mode 100644 src/scheme/ao_scheme_read.c create mode 100644 src/scheme/ao_scheme_read.h create mode 100644 src/scheme/ao_scheme_rep.c create mode 100644 src/scheme/ao_scheme_save.c create mode 100644 src/scheme/ao_scheme_stack.c create mode 100644 src/scheme/ao_scheme_string.c create mode 100644 src/scheme/make-const/.gitignore create mode 100644 src/scheme/make-const/Makefile create mode 100644 src/scheme/make-const/ao_scheme_os.h delete mode 100644 src/test/ao_lisp_os.h delete mode 100644 src/test/ao_lisp_test.c create mode 100644 src/test/ao_scheme_os.h create mode 100644 src/test/ao_scheme_test.c (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore deleted file mode 100644 index 1faa9b67..00000000 --- a/src/lisp/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -ao_lisp_make_const -ao_lisp_const.h -ao_lisp_builtin.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile deleted file mode 100644 index 05f54550..00000000 --- a/src/lisp/Makefile +++ /dev/null @@ -1,24 +0,0 @@ -all: ao_lisp_builtin.h ao_lisp_const.h - -clean: - rm -f ao_lisp_const.h ao_lisp_builtin.h $(OBJS) ao_lisp_make_const - -ao_lisp_const.h: ao_lisp_const.lisp ao_lisp_make_const - ./ao_lisp_make_const -o $@ ao_lisp_const.lisp - -ao_lisp_builtin.h: ao_lisp_make_builtin ao_lisp_builtin.txt - nickle ./ao_lisp_make_builtin ao_lisp_builtin.txt > $@ - -include Makefile-inc -SRCS=$(LISP_SRCS) ao_lisp_make_const.c - -HDRS=$(LISP_HDRS) - -OBJS=$(SRCS:.c=.o) - -CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra -no-pie - -ao_lisp_make_const: $(OBJS) - $(CC) $(CFLAGS) -o $@ $(OBJS) -lm - -$(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc deleted file mode 100644 index a097f1be..00000000 --- a/src/lisp/Makefile-inc +++ /dev/null @@ -1,24 +0,0 @@ -LISP_SRCS=\ - ao_lisp_mem.c \ - ao_lisp_cons.c \ - ao_lisp_string.c \ - ao_lisp_atom.c \ - ao_lisp_int.c \ - ao_lisp_poly.c \ - ao_lisp_bool.c \ - ao_lisp_float.c \ - ao_lisp_builtin.c \ - ao_lisp_read.c \ - ao_lisp_frame.c \ - ao_lisp_lambda.c \ - ao_lisp_eval.c \ - ao_lisp_rep.c \ - ao_lisp_save.c \ - ao_lisp_stack.c \ - ao_lisp_error.c - -LISP_HDRS=\ - ao_lisp.h \ - ao_lisp_os.h \ - ao_lisp_read.h \ - ao_lisp_builtin.h diff --git a/src/lisp/Makefile-lisp b/src/lisp/Makefile-lisp deleted file mode 100644 index 998c7673..00000000 --- a/src/lisp/Makefile-lisp +++ /dev/null @@ -1,4 +0,0 @@ -include ../lisp/Makefile-inc - -ao_lisp_const.h: $(LISP_SRCS) $(LISP_HDRS) - +cd ../lisp && make $@ diff --git a/src/lisp/README b/src/lisp/README deleted file mode 100644 index c1e84475..00000000 --- a/src/lisp/README +++ /dev/null @@ -1,11 +0,0 @@ -This follows the R7RS with the following known exceptions: - -* No vectors or bytevectors -* Characters are just numbers -* No dynamic-wind or exceptions -* No environments -* No ports -* No syntax-rules; we have macros instead -* define inside of lambda does not add name to lambda scope -* No record types -* No libraries diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h deleted file mode 100644 index b5e03b1e..00000000 --- a/src/lisp/ao_lisp.h +++ /dev/null @@ -1,928 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#ifndef _AO_LISP_H_ -#define _AO_LISP_H_ - -#define DBG_MEM 0 -#define DBG_EVAL 0 -#define DBG_READ 0 -#define DBG_FREE_CONS 0 -#define NDEBUG 1 - -#include -#include -#include -#ifndef __BYTE_ORDER -#include -#endif - -typedef uint16_t ao_poly; -typedef int16_t ao_signed_poly; - -#ifdef AO_LISP_SAVE - -struct ao_lisp_os_save { - ao_poly atoms; - ao_poly globals; - uint16_t const_checksum; - uint16_t const_checksum_inv; -}; - -#define AO_LISP_POOL_EXTRA (sizeof(struct ao_lisp_os_save)) -#define AO_LISP_POOL ((int) (AO_LISP_POOL_TOTAL - AO_LISP_POOL_EXTRA)) - -int -ao_lisp_os_save(void); - -int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset); - -int -ao_lisp_os_restore(void); - -#endif - -#ifdef AO_LISP_MAKE_CONST -#define AO_LISP_POOL_CONST 16384 -extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); -#define ao_lisp_pool ao_lisp_const -#define AO_LISP_POOL AO_LISP_POOL_CONST - -#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n)) -#define _bool(v) ao_lisp_bool_poly(ao_lisp_bool_get(v)) - -#define _ao_lisp_bool_true _bool(1) -#define _ao_lisp_bool_false _bool(0) - -#define _ao_lisp_atom_eof _atom("eof") -#define _ao_lisp_atom_else _atom("else") - -#define AO_LISP_BUILTIN_ATOMS -#include "ao_lisp_builtin.h" - -#else -#include "ao_lisp_const.h" -#ifndef AO_LISP_POOL -#define AO_LISP_POOL 3072 -#endif -extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); -#endif - -/* Primitive types */ -#define AO_LISP_CONS 0 -#define AO_LISP_INT 1 -#define AO_LISP_STRING 2 -#define AO_LISP_OTHER 3 - -#define AO_LISP_TYPE_MASK 0x0003 -#define AO_LISP_TYPE_SHIFT 2 -#define AO_LISP_REF_MASK 0x7ffc -#define AO_LISP_CONST 0x8000 - -/* These have a type value at the start of the struct */ -#define AO_LISP_ATOM 4 -#define AO_LISP_BUILTIN 5 -#define AO_LISP_FRAME 6 -#define AO_LISP_FRAME_VALS 7 -#define AO_LISP_LAMBDA 8 -#define AO_LISP_STACK 9 -#define AO_LISP_BOOL 10 -#define AO_LISP_BIGINT 11 -#define AO_LISP_FLOAT 12 -#define AO_LISP_NUM_TYPE 13 - -/* Leave two bits for types to use as they please */ -#define AO_LISP_OTHER_TYPE_MASK 0x3f - -#define AO_LISP_NIL 0 - -extern uint16_t ao_lisp_top; - -#define AO_LISP_OOM 0x01 -#define AO_LISP_DIVIDE_BY_ZERO 0x02 -#define AO_LISP_INVALID 0x04 -#define AO_LISP_UNDEFINED 0x08 -#define AO_LISP_REDEFINED 0x10 -#define AO_LISP_EOF 0x20 -#define AO_LISP_EXIT 0x40 - -extern uint8_t ao_lisp_exception; - -static inline int -ao_lisp_is_const(ao_poly poly) { - return poly & AO_LISP_CONST; -} - -#define AO_LISP_IS_CONST(a) (ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST) -#define AO_LISP_IS_POOL(a) (ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) -#define AO_LISP_IS_INT(p) (ao_lisp_poly_base_type(p) == AO_LISP_INT) - -void * -ao_lisp_ref(ao_poly poly); - -ao_poly -ao_lisp_poly(const void *addr, ao_poly type); - -struct ao_lisp_type { - int (*size)(void *addr); - void (*mark)(void *addr); - void (*move)(void *addr); - char name[]; -}; - -struct ao_lisp_cons { - ao_poly car; - ao_poly cdr; -}; - -struct ao_lisp_atom { - uint8_t type; - uint8_t pad[1]; - ao_poly next; - char name[]; -}; - -struct ao_lisp_val { - ao_poly atom; - ao_poly val; -}; - -struct ao_lisp_frame_vals { - uint8_t type; - uint8_t size; - struct ao_lisp_val vals[]; -}; - -struct ao_lisp_frame { - uint8_t type; - uint8_t num; - ao_poly prev; - ao_poly vals; -}; - -struct ao_lisp_bool { - uint8_t type; - uint8_t value; - uint16_t pad; -}; - -struct ao_lisp_bigint { - uint32_t value; -}; - -struct ao_lisp_float { - uint8_t type; - uint8_t pad1; - uint16_t pad2; - float value; -}; - -#if __BYTE_ORDER == __LITTLE_ENDIAN -static inline uint32_t -ao_lisp_int_bigint(int32_t i) { - return AO_LISP_BIGINT | (i << 8); -} -static inline int32_t -ao_lisp_bigint_int(uint32_t bi) { - return (int32_t) bi >> 8; -} -#else -static inline uint32_t -ao_lisp_int_bigint(int32_t i) { - return (uint32_t) (i & 0xffffff) | (AO_LISP_BIGINT << 24); -} -static inlint int32_t -ao_lisp_bigint_int(uint32_t bi) { - return (int32_t) (bi << 8) >> 8; -} -#endif - -#define AO_LISP_MIN_INT (-(1 << (15 - AO_LISP_TYPE_SHIFT))) -#define AO_LISP_MAX_INT ((1 << (15 - AO_LISP_TYPE_SHIFT)) - 1) -#define AO_LISP_MIN_BIGINT (-(1 << 24)) -#define AO_LISP_MAX_BIGINT ((1 << 24) - 1) - -#define AO_LISP_NOT_INTEGER 0x7fffffff - -/* Set on type when the frame escapes the lambda */ -#define AO_LISP_FRAME_MARK 0x80 -#define AO_LISP_FRAME_PRINT 0x40 - -static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { - return f->type & AO_LISP_FRAME_MARK; -} - -static inline struct ao_lisp_frame * -ao_lisp_poly_frame(ao_poly poly) { - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_frame_poly(struct ao_lisp_frame *frame) { - return ao_lisp_poly(frame, AO_LISP_OTHER); -} - -static inline struct ao_lisp_frame_vals * -ao_lisp_poly_frame_vals(ao_poly poly) { - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_frame_vals_poly(struct ao_lisp_frame_vals *vals) { - return ao_lisp_poly(vals, AO_LISP_OTHER); -} - -enum eval_state { - eval_sexpr, /* Evaluate an sexpr */ - eval_val, /* Value computed */ - eval_formal, /* Formal computed */ - eval_exec, /* Start a lambda evaluation */ - eval_apply, /* Execute apply */ - eval_cond, /* Start next cond clause */ - eval_cond_test, /* Check cond condition */ - eval_begin, /* Start next begin entry */ - eval_while, /* Start while condition */ - eval_while_test, /* Check while condition */ - eval_macro, /* Finished with macro generation */ -}; - -struct ao_lisp_stack { - uint8_t type; /* AO_LISP_STACK */ - uint8_t state; /* enum eval_state */ - ao_poly prev; /* previous stack frame */ - ao_poly sexprs; /* expressions to evaluate */ - ao_poly values; /* values computed */ - ao_poly values_tail; /* end of the values list for easy appending */ - ao_poly frame; /* current lookup frame */ - ao_poly list; /* most recent function call */ -}; - -#define AO_LISP_STACK_MARK 0x80 /* set on type when a reference has been taken */ -#define AO_LISP_STACK_PRINT 0x40 /* stack is being printed */ - -static inline int ao_lisp_stack_marked(struct ao_lisp_stack *s) { - return s->type & AO_LISP_STACK_MARK; -} - -static inline void ao_lisp_stack_mark(struct ao_lisp_stack *s) { - s->type |= AO_LISP_STACK_MARK; -} - -static inline struct ao_lisp_stack * -ao_lisp_poly_stack(ao_poly p) -{ - return ao_lisp_ref(p); -} - -static inline ao_poly -ao_lisp_stack_poly(struct ao_lisp_stack *stack) -{ - return ao_lisp_poly(stack, AO_LISP_OTHER); -} - -extern ao_poly ao_lisp_v; - -#define AO_LISP_FUNC_LAMBDA 0 -#define AO_LISP_FUNC_NLAMBDA 1 -#define AO_LISP_FUNC_MACRO 2 - -#define AO_LISP_FUNC_FREE_ARGS 0x80 -#define AO_LISP_FUNC_MASK 0x7f - -#define AO_LISP_FUNC_F_LAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LAMBDA) -#define AO_LISP_FUNC_F_NLAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_NLAMBDA) -#define AO_LISP_FUNC_F_MACRO (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_MACRO) - -struct ao_lisp_builtin { - uint8_t type; - uint8_t args; - uint16_t func; -}; - -#define AO_LISP_BUILTIN_ID -#include "ao_lisp_builtin.h" - -typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); - -extern const ao_lisp_func_t ao_lisp_builtins[]; - -static inline ao_lisp_func_t -ao_lisp_func(struct ao_lisp_builtin *b) -{ - return ao_lisp_builtins[b->func]; -} - -struct ao_lisp_lambda { - uint8_t type; - uint8_t args; - ao_poly code; - ao_poly frame; -}; - -static inline struct ao_lisp_lambda * -ao_lisp_poly_lambda(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_lambda_poly(struct ao_lisp_lambda *lambda) -{ - return ao_lisp_poly(lambda, AO_LISP_OTHER); -} - -static inline void * -ao_lisp_poly_other(ao_poly poly) { - return ao_lisp_ref(poly); -} - -static inline uint8_t -ao_lisp_other_type(void *other) { -#if DBG_MEM - if ((*((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK) >= AO_LISP_NUM_TYPE) - ao_lisp_abort(); -#endif - return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK; -} - -static inline ao_poly -ao_lisp_other_poly(const void *other) -{ - return ao_lisp_poly(other, AO_LISP_OTHER); -} - -static inline int -ao_lisp_size_round(int size) -{ - return (size + 3) & ~3; -} - -static inline int -ao_lisp_size(const struct ao_lisp_type *type, void *addr) -{ - return ao_lisp_size_round(type->size(addr)); -} - -#define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) - -static inline int ao_lisp_poly_base_type(ao_poly poly) { - return poly & AO_LISP_TYPE_MASK; -} - -static inline int ao_lisp_poly_type(ao_poly poly) { - int type = poly & AO_LISP_TYPE_MASK; - if (type == AO_LISP_OTHER) - return ao_lisp_other_type(ao_lisp_poly_other(poly)); - return type; -} - -static inline int -ao_lisp_is_cons(ao_poly poly) { - return (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); -} - -static inline int -ao_lisp_is_pair(ao_poly poly) { - return poly != AO_LISP_NIL && (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); -} - -static inline struct ao_lisp_cons * -ao_lisp_poly_cons(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_cons_poly(struct ao_lisp_cons *cons) -{ - return ao_lisp_poly(cons, AO_LISP_CONS); -} - -static inline int32_t -ao_lisp_poly_int(ao_poly poly) -{ - return (int32_t) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); -} - -static inline ao_poly -ao_lisp_int_poly(int32_t i) -{ - return ((ao_poly) i << 2) | AO_LISP_INT; -} - -static inline struct ao_lisp_bigint * -ao_lisp_poly_bigint(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_bigint_poly(struct ao_lisp_bigint *bi) -{ - return ao_lisp_poly(bi, AO_LISP_OTHER); -} - -static inline char * -ao_lisp_poly_string(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_string_poly(char *s) -{ - return ao_lisp_poly(s, AO_LISP_STRING); -} - -static inline struct ao_lisp_atom * -ao_lisp_poly_atom(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_atom_poly(struct ao_lisp_atom *a) -{ - return ao_lisp_poly(a, AO_LISP_OTHER); -} - -static inline struct ao_lisp_builtin * -ao_lisp_poly_builtin(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_builtin_poly(struct ao_lisp_builtin *b) -{ - return ao_lisp_poly(b, AO_LISP_OTHER); -} - -static inline ao_poly -ao_lisp_bool_poly(struct ao_lisp_bool *b) -{ - return ao_lisp_poly(b, AO_LISP_OTHER); -} - -static inline struct ao_lisp_bool * -ao_lisp_poly_bool(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_float_poly(struct ao_lisp_float *f) -{ - return ao_lisp_poly(f, AO_LISP_OTHER); -} - -static inline struct ao_lisp_float * -ao_lisp_poly_float(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -float -ao_lisp_poly_number(ao_poly p); - -/* memory functions */ - -extern int ao_lisp_collects[2]; -extern int ao_lisp_freed[2]; -extern int ao_lisp_loops[2]; - -/* returns 1 if the object was already marked */ -int -ao_lisp_mark(const struct ao_lisp_type *type, void *addr); - -/* returns 1 if the object was already marked */ -int -ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr); - -void * -ao_lisp_move_map(void *addr); - -/* returns 1 if the object was already moved */ -int -ao_lisp_move(const struct ao_lisp_type *type, void **ref); - -/* returns 1 if the object was already moved */ -int -ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref); - -void * -ao_lisp_alloc(int size); - -#define AO_LISP_COLLECT_FULL 1 -#define AO_LISP_COLLECT_INCREMENTAL 0 - -int -ao_lisp_collect(uint8_t style); - -#if DBG_FREE_CONS -void -ao_lisp_cons_check(struct ao_lisp_cons *cons); -#endif - -void -ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons); - -struct ao_lisp_cons * -ao_lisp_cons_fetch(int id); - -void -ao_lisp_poly_stash(int id, ao_poly poly); - -ao_poly -ao_lisp_poly_fetch(int id); - -void -ao_lisp_string_stash(int id, char *string); - -char * -ao_lisp_string_fetch(int id); - -static inline void -ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack) { - ao_lisp_poly_stash(id, ao_lisp_stack_poly(stack)); -} - -static inline struct ao_lisp_stack * -ao_lisp_stack_fetch(int id) { - return ao_lisp_poly_stack(ao_lisp_poly_fetch(id)); -} - -void -ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame); - -struct ao_lisp_frame * -ao_lisp_frame_fetch(int id); - -/* bool */ - -extern const struct ao_lisp_type ao_lisp_bool_type; - -void -ao_lisp_bool_write(ao_poly v); - -#ifdef AO_LISP_MAKE_CONST -struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; - -struct ao_lisp_bool * -ao_lisp_bool_get(uint8_t value); -#endif - -/* cons */ -extern const struct ao_lisp_type ao_lisp_cons_type; - -struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, ao_poly cdr); - -/* Return a cons or NULL for a proper list, else error */ -struct ao_lisp_cons * -ao_lisp_cons_cdr(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp__cons(ao_poly car, ao_poly cdr); - -extern struct ao_lisp_cons *ao_lisp_cons_free_list; - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons); - -void -ao_lisp_cons_write(ao_poly); - -void -ao_lisp_cons_display(ao_poly); - -int -ao_lisp_cons_length(struct ao_lisp_cons *cons); - -/* string */ -extern const struct ao_lisp_type ao_lisp_string_type; - -char * -ao_lisp_string_copy(char *a); - -char * -ao_lisp_string_cat(char *a, char *b); - -ao_poly -ao_lisp_string_pack(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_string_unpack(char *a); - -void -ao_lisp_string_write(ao_poly s); - -void -ao_lisp_string_display(ao_poly s); - -/* atom */ -extern const struct ao_lisp_type ao_lisp_atom_type; - -extern struct ao_lisp_atom *ao_lisp_atoms; -extern struct ao_lisp_frame *ao_lisp_frame_global; -extern struct ao_lisp_frame *ao_lisp_frame_current; - -void -ao_lisp_atom_write(ao_poly a); - -struct ao_lisp_atom * -ao_lisp_atom_intern(char *name); - -ao_poly * -ao_lisp_atom_ref(ao_poly atom); - -ao_poly -ao_lisp_atom_get(ao_poly atom); - -ao_poly -ao_lisp_atom_set(ao_poly atom, ao_poly val); - -ao_poly -ao_lisp_atom_def(ao_poly atom, ao_poly val); - -/* int */ -void -ao_lisp_int_write(ao_poly i); - -int32_t -ao_lisp_poly_integer(ao_poly p); - -ao_poly -ao_lisp_integer_poly(int32_t i); - -static inline int -ao_lisp_integer_typep(uint8_t t) -{ - return (t == AO_LISP_INT) || (t == AO_LISP_BIGINT); -} - -void -ao_lisp_bigint_write(ao_poly i); - -extern const struct ao_lisp_type ao_lisp_bigint_type; -/* prim */ -void -ao_lisp_poly_write(ao_poly p); - -void -ao_lisp_poly_display(ao_poly p); - -int -ao_lisp_poly_mark(ao_poly p, uint8_t note_cons); - -/* returns 1 if the object has already been moved */ -int -ao_lisp_poly_move(ao_poly *p, uint8_t note_cons); - -/* eval */ - -void -ao_lisp_eval_clear_globals(void); - -int -ao_lisp_eval_restart(void); - -ao_poly -ao_lisp_eval(ao_poly p); - -ao_poly -ao_lisp_set_cond(struct ao_lisp_cons *cons); - -/* float */ -extern const struct ao_lisp_type ao_lisp_float_type; - -void -ao_lisp_float_write(ao_poly p); - -ao_poly -ao_lisp_float_get(float value); - -static inline uint8_t -ao_lisp_number_typep(uint8_t t) -{ - return ao_lisp_integer_typep(t) || (t == AO_LISP_FLOAT); -} - -float -ao_lisp_poly_number(ao_poly p); - -/* builtin */ -void -ao_lisp_builtin_write(ao_poly b); - -extern const struct ao_lisp_type ao_lisp_builtin_type; - -/* Check argument count */ -ao_poly -ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max); - -/* Check argument type */ -ao_poly -ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok); - -/* Fetch an arg (nil if off the end) */ -ao_poly -ao_lisp_arg(struct ao_lisp_cons *cons, int argc); - -char * -ao_lisp_args_name(uint8_t args); - -/* read */ -extern struct ao_lisp_cons *ao_lisp_read_cons; -extern struct ao_lisp_cons *ao_lisp_read_cons_tail; -extern struct ao_lisp_cons *ao_lisp_read_stack; - -ao_poly -ao_lisp_read(void); - -/* rep */ -ao_poly -ao_lisp_read_eval_print(void); - -/* frame */ -extern const struct ao_lisp_type ao_lisp_frame_type; -extern const struct ao_lisp_type ao_lisp_frame_vals_type; - -#define AO_LISP_FRAME_FREE 6 - -extern struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; - -ao_poly -ao_lisp_frame_mark(struct ao_lisp_frame *frame); - -ao_poly * -ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); - -struct ao_lisp_frame * -ao_lisp_frame_new(int num); - -void -ao_lisp_frame_free(struct ao_lisp_frame *frame); - -void -ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val); - -ao_poly -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); - -void -ao_lisp_frame_write(ao_poly p); - -void -ao_lisp_frame_init(void); - -/* lambda */ -extern const struct ao_lisp_type ao_lisp_lambda_type; - -extern const char *ao_lisp_state_names[]; - -struct ao_lisp_lambda * -ao_lisp_lambda_new(ao_poly cons); - -void -ao_lisp_lambda_write(ao_poly lambda); - -ao_poly -ao_lisp_lambda_eval(void); - -/* stack */ - -extern const struct ao_lisp_type ao_lisp_stack_type; -extern struct ao_lisp_stack *ao_lisp_stack; -extern struct ao_lisp_stack *ao_lisp_stack_free_list; - -void -ao_lisp_stack_reset(struct ao_lisp_stack *stack); - -int -ao_lisp_stack_push(void); - -void -ao_lisp_stack_pop(void); - -void -ao_lisp_stack_clear(void); - -void -ao_lisp_stack_write(ao_poly stack); - -ao_poly -ao_lisp_stack_eval(void); - -/* error */ - -void -ao_lisp_vprintf(char *format, va_list args); - -void -ao_lisp_printf(char *format, ...); - -void -ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last); - -void -ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame); - -ao_poly -ao_lisp_error(int error, char *format, ...); - -/* builtins */ - -#define AO_LISP_BUILTIN_DECLS -#include "ao_lisp_builtin.h" - -/* debugging macros */ - -#if DBG_EVAL || DBG_READ || DBG_MEM -#define DBG_CODE 1 -int ao_lisp_stack_depth; -#define DBG_DO(a) a -#define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_lisp_stack_depth; _s++) printf(" "); } while(0) -#define DBG_IN() (++ao_lisp_stack_depth) -#define DBG_OUT() (--ao_lisp_stack_depth) -#define DBG_RESET() (ao_lisp_stack_depth = 0) -#define DBG(...) ao_lisp_printf(__VA_ARGS__) -#define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_lisp_cons_write(ao_lisp_cons_poly(a)) -#define DBG_POLY(a) ao_lisp_poly_write(a) -#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) -#define DBG_STACK() ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)) -static inline void -ao_lisp_frames_dump(void) -{ - struct ao_lisp_stack *s; - DBGI(".. current frame: "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { - DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); - } -} -#define DBG_FRAMES() ao_lisp_frames_dump() -#else -#define DBG_DO(a) -#define DBG_INDENT() -#define DBG_IN() -#define DBG_OUT() -#define DBG(...) -#define DBGI(...) -#define DBG_CONS(a) -#define DBG_POLY(a) -#define DBG_RESET() -#define DBG_STACK() -#define DBG_FRAMES() -#endif - -#if DBG_READ -#define RDBGI(...) DBGI(__VA_ARGS__) -#define RDBG_IN() DBG_IN() -#define RDBG_OUT() DBG_OUT() -#else -#define RDBGI(...) -#define RDBG_IN() -#define RDBG_OUT() -#endif - -#define DBG_MEM_START 1 - -#if DBG_MEM - -#include -extern int dbg_move_depth; -#define MDBG_DUMP 1 -#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_lisp_pool) : -1) - -extern int dbg_mem; - -#define MDBG_DO(a) DBG_DO(a) -#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) -#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) -#define MDBG_MOVE_IN() (dbg_move_depth++) -#define MDBG_MOVE_OUT() (assert(--dbg_move_depth >= 0)) - -#else - -#define MDBG_DO(a) -#define MDBG_MOVE(...) -#define MDBG_MORE(...) -#define MDBG_MOVE_IN() -#define MDBG_MOVE_OUT() - -#endif - -#endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c deleted file mode 100644 index a633c223..00000000 --- a/src/lisp/ao_lisp_atom.c +++ /dev/null @@ -1,159 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_lisp.h" - -static int name_size(char *name) -{ - return sizeof(struct ao_lisp_atom) + strlen(name) + 1; -} - -static int atom_size(void *addr) -{ - struct ao_lisp_atom *atom = addr; - if (!atom) - return 0; - return name_size(atom->name); -} - -static void atom_mark(void *addr) -{ - struct ao_lisp_atom *atom = addr; - - for (;;) { - atom = ao_lisp_poly_atom(atom->next); - if (!atom) - break; - if (ao_lisp_mark_memory(&ao_lisp_atom_type, atom)) - break; - } -} - -static void atom_move(void *addr) -{ - struct ao_lisp_atom *atom = addr; - int ret; - - for (;;) { - struct ao_lisp_atom *next = ao_lisp_poly_atom(atom->next); - - if (!next) - break; - ret = ao_lisp_move_memory(&ao_lisp_atom_type, (void **) &next); - if (next != ao_lisp_poly_atom(atom->next)) - atom->next = ao_lisp_atom_poly(next); - if (ret) - break; - atom = next; - } -} - -const struct ao_lisp_type ao_lisp_atom_type = { - .mark = atom_mark, - .size = atom_size, - .move = atom_move, - .name = "atom" -}; - -struct ao_lisp_atom *ao_lisp_atoms; - -struct ao_lisp_atom * -ao_lisp_atom_intern(char *name) -{ - struct ao_lisp_atom *atom; - - for (atom = ao_lisp_atoms; atom; atom = ao_lisp_poly_atom(atom->next)) { - if (!strcmp(atom->name, name)) - return atom; - } -#ifdef ao_builtin_atoms - for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) { - if (!strcmp(atom->name, name)) - return atom; - } -#endif - ao_lisp_string_stash(0, name); - atom = ao_lisp_alloc(name_size(name)); - name = ao_lisp_string_fetch(0); - if (atom) { - atom->type = AO_LISP_ATOM; - atom->next = ao_lisp_atom_poly(ao_lisp_atoms); - ao_lisp_atoms = atom; - strcpy(atom->name, name); - } - return atom; -} - -ao_poly * -ao_lisp_atom_ref(ao_poly atom) -{ - ao_poly *ref; - struct ao_lisp_frame *frame; - - for (frame = ao_lisp_frame_current; frame; frame = ao_lisp_poly_frame(frame->prev)) { - ref = ao_lisp_frame_ref(frame, atom); - if (ref) - return ref; - } - return ao_lisp_frame_ref(ao_lisp_frame_global, atom); -} - -ao_poly -ao_lisp_atom_get(ao_poly atom) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - -#ifdef ao_builtin_frame - if (!ref) - ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom); -#endif - if (ref) - return *ref; - return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); -} - -ao_poly -ao_lisp_atom_set(ao_poly atom, ao_poly val) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - - if (!ref) - return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); - *ref = val; - return val; -} - -ao_poly -ao_lisp_atom_def(ao_poly atom, ao_poly val) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - - if (ref) { - if (ao_lisp_frame_current) - return ao_lisp_error(AO_LISP_REDEFINED, "attempt to redefine atom %s", ao_lisp_poly_atom(atom)->name); - *ref = val; - return val; - } - return ao_lisp_frame_add(ao_lisp_frame_current ? ao_lisp_frame_current : ao_lisp_frame_global, atom, val); -} - -void -ao_lisp_atom_write(ao_poly a) -{ - struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); - printf("%s", atom->name); -} diff --git a/src/lisp/ao_lisp_bool.c b/src/lisp/ao_lisp_bool.c deleted file mode 100644 index 391a7f78..00000000 --- a/src/lisp/ao_lisp_bool.c +++ /dev/null @@ -1,73 +0,0 @@ -/* - * Copyright © 2017 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static void bool_mark(void *addr) -{ - (void) addr; -} - -static int bool_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_bool); -} - -static void bool_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_bool_type = { - .mark = bool_mark, - .size = bool_size, - .move = bool_move, - .name = "bool" -}; - -void -ao_lisp_bool_write(ao_poly v) -{ - struct ao_lisp_bool *b = ao_lisp_poly_bool(v); - - if (b->value) - printf("#t"); - else - printf("#f"); -} - -#ifdef AO_LISP_MAKE_CONST - -struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; - -struct ao_lisp_bool * -ao_lisp_bool_get(uint8_t value) -{ - struct ao_lisp_bool **b; - - if (value) - b = &ao_lisp_true; - else - b = &ao_lisp_false; - - if (!*b) { - *b = ao_lisp_alloc(sizeof (struct ao_lisp_bool)); - (*b)->type = AO_LISP_BOOL; - (*b)->value = value; - } - return *b; -} - -#endif diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c deleted file mode 100644 index 6af2a6ea..00000000 --- a/src/lisp/ao_lisp_builtin.c +++ /dev/null @@ -1,868 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include -#include - -static int -builtin_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_builtin); -} - -static void -builtin_mark(void *addr) -{ - (void) addr; -} - -static void -builtin_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_builtin_type = { - .size = builtin_size, - .mark = builtin_mark, - .move = builtin_move -}; - -#ifdef AO_LISP_MAKE_CONST - -#define AO_LISP_BUILTIN_CASENAME -#include "ao_lisp_builtin.h" - -char *ao_lisp_args_name(uint8_t args) { - args &= AO_LISP_FUNC_MASK; - switch (args) { - case AO_LISP_FUNC_LAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_lambda)->name; - case AO_LISP_FUNC_NLAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_nlambda)->name; - case AO_LISP_FUNC_MACRO: return ao_lisp_poly_atom(_ao_lisp_atom_macro)->name; - default: return "???"; - } -} -#else - -#define AO_LISP_BUILTIN_ARRAYNAME -#include "ao_lisp_builtin.h" - -static char * -ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { - if (b < _builtin_last) - return ao_lisp_poly_atom(builtin_names[b])->name; - return "???"; -} - -static const ao_poly ao_lisp_args_atoms[] = { - [AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda, - [AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda, - [AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro, -}; - -char * -ao_lisp_args_name(uint8_t args) -{ - args &= AO_LISP_FUNC_MASK; - if (args < sizeof ao_lisp_args_atoms / sizeof ao_lisp_args_atoms[0]) - return ao_lisp_poly_atom(ao_lisp_args_atoms[args])->name; - return "(unknown)"; -} -#endif - -void -ao_lisp_builtin_write(ao_poly b) -{ - struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); - printf("%s", ao_lisp_builtin_name(builtin->func)); -} - -ao_poly -ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) -{ - int argc = 0; - - while (cons && argc <= max) { - argc++; - cons = ao_lisp_cons_cdr(cons); - } - if (argc < min || argc > max) - return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_arg(struct ao_lisp_cons *cons, int argc) -{ - if (!cons) - return AO_LISP_NIL; - while (argc--) { - if (!cons) - return AO_LISP_NIL; - cons = ao_lisp_cons_cdr(cons); - } - return cons->car; -} - -ao_poly -ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok) -{ - ao_poly car = ao_lisp_arg(cons, argc); - - if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type) - return ao_lisp_error(AO_LISP_INVALID, "%s: arg %d invalid type %v", ao_lisp_poly_atom(name)->name, argc, car); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_car(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_car, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(cons->car)->car; -} - -ao_poly -ao_lisp_do_cdr(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_cdr, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(cons->car)->cdr; -} - -ao_poly -ao_lisp_do_cons(struct ao_lisp_cons *cons) -{ - ao_poly car, cdr; - if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) - return AO_LISP_NIL; - car = ao_lisp_arg(cons, 0); - cdr = ao_lisp_arg(cons, 1); - return ao_lisp__cons(car, cdr); -} - -ao_poly -ao_lisp_do_last(struct ao_lisp_cons *cons) -{ - struct ao_lisp_cons *list; - if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - for (list = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); - list; - list = ao_lisp_cons_cdr(list)) - { - if (!list->cdr) - return list->car; - } - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_length(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_length, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_length, cons, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - return ao_lisp_int_poly(ao_lisp_cons_length(ao_lisp_poly_cons(ao_lisp_arg(cons, 0)))); -} - -ao_poly -ao_lisp_do_quote(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) - return AO_LISP_NIL; - return ao_lisp_arg(cons, 0); -} - -ao_poly -ao_lisp_do_set(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0)) - return AO_LISP_NIL; - - return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); -} - -ao_poly -ao_lisp_do_def(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_def, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_def, cons, 0, AO_LISP_ATOM, 0)) - return AO_LISP_NIL; - - return ao_lisp_atom_def(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); -} - -ao_poly -ao_lisp_do_setq(struct ao_lisp_cons *cons) -{ - ao_poly name; - 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) - return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom %v", name); - if (!ao_lisp_atom_ref(name)) - return ao_lisp_error(AO_LISP_INVALID, "atom %v not defined", name); - return ao_lisp__cons(_ao_lisp_atom_set, - ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, - ao_lisp__cons(name, AO_LISP_NIL)), - cons->cdr)); -} - -ao_poly -ao_lisp_do_cond(struct ao_lisp_cons *cons) -{ - ao_lisp_set_cond(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_begin(struct ao_lisp_cons *cons) -{ - ao_lisp_stack->state = eval_begin; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_while(struct ao_lisp_cons *cons) -{ - ao_lisp_stack->state = eval_while; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_write(struct ao_lisp_cons *cons) -{ - ao_poly val = AO_LISP_NIL; - while (cons) { - val = cons->car; - ao_lisp_poly_write(val); - cons = ao_lisp_cons_cdr(cons); - if (cons) - printf(" "); - } - printf("\n"); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_display(struct ao_lisp_cons *cons) -{ - ao_poly val = AO_LISP_NIL; - while (cons) { - val = cons->car; - ao_lisp_poly_display(val); - cons = ao_lisp_cons_cdr(cons); - } - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) -{ - struct ao_lisp_cons *cons = cons; - ao_poly ret = AO_LISP_NIL; - - for (cons = orig_cons; cons; cons = ao_lisp_cons_cdr(cons)) { - ao_poly car = cons->car; - uint8_t rt = ao_lisp_poly_type(ret); - uint8_t ct = ao_lisp_poly_type(car); - - if (cons == orig_cons) { - ret = car; - if (cons->cdr == AO_LISP_NIL) { - switch (op) { - case builtin_minus: - if (ao_lisp_integer_typep(ct)) - ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); - else if (ct == AO_LISP_FLOAT) - ret = ao_lisp_float_get(-ao_lisp_poly_number(ret)); - break; - case builtin_divide: - if (ao_lisp_integer_typep(ct) && ao_lisp_poly_integer(ret) == 1) - ; - else if (ao_lisp_number_typep(ct)) { - float v = ao_lisp_poly_number(ret); - ret = ao_lisp_float_get(1/v); - } - break; - default: - break; - } - } - } else if (ao_lisp_integer_typep(rt) && ao_lisp_integer_typep(ct)) { - int32_t r = ao_lisp_poly_integer(ret); - int32_t c = ao_lisp_poly_integer(car); - int64_t t; - - switch(op) { - case builtin_plus: - r += c; - check_overflow: - if (r < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < r) - goto inexact; - break; - case builtin_minus: - r -= c; - goto check_overflow; - break; - case builtin_times: - t = (int64_t) r * (int64_t) c; - if (t < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < t) - goto inexact; - r = (int32_t) t; - break; - case builtin_divide: - if (c != 0 && (r % c) == 0) - r /= c; - else - goto inexact; - break; - case builtin_quotient: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); - if (r % c != 0 && (c < 0) != (r < 0)) - r = r / c - 1; - else - r = r / c; - break; - case builtin_remainder: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); - r %= c; - break; - case builtin_modulo: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); - r %= c; - if ((r < 0) != (c < 0)) - r += c; - break; - default: - break; - } - ret = ao_lisp_integer_poly(r); - } else if (ao_lisp_number_typep(rt) && ao_lisp_number_typep(ct)) { - float r, c; - inexact: - r = ao_lisp_poly_number(ret); - c = ao_lisp_poly_number(car); - switch(op) { - case builtin_plus: - r += c; - break; - case builtin_minus: - r -= c; - break; - case builtin_times: - r *= c; - break; - case builtin_divide: - r /= c; - break; - case builtin_quotient: - case builtin_remainder: - case builtin_modulo: - return ao_lisp_error(AO_LISP_INVALID, "non-integer value in integer divide"); - default: - break; - } - ret = ao_lisp_float_get(r); - } - - else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) - ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), - ao_lisp_poly_string(car))); - else - return ao_lisp_error(AO_LISP_INVALID, "invalid args"); - } - return ret; -} - -ao_poly -ao_lisp_do_plus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_plus); -} - -ao_poly -ao_lisp_do_minus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_minus); -} - -ao_poly -ao_lisp_do_times(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_times); -} - -ao_poly -ao_lisp_do_divide(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_divide); -} - -ao_poly -ao_lisp_do_quotient(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_quotient); -} - -ao_poly -ao_lisp_do_modulo(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_modulo); -} - -ao_poly -ao_lisp_do_remainder(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_remainder); -} - -ao_poly -ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) -{ - ao_poly left; - - if (!cons) - return _ao_lisp_bool_true; - - left = cons->car; - for (cons = ao_lisp_cons_cdr(cons); cons; cons = ao_lisp_cons_cdr(cons)) { - ao_poly right = cons->car; - - if (op == builtin_equal) { - if (left != right) - return _ao_lisp_bool_false; - } else { - uint8_t lt = ao_lisp_poly_type(left); - uint8_t rt = ao_lisp_poly_type(right); - if (ao_lisp_integer_typep(lt) && ao_lisp_integer_typep(rt)) { - int32_t l = ao_lisp_poly_integer(left); - int32_t r = ao_lisp_poly_integer(right); - - switch (op) { - case builtin_less: - if (!(l < r)) - return _ao_lisp_bool_false; - break; - case builtin_greater: - if (!(l > r)) - return _ao_lisp_bool_false; - break; - case builtin_less_equal: - if (!(l <= r)) - return _ao_lisp_bool_false; - break; - case builtin_greater_equal: - if (!(l >= r)) - return _ao_lisp_bool_false; - break; - default: - break; - } - } else if (lt == AO_LISP_STRING && rt == AO_LISP_STRING) { - int c = strcmp(ao_lisp_poly_string(left), - ao_lisp_poly_string(right)); - switch (op) { - case builtin_less: - if (!(c < 0)) - return _ao_lisp_bool_false; - break; - case builtin_greater: - if (!(c > 0)) - return _ao_lisp_bool_false; - break; - case builtin_less_equal: - if (!(c <= 0)) - return _ao_lisp_bool_false; - break; - case builtin_greater_equal: - if (!(c >= 0)) - return _ao_lisp_bool_false; - break; - default: - break; - } - } - } - left = right; - } - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_equal); -} - -ao_poly -ao_lisp_do_less(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_less); -} - -ao_poly -ao_lisp_do_greater(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_greater); -} - -ao_poly -ao_lisp_do_less_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_less_equal); -} - -ao_poly -ao_lisp_do_greater_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_greater_equal); -} - -ao_poly -ao_lisp_do_list_to_string(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_list2d3estring, cons, 1, 1)) - return AO_LISP_NIL; - 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_string_to_list(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_string2d3elist, cons, 1, 1)) - return AO_LISP_NIL; - 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))); -} - -ao_poly -ao_lisp_do_flush_output(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_flush2doutput, cons, 0, 0)) - return AO_LISP_NIL; - ao_lisp_os_flush(); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_led(struct ao_lisp_cons *cons) -{ - ao_poly led; - 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_INT, 0)) - return AO_LISP_NIL; - led = ao_lisp_arg(cons, 0); - ao_lisp_os_led(ao_lisp_poly_int(led)); - return led; -} - -ao_poly -ao_lisp_do_delay(struct ao_lisp_cons *cons) -{ - ao_poly delay; - 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_INT, 0)) - return AO_LISP_NIL; - delay = ao_lisp_arg(cons, 0); - ao_lisp_os_delay(ao_lisp_poly_int(delay)); - return delay; -} - -ao_poly -ao_lisp_do_eval(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_eval, cons, 1, 1)) - return AO_LISP_NIL; - ao_lisp_stack->state = eval_sexpr; - return cons->car; -} - -ao_poly -ao_lisp_do_apply(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_apply, cons, 2, INT_MAX)) - return AO_LISP_NIL; - ao_lisp_stack->state = eval_apply; - return ao_lisp_cons_poly(cons); -} - -ao_poly -ao_lisp_do_read(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_read, cons, 0, 0)) - return AO_LISP_NIL; - return ao_lisp_read(); -} - -ao_poly -ao_lisp_do_collect(struct ao_lisp_cons *cons) -{ - int free; - (void) cons; - free = ao_lisp_collect(AO_LISP_COLLECT_FULL); - return ao_lisp_int_poly(free); -} - -ao_poly -ao_lisp_do_nullp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_arg(cons, 0) == AO_LISP_NIL) - return _ao_lisp_bool_true; - else - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_not(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_arg(cons, 0) == _ao_lisp_bool_false) - return _ao_lisp_bool_true; - else - return _ao_lisp_bool_false; -} - -static ao_poly -ao_lisp_do_typep(int type, struct ao_lisp_cons *cons) -{ - 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)) == 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 (v != AO_LISP_NIL && ao_lisp_poly_type(v) == AO_LISP_CONS) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_integerp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { - case AO_LISP_INT: - case AO_LISP_BIGINT: - return _ao_lisp_bool_true; - default: - return _ao_lisp_bool_false; - } -} - -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; - switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { - case AO_LISP_INT: - case AO_LISP_BIGINT: - case AO_LISP_FLOAT: - return _ao_lisp_bool_true; - default: - return _ao_lisp_bool_false; - } -} - -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); -} - -ao_poly -ao_lisp_do_procedurep(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { - case AO_LISP_BUILTIN: - case AO_LISP_LAMBDA: - return _ao_lisp_bool_true; - default: - return _ao_lisp_bool_false; - } -} - -/* 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; - 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 -ao_lisp_do_set_car(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->car = ao_lisp_arg(cons, 1); -} - -ao_poly -ao_lisp_do_set_cdr(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - 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)))); -} - -ao_poly -ao_lisp_do_read_char(struct ao_lisp_cons *cons) -{ - int c; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - c = getchar(); - return ao_lisp_int_poly(c); -} - -ao_poly -ao_lisp_do_write_char(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_INT, 0)) - return AO_LISP_NIL; - putchar(ao_lisp_poly_integer(ao_lisp_arg(cons, 0))); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_exit(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - ao_lisp_exception |= AO_LISP_EXIT; - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_current_jiffy(struct ao_lisp_cons *cons) -{ - int jiffy; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - jiffy = ao_lisp_os_jiffy(); - return (ao_lisp_int_poly(jiffy)); -} - -ao_poly -ao_lisp_do_current_second(struct ao_lisp_cons *cons) -{ - int second; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - second = ao_lisp_os_jiffy() / AO_LISP_JIFFIES_PER_SECOND; - return (ao_lisp_int_poly(second)); -} - -ao_poly -ao_lisp_do_jiffies_per_second(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - return (ao_lisp_int_poly(AO_LISP_JIFFIES_PER_SECOND)); -} - -#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 deleted file mode 100644 index cb65e252..00000000 --- a/src/lisp/ao_lisp_builtin.txt +++ /dev/null @@ -1,68 +0,0 @@ -f_lambda eval -f_lambda read -nlambda lambda -nlambda nlambda -nlambda macro -f_lambda car -f_lambda cdr -f_lambda cons -f_lambda last -f_lambda length -nlambda quote -atom quasiquote -atom unquote -atom unquote_splicing unquote-splicing -f_lambda set -macro setq set! -f_lambda def -nlambda cond -nlambda begin -nlambda while -f_lambda write -f_lambda display -f_lambda plus + -f_lambda minus - -f_lambda times * -f_lambda divide / -f_lambda modulo modulo % -f_lambda remainder -f_lambda quotient -f_lambda equal = eq? eqv? -f_lambda less < -f_lambda greater > -f_lambda less_equal <= -f_lambda greater_equal >= -f_lambda list_to_string list->string -f_lambda string_to_list string->list -f_lambda flush_output flush-output -f_lambda delay -f_lambda led -f_lambda save -f_lambda restore -f_lambda call_cc call-with-current-continuation call/cc -f_lambda collect -f_lambda nullp null? -f_lambda not -f_lambda listp list? -f_lambda pairp pair? -f_lambda integerp integer? exact? exact-integer? -f_lambda numberp number? real? -f_lambda booleanp boolean? -f_lambda set_car set-car! -f_lambda set_cdr set-cdr! -f_lambda symbolp symbol? -f_lambda symbol_to_string symbol->string -f_lambda string_to_symbol string->symbol -f_lambda stringp string? -f_lambda procedurep procedure? -lambda apply -f_lambda read_char read-char -f_lambda write_char write-char -f_lambda exit -f_lambda current_jiffy current-jiffy -f_lambda current_second current-second -f_lambda jiffies_per_second jiffies-per-second -f_lambda finitep finite? -f_lambda infinitep infinite? -f_lambda inexactp inexact? -f_lambda sqrt diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c deleted file mode 100644 index d3b97383..00000000 --- a/src/lisp/ao_lisp_cons.c +++ /dev/null @@ -1,184 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static void cons_mark(void *addr) -{ - struct ao_lisp_cons *cons = addr; - - for (;;) { - ao_poly cdr = cons->cdr; - - ao_lisp_poly_mark(cons->car, 1); - if (!cdr) - break; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - ao_lisp_poly_mark(cdr, 1); - break; - } - cons = ao_lisp_poly_cons(cdr); - if (ao_lisp_mark_memory(&ao_lisp_cons_type, cons)) - break; - } -} - -static int cons_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_cons); -} - -static void cons_move(void *addr) -{ - struct ao_lisp_cons *cons = addr; - - if (!cons) - return; - - for (;;) { - ao_poly cdr; - struct ao_lisp_cons *c; - int ret; - - MDBG_MOVE("cons_move start %d (%d, %d)\n", - MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); - (void) ao_lisp_poly_move(&cons->car, 1); - cdr = cons->cdr; - if (!cdr) - break; - if (ao_lisp_poly_base_type(cdr) != AO_LISP_CONS) { - (void) ao_lisp_poly_move(&cons->cdr, 0); - break; - } - c = ao_lisp_poly_cons(cdr); - ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &c); - if (c != ao_lisp_poly_cons(cons->cdr)) - cons->cdr = ao_lisp_cons_poly(c); - MDBG_MOVE("cons_move end %d (%d, %d)\n", - MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); - if (ret) - break; - cons = c; - } -} - -const struct ao_lisp_type ao_lisp_cons_type = { - .mark = cons_mark, - .size = cons_size, - .move = cons_move, - .name = "cons", -}; - -struct ao_lisp_cons *ao_lisp_cons_free_list; - -struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, ao_poly cdr) -{ - struct ao_lisp_cons *cons; - - if (ao_lisp_cons_free_list) { - cons = ao_lisp_cons_free_list; - ao_lisp_cons_free_list = ao_lisp_poly_cons(cons->cdr); - } else { - ao_lisp_poly_stash(0, car); - ao_lisp_poly_stash(1, cdr); - cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); - cdr = ao_lisp_poly_fetch(1); - car = ao_lisp_poly_fetch(0); - if (!cons) - return NULL; - } - cons->car = car; - cons->cdr = cdr; - return cons; -} - -struct ao_lisp_cons * -ao_lisp_cons_cdr(struct ao_lisp_cons *cons) -{ - ao_poly cdr = cons->cdr; - if (cdr == AO_LISP_NIL) - return NULL; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - (void) ao_lisp_error(AO_LISP_INVALID, "improper list"); - return NULL; - } - return ao_lisp_poly_cons(cdr); -} - -ao_poly -ao_lisp__cons(ao_poly car, ao_poly cdr) -{ - return ao_lisp_cons_poly(ao_lisp_cons_cons(car, cdr)); -} - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons) -{ -#if DBG_FREE_CONS - ao_lisp_cons_check(cons); -#endif - while (cons) { - ao_poly cdr = cons->cdr; - cons->cdr = ao_lisp_cons_poly(ao_lisp_cons_free_list); - ao_lisp_cons_free_list = cons; - cons = ao_lisp_poly_cons(cdr); - } -} - -void -ao_lisp_cons_write(ao_poly c) -{ - struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); - int first = 1; - printf("("); - while (cons) { - if (!first) - printf(" "); - ao_lisp_poly_write(cons->car); - c = cons->cdr; - if (ao_lisp_poly_type(c) == AO_LISP_CONS) { - cons = ao_lisp_poly_cons(c); - first = 0; - } else { - printf(" . "); - ao_lisp_poly_write(c); - cons = NULL; - } - } - printf(")"); -} - -void -ao_lisp_cons_display(ao_poly c) -{ - struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); - - while (cons) { - ao_lisp_poly_display(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - } -} - -int -ao_lisp_cons_length(struct ao_lisp_cons *cons) -{ - int len = 0; - while (cons) { - len++; - cons = ao_lisp_poly_cons(cons->cdr); - } - return len; -} diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp deleted file mode 100644 index 422bdd63..00000000 --- a/src/lisp/ao_lisp_const.lisp +++ /dev/null @@ -1,813 +0,0 @@ -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Lisp code placed in ROM - - ; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (name value) - (list - def - (list quote name) - value) - ) - ) - -(begin - (def! append - (lambda args - (def! append-list - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - - (def! append-lists - (lambda (lists) - (cond ((null? lists) lists) - ((null? (cdr lists)) (car lists)) - (else (append-list (car lists) (append-lists (cdr lists)))) - ) - ) - ) - (append-lists args) - ) - ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - - ; boolean operators - -(begin - (def! or - (macro l - (def! _or - (lambda (l) - (cond ((null? l) #f) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l)) - (list - 'else - (_or (cdr l)) - ) - ) - ) - ) - ) - ) - (_or l))) - 'or) - - ; execute to resolve macros - -(or #f #t) - -(begin - (def! and - (macro l - (def! _and - (lambda (l) - (cond ((null? l) #t) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l) - (_and (cdr l)) - ) - ) - ) - ) - ) - ) - (_and l) - ) - ) - 'and) - - ; execute to resolve macros - -(and #t #f) - -(begin - (def! quasiquote - (macro (x) - (def! constant? - ; A constant value is either a pair starting with quote, - ; or anything which is neither a pair nor a symbol - - (lambda (exp) - (cond ((pair? exp) - (eq? (car exp) 'quote) - ) - (else - (not (symbol? exp)) - ) - ) - ) - ) - (def! combine-skeletons - (lambda (left right exp) - (cond - ((and (constant? left) (constant? right)) - (cond ((and (eqv? (eval left) (car exp)) - (eqv? (eval right) (cdr exp))) - (list 'quote exp) - ) - (else - (list 'quote (cons (eval left) (eval right))) - ) - ) - ) - ((null? right) - (list 'list left) - ) - ((and (pair? right) (eq? (car right) 'list)) - (cons 'list (cons left (cdr right))) - ) - (else - (list 'cons left right) - ) - ) - ) - ) - - (def! expand-quasiquote - (lambda (exp nesting) - (cond - - ; non cons -- constants - ; themselves, others are - ; quoted - - ((not (pair? exp)) - (cond ((constant? exp) - exp - ) - (else - (list 'quote exp) - ) - ) - ) - - ; check for an unquote exp and - ; add the param unquoted - - ((and (eq? (car exp) 'unquote) (= (length exp) 2)) - (cond ((= nesting 0) - (car (cdr exp)) - ) - (else - (combine-skeletons ''unquote - (expand-quasiquote (cdr exp) (- nesting 1)) - exp)) - ) - ) - - ; nested quasi-quote -- - ; construct the right - ; expression - - ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) - (combine-skeletons ''quasiquote - (expand-quasiquote (cdr exp) (+ nesting 1)) - exp)) - - ; check for an - ; unquote-splicing member, - ; compute the expansion of the - ; value and append the rest of - ; the quasiquote result to it - - ((and (pair? (car exp)) - (eq? (car (car exp)) 'unquote-splicing) - (= (length (car exp)) 2)) - (cond ((= nesting 0) - (list 'append (car (cdr (car exp))) - (expand-quasiquote (cdr exp) nesting)) - ) - (else - (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) - (expand-quasiquote (cdr exp) nesting) - exp)) - ) - ) - - ; for other lists, just glue - ; the expansion of the first - ; element to the expansion of - ; the rest of the list - - (else (combine-skeletons (expand-quasiquote (car exp) nesting) - (expand-quasiquote (cdr exp) nesting) - exp) - ) - ) - ) - ) - (def! result (expand-quasiquote x 0)) - result - ) - ) - 'quasiquote) - - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated. - ; - ; Also accepts the alternate - ; form for defining lambdas of - ; (define (name x y z) sexprs ...) - ; - -(begin - (def! define - (macro (first . rest) - ; check for alternate lambda definition form - - (cond ((list? first) - (set! rest - (append - (list - 'lambda - (cdr first)) - rest)) - (set! first (car first)) - ) - (else - (set! rest (car rest)) - ) - ) - (def! result `(,begin - (,def (,quote ,first) ,rest) - (,quote ,first)) - ) - result - ) - ) - 'define - ) - - ; basic list accessors - -(define (caar l) (car (car l))) - -(define (cadr l) (car (cdr l))) - -(define (cdar l) (cdr (car l))) - -(define (caddr l) (car (cdr (cdr l)))) - - ; (if ) - ; (if 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) - - ; simple math operators - -(define zero? (macro (value) `(eq? ,value 0))) - -(zero? 1) -(zero? 0) -(zero? "hello") - -(define positive? (macro (value) `(> ,value 0))) - -(positive? 12) -(positive? -12) - -(define negative? (macro (value) `(< ,value 0))) - -(negative? 12) -(negative? -12) - -(define (abs x) (if (>= x 0) x (- x))) - -(abs 12) -(abs -12) - -(define max (lambda (first . rest) - (while (not (null? rest)) - (cond ((< first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(max 1 2 3) -(max 3 2 1) - -(define min (lambda (first . rest) - (while (not (null? rest)) - (cond ((> first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(min 1 2 3) -(min 3 2 1) - -(define (even? x) (zero? (% x 2))) - -(even? 2) -(even? -2) -(even? 3) -(even? -1) - -(define (odd? x) (not (even? x))) - -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x (- k 1))) - ) - ) - -(define (list-ref x k) - (car (list-tail x k)) - ) - - ; define a set of local - ; variables all at once and - ; then evaluate a list of - ; sexprs - ; - ; (let (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let ((x 1) (y)) (set! y (+ x 1)) y) - -(define let - (macro (vars . exprs) - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-vals vars) - (cond ((not (null? vars)) - (cons (cond ((null? (cdr (car vars))) ()) - (else - (car (cdr (car vars)))) - ) - (make-vals (cdr vars)))) - (else ()) - ) - ) - ; prepend the set operations - ; to the expressions - - ; build the lambda. - - `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) - ) - ) - - -(let ((x 1) (y)) (set! y 2) (+ x y)) - - ; define a set of local - ; variables one at a time and - ; then evaluate a list of - ; sexprs - ; - ; (let* (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let* ((x 1) (y)) (set! y (+ x 1)) y) - -(define let* - (macro (vars . exprs) - - ; - ; make the list of names in the let - ; - - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (define (make-exprs vars exprs) - (cond ((null? vars) exprs) - (else - (cons - (list set - (list quote - (car (car vars)) - ) - (cond ((null? (cdr (car vars))) ()) - (else (cadr (car vars)))) - ) - (make-exprs (cdr vars) exprs) - ) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-nils vars) - (cond ((null? vars) ()) - (else (cons () (make-nils (cdr vars)))) - ) - ) - ; build the lambda. - - `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) - ) - ) - -(let* ((x 1) (y x)) (+ x y)) - -(define when (macro (test . l) `(cond (,test ,@l)))) - -(when #t (write 'when)) - -(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) - -(unless #f (write 'unless)) - -(define (reverse list) - (let ((result ())) - (while (not (null? list)) - (set! result (cons (car list) result)) - (set! list (cdr list)) - ) - result) - ) - -(reverse '(1 2 3)) - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x) (- k 1)))) - -(list-tail '(1 2 3) 2) - -(define (list-ref x k) (car (list-tail x k))) - -(list-ref '(1 2 3) 2) - - ; recursive equality - -(define (equal? a b) - (cond ((eq? a b) #t) - ((and (pair? a) (pair? b)) - (and (equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - (else #f) - ) - ) - -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) - -(define member (lambda (obj list . test?) - (cond ((null? list) - #f - ) - (else - (if (null? test?) (set! test? equal?) (set! test? (car test?))) - (if (test? obj (car list)) - list - (member obj (cdr list) test?)) - ) - ) - ) - ) - -(member '(2) '((1) (2) (3))) - -(member '(4) '((1) (2) (3))) - -(define (memq obj list) (member obj list eq?)) - -(memq 2 '(1 2 3)) - -(memq 4 '(1 2 3)) - -(memq '(2) '((1) (2) (3))) - -(define (memv obj list) (member obj list eqv?)) - -(memv 2 '(1 2 3)) - -(memv 4 '(1 2 3)) - -(memv '(2) '((1) (2) (3))) - -(define (_assoc obj list test?) - (if (null? list) - #f - (if (test? obj (caar list)) - (car list) - (_assoc obj (cdr list) test?) - ) - ) - ) - -(define (assq obj list) (_assoc obj list eq?)) -(define (assv obj list) (_assoc obj list eqv?)) -(define (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") - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(char-upper-case? #\a) -(char-upper-case? #\B) -(char-upper-case? #\0) -(char-upper-case? #\space) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(char-lower-case? #\a) -(char-lower-case? #\B) -(char-lower-case? #\0) -(char-lower-case? #\space) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(char-alphabetic? #\a) -(char-alphabetic? #\B) -(char-alphabetic? #\0) -(char-alphabetic? #\space) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(char-numeric? #\a) -(char-numeric? #\B) -(char-numeric? #\0) -(char-numeric? #\space) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(char-whitespace? #\a) -(char-whitespace? #\B) -(char-whitespace? #\0) -(char-whitespace? #\space) - -(define (char->integer c) c) -(define (integer->char c) char-integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(char-upcase #\a) -(char-upcase #\B) -(char-upcase #\0) -(char-upcase #\space) - -(define (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 (lambda chars (list->string chars))) - -(display "apply\n") -(apply cons '(a b)) - -(define map - (lambda (proc . lists) - (define (args lists) - (cond ((null? lists) ()) - (else - (cons (caar lists) (args (cdr lists))) - ) - ) - ) - (define (next lists) - (cond ((null? lists) ()) - (else - (cons (cdr (car lists)) (next (cdr lists))) - ) - ) - ) - (define (domap lists) - (cond ((null? (car lists)) ()) - (else - (cons (apply proc (args lists)) (domap (next lists))) - ) - ) - ) - (domap lists) - ) - ) - -(map cadr '((a b) (d e) (g h))) - -(define for-each (lambda (proc . lists) - (apply map proc lists) - #t)) - -(for-each display '("hello" " " "world" "\n")) - -(define (_string-ml strings) - (if (null? strings) () - (cons (string->list (car strings)) (_string-ml (cdr strings))) - ) - ) - -(define string-map (lambda (proc . strings) - (list->string (apply map proc (_string-ml strings)))))) - -(string-map (lambda (x) (+ 1 x)) "HAL") - -(define string-for-each (lambda (proc . strings) - (apply for-each proc (_string-ml strings)))) - -(string-for-each write-char "IBM\n") - -(define (newline) (write-char #\newline)) - -(newline) - -(call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (write "test" x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - #t)) - - - ; `q -> (quote q) - ; `(q) -> (append (quote (q))) - ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) - ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) - - - -`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) - - -(define repeat - (macro (count . rest) - (define counter '__count__) - (cond ((pair? count) - (set! counter (car count)) - (set! count (cadr count)) - ) - ) - `(let ((,counter 0) - (__max__ ,count) - ) - (while (< ,counter __max__) - ,@rest - (set! ,counter (+ ,counter 1)) - ) - ) - ) - ) - -(repeat 2 (write 'hello)) -(repeat (x 3) (write 'goodbye x)) - -(define case - (macro (test . l) - ; construct the body of the - ; case, dealing with the - ; lambda version ( => lambda) - - (define (_unarrow l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)) - ) - - ; Build the case elements, which is - ; simply a list of cond clauses - - (define (_case l) - - (cond ((null? l) ()) - - ; else case - - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) - - ; regular case - - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - ) - ) - - ; now construct the overall - ; expression, using a lambda - ; to hold the computed value - ; of the test expression - - `((lambda (__key__) - (cond ,@(_case l))) ,test) - ) - ) - -(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) - -;(define number->string (lambda (arg . opt) -; (let ((base (if (null? opt) 10 (car opt))) - ; -; - diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c deleted file mode 100644 index 7f909487..00000000 --- a/src/lisp/ao_lisp_error.c +++ /dev/null @@ -1,139 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -void -ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) -{ - int first = 1; - printf("\t\t%s(", name); - if (ao_lisp_poly_type(poly) == AO_LISP_CONS) { - if (poly) { - while (poly) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); - if (!first) - printf("\t\t "); - else - first = 0; - ao_lisp_poly_write(cons->car); - printf("\n"); - if (poly == last) - break; - poly = cons->cdr; - } - printf("\t\t )\n"); - } else - printf(")\n"); - } else { - ao_lisp_poly_write(poly); - printf("\n"); - } -} - -static void tabs(int indent) -{ - while (indent--) - printf("\t"); -} - -void -ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) -{ - int f; - - tabs(indent); - printf ("%s{", name); - if (frame) { - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - if (frame->type & AO_LISP_FRAME_PRINT) - printf("recurse..."); - else { - frame->type |= AO_LISP_FRAME_PRINT; - for (f = 0; f < frame->num; f++) { - if (f != 0) { - tabs(indent); - printf(" "); - } - ao_lisp_poly_write(vals->vals[f].atom); - printf(" = "); - ao_lisp_poly_write(vals->vals[f].val); - printf("\n"); - } - if (frame->prev) - ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); - frame->type &= ~AO_LISP_FRAME_PRINT; - } - tabs(indent); - printf(" }\n"); - } else - printf ("}\n"); -} - -void -ao_lisp_vprintf(char *format, va_list args) -{ - char c; - - while ((c = *format++) != '\0') { - if (c == '%') { - switch (c = *format++) { - case 'v': - ao_lisp_poly_write((ao_poly) va_arg(args, unsigned int)); - break; - case 'p': - printf("%p", va_arg(args, void *)); - break; - case 'd': - printf("%d", va_arg(args, int)); - break; - case 's': - printf("%s", va_arg(args, char *)); - break; - default: - putchar(c); - break; - } - } else - putchar(c); - } -} - -void -ao_lisp_printf(char *format, ...) -{ - va_list args; - va_start(args, format); - ao_lisp_vprintf(format, args); - va_end(args); -} - -ao_poly -ao_lisp_error(int error, char *format, ...) -{ - va_list args; - - ao_lisp_exception |= error; - va_start(args, format); - ao_lisp_vprintf(format, args); - putchar('\n'); - va_end(args); - ao_lisp_printf("Value: %v\n", ao_lisp_v); - ao_lisp_printf("Frame: %v\n", ao_lisp_frame_poly(ao_lisp_frame_current)); - printf("Stack:\n"); - ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)); - ao_lisp_printf("Globals: %v\n", ao_lisp_frame_poly(ao_lisp_frame_global)); - return AO_LISP_NIL; -} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c deleted file mode 100644 index c3dd2ed2..00000000 --- a/src/lisp/ao_lisp_eval.c +++ /dev/null @@ -1,578 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -struct ao_lisp_stack *ao_lisp_stack; -ao_poly ao_lisp_v; -uint8_t ao_lisp_skip_cons_free; - -ao_poly -ao_lisp_set_cond(struct ao_lisp_cons *c) -{ - ao_lisp_stack->state = eval_cond; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(c); - return AO_LISP_NIL; -} - -static int -func_type(ao_poly func) -{ - if (func == AO_LISP_NIL) - return ao_lisp_error(AO_LISP_INVALID, "func is nil"); - switch (ao_lisp_poly_type(func)) { - case AO_LISP_BUILTIN: - return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK; - case AO_LISP_LAMBDA: - return ao_lisp_poly_lambda(func)->args; - case AO_LISP_STACK: - return AO_LISP_FUNC_LAMBDA; - default: - ao_lisp_error(AO_LISP_INVALID, "not a func"); - return -1; - } -} - -/* - * Flattened eval to avoid stack issues - */ - -/* - * Evaluate an s-expression - * - * For a list, evaluate all of the elements and - * then execute the resulting function call. - * - * Each element of the list is evaluated in - * a clean stack context. - * - * The current stack state is set to 'formal' so that - * when the evaluation is complete, the value - * will get appended to the values list. - * - * For other types, compute the value directly. - */ - -static int -ao_lisp_eval_sexpr(void) -{ - DBGI("sexpr: %v\n", ao_lisp_v); - switch (ao_lisp_poly_type(ao_lisp_v)) { - case AO_LISP_CONS: - if (ao_lisp_v == AO_LISP_NIL) { - if (!ao_lisp_stack->values) { - /* - * empty list evaluates to empty list - */ - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - /* - * done with arguments, go execute it - */ - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; - ao_lisp_stack->state = eval_exec; - } - } else { - if (!ao_lisp_stack->values) - ao_lisp_stack->list = ao_lisp_v; - /* - * Evaluate another argument and then switch - * to 'formal' to add the value to the values - * list - */ - ao_lisp_stack->sexprs = ao_lisp_v; - ao_lisp_stack->state = eval_formal; - if (!ao_lisp_stack_push()) - return 0; - /* - * push will reset the state to 'sexpr', which - * will evaluate the expression - */ - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - } - break; - case AO_LISP_ATOM: - DBGI("..frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); - /* fall through */ - case AO_LISP_BOOL: - case AO_LISP_INT: - case AO_LISP_BIGINT: - case AO_LISP_FLOAT: - case AO_LISP_STRING: - case AO_LISP_BUILTIN: - case AO_LISP_LAMBDA: - ao_lisp_stack->state = eval_val; - break; - } - DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG("\n"); - return 1; -} - -/* - * A value has been computed. - * - * If the value was computed from a macro, - * then we want to reset the current context - * to evaluate the macro result again. - * - * If not a macro, then pop the stack. - * If the stack is empty, we're done. - * Otherwise, the stack will contain - * the next state. - */ - -static int -ao_lisp_eval_val(void) -{ - DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); - /* - * Value computed, pop the stack - * to figure out what to do with the value - */ - ao_lisp_stack_pop(); - DBGI("..state %d\n", ao_lisp_stack ? ao_lisp_stack->state : -1); - return 1; -} - -/* - * A formal has been computed. - * - * If this is the first formal, then check to see if we've got a - * lamda, macro or nlambda. - * - * For lambda, go compute another formal. This will terminate - * when the sexpr state sees nil. - * - * For macro/nlambda, we're done, so move the sexprs into the values - * and go execute it. - * - * Macros have an additional step of saving a stack frame holding the - * macro value execution context, which then gets the result of the - * macro to run - */ - -static int -ao_lisp_eval_formal(void) -{ - ao_poly formal; - struct ao_lisp_stack *prev; - - DBGI("formal: "); DBG_POLY(ao_lisp_v); DBG("\n"); - - /* Check what kind of function we've got */ - if (!ao_lisp_stack->values) { - switch (func_type(ao_lisp_v)) { - case AO_LISP_FUNC_LAMBDA: - DBGI(".. lambda\n"); - break; - case AO_LISP_FUNC_MACRO: - /* Evaluate the result once more */ - ao_lisp_stack->state = eval_macro; - if (!ao_lisp_stack_push()) - return 0; - - /* After the function returns, take that - * value and re-evaluate it - */ - prev = ao_lisp_poly_stack(ao_lisp_stack->prev); - ao_lisp_stack->sexprs = prev->sexprs; - - DBGI(".. start macro\n"); - DBGI("\t.. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI("\t.. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); - DBG_FRAMES(); - - /* fall through ... */ - case AO_LISP_FUNC_NLAMBDA: - DBGI(".. nlambda or macro\n"); - - /* use the raw sexprs as values */ - ao_lisp_stack->values = ao_lisp_stack->sexprs; - ao_lisp_stack->values_tail = AO_LISP_NIL; - ao_lisp_stack->state = eval_exec; - - /* ready to execute now */ - return 1; - case -1: - return 0; - } - } - - /* Append formal to list of values */ - formal = ao_lisp__cons(ao_lisp_v, AO_LISP_NIL); - if (!formal) - return 0; - - if (ao_lisp_stack->values_tail) - ao_lisp_poly_cons(ao_lisp_stack->values_tail)->cdr = formal; - else - ao_lisp_stack->values = formal; - ao_lisp_stack->values_tail = formal; - - DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); - - /* - * Step to the next argument, if this is last, then - * 'sexpr' will end up switching to 'exec' - */ - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - - ao_lisp_stack->state = eval_sexpr; - - DBGI(".. "); DBG_POLY(ao_lisp_v); DBG("\n"); - return 1; -} - -/* - * Start executing a function call - * - * Most builtins are easy, just call the function. - * 'cond' is magic; it sticks the list of clauses - * in 'sexprs' and switches to 'cond' state. That - * bit of magic is done in ao_lisp_set_cond. - * - * Lambdas build a new frame to hold the locals and - * then re-use the current stack context to evaluate - * the s-expression from the lambda. - */ - -static int -ao_lisp_eval_exec(void) -{ - ao_poly v; - struct ao_lisp_builtin *builtin; - - DBGI("exec: "); DBG_POLY(ao_lisp_v); DBG(" values "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); - ao_lisp_stack->sexprs = AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_v)) { - case AO_LISP_BUILTIN: - ao_lisp_stack->state = eval_val; - builtin = ao_lisp_poly_builtin(ao_lisp_v); - v = ao_lisp_func(builtin) ( - ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr)); - DBG_DO(if (!ao_lisp_exception && ao_lisp_poly_builtin(ao_lisp_v)->func == builtin_set) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - ao_poly atom = ao_lisp_arg(cons, 1); - ao_poly val = ao_lisp_arg(cons, 2); - DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); - }); - builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin && (builtin->args & AO_LISP_FUNC_FREE_ARGS) && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_cons_free(cons); - } - - ao_lisp_v = v; - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; - DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - break; - case AO_LISP_LAMBDA: - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - ao_lisp_stack->state = eval_begin; - v = ao_lisp_lambda_eval(); - ao_lisp_stack->sexprs = v; - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; - DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - break; - case AO_LISP_STACK: - DBGI(".. stack "); DBG_POLY(ao_lisp_v); DBG("\n"); - ao_lisp_v = ao_lisp_stack_eval(); - DBGI(".. value "); DBG_POLY(ao_lisp_v); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - break; - } - ao_lisp_skip_cons_free = 0; - return 1; -} - -/* - * Finish setting up the apply evaluation - * - * The value is the list to execute - */ -static int -ao_lisp_eval_apply(void) -{ - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_v); - struct ao_lisp_cons *cdr, *prev; - - /* Glue the arguments into the right shape. That's all but the last - * concatenated onto the last - */ - cdr = cons; - for (;;) { - prev = cdr; - cdr = ao_lisp_poly_cons(prev->cdr); - if (cdr->cdr == AO_LISP_NIL) - break; - } - DBGI("before mangling: "); DBG_POLY(ao_lisp_v); DBG("\n"); - prev->cdr = cdr->car; - ao_lisp_stack->values = ao_lisp_v; - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; - DBGI("apply: "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); - ao_lisp_stack->state = eval_exec; - ao_lisp_skip_cons_free = 1; - return 1; -} - -/* - * Start evaluating the next cond clause - * - * If the list of clauses is empty, then - * the result of the cond is nil. - * - * Otherwise, set the current stack state to 'cond_test' and create a - * new stack context to evaluate the test s-expression. Once that's - * complete, we'll land in 'cond_test' to finish the clause. - */ -static int -ao_lisp_eval_cond(void) -{ - DBGI("cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - if (!ao_lisp_stack->sexprs) { - ao_lisp_v = _ao_lisp_bool_false; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; - if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { - ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); - return 0; - } - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - if (ao_lisp_v == _ao_lisp_atom_else) - ao_lisp_v = _ao_lisp_bool_true; - ao_lisp_stack->state = eval_cond_test; - if (!ao_lisp_stack_push()) - return 0; - } - return 1; -} - -/* - * Finish a cond clause. - * - * Check the value from the test expression, if - * non-nil, then set up to evaluate the value expression. - * - * Otherwise, step to the next clause and go back to the 'cond' - * state - */ -static int -ao_lisp_eval_cond_test(void) -{ - DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - if (ao_lisp_v != _ao_lisp_bool_false) { - struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); - ao_poly c = car->cdr; - - if (c) { - ao_lisp_stack->state = eval_begin; - ao_lisp_stack->sexprs = c; - } else - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - DBGI("next cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - ao_lisp_stack->state = eval_cond; - } - return 1; -} - -/* - * Evaluate a list of sexprs, returning the value from the last one. - * - * ao_lisp_begin records the list in stack->sexprs, so we just need to - * walk that list. Set ao_lisp_v to the car of the list and jump to - * eval_sexpr. When that's done, it will land in eval_val. For all but - * the last, leave a stack frame with eval_begin set so that we come - * back here. For the last, don't add a stack frame so that we can - * just continue on. - */ -static int -ao_lisp_eval_begin(void) -{ - DBGI("begin: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - - if (!ao_lisp_stack->sexprs) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; - ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - - /* If there are more sexprs to do, then come back here, otherwise - * return the value of the last one by just landing in eval_sexpr - */ - if (ao_lisp_stack->sexprs) { - ao_lisp_stack->state = eval_begin; - if (!ao_lisp_stack_push()) - return 0; - } - ao_lisp_stack->state = eval_sexpr; - } - return 1; -} - -/* - * Conditionally execute a list of sexprs while the first is true - */ -static int -ao_lisp_eval_while(void) -{ - DBGI("while: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - - ao_lisp_stack->values = ao_lisp_v; - if (!ao_lisp_stack->sexprs) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; - ao_lisp_stack->state = eval_while_test; - if (!ao_lisp_stack_push()) - return 0; - } - return 1; -} - -/* - * Check the while condition, terminate the loop if nil. Otherwise keep going - */ -static int -ao_lisp_eval_while_test(void) -{ - DBGI("while_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - - if (ao_lisp_v != _ao_lisp_bool_false) { - ao_lisp_stack->values = ao_lisp_v; - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - ao_lisp_stack->state = eval_while; - if (!ao_lisp_stack_push()) - return 0; - ao_lisp_stack->state = eval_begin; - ao_lisp_stack->sexprs = ao_lisp_v; - } - else - { - ao_lisp_stack->state = eval_val; - ao_lisp_v = ao_lisp_stack->values; - } - return 1; -} - -/* - * Replace the original sexpr with the macro expansion, then - * execute that - */ -static int -ao_lisp_eval_macro(void) -{ - DBGI("macro: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - - if (ao_lisp_v == AO_LISP_NIL) - ao_lisp_abort(); - if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_CONS) { - *ao_lisp_poly_cons(ao_lisp_stack->sexprs) = *ao_lisp_poly_cons(ao_lisp_v); - ao_lisp_v = ao_lisp_stack->sexprs; - DBGI("sexprs rewritten to: "); DBG_POLY(ao_lisp_v); DBG("\n"); - } - ao_lisp_stack->sexprs = AO_LISP_NIL; - ao_lisp_stack->state = eval_sexpr; - return 1; -} - -static int (*const evals[])(void) = { - [eval_sexpr] = ao_lisp_eval_sexpr, - [eval_val] = ao_lisp_eval_val, - [eval_formal] = ao_lisp_eval_formal, - [eval_exec] = ao_lisp_eval_exec, - [eval_apply] = ao_lisp_eval_apply, - [eval_cond] = ao_lisp_eval_cond, - [eval_cond_test] = ao_lisp_eval_cond_test, - [eval_begin] = ao_lisp_eval_begin, - [eval_while] = ao_lisp_eval_while, - [eval_while_test] = ao_lisp_eval_while_test, - [eval_macro] = ao_lisp_eval_macro, -}; - -const char *ao_lisp_state_names[] = { - [eval_sexpr] = "sexpr", - [eval_val] = "val", - [eval_formal] = "formal", - [eval_exec] = "exec", - [eval_apply] = "apply", - [eval_cond] = "cond", - [eval_cond_test] = "cond_test", - [eval_begin] = "begin", - [eval_while] = "while", - [eval_while_test] = "while_test", - [eval_macro] = "macro", -}; - -/* - * Called at restore time to reset all execution state - */ - -void -ao_lisp_eval_clear_globals(void) -{ - ao_lisp_stack = NULL; - ao_lisp_frame_current = NULL; - ao_lisp_v = AO_LISP_NIL; -} - -int -ao_lisp_eval_restart(void) -{ - return ao_lisp_stack_push(); -} - -ao_poly -ao_lisp_eval(ao_poly _v) -{ - ao_lisp_v = _v; - - ao_lisp_frame_init(); - - if (!ao_lisp_stack_push()) - return AO_LISP_NIL; - - while (ao_lisp_stack) { - if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) { - ao_lisp_stack_clear(); - return AO_LISP_NIL; - } - } - DBG_DO(if (ao_lisp_frame_current) {DBGI("frame left as "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");}); - ao_lisp_frame_current = NULL; - return ao_lisp_v; -} diff --git a/src/lisp/ao_lisp_float.c b/src/lisp/ao_lisp_float.c deleted file mode 100644 index 0aa6f2ea..00000000 --- a/src/lisp/ao_lisp_float.c +++ /dev/null @@ -1,148 +0,0 @@ -/* - * Copyright © 2017 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -static void float_mark(void *addr) -{ - (void) addr; -} - -static int float_size(void *addr) -{ - if (!addr) - return 0; - return sizeof (struct ao_lisp_float); -} - -static void float_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_float_type = { - .mark = float_mark, - .size = float_size, - .move = float_move, - .name = "float", -}; - -void -ao_lisp_float_write(ao_poly p) -{ - struct ao_lisp_float *f = ao_lisp_poly_float(p); - float v = f->value; - - if (isnanf(v)) - printf("+nan.0"); - else if (isinff(v)) { - if (v < 0) - printf("-"); - else - printf("+"); - printf("inf.0"); - } else - printf ("%g", f->value); -} - -float -ao_lisp_poly_number(ao_poly p) -{ - switch (ao_lisp_poly_base_type(p)) { - case AO_LISP_INT: - return ao_lisp_poly_int(p); - case AO_LISP_OTHER: - switch (ao_lisp_other_type(ao_lisp_poly_other(p))) { - case AO_LISP_BIGINT: - return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); - case AO_LISP_FLOAT: - return ao_lisp_poly_float(p)->value; - } - } - return NAN; -} - -ao_poly -ao_lisp_float_get(float value) -{ - struct ao_lisp_float *f; - - f = ao_lisp_alloc(sizeof (struct ao_lisp_float)); - f->type = AO_LISP_FLOAT; - f->value = value; - return ao_lisp_float_poly(f); -} - -ao_poly -ao_lisp_do_inexactp(struct ao_lisp_cons *cons) -{ - 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_FLOAT) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_finitep(struct ao_lisp_cons *cons) -{ - ao_poly value; - float f; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - value = ao_lisp_arg(cons, 0); - switch (ao_lisp_poly_type(value)) { - case AO_LISP_INT: - case AO_LISP_BIGINT: - return _ao_lisp_bool_true; - case AO_LISP_FLOAT: - f = ao_lisp_poly_float(value)->value; - if (!isnan(f) && !isinf(f)) - return _ao_lisp_bool_true; - } - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_infinitep(struct ao_lisp_cons *cons) -{ - ao_poly value; - float f; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - value = ao_lisp_arg(cons, 0); - switch (ao_lisp_poly_type(value)) { - case AO_LISP_FLOAT: - f = ao_lisp_poly_float(value)->value; - if (isinf(f)) - return _ao_lisp_bool_true; - } - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_sqrt(struct ao_lisp_cons *cons) -{ - ao_poly value; - - if (!ao_lisp_check_argc(_ao_lisp_atom_sqrt, cons, 1, 1)) - return AO_LISP_NIL; - value = ao_lisp_arg(cons, 0); - if (!ao_lisp_number_typep(ao_lisp_poly_type(value))) - return ao_lisp_error(AO_LISP_INVALID, "%s: non-numeric", ao_lisp_poly_atom(_ao_lisp_atom_sqrt)->name); - return ao_lisp_float_get(sqrtf(ao_lisp_poly_number(value))); -} diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c deleted file mode 100644 index c285527e..00000000 --- a/src/lisp/ao_lisp_frame.c +++ /dev/null @@ -1,330 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static inline int -frame_vals_num_size(int num) -{ - return sizeof (struct ao_lisp_frame_vals) + num * sizeof (struct ao_lisp_val); -} - -static int -frame_vals_size(void *addr) -{ - struct ao_lisp_frame_vals *vals = addr; - return frame_vals_num_size(vals->size); -} - -static void -frame_vals_mark(void *addr) -{ - struct ao_lisp_frame_vals *vals = addr; - int f; - - for (f = 0; f < vals->size; f++) { - struct ao_lisp_val *v = &vals->vals[f]; - - ao_lisp_poly_mark(v->val, 0); - MDBG_MOVE("frame mark atom %s %d val %d at %d ", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - MDBG_DO(ao_lisp_poly_write(v->val)); - MDBG_DO(printf("\n")); - } -} - -static void -frame_vals_move(void *addr) -{ - struct ao_lisp_frame_vals *vals = addr; - int f; - - for (f = 0; f < vals->size; f++) { - struct ao_lisp_val *v = &vals->vals[f]; - - ao_lisp_poly_move(&v->atom, 0); - ao_lisp_poly_move(&v->val, 0); - MDBG_MOVE("frame move atom %s %d val %d at %d\n", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - } -} - -const struct ao_lisp_type ao_lisp_frame_vals_type = { - .mark = frame_vals_mark, - .size = frame_vals_size, - .move = frame_vals_move, - .name = "frame_vals" -}; - -static int -frame_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_frame); -} - -static void -frame_mark(void *addr) -{ - struct ao_lisp_frame *frame = addr; - - for (;;) { - MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); - if (!AO_LISP_IS_POOL(frame)) - break; - ao_lisp_poly_mark(frame->vals, 0); - frame = ao_lisp_poly_frame(frame->prev); - MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); - if (!frame) - break; - if (ao_lisp_mark_memory(&ao_lisp_frame_type, frame)) - break; - } -} - -static void -frame_move(void *addr) -{ - struct ao_lisp_frame *frame = addr; - - for (;;) { - struct ao_lisp_frame *prev; - int ret; - - MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); - if (!AO_LISP_IS_POOL(frame)) - break; - ao_lisp_poly_move(&frame->vals, 0); - prev = ao_lisp_poly_frame(frame->prev); - if (!prev) - break; - ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &prev); - if (prev != ao_lisp_poly_frame(frame->prev)) { - MDBG_MOVE("frame prev moved from %d to %d\n", - MDBG_OFFSET(ao_lisp_poly_frame(frame->prev)), - MDBG_OFFSET(prev)); - frame->prev = ao_lisp_frame_poly(prev); - } - if (ret) - break; - frame = prev; - } -} - -const struct ao_lisp_type ao_lisp_frame_type = { - .mark = frame_mark, - .size = frame_size, - .move = frame_move, - .name = "frame", -}; - -void -ao_lisp_frame_write(ao_poly p) -{ - struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int f; - - printf ("{"); - if (frame) { - if (frame->type & AO_LISP_FRAME_PRINT) - printf("recurse..."); - else { - frame->type |= AO_LISP_FRAME_PRINT; - for (f = 0; f < frame->num; f++) { - if (f != 0) - printf(", "); - ao_lisp_poly_write(vals->vals[f].atom); - printf(" = "); - ao_lisp_poly_write(vals->vals[f].val); - } - if (frame->prev) - ao_lisp_poly_write(frame->prev); - frame->type &= ~AO_LISP_FRAME_PRINT; - } - } - printf("}"); -} - -static int -ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) -{ - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int l = 0; - int r = top - 1; - - while (l <= r) { - int m = (l + r) >> 1; - if (vals->vals[m].atom < atom) - l = m + 1; - else - r = m - 1; - } - return l; -} - -ao_poly * -ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) -{ - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int l = ao_lisp_frame_find(frame, frame->num, atom); - - if (l >= frame->num) - return NULL; - - if (vals->vals[l].atom != atom) - return NULL; - return &vals->vals[l].val; -} - -struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; - -static struct ao_lisp_frame_vals * -ao_lisp_frame_vals_new(int num) -{ - struct ao_lisp_frame_vals *vals; - - vals = ao_lisp_alloc(frame_vals_num_size(num)); - if (!vals) - return NULL; - vals->type = AO_LISP_FRAME_VALS; - vals->size = num; - memset(vals->vals, '\0', num * sizeof (struct ao_lisp_val)); - return vals; -} - -struct ao_lisp_frame * -ao_lisp_frame_new(int num) -{ - struct ao_lisp_frame *frame; - struct ao_lisp_frame_vals *vals; - - if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) { - ao_lisp_frame_free_list[num] = ao_lisp_poly_frame(frame->prev); - vals = ao_lisp_poly_frame_vals(frame->vals); - } else { - frame = ao_lisp_alloc(sizeof (struct ao_lisp_frame)); - if (!frame) - return NULL; - frame->type = AO_LISP_FRAME; - frame->num = 0; - frame->prev = AO_LISP_NIL; - frame->vals = AO_LISP_NIL; - ao_lisp_frame_stash(0, frame); - vals = ao_lisp_frame_vals_new(num); - frame = ao_lisp_frame_fetch(0); - if (!vals) - return NULL; - frame->vals = ao_lisp_frame_vals_poly(vals); - frame->num = num; - } - frame->prev = AO_LISP_NIL; - return frame; -} - -ao_poly -ao_lisp_frame_mark(struct ao_lisp_frame *frame) -{ - if (!frame) - return AO_LISP_NIL; - frame->type |= AO_LISP_FRAME_MARK; - return ao_lisp_frame_poly(frame); -} - -void -ao_lisp_frame_free(struct ao_lisp_frame *frame) -{ - if (frame && !ao_lisp_frame_marked(frame)) { - int num = frame->num; - if (num < AO_LISP_FRAME_FREE) { - struct ao_lisp_frame_vals *vals; - - vals = ao_lisp_poly_frame_vals(frame->vals); - memset(vals->vals, '\0', vals->size * sizeof (struct ao_lisp_val)); - frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); - ao_lisp_frame_free_list[num] = frame; - } - } -} - -static struct ao_lisp_frame * -ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) -{ - struct ao_lisp_frame_vals *vals; - struct ao_lisp_frame_vals *new_vals; - int copy; - - if (new_num == frame->num) - return frame; - ao_lisp_frame_stash(0, frame); - new_vals = ao_lisp_frame_vals_new(new_num); - frame = ao_lisp_frame_fetch(0); - if (!new_vals) - return NULL; - vals = ao_lisp_poly_frame_vals(frame->vals); - copy = new_num; - if (copy > frame->num) - copy = frame->num; - memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_lisp_val)); - frame->vals = ao_lisp_frame_vals_poly(new_vals); - frame->num = new_num; - return frame; -} - -void -ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val) -{ - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int l = ao_lisp_frame_find(frame, num, atom); - - memmove(&vals->vals[l+1], - &vals->vals[l], - (num - l) * sizeof (struct ao_lisp_val)); - vals->vals[l].atom = atom; - vals->vals[l].val = val; -} - -ao_poly -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) -{ - ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; - - if (!ref) { - int f = frame->num; - ao_lisp_poly_stash(0, atom); - ao_lisp_poly_stash(1, val); - frame = ao_lisp_frame_realloc(frame, f + 1); - val = ao_lisp_poly_fetch(1); - atom = ao_lisp_poly_fetch(0); - if (!frame) - return AO_LISP_NIL; - ao_lisp_frame_bind(frame, frame->num - 1, atom, val); - } else - *ref = val; - return val; -} - -struct ao_lisp_frame *ao_lisp_frame_global; -struct ao_lisp_frame *ao_lisp_frame_current; - -void -ao_lisp_frame_init(void) -{ - if (!ao_lisp_frame_global) - ao_lisp_frame_global = ao_lisp_frame_new(0); -} diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c deleted file mode 100644 index 8e467755..00000000 --- a/src/lisp/ao_lisp_int.c +++ /dev/null @@ -1,79 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -void -ao_lisp_int_write(ao_poly p) -{ - int i = ao_lisp_poly_int(p); - printf("%d", i); -} - -int32_t -ao_lisp_poly_integer(ao_poly p) -{ - switch (ao_lisp_poly_base_type(p)) { - case AO_LISP_INT: - return ao_lisp_poly_int(p); - case AO_LISP_OTHER: - if (ao_lisp_other_type(ao_lisp_poly_other(p)) == AO_LISP_BIGINT) - return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); - } - return AO_LISP_NOT_INTEGER; -} - -ao_poly -ao_lisp_integer_poly(int32_t p) -{ - struct ao_lisp_bigint *bi; - - if (AO_LISP_MIN_INT <= p && p <= AO_LISP_MAX_INT) - return ao_lisp_int_poly(p); - bi = ao_lisp_alloc(sizeof (struct ao_lisp_bigint)); - bi->value = ao_lisp_int_bigint(p); - return ao_lisp_bigint_poly(bi); -} - -static void bigint_mark(void *addr) -{ - (void) addr; -} - -static int bigint_size(void *addr) -{ - if (!addr) - return 0; - return sizeof (struct ao_lisp_bigint); -} - -static void bigint_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_bigint_type = { - .mark = bigint_mark, - .size = bigint_size, - .move = bigint_move, - .name = "bigint", -}; - -void -ao_lisp_bigint_write(ao_poly p) -{ - struct ao_lisp_bigint *bi = ao_lisp_poly_bigint(p); - - printf("%d", ao_lisp_bigint_int(bi->value)); -} diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c deleted file mode 100644 index e72281db..00000000 --- a/src/lisp/ao_lisp_lambda.c +++ /dev/null @@ -1,208 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_lisp.h" - -int -lambda_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_lambda); -} - -void -lambda_mark(void *addr) -{ - struct ao_lisp_lambda *lambda = addr; - - ao_lisp_poly_mark(lambda->code, 0); - ao_lisp_poly_mark(lambda->frame, 0); -} - -void -lambda_move(void *addr) -{ - struct ao_lisp_lambda *lambda = addr; - - ao_lisp_poly_move(&lambda->code, 0); - ao_lisp_poly_move(&lambda->frame, 0); -} - -const struct ao_lisp_type ao_lisp_lambda_type = { - .size = lambda_size, - .mark = lambda_mark, - .move = lambda_move, - .name = "lambda", -}; - -void -ao_lisp_lambda_write(ao_poly poly) -{ - struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(poly); - struct ao_lisp_cons *cons = ao_lisp_poly_cons(lambda->code); - - printf("("); - printf("%s", ao_lisp_args_name(lambda->args)); - while (cons) { - printf(" "); - ao_lisp_poly_write(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - } - printf(")"); -} - -ao_poly -ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) -{ - struct ao_lisp_lambda *lambda; - ao_poly formal; - struct ao_lisp_cons *cons; - - formal = ao_lisp_arg(code, 0); - while (formal != AO_LISP_NIL) { - switch (ao_lisp_poly_type(formal)) { - case AO_LISP_CONS: - cons = ao_lisp_poly_cons(formal); - if (ao_lisp_poly_type(cons->car) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", cons->car); - formal = cons->cdr; - break; - case AO_LISP_ATOM: - formal = AO_LISP_NIL; - break; - default: - return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", formal); - } - } - - ao_lisp_cons_stash(0, code); - lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); - code = ao_lisp_cons_fetch(0); - if (!lambda) - return AO_LISP_NIL; - - lambda->type = AO_LISP_LAMBDA; - lambda->args = args; - lambda->code = ao_lisp_cons_poly(code); - lambda->frame = ao_lisp_frame_mark(ao_lisp_frame_current); - DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); - DBG_STACK(); - return ao_lisp_lambda_poly(lambda); -} - -ao_poly -ao_lisp_do_lambda(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); -} - -ao_poly -ao_lisp_do_nlambda(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); -} - -ao_poly -ao_lisp_do_macro(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO); -} - -ao_poly -ao_lisp_lambda_eval(void) -{ - struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(ao_lisp_v); - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - struct ao_lisp_cons *code = ao_lisp_poly_cons(lambda->code); - ao_poly formals; - struct ao_lisp_frame *next_frame; - int args_wanted; - ao_poly varargs = AO_LISP_NIL; - int args_provided; - int f; - struct ao_lisp_cons *vals; - - DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); - - args_wanted = 0; - for (formals = ao_lisp_arg(code, 0); - ao_lisp_is_pair(formals); - formals = ao_lisp_poly_cons(formals)->cdr) - ++args_wanted; - if (formals != AO_LISP_NIL) { - if (ao_lisp_poly_type(formals) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "bad lambda form"); - varargs = formals; - } - - /* Create a frame to hold the variables - */ - args_provided = ao_lisp_cons_length(cons) - 1; - if (varargs == AO_LISP_NIL) { - if (args_wanted != args_provided) - return ao_lisp_error(AO_LISP_INVALID, "need %d args, got %d", args_wanted, args_provided); - } else { - if (args_provided < args_wanted) - return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided); - } - - ao_lisp_poly_stash(1, varargs); - next_frame = ao_lisp_frame_new(args_wanted + (varargs != AO_LISP_NIL)); - varargs = ao_lisp_poly_fetch(1); - if (!next_frame) - return AO_LISP_NIL; - - /* Re-fetch all of the values in case something moved */ - lambda = ao_lisp_poly_lambda(ao_lisp_v); - cons = ao_lisp_poly_cons(ao_lisp_stack->values); - code = ao_lisp_poly_cons(lambda->code); - formals = ao_lisp_arg(code, 0); - vals = ao_lisp_poly_cons(cons->cdr); - - next_frame->prev = lambda->frame; - ao_lisp_frame_current = next_frame; - ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - - for (f = 0; f < args_wanted; f++) { - struct ao_lisp_cons *arg = ao_lisp_poly_cons(formals); - DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, arg->car, vals->car); - formals = arg->cdr; - vals = ao_lisp_poly_cons(vals->cdr); - } - if (varargs) { - DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); - /* - * Bind the rest of the arguments to the final parameter - */ - ao_lisp_frame_bind(next_frame, f, varargs, ao_lisp_cons_poly(vals)); - } else { - /* - * Mark the cons cells from the actuals as freed for immediate re-use, unless - * the actuals point into the source function (nlambdas and macros), or if the - * stack containing them was copied as a part of a continuation - */ - if (lambda->args == AO_LISP_FUNC_LAMBDA && !ao_lisp_stack_marked(ao_lisp_stack)) { - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_cons_free(cons); - } - } - DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); - DBG_STACK(); - DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); - return code->cdr; -} diff --git a/src/lisp/ao_lisp_lex.c b/src/lisp/ao_lisp_lex.c deleted file mode 100644 index fe7c47f4..00000000 --- a/src/lisp/ao_lisp_lex.c +++ /dev/null @@ -1,16 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin deleted file mode 100644 index 783ab378..00000000 --- a/src/lisp/ao_lisp_make_builtin +++ /dev/null @@ -1,190 +0,0 @@ -#!/usr/bin/nickle - -typedef struct { - string type; - string c_name; - string[*] lisp_names; -} builtin_t; - -string[string] type_map = { - "lambda" => "LAMBDA", - "nlambda" => "NLAMBDA", - "macro" => "MACRO", - "f_lambda" => "F_LAMBDA", - "atom" => "atom", -}; - -string[*] -make_lisp(string[*] tokens) -{ - string[...] lisp = {}; - - if (dim(tokens) < 3) - return (string[1]) { tokens[dim(tokens) - 1] }; - return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; -} - -builtin_t -read_builtin(file f) { - string line = File::fgets(f); - string[*] tokens = String::wordsplit(line, " \t"); - - return (builtin_t) { - .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", - .c_name = dim(tokens) > 1 ? tokens[1] : "#", - .lisp_names = make_lisp(tokens), - }; -} - -builtin_t[*] -read_builtins(file f) { - builtin_t[...] builtins = {}; - - while (!File::end(f)) { - builtin_t b = read_builtin(f); - - if (b.type[0] != '#') - builtins[dim(builtins)] = b; - } - return builtins; -} - -bool is_atom(builtin_t b) = b.type == "atom"; - -void -dump_ids(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_ID\n"); - printf("#undef AO_LISP_BUILTIN_ID\n"); - printf("enum ao_lisp_builtin_id {\n"); - for (int i = 0; i < dim(builtins); i++) - if (!is_atom(builtins[i])) - printf("\tbuiltin_%s,\n", builtins[i].c_name); - printf("\t_builtin_last\n"); - printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_ID */\n"); -} - -void -dump_casename(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_CASENAME\n"); - printf("#undef AO_LISP_BUILTIN_CASENAME\n"); - printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n"); - printf("\tswitch(b) {\n"); - for (int i = 0; i < dim(builtins); i++) - if (!is_atom(builtins[i])) - printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n", - builtins[i].c_name, builtins[i].lisp_names[0]); - printf("\tdefault: return \"???\";\n"); - printf("\t}\n"); - printf("}\n"); - printf("#endif /* AO_LISP_BUILTIN_CASENAME */\n"); -} - -void -cify_lisp(string l) { - for (int j = 0; j < String::length(l); j++) { - int c= l[j]; - if (Ctype::isalnum(c) || c == '_') - printf("%c", c); - else - printf("%02x", c); - } -} - -void -dump_arrayname(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_ARRAYNAME\n"); - printf("#undef AO_LISP_BUILTIN_ARRAYNAME\n"); - printf("static const ao_poly builtin_names[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) { - printf("\t[builtin_%s] = _ao_lisp_atom_", - builtins[i].c_name); - cify_lisp(builtins[i].lisp_names[0]); - printf(",\n"); - } - } - printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_ARRAYNAME */\n"); -} - -void -dump_funcs(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_FUNCS\n"); - printf("#undef AO_LISP_BUILTIN_FUNCS\n"); - printf("const ao_lisp_func_t ao_lisp_builtins[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) - printf("\t[builtin_%s] = ao_lisp_do_%s,\n", - builtins[i].c_name, - builtins[i].c_name); - } - printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_FUNCS */\n"); -} - -void -dump_decls(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_DECLS\n"); - printf("#undef AO_LISP_BUILTIN_DECLS\n"); - for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) { - printf("ao_poly\n"); - printf("ao_lisp_do_%s(struct ao_lisp_cons *cons);\n", - builtins[i].c_name); - } - } - printf("#endif /* AO_LISP_BUILTIN_DECLS */\n"); -} - -void -dump_consts(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_CONSTS\n"); - printf("#undef AO_LISP_BUILTIN_CONSTS\n"); - printf("struct builtin_func funcs[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) { - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", - builtins[i].lisp_names[j], - builtins[i].type, - builtins[i].c_name); - } - } - } - printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); -} - -void -dump_atoms(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_ATOMS\n"); - printf("#undef AO_LISP_BUILTIN_ATOMS\n"); - for (int i = 0; i < dim(builtins); i++) { - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - printf("#define _ao_lisp_atom_"); - cify_lisp(builtins[i].lisp_names[j]); - printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); - } - } - printf("#endif /* AO_LISP_BUILTIN_ATOMS */\n"); -} - -void main() { - if (dim(argv) < 2) { - File::fprintf(stderr, "usage: %s \n", argv[0]); - exit(1); - } - twixt(file f = File::open(argv[1], "r"); File::close(f)) { - builtin_t[*] builtins = read_builtins(f); - dump_ids(builtins); - dump_casename(builtins); - dump_arrayname(builtins); - dump_funcs(builtins); - dump_decls(builtins); - dump_consts(builtins); - dump_atoms(builtins); - } -} - -main(); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c deleted file mode 100644 index 6e4b411e..00000000 --- a/src/lisp/ao_lisp_make_const.c +++ /dev/null @@ -1,395 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include -#include -#include -#include - -static struct ao_lisp_builtin * -ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { - struct ao_lisp_builtin *b = ao_lisp_alloc(sizeof (struct ao_lisp_builtin)); - - b->type = AO_LISP_BUILTIN; - b->func = func; - b->args = args; - return b; -} - -struct builtin_func { - char *name; - int args; - enum ao_lisp_builtin_id func; -}; - -#define AO_LISP_BUILTIN_CONSTS -#include "ao_lisp_builtin.h" - -#define N_FUNC (sizeof funcs / sizeof funcs[0]) - -struct ao_lisp_frame *globals; - -static int -is_atom(int offset) -{ - struct ao_lisp_atom *a; - - for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) - if (((uint8_t *) a->name - ao_lisp_const) == offset) - return strlen(a->name); - return 0; -} - -#define AO_FEC_CRC_INIT 0xffff - -static inline uint16_t -ao_fec_crc_byte(uint8_t byte, uint16_t crc) -{ - uint8_t bit; - - for (bit = 0; bit < 8; bit++) { - if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) - crc = (crc << 1) ^ 0x8005; - else - crc = (crc << 1); - byte <<= 1; - } - return crc; -} - -uint16_t -ao_fec_crc(const uint8_t *bytes, uint8_t len) -{ - uint16_t crc = AO_FEC_CRC_INIT; - - while (len--) - crc = ao_fec_crc_byte(*bytes++, crc); - return crc; -} - -struct ao_lisp_macro_stack { - struct ao_lisp_macro_stack *next; - ao_poly p; -}; - -struct ao_lisp_macro_stack *macro_stack; - -int -ao_lisp_macro_push(ao_poly p) -{ - struct ao_lisp_macro_stack *m = macro_stack; - - while (m) { - if (m->p == p) - return 1; - m = m->next; - } - m = malloc (sizeof (struct ao_lisp_macro_stack)); - m->p = p; - m->next = macro_stack; - macro_stack = m; - return 0; -} - -void -ao_lisp_macro_pop(void) -{ - struct ao_lisp_macro_stack *m = macro_stack; - - macro_stack = m->next; - free(m); -} - -#define DBG_MACRO 0 -#if DBG_MACRO -int macro_scan_depth; - -void indent(void) -{ - int i; - for (i = 0; i < macro_scan_depth; i++) - printf(" "); -} -#define MACRO_DEBUG(a) a -#else -#define MACRO_DEBUG(a) -#endif - -ao_poly -ao_has_macro(ao_poly p); - -ao_poly -ao_macro_test_get(ao_poly atom) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - if (ref) - return *ref; - return AO_LISP_NIL; -} - -ao_poly -ao_is_macro(ao_poly p) -{ - struct ao_lisp_builtin *builtin; - struct ao_lisp_lambda *lambda; - ao_poly ret; - - MACRO_DEBUG(indent(); printf ("is macro "); ao_lisp_poly_write(p); printf("\n"); ++macro_scan_depth); - switch (ao_lisp_poly_type(p)) { - case AO_LISP_ATOM: - if (ao_lisp_macro_push(p)) - ret = AO_LISP_NIL; - else { - if (ao_is_macro(ao_macro_test_get(p))) - ret = p; - else - ret = AO_LISP_NIL; - ao_lisp_macro_pop(); - } - break; - case AO_LISP_CONS: - ret = ao_has_macro(p); - break; - case AO_LISP_BUILTIN: - builtin = ao_lisp_poly_builtin(p); - if ((builtin->args & AO_LISP_FUNC_MASK) == AO_LISP_FUNC_MACRO) - ret = p; - else - ret = 0; - break; - - case AO_LISP_LAMBDA: - lambda = ao_lisp_poly_lambda(p); - if (lambda->args == AO_LISP_FUNC_MACRO) - ret = p; - else - ret = ao_has_macro(lambda->code); - break; - default: - ret = AO_LISP_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_lisp_poly_write(ret); printf("\n")); - return ret; -} - -ao_poly -ao_has_macro(ao_poly p) -{ - struct ao_lisp_cons *cons; - struct ao_lisp_lambda *lambda; - ao_poly m; - ao_poly list; - - if (p == AO_LISP_NIL) - return AO_LISP_NIL; - - MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_write(p); printf("\n"); ++macro_scan_depth); - switch (ao_lisp_poly_type(p)) { - case AO_LISP_LAMBDA: - lambda = ao_lisp_poly_lambda(p); - p = ao_has_macro(lambda->code); - break; - case AO_LISP_CONS: - cons = ao_lisp_poly_cons(p); - if ((p = ao_is_macro(cons->car))) - break; - - list = cons->cdr; - p = AO_LISP_NIL; - while (list != AO_LISP_NIL && ao_lisp_poly_type(list) == AO_LISP_CONS) { - cons = ao_lisp_poly_cons(list); - m = ao_has_macro(cons->car); - if (m) { - p = m; - break; - } - list = cons->cdr; - } - break; - - default: - p = AO_LISP_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_lisp_poly_write(p); printf("\n")); - return p; -} - -int -ao_lisp_read_eval_abort(void) -{ - ao_poly in, out = AO_LISP_NIL; - for(;;) { - in = ao_lisp_read(); - if (in == _ao_lisp_atom_eof) - break; - out = ao_lisp_eval(in); - if (ao_lisp_exception) - return 0; - ao_lisp_poly_write(out); - putchar ('\n'); - } - return 1; -} - -static FILE *in; -static FILE *out; - -int -ao_lisp_getc(void) -{ - return getc(in); -} - -static const struct option options[] = { - { .name = "out", .has_arg = 1, .val = 'o' }, - { 0, 0, 0, 0 } -}; - -static void usage(char *program) -{ - fprintf(stderr, "usage: %s [--out=] [input]\n", program); - exit(1); -} - -int -main(int argc, char **argv) -{ - int f, o; - ao_poly val; - struct ao_lisp_atom *a; - struct ao_lisp_builtin *b; - int in_atom = 0; - char *out_name = NULL; - int c; - enum ao_lisp_builtin_id prev_func; - - in = stdin; - out = stdout; - - while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { - switch (c) { - case 'o': - out_name = optarg; - break; - default: - usage(argv[0]); - break; - } - } - - ao_lisp_frame_init(); - - /* Boolean values #f and #t */ - ao_lisp_bool_get(0); - ao_lisp_bool_get(1); - - prev_func = _builtin_last; - for (f = 0; f < (int) N_FUNC; f++) { - if (funcs[f].func != prev_func) - b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); - a = ao_lisp_atom_intern(funcs[f].name); - ao_lisp_atom_def(ao_lisp_atom_poly(a), - ao_lisp_builtin_poly(b)); - } - - /* end of file value */ - a = ao_lisp_atom_intern("eof"); - ao_lisp_atom_def(ao_lisp_atom_poly(a), - ao_lisp_atom_poly(a)); - - /* 'else' */ - a = ao_lisp_atom_intern("else"); - - if (argv[optind]){ - in = fopen(argv[optind], "r"); - if (!in) { - perror(argv[optind]); - exit(1); - } - } - if (!ao_lisp_read_eval_abort()) { - fprintf(stderr, "eval failed\n"); - exit(1); - } - - /* Reduce to referenced values */ - ao_lisp_collect(AO_LISP_COLLECT_FULL); - - for (f = 0; f < ao_lisp_frame_global->num; f++) { - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(ao_lisp_frame_global->vals); - val = ao_has_macro(vals->vals[f].val); - if (val != AO_LISP_NIL) { - printf("error: function %s contains unresolved macro: ", - ao_lisp_poly_atom(vals->vals[f].atom)->name); - ao_lisp_poly_write(val); - printf("\n"); - exit(1); - } - } - - if (out_name) { - out = fopen(out_name, "w"); - if (!out) { - perror(out_name); - exit(1); - } - } - - fprintf(out, "/* Generated file, do not edit */\n\n"); - - fprintf(out, "#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); - fprintf(out, "extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); - fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); - fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(ao_lisp_frame_global)); - fprintf(out, "#define ao_lisp_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_lisp_const, ao_lisp_top)); - - fprintf(out, "#define _ao_lisp_bool_false 0x%04x\n", ao_lisp_bool_poly(ao_lisp_false)); - fprintf(out, "#define _ao_lisp_bool_true 0x%04x\n", ao_lisp_bool_poly(ao_lisp_true)); - - for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { - char *n = a->name, c; - fprintf(out, "#define _ao_lisp_atom_"); - while ((c = *n++)) { - if (isalnum(c)) - fprintf(out, "%c", c); - else - fprintf(out, "%02x", c); - } - fprintf(out, " 0x%04x\n", ao_lisp_atom_poly(a)); - } - fprintf(out, "#ifdef AO_LISP_CONST_BITS\n"); - fprintf(out, "const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute((aligned(4))) = {"); - for (o = 0; o < ao_lisp_top; o++) { - uint8_t c; - if ((o & 0xf) == 0) - fprintf(out, "\n\t"); - else - fprintf(out, " "); - c = ao_lisp_const[o]; - if (!in_atom) - in_atom = is_atom(o); - if (in_atom) { - fprintf(out, " '%c',", c); - in_atom--; - } else { - fprintf(out, "0x%02x,", c); - } - } - fprintf(out, "\n};\n"); - fprintf(out, "#endif /* AO_LISP_CONST_BITS */\n"); - exit(0); -} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c deleted file mode 100644 index 5471b137..00000000 --- a/src/lisp/ao_lisp_mem.c +++ /dev/null @@ -1,968 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#define AO_LISP_CONST_BITS - -#include "ao_lisp.h" -#include -#include - -#ifdef AO_LISP_MAKE_CONST - -/* - * When building the constant table, it is the - * pool for allocations. - */ - -#include -uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); -#define ao_lisp_pool ao_lisp_const -#undef AO_LISP_POOL -#define AO_LISP_POOL AO_LISP_POOL_CONST - -#else - -uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); - -#endif - -#ifndef DBG_MEM_STATS -#define DBG_MEM_STATS DBG_MEM -#endif - -#if DBG_MEM -int dbg_move_depth; -int dbg_mem = DBG_MEM_START; -int dbg_validate = 0; - -struct ao_lisp_record { - struct ao_lisp_record *next; - const struct ao_lisp_type *type; - void *addr; - int size; -}; - -static struct ao_lisp_record *record_head, **record_tail; - -static void -ao_lisp_record_free(struct ao_lisp_record *record) -{ - while (record) { - struct ao_lisp_record *next = record->next; - free(record); - record = next; - } -} - -static void -ao_lisp_record_reset(void) -{ - ao_lisp_record_free(record_head); - record_head = NULL; - record_tail = &record_head; -} - -static void -ao_lisp_record(const struct ao_lisp_type *type, - void *addr, - int size) -{ - struct ao_lisp_record *r = malloc(sizeof (struct ao_lisp_record)); - - r->next = NULL; - r->type = type; - r->addr = addr; - r->size = size; - *record_tail = r; - record_tail = &r->next; -} - -static struct ao_lisp_record * -ao_lisp_record_save(void) -{ - struct ao_lisp_record *r = record_head; - - record_head = NULL; - record_tail = &record_head; - return r; -} - -static void -ao_lisp_record_compare(char *where, - struct ao_lisp_record *a, - struct ao_lisp_record *b) -{ - while (a && b) { - if (a->type != b->type || a->size != b->size) { - printf("%s record difers %d %s %d -> %d %s %d\n", - where, - MDBG_OFFSET(a->addr), - a->type->name, - a->size, - MDBG_OFFSET(b->addr), - b->type->name, - b->size); - ao_lisp_abort(); - } - a = a->next; - b = b->next; - } - if (a) { - printf("%s record differs %d %s %d -> NULL\n", - where, - MDBG_OFFSET(a->addr), - a->type->name, - a->size); - ao_lisp_abort(); - } - if (b) { - printf("%s record differs NULL -> %d %s %d\n", - where, - MDBG_OFFSET(b->addr), - b->type->name, - b->size); - ao_lisp_abort(); - } -} - -#else -#define ao_lisp_record_reset() -#endif - -uint8_t ao_lisp_exception; - -struct ao_lisp_root { - const struct ao_lisp_type *type; - void **addr; -}; - -static struct ao_lisp_cons *save_cons[2]; -static char *save_string[2]; -static struct ao_lisp_frame *save_frame[1]; -static ao_poly save_poly[3]; - -static const struct ao_lisp_root ao_lisp_root[] = { - { - .type = &ao_lisp_cons_type, - .addr = (void **) &save_cons[0], - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &save_cons[1], - }, - { - .type = &ao_lisp_string_type, - .addr = (void **) &save_string[0], - }, - { - .type = &ao_lisp_string_type, - .addr = (void **) &save_string[1], - }, - { - .type = &ao_lisp_frame_type, - .addr = (void **) &save_frame[0], - }, - { - .type = NULL, - .addr = (void **) (void *) &save_poly[0] - }, - { - .type = NULL, - .addr = (void **) (void *) &save_poly[1] - }, - { - .type = NULL, - .addr = (void **) (void *) &save_poly[2] - }, - { - .type = &ao_lisp_atom_type, - .addr = (void **) &ao_lisp_atoms - }, - { - .type = &ao_lisp_frame_type, - .addr = (void **) &ao_lisp_frame_global, - }, - { - .type = &ao_lisp_frame_type, - .addr = (void **) &ao_lisp_frame_current, - }, - { - .type = &ao_lisp_stack_type, - .addr = (void **) &ao_lisp_stack, - }, - { - .type = NULL, - .addr = (void **) (void *) &ao_lisp_v, - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &ao_lisp_read_cons, - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &ao_lisp_read_cons_tail, - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &ao_lisp_read_stack, - }, -#ifdef AO_LISP_MAKE_CONST - { - .type = &ao_lisp_bool_type, - .addr = (void **) &ao_lisp_false, - }, - { - .type = &ao_lisp_bool_type, - .addr = (void **) &ao_lisp_true, - }, -#endif -}; - -#define AO_LISP_ROOT (sizeof (ao_lisp_root) / sizeof (ao_lisp_root[0])) - -static const void ** const ao_lisp_cache[] = { - (const void **) &ao_lisp_cons_free_list, - (const void **) &ao_lisp_stack_free_list, - (const void **) &ao_lisp_frame_free_list[0], - (const void **) &ao_lisp_frame_free_list[1], - (const void **) &ao_lisp_frame_free_list[2], - (const void **) &ao_lisp_frame_free_list[3], - (const void **) &ao_lisp_frame_free_list[4], - (const void **) &ao_lisp_frame_free_list[5], -}; - -#if AO_LISP_FRAME_FREE != 6 -#error Unexpected AO_LISP_FRAME_FREE value -#endif - -#define AO_LISP_CACHE (sizeof (ao_lisp_cache) / sizeof (ao_lisp_cache[0])) - -#define AO_LISP_BUSY_SIZE ((AO_LISP_POOL + 31) / 32) - -static uint8_t ao_lisp_busy[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_cons_note[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_cons_last[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_cons_noted; - -uint16_t ao_lisp_top; - -struct ao_lisp_chunk { - uint16_t old_offset; - union { - uint16_t size; - uint16_t new_offset; - }; -}; - -#define AO_LISP_NCHUNK 64 - -static struct ao_lisp_chunk ao_lisp_chunk[AO_LISP_NCHUNK]; - -/* Offset of an address within the pool. */ -static inline uint16_t pool_offset(void *addr) { -#if DBG_MEM - if (!AO_LISP_IS_POOL(addr)) - ao_lisp_abort(); -#endif - return ((uint8_t *) addr) - ao_lisp_pool; -} - -static inline void mark(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - tag[byte] |= (1 << bit); -} - -static inline void clear(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - tag[byte] &= ~(1 << bit); -} - -static inline int busy(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - return (tag[byte] >> bit) & 1; -} - -static inline int min(int a, int b) { return a < b ? a : b; } -static inline int max(int a, int b) { return a > b ? a : b; } - -static inline int limit(int offset) { - return min(AO_LISP_POOL, max(offset, 0)); -} - -static void -note_cons(uint16_t offset) -{ - MDBG_MOVE("note cons %d\n", offset); - ao_lisp_cons_noted = 1; - mark(ao_lisp_cons_note, offset); -} - -static uint16_t chunk_low, chunk_high; -static uint16_t chunk_first, chunk_last; - -static int -find_chunk(uint16_t offset) -{ - int l, r; - /* Binary search for the location */ - l = chunk_first; - r = chunk_last - 1; - while (l <= r) { - int m = (l + r) >> 1; - if (ao_lisp_chunk[m].old_offset < offset) - l = m + 1; - else - r = m - 1; - } - return l; -} - -static void -note_chunk(uint16_t offset, uint16_t size) -{ - int l; - - if (offset < chunk_low || chunk_high <= offset) - return; - - l = find_chunk(offset); - - /* - * The correct location is always in 'l', with r = l-1 being - * the entry before the right one - */ - -#if DBG_MEM - /* Off the right side */ - if (l >= AO_LISP_NCHUNK) - ao_lisp_abort(); - - /* Off the left side */ - if (l == 0 && chunk_last && offset > ao_lisp_chunk[0].old_offset) - ao_lisp_abort(); -#endif - - /* Shuffle existing entries right */ - int end = min(AO_LISP_NCHUNK, chunk_last + 1); - - memmove(&ao_lisp_chunk[l+1], - &ao_lisp_chunk[l], - (end - (l+1)) * sizeof (struct ao_lisp_chunk)); - - /* Add new entry */ - ao_lisp_chunk[l].old_offset = offset; - ao_lisp_chunk[l].size = size; - - /* Increment the number of elements up to the size of the array */ - if (chunk_last < AO_LISP_NCHUNK) - chunk_last++; - - /* Set the top address if the array is full */ - if (chunk_last == AO_LISP_NCHUNK) - chunk_high = ao_lisp_chunk[AO_LISP_NCHUNK-1].old_offset + - ao_lisp_chunk[AO_LISP_NCHUNK-1].size; -} - -static void -reset_chunks(void) -{ - chunk_high = ao_lisp_top; - chunk_last = 0; - chunk_first = 0; -} - -/* - * Walk all referenced objects calling functions on each one - */ - -static void -walk(int (*visit_addr)(const struct ao_lisp_type *type, void **addr), - int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) -{ - int i; - - ao_lisp_record_reset(); - memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); - memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); - ao_lisp_cons_noted = 0; - for (i = 0; i < (int) AO_LISP_ROOT; i++) { - if (ao_lisp_root[i].type) { - void **a = ao_lisp_root[i].addr, *v; - if (a && (v = *a)) { - MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); - visit_addr(ao_lisp_root[i].type, a); - } - } else { - ao_poly *a = (ao_poly *) ao_lisp_root[i].addr, p; - if (a && (p = *a)) { - MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_lisp_ref(p))); - visit_poly(a, 0); - } - } - } - while (ao_lisp_cons_noted) { - memcpy(ao_lisp_cons_last, ao_lisp_cons_note, sizeof (ao_lisp_cons_note)); - memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); - ao_lisp_cons_noted = 0; - for (i = 0; i < AO_LISP_POOL; i += 4) { - if (busy(ao_lisp_cons_last, i)) { - void *v = ao_lisp_pool + i; - MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); - visit_addr(&ao_lisp_cons_type, &v); - } - } - } -} - -#if MDBG_DUMP -static void -dump_busy(void) -{ - int i; - MDBG_MOVE("busy:"); - for (i = 0; i < ao_lisp_top; i += 4) { - if ((i & 0xff) == 0) { - MDBG_MORE("\n"); - MDBG_MOVE("%s", ""); - } - else if ((i & 0x1f) == 0) - MDBG_MORE(" "); - if (busy(ao_lisp_busy, i)) - MDBG_MORE("*"); - else - MDBG_MORE("-"); - } - MDBG_MORE ("\n"); -} -#define DUMP_BUSY() dump_busy() -#else -#define DUMP_BUSY() -#endif - -static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { - [AO_LISP_CONS] = &ao_lisp_cons_type, - [AO_LISP_INT] = NULL, - [AO_LISP_STRING] = &ao_lisp_string_type, - [AO_LISP_OTHER] = (void *) 0x1, - [AO_LISP_ATOM] = &ao_lisp_atom_type, - [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, - [AO_LISP_FRAME] = &ao_lisp_frame_type, - [AO_LISP_FRAME_VALS] = &ao_lisp_frame_vals_type, - [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, - [AO_LISP_STACK] = &ao_lisp_stack_type, - [AO_LISP_BOOL] = &ao_lisp_bool_type, - [AO_LISP_BIGINT] = &ao_lisp_bigint_type, - [AO_LISP_FLOAT] = &ao_lisp_float_type, -}; - -static int -ao_lisp_mark_ref(const struct ao_lisp_type *type, void **ref) -{ - return ao_lisp_mark(type, *ref); -} - -static int -ao_lisp_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) -{ - return ao_lisp_poly_mark(*p, do_note_cons); -} - -#if DBG_MEM_STATS -int ao_lisp_collects[2]; -int ao_lisp_freed[2]; -int ao_lisp_loops[2]; -#endif - -int ao_lisp_last_top; - -int -ao_lisp_collect(uint8_t style) -{ - int i; - int top; -#if DBG_MEM_STATS - int loops = 0; -#endif -#if DBG_MEM - struct ao_lisp_record *mark_record = NULL, *move_record = NULL; - - MDBG_MOVE("collect %d\n", ao_lisp_collects[style]); -#endif - MDBG_DO(ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global))); - - /* The first time through, we're doing a full collect */ - if (ao_lisp_last_top == 0) - style = AO_LISP_COLLECT_FULL; - - /* Clear references to all caches */ - for (i = 0; i < (int) AO_LISP_CACHE; i++) - *ao_lisp_cache[i] = NULL; - if (style == AO_LISP_COLLECT_FULL) { - chunk_low = top = 0; - } else { - chunk_low = top = ao_lisp_last_top; - } - for (;;) { -#if DBG_MEM_STATS - loops++; -#endif - MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); - /* Find the sizes of the first chunk of objects to move */ - reset_chunks(); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); -#if DBG_MEM - - ao_lisp_record_free(mark_record); - mark_record = ao_lisp_record_save(); - if (mark_record && move_record) - ao_lisp_record_compare("mark", move_record, mark_record); -#endif - - DUMP_BUSY(); - - /* Find the first moving object */ - for (i = 0; i < chunk_last; i++) { - uint16_t size = ao_lisp_chunk[i].size; - -#if DBG_MEM - if (!size) - ao_lisp_abort(); -#endif - - if (ao_lisp_chunk[i].old_offset > top) - break; - - MDBG_MOVE("chunk %d %d not moving\n", - ao_lisp_chunk[i].old_offset, - ao_lisp_chunk[i].size); -#if DBG_MEM - if (ao_lisp_chunk[i].old_offset != top) - ao_lisp_abort(); -#endif - top += size; - } - - /* - * Limit amount of chunk array used in mapping moves - * to the active region - */ - chunk_first = i; - chunk_low = ao_lisp_chunk[i].old_offset; - - /* Copy all of the objects */ - for (; i < chunk_last; i++) { - uint16_t size = ao_lisp_chunk[i].size; - -#if DBG_MEM - if (!size) - ao_lisp_abort(); -#endif - - MDBG_MOVE("chunk %d %d -> %d\n", - ao_lisp_chunk[i].old_offset, - size, - top); - ao_lisp_chunk[i].new_offset = top; - - memmove(&ao_lisp_pool[top], - &ao_lisp_pool[ao_lisp_chunk[i].old_offset], - size); - - top += size; - } - - if (chunk_first < chunk_last) { - /* Relocate all references to the objects */ - walk(ao_lisp_move, ao_lisp_poly_move); - -#if DBG_MEM - ao_lisp_record_free(move_record); - move_record = ao_lisp_record_save(); - if (mark_record && move_record) - ao_lisp_record_compare("move", mark_record, move_record); -#endif - } - - /* If we ran into the end of the heap, then - * there's no need to keep walking - */ - if (chunk_last != AO_LISP_NCHUNK) - break; - - /* Next loop starts right above this loop */ - chunk_low = chunk_high; - } - -#if DBG_MEM_STATS - /* Collect stats */ - ++ao_lisp_collects[style]; - ao_lisp_freed[style] += ao_lisp_top - top; - ao_lisp_loops[style] += loops; -#endif - - ao_lisp_top = top; - if (style == AO_LISP_COLLECT_FULL) - ao_lisp_last_top = top; - - MDBG_DO(memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref)); - - return AO_LISP_POOL - ao_lisp_top; -} - -#if DBG_FREE_CONS -void -ao_lisp_cons_check(struct ao_lisp_cons *cons) -{ - ao_poly cdr; - int offset; - - chunk_low = 0; - reset_chunks(); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); - while (cons) { - if (!AO_LISP_IS_POOL(cons)) - break; - offset = pool_offset(cons); - if (busy(ao_lisp_busy, offset)) { - ao_lisp_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_lisp_cons_poly(cons), ao_lisp_cons_poly(cons)); - abort(); - } - cdr = cons->cdr; - if (!ao_lisp_is_pair(cdr)) - break; - cons = ao_lisp_poly_cons(cdr); - } -} -#endif - -/* - * Mark interfaces for objects - */ - - -/* - * Mark a block of memory with an explicit size - */ - -int -ao_lisp_mark_block(void *addr, int size) -{ - int offset; - if (!AO_LISP_IS_POOL(addr)) - return 1; - - offset = pool_offset(addr); - MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); - if (busy(ao_lisp_busy, offset)) { - MDBG_MOVE("already marked\n"); - return 1; - } - mark(ao_lisp_busy, offset); - note_chunk(offset, size); - return 0; -} - -/* - * Note a reference to memory and collect information about a few - * object sizes at a time - */ - -int -ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr) -{ - int offset; - if (!AO_LISP_IS_POOL(addr)) - return 1; - - offset = pool_offset(addr); - MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); - if (busy(ao_lisp_busy, offset)) { - MDBG_MOVE("already marked\n"); - return 1; - } - mark(ao_lisp_busy, offset); - note_chunk(offset, ao_lisp_size(type, addr)); - return 0; -} - -/* - * Mark an object and all that it refereces - */ -int -ao_lisp_mark(const struct ao_lisp_type *type, void *addr) -{ - int ret; - MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); - MDBG_MOVE_IN(); - ret = ao_lisp_mark_memory(type, addr); - if (!ret) { - MDBG_MOVE("mark recurse\n"); - type->mark(addr); - } - MDBG_MOVE_OUT(); - return ret; -} - -/* - * Mark an object, unless it is a cons cell and - * do_note_cons is set. In that case, just - * set a bit in the cons note array; those - * will be marked in a separate pass to avoid - * deep recursion in the collector - */ -int -ao_lisp_poly_mark(ao_poly p, uint8_t do_note_cons) -{ - uint8_t type; - void *addr; - - type = ao_lisp_poly_base_type(p); - - if (type == AO_LISP_INT) - return 1; - - addr = ao_lisp_ref(p); - if (!AO_LISP_IS_POOL(addr)) - return 1; - - if (type == AO_LISP_CONS && do_note_cons) { - note_cons(pool_offset(addr)); - return 1; - } else { - if (type == AO_LISP_OTHER) - type = ao_lisp_other_type(addr); - - const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_lisp_abort(); -#endif - - return ao_lisp_mark(lisp_type, addr); - } -} - -/* - * Find the current location of an object - * based on the original location. For unmoved - * objects, this is simple. For moved objects, - * go search for it - */ - -static uint16_t -move_map(uint16_t offset) -{ - int l; - - if (offset < chunk_low || chunk_high <= offset) - return offset; - - l = find_chunk(offset); - -#if DBG_MEM - if (ao_lisp_chunk[l].old_offset != offset) - ao_lisp_abort(); -#endif - return ao_lisp_chunk[l].new_offset; -} - -int -ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) -{ - void *addr = *ref; - uint16_t offset, orig_offset; - - if (!AO_LISP_IS_POOL(addr)) - return 1; - - (void) type; - - MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); - orig_offset = pool_offset(addr); - offset = move_map(orig_offset); - if (offset != orig_offset) { - MDBG_MOVE("update ref %d %d -> %d\n", - AO_LISP_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, - orig_offset, offset); - *ref = ao_lisp_pool + offset; - } - if (busy(ao_lisp_busy, offset)) { - MDBG_MOVE("already moved\n"); - return 1; - } - mark(ao_lisp_busy, offset); - MDBG_DO(ao_lisp_record(type, addr, ao_lisp_size(type, addr))); - return 0; -} - -int -ao_lisp_move(const struct ao_lisp_type *type, void **ref) -{ - int ret; - MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); - MDBG_MOVE_IN(); - ret = ao_lisp_move_memory(type, ref); - if (!ret) { - MDBG_MOVE("move recurse\n"); - type->move(*ref); - } - MDBG_MOVE_OUT(); - return ret; -} - -int -ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) -{ - uint8_t type; - ao_poly p = *ref; - int ret; - void *addr; - uint16_t offset, orig_offset; - uint8_t base_type; - - base_type = type = ao_lisp_poly_base_type(p); - - if (type == AO_LISP_INT) - return 1; - - addr = ao_lisp_ref(p); - if (!AO_LISP_IS_POOL(addr)) - return 1; - - orig_offset = pool_offset(addr); - offset = move_map(orig_offset); - - if (type == AO_LISP_CONS && do_note_cons) { - note_cons(orig_offset); - ret = 1; - } else { - if (type == AO_LISP_OTHER) - type = ao_lisp_other_type(ao_lisp_pool + offset); - - const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_lisp_abort(); -#endif - - ret = ao_lisp_move(lisp_type, &addr); - } - - /* Re-write the poly value */ - if (offset != orig_offset) { - ao_poly np = ao_lisp_poly(ao_lisp_pool + offset, base_type); - MDBG_MOVE("poly %d moved %d -> %d\n", - type, orig_offset, offset); - *ref = np; - } - return ret; -} - -#if DBG_MEM -void -ao_lisp_validate(void) -{ - chunk_low = 0; - memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); -} - -int dbg_allocs; - -#endif - -void * -ao_lisp_alloc(int size) -{ - void *addr; - - MDBG_DO(++dbg_allocs); - MDBG_DO(if (dbg_validate) ao_lisp_validate()); - size = ao_lisp_size_round(size); - if (AO_LISP_POOL - ao_lisp_top < size && - ao_lisp_collect(AO_LISP_COLLECT_INCREMENTAL) < size && - ao_lisp_collect(AO_LISP_COLLECT_FULL) < size) - { - ao_lisp_error(AO_LISP_OOM, "out of memory"); - return NULL; - } - addr = ao_lisp_pool + ao_lisp_top; - ao_lisp_top += size; - MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); - return addr; -} - -void -ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) -{ - assert(save_cons[id] == 0); - save_cons[id] = cons; -} - -struct ao_lisp_cons * -ao_lisp_cons_fetch(int id) -{ - struct ao_lisp_cons *cons = save_cons[id]; - save_cons[id] = NULL; - return cons; -} - -void -ao_lisp_poly_stash(int id, ao_poly poly) -{ - assert(save_poly[id] == AO_LISP_NIL); - save_poly[id] = poly; -} - -ao_poly -ao_lisp_poly_fetch(int id) -{ - ao_poly poly = save_poly[id]; - save_poly[id] = AO_LISP_NIL; - return poly; -} - -void -ao_lisp_string_stash(int id, char *string) -{ - assert(save_string[id] == NULL); - save_string[id] = string; -} - -char * -ao_lisp_string_fetch(int id) -{ - char *string = save_string[id]; - save_string[id] = NULL; - return string; -} - -void -ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame) -{ - assert(save_frame[id] == NULL); - save_frame[id] = frame; -} - -struct ao_lisp_frame * -ao_lisp_frame_fetch(int id) -{ - struct ao_lisp_frame *frame = save_frame[id]; - save_frame[id] = NULL; - return frame; -} diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h deleted file mode 100644 index 4285cb8c..00000000 --- a/src/lisp/ao_lisp_os.h +++ /dev/null @@ -1,63 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ - -#include -#include -#include - -extern int ao_lisp_getc(void); - -static inline void -ao_lisp_os_flush(void) { - fflush(stdout); -} - -static inline void -ao_lisp_abort(void) -{ - abort(); -} - -static inline void -ao_lisp_os_led(int led) -{ - printf("leds set to 0x%x\n", led); -} - -#define AO_LISP_JIFFIES_PER_SECOND 100 - -static inline void -ao_lisp_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_lisp_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); -} -#endif diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c deleted file mode 100644 index d14f4151..00000000 --- a/src/lisp/ao_lisp_poly.c +++ /dev/null @@ -1,118 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -struct ao_lisp_funcs { - void (*write)(ao_poly); - void (*display)(ao_poly); -}; - -static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { - [AO_LISP_CONS] = { - .write = ao_lisp_cons_write, - .display = ao_lisp_cons_display, - }, - [AO_LISP_STRING] = { - .write = ao_lisp_string_write, - .display = ao_lisp_string_display, - }, - [AO_LISP_INT] = { - .write = ao_lisp_int_write, - .display = ao_lisp_int_write, - }, - [AO_LISP_ATOM] = { - .write = ao_lisp_atom_write, - .display = ao_lisp_atom_write, - }, - [AO_LISP_BUILTIN] = { - .write = ao_lisp_builtin_write, - .display = ao_lisp_builtin_write, - }, - [AO_LISP_FRAME] = { - .write = ao_lisp_frame_write, - .display = ao_lisp_frame_write, - }, - [AO_LISP_FRAME_VALS] = { - .write = NULL, - .display = NULL, - }, - [AO_LISP_LAMBDA] = { - .write = ao_lisp_lambda_write, - .display = ao_lisp_lambda_write, - }, - [AO_LISP_STACK] = { - .write = ao_lisp_stack_write, - .display = ao_lisp_stack_write, - }, - [AO_LISP_BOOL] = { - .write = ao_lisp_bool_write, - .display = ao_lisp_bool_write, - }, - [AO_LISP_BIGINT] = { - .write = ao_lisp_bigint_write, - .display = ao_lisp_bigint_write, - }, - [AO_LISP_FLOAT] = { - .write = ao_lisp_float_write, - .display = ao_lisp_float_write, - }, -}; - -static const struct ao_lisp_funcs * -funcs(ao_poly p) -{ - uint8_t type = ao_lisp_poly_type(p); - - if (type < AO_LISP_NUM_TYPE) - return &ao_lisp_funcs[type]; - return NULL; -} - -void -ao_lisp_poly_write(ao_poly p) -{ - const struct ao_lisp_funcs *f = funcs(p); - - if (f && f->write) - f->write(p); -} - -void -ao_lisp_poly_display(ao_poly p) -{ - const struct ao_lisp_funcs *f = funcs(p); - - if (f && f->display) - f->display(p); -} - -void * -ao_lisp_ref(ao_poly poly) { - if (poly == AO_LISP_NIL) - return NULL; - if (poly & AO_LISP_CONST) - return (void *) (ao_lisp_const + (poly & AO_LISP_REF_MASK) - 4); - return (void *) (ao_lisp_pool + (poly & AO_LISP_REF_MASK) - 4); -} - -ao_poly -ao_lisp_poly(const void *addr, ao_poly type) { - const uint8_t *a = addr; - if (a == NULL) - return AO_LISP_NIL; - if (AO_LISP_IS_CONST(a)) - return AO_LISP_CONST | (a - ao_lisp_const + 4) | type; - return (a - ao_lisp_pool + 4) | type; -} diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c deleted file mode 100644 index 0ca12a81..00000000 --- a/src/lisp/ao_lisp_read.c +++ /dev/null @@ -1,655 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include "ao_lisp_read.h" -#include -#include - -static const uint16_t lex_classes[128] = { - IGNORE, /* ^@ */ - IGNORE, /* ^A */ - IGNORE, /* ^B */ - IGNORE, /* ^C */ - IGNORE, /* ^D */ - IGNORE, /* ^E */ - IGNORE, /* ^F */ - IGNORE, /* ^G */ - IGNORE, /* ^H */ - WHITE, /* ^I */ - WHITE, /* ^J */ - WHITE, /* ^K */ - WHITE, /* ^L */ - WHITE, /* ^M */ - IGNORE, /* ^N */ - IGNORE, /* ^O */ - IGNORE, /* ^P */ - IGNORE, /* ^Q */ - IGNORE, /* ^R */ - IGNORE, /* ^S */ - IGNORE, /* ^T */ - IGNORE, /* ^U */ - IGNORE, /* ^V */ - IGNORE, /* ^W */ - IGNORE, /* ^X */ - IGNORE, /* ^Y */ - IGNORE, /* ^Z */ - IGNORE, /* ^[ */ - IGNORE, /* ^\ */ - IGNORE, /* ^] */ - IGNORE, /* ^^ */ - IGNORE, /* ^_ */ - PRINTABLE|WHITE, /* */ - PRINTABLE, /* ! */ - PRINTABLE|STRINGC, /* " */ - PRINTABLE|POUND, /* # */ - PRINTABLE, /* $ */ - PRINTABLE, /* % */ - PRINTABLE, /* & */ - PRINTABLE|SPECIAL, /* ' */ - PRINTABLE|SPECIAL, /* ( */ - PRINTABLE|SPECIAL, /* ) */ - PRINTABLE, /* * */ - PRINTABLE|SIGN, /* + */ - PRINTABLE|SPECIAL, /* , */ - PRINTABLE|SIGN, /* - */ - PRINTABLE|DOTC|FLOATC, /* . */ - PRINTABLE, /* / */ - PRINTABLE|DIGIT, /* 0 */ - PRINTABLE|DIGIT, /* 1 */ - PRINTABLE|DIGIT, /* 2 */ - PRINTABLE|DIGIT, /* 3 */ - PRINTABLE|DIGIT, /* 4 */ - PRINTABLE|DIGIT, /* 5 */ - PRINTABLE|DIGIT, /* 6 */ - PRINTABLE|DIGIT, /* 7 */ - PRINTABLE|DIGIT, /* 8 */ - PRINTABLE|DIGIT, /* 9 */ - PRINTABLE, /* : */ - PRINTABLE|COMMENT, /* ; */ - PRINTABLE, /* < */ - PRINTABLE, /* = */ - PRINTABLE, /* > */ - PRINTABLE, /* ? */ - PRINTABLE, /* @ */ - PRINTABLE, /* A */ - PRINTABLE, /* B */ - PRINTABLE, /* C */ - PRINTABLE, /* D */ - PRINTABLE|FLOATC, /* E */ - PRINTABLE, /* F */ - PRINTABLE, /* G */ - PRINTABLE, /* H */ - PRINTABLE, /* I */ - PRINTABLE, /* J */ - PRINTABLE, /* K */ - PRINTABLE, /* L */ - PRINTABLE, /* M */ - PRINTABLE, /* N */ - PRINTABLE, /* O */ - PRINTABLE, /* P */ - PRINTABLE, /* Q */ - PRINTABLE, /* R */ - PRINTABLE, /* S */ - PRINTABLE, /* T */ - PRINTABLE, /* U */ - PRINTABLE, /* V */ - PRINTABLE, /* W */ - PRINTABLE, /* X */ - PRINTABLE, /* Y */ - PRINTABLE, /* Z */ - PRINTABLE, /* [ */ - PRINTABLE|BACKSLASH, /* \ */ - PRINTABLE, /* ] */ - PRINTABLE, /* ^ */ - PRINTABLE, /* _ */ - PRINTABLE|SPECIAL, /* ` */ - PRINTABLE, /* a */ - PRINTABLE, /* b */ - PRINTABLE, /* c */ - PRINTABLE, /* d */ - PRINTABLE|FLOATC, /* e */ - PRINTABLE, /* f */ - PRINTABLE, /* g */ - PRINTABLE, /* h */ - PRINTABLE, /* i */ - PRINTABLE, /* j */ - PRINTABLE, /* k */ - PRINTABLE, /* l */ - PRINTABLE, /* m */ - PRINTABLE, /* n */ - PRINTABLE, /* o */ - PRINTABLE, /* p */ - PRINTABLE, /* q */ - PRINTABLE, /* r */ - PRINTABLE, /* s */ - PRINTABLE, /* t */ - PRINTABLE, /* u */ - PRINTABLE, /* v */ - PRINTABLE, /* w */ - PRINTABLE, /* x */ - PRINTABLE, /* y */ - PRINTABLE, /* z */ - PRINTABLE, /* { */ - PRINTABLE, /* | */ - PRINTABLE, /* } */ - PRINTABLE, /* ~ */ - IGNORE, /* ^? */ -}; - -static int lex_unget_c; - -static inline int -lex_get() -{ - int c; - if (lex_unget_c) { - c = lex_unget_c; - lex_unget_c = 0; - } else { - c = ao_lisp_getc(); - } - return c; -} - -static inline void -lex_unget(int c) -{ - if (c != EOF) - 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) -{ - int c; - int v; - int count; - - c = lex_get(); - if (c == EOF) { - lex_class = ENDOFFILE; - return 0; - } - lex_class = 0; - c &= 0x7f; - switch (c) { - case 'n': - return '\n'; - case 'f': - return '\f'; - case 'b': - return '\b'; - case 'r': - return '\r'; - case 'v': - return '\v'; - case 't': - return '\t'; - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - v = c - '0'; - count = 1; - while (count <= 3) { - c = lex_get(); - if (c == EOF) - return EOF; - c &= 0x7f; - if (c < '0' || '7' < c) { - lex_unget(c); - break; - } - v = (v << 3) + c - '0'; - ++count; - } - return v; - default: - return c; - } -} - -#define AO_LISP_TOKEN_MAX 32 - -static char token_string[AO_LISP_TOKEN_MAX]; -static int32_t token_int; -static int token_len; -static float token_float; - -static inline void add_token(int c) { - if (c && token_len < AO_LISP_TOKEN_MAX - 1) - token_string[token_len++] = c; -} - -static inline void del_token(void) { - if (token_len > 0) - token_len--; -} - -static inline void end_token(void) { - token_string[token_len] = '\0'; -} - -struct namedfloat { - const char *name; - float value; -}; - -static const struct namedfloat namedfloats[] = { - { .name = "+inf.0", .value = INFINITY }, - { .name = "-inf.0", .value = -INFINITY }, - { .name = "+nan.0", .value = NAN }, - { .name = "-nan.0", .value = NAN }, -}; - -#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) - -static int -_lex(void) -{ - int c; - - token_len = 0; - for (;;) { - c = lexc(); - if (lex_class & ENDOFFILE) - return END; - - if (lex_class & WHITE) - continue; - - if (lex_class & COMMENT) { - while ((c = lexc()) != '\n') { - if (lex_class & ENDOFFILE) - return END; - } - continue; - } - - if (lex_class & (SPECIAL|DOTC)) { - add_token(c); - end_token(); - switch (c) { - case '(': - case '[': - return OPEN; - case ')': - case ']': - return CLOSE; - case '\'': - return QUOTE; - case '.': - return DOT; - case '`': - return QUASIQUOTE; - case ',': - c = lexc(); - if (c == '@') { - add_token(c); - end_token(); - return UNQUOTE_SPLICING; - } else { - lex_unget(c); - return UNQUOTE; - } - } - } - if (lex_class & POUND) { - c = lexc(); - switch (c) { - case 't': - add_token(c); - 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; - } - add_token(c); - } - } - if (lex_class & PRINTABLE) { - int isfloat; - int hasdigit; - int isneg; - int isint; - int epos; - - isfloat = 1; - isint = 1; - hasdigit = 0; - token_int = 0; - isneg = 0; - epos = 0; - for (;;) { - if (!(lex_class & NUMBER)) { - isint = 0; - isfloat = 0; - } else { - if (!(lex_class & INTEGER)) - isint = 0; - if (token_len != epos && - (lex_class & SIGN)) - { - isint = 0; - isfloat = 0; - } - if (c == '-') - isneg = 1; - if (c == '.' && epos != 0) - isfloat = 0; - if (c == 'e' || c == 'E') { - if (token_len == 0) - isfloat = 0; - else - epos = token_len + 1; - } - if (lex_class & DIGIT) { - hasdigit = 1; - if (isint) - token_int = token_int * 10 + c - '0'; - } - } - add_token (c); - c = lexc (); - if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { - unsigned int u; -// if (lex_class & ENDOFFILE) -// clearerr (f); - lex_unget(c); - end_token (); - if (isint && hasdigit) { - if (isneg) - token_int = -token_int; - return NUM; - } - if (isfloat && hasdigit) { - token_float = strtof(token_string, NULL); - return FLOAT; - } - for (u = 0; u < NUM_NAMED_FLOATS; u++) - if (!strcmp(namedfloats[u].name, token_string)) { - token_float = namedfloats[u].value; - return FLOAT; - } - return NAME; - } - } - } - } -} - -static inline int lex(void) -{ - int parse_token = _lex(); - RDBGI("token %d (%s)\n", parse_token, token_string); - return parse_token; -} - -static int parse_token; - -struct ao_lisp_cons *ao_lisp_read_cons; -struct ao_lisp_cons *ao_lisp_read_cons_tail; -struct ao_lisp_cons *ao_lisp_read_stack; - -#define READ_IN_QUOTE 0x01 -#define READ_SAW_DOT 0x02 -#define READ_DONE_DOT 0x04 - -static int -push_read_stack(int cons, int read_state) -{ - RDBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); - RDBG_IN(); - if (cons) { - ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), - ao_lisp__cons(ao_lisp_int_poly(read_state), - ao_lisp_cons_poly(ao_lisp_read_stack))); - if (!ao_lisp_read_stack) - return 0; - } - ao_lisp_read_cons = NULL; - ao_lisp_read_cons_tail = NULL; - return 1; -} - -static int -pop_read_stack(int cons) -{ - int read_state = 0; - if (cons) { - ao_lisp_read_cons = ao_lisp_poly_cons(ao_lisp_read_stack->car); - ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); - read_state = ao_lisp_poly_int(ao_lisp_read_stack->car); - ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); - for (ao_lisp_read_cons_tail = ao_lisp_read_cons; - ao_lisp_read_cons_tail && ao_lisp_read_cons_tail->cdr; - ao_lisp_read_cons_tail = ao_lisp_poly_cons(ao_lisp_read_cons_tail->cdr)) - ; - } else { - ao_lisp_read_cons = 0; - ao_lisp_read_cons_tail = 0; - ao_lisp_read_stack = 0; - } - RDBG_OUT(); - RDBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state); - return read_state; -} - -ao_poly -ao_lisp_read(void) -{ - struct ao_lisp_atom *atom; - char *string; - int cons; - int read_state; - ao_poly v = AO_LISP_NIL; - - cons = 0; - read_state = 0; - ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; - for (;;) { - parse_token = lex(); - while (parse_token == OPEN) { - if (!push_read_stack(cons, read_state)) - return AO_LISP_NIL; - cons++; - read_state = 0; - parse_token = lex(); - } - - switch (parse_token) { - case END: - default: - if (cons) - ao_lisp_error(AO_LISP_EOF, "unexpected end of file"); - return _ao_lisp_atom_eof; - break; - case NAME: - atom = ao_lisp_atom_intern(token_string); - if (atom) - v = ao_lisp_atom_poly(atom); - else - v = AO_LISP_NIL; - break; - case NUM: - v = ao_lisp_integer_poly(token_int); - break; - case FLOAT: - v = ao_lisp_float_get(token_float); - break; - case BOOL: - if (token_string[0] == 't') - v = _ao_lisp_bool_true; - else - v = _ao_lisp_bool_false; - break; - case STRING: - string = ao_lisp_string_copy(token_string); - if (string) - v = ao_lisp_string_poly(string); - else - v = AO_LISP_NIL; - break; - case QUOTE: - case QUASIQUOTE: - case UNQUOTE: - case UNQUOTE_SPLICING: - if (!push_read_stack(cons, read_state)) - return AO_LISP_NIL; - cons++; - read_state = READ_IN_QUOTE; - switch (parse_token) { - case QUOTE: - v = _ao_lisp_atom_quote; - break; - case QUASIQUOTE: - v = _ao_lisp_atom_quasiquote; - break; - case UNQUOTE: - v = _ao_lisp_atom_unquote; - break; - case UNQUOTE_SPLICING: - v = _ao_lisp_atom_unquote2dsplicing; - break; - } - break; - case CLOSE: - if (!cons) { - v = AO_LISP_NIL; - break; - } - v = ao_lisp_cons_poly(ao_lisp_read_cons); - --cons; - read_state = pop_read_stack(cons); - break; - case DOT: - if (!cons) { - ao_lisp_error(AO_LISP_INVALID, ". outside of cons"); - return AO_LISP_NIL; - } - if (!ao_lisp_read_cons) { - ao_lisp_error(AO_LISP_INVALID, ". first in cons"); - return AO_LISP_NIL; - } - read_state |= READ_SAW_DOT; - continue; - } - - /* loop over QUOTE ends */ - for (;;) { - if (!cons) - return v; - - if (read_state & READ_DONE_DOT) { - ao_lisp_error(AO_LISP_INVALID, ". not last in cons"); - return AO_LISP_NIL; - } - - if (read_state & READ_SAW_DOT) { - read_state |= READ_DONE_DOT; - ao_lisp_read_cons_tail->cdr = v; - } else { - struct ao_lisp_cons *read = ao_lisp_cons_cons(v, AO_LISP_NIL); - if (!read) - return AO_LISP_NIL; - - if (ao_lisp_read_cons_tail) - ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); - else - ao_lisp_read_cons = read; - ao_lisp_read_cons_tail = read; - } - - if (!(read_state & READ_IN_QUOTE) || !ao_lisp_read_cons->cdr) - break; - - v = ao_lisp_cons_poly(ao_lisp_read_cons); - --cons; - read_state = pop_read_stack(cons); - } - } - return v; -} diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h deleted file mode 100644 index 8f6bf130..00000000 --- a/src/lisp/ao_lisp_read.h +++ /dev/null @@ -1,58 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#ifndef _AO_LISP_READ_H_ -#define _AO_LISP_READ_H_ - -/* - * token classes - */ - -# define END 0 -# define NAME 1 -# define OPEN 2 -# define CLOSE 3 -# define QUOTE 4 -# define QUASIQUOTE 5 -# define UNQUOTE 6 -# define UNQUOTE_SPLICING 7 -# define STRING 8 -# define NUM 9 -# define FLOAT 10 -# define DOT 11 -# define BOOL 12 - -/* - * character classes - */ - -# define PRINTABLE 0x0001 /* \t \n ' ' - ~ */ -# define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */ -# define DOTC 0x0004 /* . */ -# define WHITE 0x0008 /* ' ' \t \n */ -# define DIGIT 0x0010 /* [0-9] */ -# define SIGN 0x0020 /* +- */ -# define FLOATC 0x0040 /* . e E */ -# define ENDOFFILE 0x0080 /* end of file */ -# define COMMENT 0x0100 /* ; */ -# define IGNORE 0x0200 /* \0 - ' ' */ -# define BACKSLASH 0x0400 /* \ */ -# define STRINGC 0x0800 /* " */ -# define POUND 0x1000 /* # */ - -# define NOTNAME (STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) -# define INTEGER (DIGIT|SIGN) -# define NUMBER (INTEGER|FLOATC) - -#endif /* _AO_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c deleted file mode 100644 index 43cc387f..00000000 --- a/src/lisp/ao_lisp_rep.c +++ /dev/null @@ -1,36 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -ao_poly -ao_lisp_read_eval_print(void) -{ - ao_poly in, out = AO_LISP_NIL; - for(;;) { - in = ao_lisp_read(); - if (in == _ao_lisp_atom_eof) - break; - out = ao_lisp_eval(in); - if (ao_lisp_exception) { - if (ao_lisp_exception & AO_LISP_EXIT) - break; - ao_lisp_exception = 0; - } else { - ao_lisp_poly_write(out); - putchar ('\n'); - } - } - return out; -} diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c deleted file mode 100644 index c990e9c6..00000000 --- a/src/lisp/ao_lisp_save.c +++ /dev/null @@ -1,77 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include - -ao_poly -ao_lisp_do_save(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) - return AO_LISP_NIL; - -#ifdef AO_LISP_SAVE - struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) (void *) &ao_lisp_pool[AO_LISP_POOL]; - - ao_lisp_collect(AO_LISP_COLLECT_FULL); - os->atoms = ao_lisp_atom_poly(ao_lisp_atoms); - os->globals = ao_lisp_frame_poly(ao_lisp_frame_global); - os->const_checksum = ao_lisp_const_checksum; - os->const_checksum_inv = (uint16_t) ~ao_lisp_const_checksum; - - if (ao_lisp_os_save()) - return _ao_lisp_bool_true; -#endif - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_restore(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) - return AO_LISP_NIL; - -#ifdef AO_LISP_SAVE - struct ao_lisp_os_save save; - struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) (void *) &ao_lisp_pool[AO_LISP_POOL]; - - if (!ao_lisp_os_restore_save(&save, AO_LISP_POOL)) - return ao_lisp_error(AO_LISP_INVALID, "header restore failed"); - - if (save.const_checksum != ao_lisp_const_checksum || - save.const_checksum_inv != (uint16_t) ~ao_lisp_const_checksum) - { - return ao_lisp_error(AO_LISP_INVALID, "image is corrupted or stale"); - } - - if (ao_lisp_os_restore()) { - - ao_lisp_atoms = ao_lisp_poly_atom(os->atoms); - ao_lisp_frame_global = ao_lisp_poly_frame(os->globals); - - /* Clear the eval global variabls */ - ao_lisp_eval_clear_globals(); - - /* Reset the allocator */ - ao_lisp_top = AO_LISP_POOL; - ao_lisp_collect(AO_LISP_COLLECT_FULL); - - /* Re-create the evaluator stack */ - if (!ao_lisp_eval_restart()) - return _ao_lisp_bool_false; - - return _ao_lisp_bool_true; - } -#endif - return _ao_lisp_bool_false; -} diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c deleted file mode 100644 index e7c89801..00000000 --- a/src/lisp/ao_lisp_stack.c +++ /dev/null @@ -1,280 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -const struct ao_lisp_type ao_lisp_stack_type; - -static int -stack_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_stack); -} - -static void -stack_mark(void *addr) -{ - struct ao_lisp_stack *stack = addr; - for (;;) { - ao_lisp_poly_mark(stack->sexprs, 0); - ao_lisp_poly_mark(stack->values, 0); - /* no need to mark values_tail */ - ao_lisp_poly_mark(stack->frame, 0); - ao_lisp_poly_mark(stack->list, 0); - stack = ao_lisp_poly_stack(stack->prev); - if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) - break; - } -} - -static void -stack_move(void *addr) -{ - struct ao_lisp_stack *stack = addr; - - while (stack) { - struct ao_lisp_stack *prev; - int ret; - (void) ao_lisp_poly_move(&stack->sexprs, 0); - (void) ao_lisp_poly_move(&stack->values, 0); - (void) ao_lisp_poly_move(&stack->values_tail, 0); - (void) ao_lisp_poly_move(&stack->frame, 0); - (void) ao_lisp_poly_move(&stack->list, 0); - prev = ao_lisp_poly_stack(stack->prev); - if (!prev) - break; - ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); - if (prev != ao_lisp_poly_stack(stack->prev)) - stack->prev = ao_lisp_stack_poly(prev); - if (ret) - break; - stack = prev; - } -} - -const struct ao_lisp_type ao_lisp_stack_type = { - .size = stack_size, - .mark = stack_mark, - .move = stack_move, - .name = "stack" -}; - -struct ao_lisp_stack *ao_lisp_stack_free_list; - -void -ao_lisp_stack_reset(struct ao_lisp_stack *stack) -{ - stack->state = eval_sexpr; - stack->sexprs = AO_LISP_NIL; - stack->values = AO_LISP_NIL; - stack->values_tail = AO_LISP_NIL; -} - -static struct ao_lisp_stack * -ao_lisp_stack_new(void) -{ - struct ao_lisp_stack *stack; - - if (ao_lisp_stack_free_list) { - stack = ao_lisp_stack_free_list; - ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); - } else { - stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); - if (!stack) - return 0; - stack->type = AO_LISP_STACK; - } - ao_lisp_stack_reset(stack); - return stack; -} - -int -ao_lisp_stack_push(void) -{ - struct ao_lisp_stack *stack; - - stack = ao_lisp_stack_new(); - - if (!stack) - return 0; - - stack->prev = ao_lisp_stack_poly(ao_lisp_stack); - stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - stack->list = AO_LISP_NIL; - - ao_lisp_stack = stack; - - DBGI("stack push\n"); - DBG_FRAMES(); - DBG_IN(); - return 1; -} - -void -ao_lisp_stack_pop(void) -{ - ao_poly prev; - struct ao_lisp_frame *prev_frame; - - if (!ao_lisp_stack) - return; - prev = ao_lisp_stack->prev; - if (!ao_lisp_stack_marked(ao_lisp_stack)) { - ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); - ao_lisp_stack_free_list = ao_lisp_stack; - } - - ao_lisp_stack = ao_lisp_poly_stack(prev); - prev_frame = ao_lisp_frame_current; - if (ao_lisp_stack) - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - else - ao_lisp_frame_current = NULL; - if (ao_lisp_frame_current != prev_frame) - ao_lisp_frame_free(prev_frame); - DBG_OUT(); - DBGI("stack pop\n"); - DBG_FRAMES(); -} - -void -ao_lisp_stack_clear(void) -{ - ao_lisp_stack = NULL; - ao_lisp_frame_current = NULL; - ao_lisp_v = AO_LISP_NIL; -} - -void -ao_lisp_stack_write(ao_poly poly) -{ - struct ao_lisp_stack *s = ao_lisp_poly_stack(poly); - - while (s) { - if (s->type & AO_LISP_STACK_PRINT) { - printf("[recurse...]"); - return; - } - s->type |= AO_LISP_STACK_PRINT; - printf("\t[\n"); - printf("\t\texpr: "); ao_lisp_poly_write(s->list); printf("\n"); - printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]); - ao_lisp_error_poly ("values: ", s->values, s->values_tail); - ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL); - ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); - printf("\t]\n"); - s->type &= ~AO_LISP_STACK_PRINT; - s = ao_lisp_poly_stack(s->prev); - } -} - -/* - * Copy a stack, being careful to keep everybody referenced - */ -static struct ao_lisp_stack * -ao_lisp_stack_copy(struct ao_lisp_stack *old) -{ - struct ao_lisp_stack *new = NULL; - struct ao_lisp_stack *n, *prev = NULL; - - while (old) { - ao_lisp_stack_stash(0, old); - ao_lisp_stack_stash(1, new); - ao_lisp_stack_stash(2, prev); - n = ao_lisp_stack_new(); - prev = ao_lisp_stack_fetch(2); - new = ao_lisp_stack_fetch(1); - old = ao_lisp_stack_fetch(0); - if (!n) - return NULL; - - ao_lisp_stack_mark(old); - ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame)); - *n = *old; - - if (prev) - prev->prev = ao_lisp_stack_poly(n); - else - new = n; - prev = n; - - old = ao_lisp_poly_stack(old->prev); - } - return new; -} - -/* - * Evaluate a continuation invocation - */ -ao_poly -ao_lisp_stack_eval(void) -{ - struct ao_lisp_stack *new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v)); - if (!new) - return AO_LISP_NIL; - - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - - if (!cons || !cons->cdr) - return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value"); - - new->state = eval_val; - - ao_lisp_stack = new; - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - - return ao_lisp_poly_cons(cons->cdr)->car; -} - -/* - * Call with current continuation. This calls a lambda, passing - * it a single argument which is the current continuation - */ -ao_poly -ao_lisp_do_call_cc(struct ao_lisp_cons *cons) -{ - struct ao_lisp_stack *new; - ao_poly v; - - /* Make sure the single parameter is a lambda */ - if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0)) - return AO_LISP_NIL; - - /* go get the lambda */ - ao_lisp_v = ao_lisp_arg(cons, 0); - - /* Note that the whole call chain now has - * a reference to it which may escape - */ - new = ao_lisp_stack_copy(ao_lisp_stack); - if (!new) - return AO_LISP_NIL; - - /* re-fetch cons after the allocation */ - cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr); - - /* Reset the arg list to the current stack, - * and call the lambda - */ - - cons->car = ao_lisp_stack_poly(new); - cons->cdr = AO_LISP_NIL; - v = ao_lisp_lambda_eval(); - ao_lisp_stack->sexprs = v; - ao_lisp_stack->state = eval_begin; - return AO_LISP_NIL; -} diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c deleted file mode 100644 index 1daa50ea..00000000 --- a/src/lisp/ao_lisp_string.c +++ /dev/null @@ -1,161 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_lisp.h" - -static void string_mark(void *addr) -{ - (void) addr; -} - -static int string_size(void *addr) -{ - if (!addr) - return 0; - return strlen(addr) + 1; -} - -static void string_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_string_type = { - .mark = string_mark, - .size = string_size, - .move = string_move, - .name = "string", -}; - -char * -ao_lisp_string_copy(char *a) -{ - int alen = strlen(a); - - ao_lisp_string_stash(0, a); - char *r = ao_lisp_alloc(alen + 1); - a = ao_lisp_string_fetch(0); - if (!r) - return NULL; - strcpy(r, a); - return r; -} - -char * -ao_lisp_string_cat(char *a, char *b) -{ - int alen = strlen(a); - int blen = strlen(b); - - ao_lisp_string_stash(0, a); - ao_lisp_string_stash(1, b); - char *r = ao_lisp_alloc(alen + blen + 1); - a = ao_lisp_string_fetch(0); - b = ao_lisp_string_fetch(1); - if (!r) - return NULL; - strcpy(r, a); - strcpy(r+alen, b); - return r; -} - -ao_poly -ao_lisp_string_pack(struct ao_lisp_cons *cons) -{ - int len = ao_lisp_cons_length(cons); - ao_lisp_cons_stash(0, cons); - char *r = ao_lisp_alloc(len + 1); - cons = ao_lisp_cons_fetch(0); - char *s = r; - - while (cons) { - if (!ao_lisp_integer_typep(ao_lisp_poly_type(cons->car))) - return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); - *s++ = ao_lisp_poly_integer(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - } - *s++ = 0; - return ao_lisp_string_poly(r); -} - -ao_poly -ao_lisp_string_unpack(char *a) -{ - struct ao_lisp_cons *cons = NULL, *tail = NULL; - int c; - int i; - - for (i = 0; (c = a[i]); i++) { - ao_lisp_cons_stash(0, cons); - ao_lisp_cons_stash(1, tail); - ao_lisp_string_stash(0, a); - struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), AO_LISP_NIL); - a = ao_lisp_string_fetch(0); - cons = ao_lisp_cons_fetch(0); - tail = ao_lisp_cons_fetch(1); - - if (!n) { - cons = NULL; - break; - } - if (tail) - tail->cdr = ao_lisp_cons_poly(n); - else - cons = n; - tail = n; - } - return ao_lisp_cons_poly(cons); -} - -void -ao_lisp_string_write(ao_poly p) -{ - char *s = ao_lisp_poly_string(p); - char c; - - putchar('"'); - while ((c = *s++)) { - switch (c) { - case '\n': - printf ("\\n"); - break; - case '\r': - printf ("\\r"); - break; - case '\t': - printf ("\\t"); - break; - default: - if (c < ' ') - printf("\\%03o", c); - else - putchar(c); - break; - } - } - putchar('"'); -} - -void -ao_lisp_string_display(ao_poly p) -{ - char *s = ao_lisp_poly_string(p); - char c; - - while ((c = *s++)) - putchar(c); -} diff --git a/src/scheme/.gitignore b/src/scheme/.gitignore new file mode 100644 index 00000000..ee72cb9d --- /dev/null +++ b/src/scheme/.gitignore @@ -0,0 +1,2 @@ +ao_scheme_const.h +ao_scheme_builtin.h diff --git a/src/scheme/Makefile b/src/scheme/Makefile new file mode 100644 index 00000000..d8e4b553 --- /dev/null +++ b/src/scheme/Makefile @@ -0,0 +1,16 @@ +all: ao_scheme_builtin.h ao_scheme_const.h + +clean: + +cd make-const && make clean + rm -f ao_scheme_const.h ao_scheme_builtin.h + +ao_scheme_const.h: ao_scheme_const.lisp make-const/ao_scheme_make_const + make-const/ao_scheme_make_const -o $@ ao_scheme_const.lisp + +ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt + nickle ao_scheme_make_builtin ao_scheme_builtin.txt > $@ + +make-const/ao_scheme_make_const: FRC + +cd make-const && make ao_scheme_make_const + +FRC: diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc new file mode 100644 index 00000000..d23ee3d7 --- /dev/null +++ b/src/scheme/Makefile-inc @@ -0,0 +1,24 @@ +SCHEME_SRCS=\ + ao_scheme_mem.c \ + ao_scheme_cons.c \ + ao_scheme_string.c \ + ao_scheme_atom.c \ + ao_scheme_int.c \ + ao_scheme_poly.c \ + ao_scheme_bool.c \ + ao_scheme_float.c \ + ao_scheme_builtin.c \ + ao_scheme_read.c \ + ao_scheme_frame.c \ + ao_scheme_lambda.c \ + ao_scheme_eval.c \ + ao_scheme_rep.c \ + ao_scheme_save.c \ + ao_scheme_stack.c \ + ao_scheme_error.c + +SCHEME_HDRS=\ + ao_scheme.h \ + ao_scheme_os.h \ + ao_scheme_read.h \ + ao_scheme_builtin.h diff --git a/src/scheme/Makefile-scheme b/src/scheme/Makefile-scheme new file mode 100644 index 00000000..2427cffa --- /dev/null +++ b/src/scheme/Makefile-scheme @@ -0,0 +1,4 @@ +include ../lisp/Makefile-inc + +ao_scheme_const.h: $(LISP_SRCS) $(LISP_HDRS) + +cd ../lisp && make $@ diff --git a/src/scheme/README b/src/scheme/README new file mode 100644 index 00000000..98932b44 --- /dev/null +++ b/src/scheme/README @@ -0,0 +1,10 @@ +This follows the R7RS with the following known exceptions: + +* No vectors or bytevectors +* Characters are just numbers +* No dynamic-wind or exceptions +* No environments +* No ports +* No syntax-rules; (have classic macros) +* No record types +* No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h new file mode 100644 index 00000000..4589f8a5 --- /dev/null +++ b/src/scheme/ao_scheme.h @@ -0,0 +1,928 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#ifndef _AO_SCHEME_H_ +#define _AO_SCHEME_H_ + +#define DBG_MEM 0 +#define DBG_EVAL 0 +#define DBG_READ 0 +#define DBG_FREE_CONS 0 +#define NDEBUG 1 + +#include +#include +#include +#ifndef __BYTE_ORDER +#include +#endif + +typedef uint16_t ao_poly; +typedef int16_t ao_signed_poly; + +#ifdef AO_SCHEME_SAVE + +struct ao_scheme_os_save { + ao_poly atoms; + ao_poly globals; + uint16_t const_checksum; + uint16_t const_checksum_inv; +}; + +#define AO_SCHEME_POOL_EXTRA (sizeof(struct ao_scheme_os_save)) +#define AO_SCHEME_POOL ((int) (AO_SCHEME_POOL_TOTAL - AO_SCHEME_POOL_EXTRA)) + +int +ao_scheme_os_save(void); + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset); + +int +ao_scheme_os_restore(void); + +#endif + +#ifdef AO_SCHEME_MAKE_CONST +#define AO_SCHEME_POOL_CONST 16384 +extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#define _atom(n) ao_scheme_atom_poly(ao_scheme_atom_intern(n)) +#define _bool(v) ao_scheme_bool_poly(ao_scheme_bool_get(v)) + +#define _ao_scheme_bool_true _bool(1) +#define _ao_scheme_bool_false _bool(0) + +#define _ao_scheme_atom_eof _atom("eof") +#define _ao_scheme_atom_else _atom("else") + +#define AO_SCHEME_BUILTIN_ATOMS +#include "ao_scheme_builtin.h" + +#else +#include "ao_scheme_const.h" +#ifndef AO_SCHEME_POOL +#define AO_SCHEME_POOL 3072 +#endif +extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); +#endif + +/* Primitive types */ +#define AO_SCHEME_CONS 0 +#define AO_SCHEME_INT 1 +#define AO_SCHEME_STRING 2 +#define AO_SCHEME_OTHER 3 + +#define AO_SCHEME_TYPE_MASK 0x0003 +#define AO_SCHEME_TYPE_SHIFT 2 +#define AO_SCHEME_REF_MASK 0x7ffc +#define AO_SCHEME_CONST 0x8000 + +/* These have a type value at the start of the struct */ +#define AO_SCHEME_ATOM 4 +#define AO_SCHEME_BUILTIN 5 +#define AO_SCHEME_FRAME 6 +#define AO_SCHEME_FRAME_VALS 7 +#define AO_SCHEME_LAMBDA 8 +#define AO_SCHEME_STACK 9 +#define AO_SCHEME_BOOL 10 +#define AO_SCHEME_BIGINT 11 +#define AO_SCHEME_FLOAT 12 +#define AO_SCHEME_NUM_TYPE 13 + +/* Leave two bits for types to use as they please */ +#define AO_SCHEME_OTHER_TYPE_MASK 0x3f + +#define AO_SCHEME_NIL 0 + +extern uint16_t ao_scheme_top; + +#define AO_SCHEME_OOM 0x01 +#define AO_SCHEME_DIVIDE_BY_ZERO 0x02 +#define AO_SCHEME_INVALID 0x04 +#define AO_SCHEME_UNDEFINED 0x08 +#define AO_SCHEME_REDEFINED 0x10 +#define AO_SCHEME_EOF 0x20 +#define AO_SCHEME_EXIT 0x40 + +extern uint8_t ao_scheme_exception; + +static inline int +ao_scheme_is_const(ao_poly poly) { + return poly & AO_SCHEME_CONST; +} + +#define AO_SCHEME_IS_CONST(a) (ao_scheme_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_const + AO_SCHEME_POOL_CONST) +#define AO_SCHEME_IS_POOL(a) (ao_scheme_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_pool + AO_SCHEME_POOL) +#define AO_SCHEME_IS_INT(p) (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) + +void * +ao_scheme_ref(ao_poly poly); + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type); + +struct ao_scheme_type { + int (*size)(void *addr); + void (*mark)(void *addr); + void (*move)(void *addr); + char name[]; +}; + +struct ao_scheme_cons { + ao_poly car; + ao_poly cdr; +}; + +struct ao_scheme_atom { + uint8_t type; + uint8_t pad[1]; + ao_poly next; + char name[]; +}; + +struct ao_scheme_val { + ao_poly atom; + ao_poly val; +}; + +struct ao_scheme_frame_vals { + uint8_t type; + uint8_t size; + struct ao_scheme_val vals[]; +}; + +struct ao_scheme_frame { + uint8_t type; + uint8_t num; + ao_poly prev; + ao_poly vals; +}; + +struct ao_scheme_bool { + uint8_t type; + uint8_t value; + uint16_t pad; +}; + +struct ao_scheme_bigint { + uint32_t value; +}; + +struct ao_scheme_float { + uint8_t type; + uint8_t pad1; + uint16_t pad2; + float value; +}; + +#if __BYTE_ORDER == __LITTLE_ENDIAN +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { + return AO_SCHEME_BIGINT | (i << 8); +} +static inline int32_t +ao_scheme_bigint_int(uint32_t bi) { + return (int32_t) bi >> 8; +} +#else +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { + return (uint32_t) (i & 0xffffff) | (AO_SCHEME_BIGINT << 24); +} +static inlint int32_t +ao_scheme_bigint_int(uint32_t bi) { + return (int32_t) (bi << 8) >> 8; +} +#endif + +#define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) +#define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) +#define AO_SCHEME_MIN_BIGINT (-(1 << 24)) +#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1) + +#define AO_SCHEME_NOT_INTEGER 0x7fffffff + +/* Set on type when the frame escapes the lambda */ +#define AO_SCHEME_FRAME_MARK 0x80 +#define AO_SCHEME_FRAME_PRINT 0x40 + +static inline int ao_scheme_frame_marked(struct ao_scheme_frame *f) { + return f->type & AO_SCHEME_FRAME_MARK; +} + +static inline struct ao_scheme_frame * +ao_scheme_poly_frame(ao_poly poly) { + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_poly(struct ao_scheme_frame *frame) { + return ao_scheme_poly(frame, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_frame_vals * +ao_scheme_poly_frame_vals(ao_poly poly) { + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_vals_poly(struct ao_scheme_frame_vals *vals) { + return ao_scheme_poly(vals, AO_SCHEME_OTHER); +} + +enum eval_state { + eval_sexpr, /* Evaluate an sexpr */ + eval_val, /* Value computed */ + eval_formal, /* Formal computed */ + eval_exec, /* Start a lambda evaluation */ + eval_apply, /* Execute apply */ + eval_cond, /* Start next cond clause */ + eval_cond_test, /* Check cond condition */ + eval_begin, /* Start next begin entry */ + eval_while, /* Start while condition */ + eval_while_test, /* Check while condition */ + eval_macro, /* Finished with macro generation */ +}; + +struct ao_scheme_stack { + uint8_t type; /* AO_SCHEME_STACK */ + uint8_t state; /* enum eval_state */ + ao_poly prev; /* previous stack frame */ + ao_poly sexprs; /* expressions to evaluate */ + ao_poly values; /* values computed */ + ao_poly values_tail; /* end of the values list for easy appending */ + ao_poly frame; /* current lookup frame */ + ao_poly list; /* most recent function call */ +}; + +#define AO_SCHEME_STACK_MARK 0x80 /* set on type when a reference has been taken */ +#define AO_SCHEME_STACK_PRINT 0x40 /* stack is being printed */ + +static inline int ao_scheme_stack_marked(struct ao_scheme_stack *s) { + return s->type & AO_SCHEME_STACK_MARK; +} + +static inline void ao_scheme_stack_mark(struct ao_scheme_stack *s) { + s->type |= AO_SCHEME_STACK_MARK; +} + +static inline struct ao_scheme_stack * +ao_scheme_poly_stack(ao_poly p) +{ + return ao_scheme_ref(p); +} + +static inline ao_poly +ao_scheme_stack_poly(struct ao_scheme_stack *stack) +{ + return ao_scheme_poly(stack, AO_SCHEME_OTHER); +} + +extern ao_poly ao_scheme_v; + +#define AO_SCHEME_FUNC_LAMBDA 0 +#define AO_SCHEME_FUNC_NLAMBDA 1 +#define AO_SCHEME_FUNC_MACRO 2 + +#define AO_SCHEME_FUNC_FREE_ARGS 0x80 +#define AO_SCHEME_FUNC_MASK 0x7f + +#define AO_SCHEME_FUNC_F_LAMBDA (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_LAMBDA) +#define AO_SCHEME_FUNC_F_NLAMBDA (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_NLAMBDA) +#define AO_SCHEME_FUNC_F_MACRO (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_MACRO) + +struct ao_scheme_builtin { + uint8_t type; + uint8_t args; + uint16_t func; +}; + +#define AO_SCHEME_BUILTIN_ID +#include "ao_scheme_builtin.h" + +typedef ao_poly (*ao_scheme_func_t)(struct ao_scheme_cons *cons); + +extern const ao_scheme_func_t ao_scheme_builtins[]; + +static inline ao_scheme_func_t +ao_scheme_func(struct ao_scheme_builtin *b) +{ + return ao_scheme_builtins[b->func]; +} + +struct ao_scheme_lambda { + uint8_t type; + uint8_t args; + ao_poly code; + ao_poly frame; +}; + +static inline struct ao_scheme_lambda * +ao_scheme_poly_lambda(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_lambda_poly(struct ao_scheme_lambda *lambda) +{ + return ao_scheme_poly(lambda, AO_SCHEME_OTHER); +} + +static inline void * +ao_scheme_poly_other(ao_poly poly) { + return ao_scheme_ref(poly); +} + +static inline uint8_t +ao_scheme_other_type(void *other) { +#if DBG_MEM + if ((*((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK) >= AO_SCHEME_NUM_TYPE) + ao_scheme_abort(); +#endif + return *((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK; +} + +static inline ao_poly +ao_scheme_other_poly(const void *other) +{ + return ao_scheme_poly(other, AO_SCHEME_OTHER); +} + +static inline int +ao_scheme_size_round(int size) +{ + return (size + 3) & ~3; +} + +static inline int +ao_scheme_size(const struct ao_scheme_type *type, void *addr) +{ + return ao_scheme_size_round(type->size(addr)); +} + +#define AO_SCHEME_OTHER_POLY(other) ((ao_poly)(other) + AO_SCHEME_OTHER) + +static inline int ao_scheme_poly_base_type(ao_poly poly) { + return poly & AO_SCHEME_TYPE_MASK; +} + +static inline int ao_scheme_poly_type(ao_poly poly) { + int type = poly & AO_SCHEME_TYPE_MASK; + if (type == AO_SCHEME_OTHER) + return ao_scheme_other_type(ao_scheme_poly_other(poly)); + return type; +} + +static inline int +ao_scheme_is_cons(ao_poly poly) { + return (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline int +ao_scheme_is_pair(ao_poly poly) { + return poly != AO_SCHEME_NIL && (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline struct ao_scheme_cons * +ao_scheme_poly_cons(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_cons_poly(struct ao_scheme_cons *cons) +{ + return ao_scheme_poly(cons, AO_SCHEME_CONS); +} + +static inline int32_t +ao_scheme_poly_int(ao_poly poly) +{ + return (int32_t) ((ao_signed_poly) poly >> AO_SCHEME_TYPE_SHIFT); +} + +static inline ao_poly +ao_scheme_int_poly(int32_t i) +{ + return ((ao_poly) i << 2) | AO_SCHEME_INT; +} + +static inline struct ao_scheme_bigint * +ao_scheme_poly_bigint(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) +{ + return ao_scheme_poly(bi, AO_SCHEME_OTHER); +} + +static inline char * +ao_scheme_poly_string(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_string_poly(char *s) +{ + return ao_scheme_poly(s, AO_SCHEME_STRING); +} + +static inline struct ao_scheme_atom * +ao_scheme_poly_atom(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_atom_poly(struct ao_scheme_atom *a) +{ + return ao_scheme_poly(a, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_builtin * +ao_scheme_poly_builtin(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_builtin_poly(struct ao_scheme_builtin *b) +{ + return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline ao_poly +ao_scheme_bool_poly(struct ao_scheme_bool *b) +{ + return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_bool * +ao_scheme_poly_bool(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_float_poly(struct ao_scheme_float *f) +{ + return ao_scheme_poly(f, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_float * +ao_scheme_poly_float(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* memory functions */ + +extern int ao_scheme_collects[2]; +extern int ao_scheme_freed[2]; +extern int ao_scheme_loops[2]; + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr); + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); + +void * +ao_scheme_move_map(void *addr); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); + +void * +ao_scheme_alloc(int size); + +#define AO_SCHEME_COLLECT_FULL 1 +#define AO_SCHEME_COLLECT_INCREMENTAL 0 + +int +ao_scheme_collect(uint8_t style); + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons); +#endif + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id); + +void +ao_scheme_poly_stash(int id, ao_poly poly); + +ao_poly +ao_scheme_poly_fetch(int id); + +void +ao_scheme_string_stash(int id, char *string); + +char * +ao_scheme_string_fetch(int id); + +static inline void +ao_scheme_stack_stash(int id, struct ao_scheme_stack *stack) { + ao_scheme_poly_stash(id, ao_scheme_stack_poly(stack)); +} + +static inline struct ao_scheme_stack * +ao_scheme_stack_fetch(int id) { + return ao_scheme_poly_stack(ao_scheme_poly_fetch(id)); +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame); + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id); + +/* bool */ + +extern const struct ao_scheme_type ao_scheme_bool_type; + +void +ao_scheme_bool_write(ao_poly v); + +#ifdef AO_SCHEME_MAKE_CONST +struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; + +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value); +#endif + +/* cons */ +extern const struct ao_scheme_type ao_scheme_cons_type; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr); + +/* Return a cons or NULL for a proper list, else error */ +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr); + +extern struct ao_scheme_cons *ao_scheme_cons_free_list; + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons); + +void +ao_scheme_cons_write(ao_poly); + +void +ao_scheme_cons_display(ao_poly); + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons); + +/* string */ +extern const struct ao_scheme_type ao_scheme_string_type; + +char * +ao_scheme_string_copy(char *a); + +char * +ao_scheme_string_cat(char *a, char *b); + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme_string_unpack(char *a); + +void +ao_scheme_string_write(ao_poly s); + +void +ao_scheme_string_display(ao_poly s); + +/* atom */ +extern const struct ao_scheme_type ao_scheme_atom_type; + +extern struct ao_scheme_atom *ao_scheme_atoms; +extern struct ao_scheme_frame *ao_scheme_frame_global; +extern struct ao_scheme_frame *ao_scheme_frame_current; + +void +ao_scheme_atom_write(ao_poly a); + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name); + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref); + +ao_poly +ao_scheme_atom_get(ao_poly atom); + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val); + +/* int */ +void +ao_scheme_int_write(ao_poly i); + +int32_t +ao_scheme_poly_integer(ao_poly p); + +ao_poly +ao_scheme_integer_poly(int32_t i); + +static inline int +ao_scheme_integer_typep(uint8_t t) +{ + return (t == AO_SCHEME_INT) || (t == AO_SCHEME_BIGINT); +} + +void +ao_scheme_bigint_write(ao_poly i); + +extern const struct ao_scheme_type ao_scheme_bigint_type; +/* prim */ +void +ao_scheme_poly_write(ao_poly p); + +void +ao_scheme_poly_display(ao_poly p); + +int +ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); + +/* returns 1 if the object has already been moved */ +int +ao_scheme_poly_move(ao_poly *p, uint8_t note_cons); + +/* eval */ + +void +ao_scheme_eval_clear_globals(void); + +int +ao_scheme_eval_restart(void); + +ao_poly +ao_scheme_eval(ao_poly p); + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *cons); + +/* float */ +extern const struct ao_scheme_type ao_scheme_float_type; + +void +ao_scheme_float_write(ao_poly p); + +ao_poly +ao_scheme_float_get(float value); + +static inline uint8_t +ao_scheme_number_typep(uint8_t t) +{ + return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* builtin */ +void +ao_scheme_builtin_write(ao_poly b); + +extern const struct ao_scheme_type ao_scheme_builtin_type; + +/* Check argument count */ +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max); + +/* Check argument type */ +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok); + +/* Fetch an arg (nil if off the end) */ +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc); + +char * +ao_scheme_args_name(uint8_t args); + +/* read */ +extern struct ao_scheme_cons *ao_scheme_read_cons; +extern struct ao_scheme_cons *ao_scheme_read_cons_tail; +extern struct ao_scheme_cons *ao_scheme_read_stack; + +ao_poly +ao_scheme_read(void); + +/* rep */ +ao_poly +ao_scheme_read_eval_print(void); + +/* frame */ +extern const struct ao_scheme_type ao_scheme_frame_type; +extern const struct ao_scheme_type ao_scheme_frame_vals_type; + +#define AO_SCHEME_FRAME_FREE 6 + +extern struct ao_scheme_frame *ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame); + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom); + +struct ao_scheme_frame * +ao_scheme_frame_new(int num); + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame); + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val); + +void +ao_scheme_frame_write(ao_poly p); + +void +ao_scheme_frame_init(void); + +/* lambda */ +extern const struct ao_scheme_type ao_scheme_lambda_type; + +extern const char * const ao_scheme_state_names[]; + +struct ao_scheme_lambda * +ao_scheme_lambda_new(ao_poly cons); + +void +ao_scheme_lambda_write(ao_poly lambda); + +ao_poly +ao_scheme_lambda_eval(void); + +/* stack */ + +extern const struct ao_scheme_type ao_scheme_stack_type; +extern struct ao_scheme_stack *ao_scheme_stack; +extern struct ao_scheme_stack *ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack); + +int +ao_scheme_stack_push(void); + +void +ao_scheme_stack_pop(void); + +void +ao_scheme_stack_clear(void); + +void +ao_scheme_stack_write(ao_poly stack); + +ao_poly +ao_scheme_stack_eval(void); + +/* error */ + +void +ao_scheme_vprintf(char *format, va_list args); + +void +ao_scheme_printf(char *format, ...); + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last); + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame); + +ao_poly +ao_scheme_error(int error, char *format, ...); + +/* builtins */ + +#define AO_SCHEME_BUILTIN_DECLS +#include "ao_scheme_builtin.h" + +/* debugging macros */ + +#if DBG_EVAL || DBG_READ || DBG_MEM +#define DBG_CODE 1 +int ao_scheme_stack_depth; +#define DBG_DO(a) a +#define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_scheme_stack_depth; _s++) printf(" "); } while(0) +#define DBG_IN() (++ao_scheme_stack_depth) +#define DBG_OUT() (--ao_scheme_stack_depth) +#define DBG_RESET() (ao_scheme_stack_depth = 0) +#define DBG(...) ao_scheme_printf(__VA_ARGS__) +#define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#define DBG_CONS(a) ao_scheme_cons_write(ao_scheme_cons_poly(a)) +#define DBG_POLY(a) ao_scheme_poly_write(a) +#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) +#define DBG_STACK() ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)) +static inline void +ao_scheme_frames_dump(void) +{ + struct ao_scheme_stack *s; + DBGI(".. current frame: "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + for (s = ao_scheme_stack; s; s = ao_scheme_poly_stack(s->prev)) { + DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); + } +} +#define DBG_FRAMES() ao_scheme_frames_dump() +#else +#define DBG_DO(a) +#define DBG_INDENT() +#define DBG_IN() +#define DBG_OUT() +#define DBG(...) +#define DBGI(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#define DBG_RESET() +#define DBG_STACK() +#define DBG_FRAMES() +#endif + +#if DBG_READ +#define RDBGI(...) DBGI(__VA_ARGS__) +#define RDBG_IN() DBG_IN() +#define RDBG_OUT() DBG_OUT() +#else +#define RDBGI(...) +#define RDBG_IN() +#define RDBG_OUT() +#endif + +#define DBG_MEM_START 1 + +#if DBG_MEM + +#include +extern int dbg_move_depth; +#define MDBG_DUMP 1 +#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_scheme_pool) : -1) + +extern int dbg_mem; + +#define MDBG_DO(a) DBG_DO(a) +#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) +#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) +#define MDBG_MOVE_IN() (dbg_move_depth++) +#define MDBG_MOVE_OUT() (assert(--dbg_move_depth >= 0)) + +#else + +#define MDBG_DO(a) +#define MDBG_MOVE(...) +#define MDBG_MORE(...) +#define MDBG_MOVE_IN() +#define MDBG_MOVE_OUT() + +#endif + +#endif /* _AO_SCHEME_H_ */ diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c new file mode 100644 index 00000000..cb32b7fe --- /dev/null +++ b/src/scheme/ao_scheme_atom.c @@ -0,0 +1,167 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_scheme.h" + +static int name_size(char *name) +{ + return sizeof(struct ao_scheme_atom) + strlen(name) + 1; +} + +static int atom_size(void *addr) +{ + struct ao_scheme_atom *atom = addr; + if (!atom) + return 0; + return name_size(atom->name); +} + +static void atom_mark(void *addr) +{ + struct ao_scheme_atom *atom = addr; + + for (;;) { + atom = ao_scheme_poly_atom(atom->next); + if (!atom) + break; + if (ao_scheme_mark_memory(&ao_scheme_atom_type, atom)) + break; + } +} + +static void atom_move(void *addr) +{ + struct ao_scheme_atom *atom = addr; + int ret; + + for (;;) { + struct ao_scheme_atom *next = ao_scheme_poly_atom(atom->next); + + if (!next) + break; + ret = ao_scheme_move_memory(&ao_scheme_atom_type, (void **) &next); + if (next != ao_scheme_poly_atom(atom->next)) + atom->next = ao_scheme_atom_poly(next); + if (ret) + break; + atom = next; + } +} + +const struct ao_scheme_type ao_scheme_atom_type = { + .mark = atom_mark, + .size = atom_size, + .move = atom_move, + .name = "atom" +}; + +struct ao_scheme_atom *ao_scheme_atoms; + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name) +{ + struct ao_scheme_atom *atom; + + for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { + if (!strcmp(atom->name, name)) + return atom; + } +#ifdef ao_builtin_atoms + for (atom = ao_scheme_poly_atom(ao_builtin_atoms); atom; atom = ao_scheme_poly_atom(atom->next)) { + if (!strcmp(atom->name, name)) + return atom; + } +#endif + ao_scheme_string_stash(0, name); + atom = ao_scheme_alloc(name_size(name)); + name = ao_scheme_string_fetch(0); + if (atom) { + atom->type = AO_SCHEME_ATOM; + atom->next = ao_scheme_atom_poly(ao_scheme_atoms); + ao_scheme_atoms = atom; + strcpy(atom->name, name); + } + return atom; +} + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref) +{ + ao_poly *ref; + struct ao_scheme_frame *frame; + + for (frame = ao_scheme_frame_current; frame; frame = ao_scheme_poly_frame(frame->prev)) { + ref = ao_scheme_frame_ref(frame, atom); + if (ref) { + if (frame_ref) + *frame_ref = frame; + return ref; + } + } + ref = ao_scheme_frame_ref(ao_scheme_frame_global, atom); + if (ref) + if (frame_ref) + *frame_ref = ao_scheme_frame_global; + return ref; +} + +ao_poly +ao_scheme_atom_get(ao_poly atom) +{ + ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + +#ifdef ao_builtin_frame + if (!ref) + ref = ao_scheme_frame_ref(ao_scheme_poly_frame(ao_builtin_frame), atom); +#endif + if (ref) + return *ref; + return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); +} + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val) +{ + ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + + if (!ref) + return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); + *ref = val; + return val; +} + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val) +{ + struct ao_scheme_frame *frame; + ao_poly *ref = ao_scheme_atom_ref(atom, &frame); + + if (ref) { + if (frame == ao_scheme_frame_current) + return ao_scheme_error(AO_SCHEME_REDEFINED, "attempt to redefine atom %s", ao_scheme_poly_atom(atom)->name); + *ref = val; + return val; + } + return ao_scheme_frame_add(ao_scheme_frame_current ? ao_scheme_frame_current : ao_scheme_frame_global, atom, val); +} + +void +ao_scheme_atom_write(ao_poly a) +{ + struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); + printf("%s", atom->name); +} diff --git a/src/scheme/ao_scheme_bool.c b/src/scheme/ao_scheme_bool.c new file mode 100644 index 00000000..c1e880ca --- /dev/null +++ b/src/scheme/ao_scheme_bool.c @@ -0,0 +1,73 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static void bool_mark(void *addr) +{ + (void) addr; +} + +static int bool_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_bool); +} + +static void bool_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_bool_type = { + .mark = bool_mark, + .size = bool_size, + .move = bool_move, + .name = "bool" +}; + +void +ao_scheme_bool_write(ao_poly v) +{ + struct ao_scheme_bool *b = ao_scheme_poly_bool(v); + + if (b->value) + printf("#t"); + else + printf("#f"); +} + +#ifdef AO_SCHEME_MAKE_CONST + +struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; + +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value) +{ + struct ao_scheme_bool **b; + + if (value) + b = &ao_scheme_true; + else + b = &ao_scheme_false; + + if (!*b) { + *b = ao_scheme_alloc(sizeof (struct ao_scheme_bool)); + (*b)->type = AO_SCHEME_BOOL; + (*b)->value = value; + } + return *b; +} + +#endif diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c new file mode 100644 index 00000000..49f218f6 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.c @@ -0,0 +1,868 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include +#include + +static int +builtin_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_builtin); +} + +static void +builtin_mark(void *addr) +{ + (void) addr; +} + +static void +builtin_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_builtin_type = { + .size = builtin_size, + .mark = builtin_mark, + .move = builtin_move +}; + +#ifdef AO_SCHEME_MAKE_CONST + +#define AO_SCHEME_BUILTIN_CASENAME +#include "ao_scheme_builtin.h" + +char *ao_scheme_args_name(uint8_t args) { + args &= AO_SCHEME_FUNC_MASK; + switch (args) { + case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name; + case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name; + case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name; + default: return "???"; + } +} +#else + +#define AO_SCHEME_BUILTIN_ARRAYNAME +#include "ao_scheme_builtin.h" + +static char * +ao_scheme_builtin_name(enum ao_scheme_builtin_id b) { + if (b < _builtin_last) + return ao_scheme_poly_atom(builtin_names[b])->name; + return "???"; +} + +static const ao_poly ao_scheme_args_atoms[] = { + [AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda, + [AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda, + [AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro, +}; + +char * +ao_scheme_args_name(uint8_t args) +{ + args &= AO_SCHEME_FUNC_MASK; + if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0]) + return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name; + return "(unknown)"; +} +#endif + +void +ao_scheme_builtin_write(ao_poly b) +{ + struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); + printf("%s", ao_scheme_builtin_name(builtin->func)); +} + +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max) +{ + int argc = 0; + + while (cons && argc <= max) { + argc++; + cons = ao_scheme_cons_cdr(cons); + } + if (argc < min || argc > max) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc) +{ + if (!cons) + return AO_SCHEME_NIL; + while (argc--) { + if (!cons) + return AO_SCHEME_NIL; + cons = ao_scheme_cons_cdr(cons); + } + return cons->car; +} + +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok) +{ + ao_poly car = ao_scheme_arg(cons, argc); + + if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: arg %d invalid type %v", ao_scheme_poly_atom(name)->name, argc, car); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_car(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(cons->car)->car; +} + +ao_poly +ao_scheme_do_cdr(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(cons->car)->cdr; +} + +ao_poly +ao_scheme_do_cons(struct ao_scheme_cons *cons) +{ + ao_poly car, cdr; + if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2)) + return AO_SCHEME_NIL; + car = ao_scheme_arg(cons, 0); + cdr = ao_scheme_arg(cons, 1); + return ao_scheme__cons(car, cdr); +} + +ao_poly +ao_scheme_do_last(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *list; + if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0)); + list; + list = ao_scheme_cons_cdr(list)) + { + if (!list->cdr) + return list->car; + } + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_length(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_quote(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1)) + return AO_SCHEME_NIL; + return ao_scheme_arg(cons, 0); +} + +ao_poly +ao_scheme_do_set(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_def(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_setq(struct ao_scheme_cons *cons) +{ + ao_poly name; + if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2)) + return AO_SCHEME_NIL; + name = cons->car; + if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name); + if (!ao_scheme_atom_ref(name, NULL)) + return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name); + return ao_scheme__cons(_ao_scheme_atom_set, + ao_scheme__cons(ao_scheme__cons(_ao_scheme_atom_quote, + ao_scheme__cons(name, AO_SCHEME_NIL)), + cons->cdr)); +} + +ao_poly +ao_scheme_do_cond(struct ao_scheme_cons *cons) +{ + ao_scheme_set_cond(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_begin(struct ao_scheme_cons *cons) +{ + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_while(struct ao_scheme_cons *cons) +{ + ao_scheme_stack->state = eval_while; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_write(struct ao_scheme_cons *cons) +{ + ao_poly val = AO_SCHEME_NIL; + while (cons) { + val = cons->car; + ao_scheme_poly_write(val); + cons = ao_scheme_cons_cdr(cons); + if (cons) + printf(" "); + } + printf("\n"); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_display(struct ao_scheme_cons *cons) +{ + ao_poly val = AO_SCHEME_NIL; + while (cons) { + val = cons->car; + ao_scheme_poly_display(val); + cons = ao_scheme_cons_cdr(cons); + } + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) +{ + struct ao_scheme_cons *cons = cons; + ao_poly ret = AO_SCHEME_NIL; + + for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) { + ao_poly car = cons->car; + uint8_t rt = ao_scheme_poly_type(ret); + uint8_t ct = ao_scheme_poly_type(car); + + if (cons == orig_cons) { + ret = car; + if (cons->cdr == AO_SCHEME_NIL) { + switch (op) { + case builtin_minus: + if (ao_scheme_integer_typep(ct)) + ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); + else if (ct == AO_SCHEME_FLOAT) + ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); + break; + case builtin_divide: + if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) + ; + else if (ao_scheme_number_typep(ct)) { + float v = ao_scheme_poly_number(ret); + ret = ao_scheme_float_get(1/v); + } + break; + default: + break; + } + } + } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { + int32_t r = ao_scheme_poly_integer(ret); + int32_t c = ao_scheme_poly_integer(car); + int64_t t; + + switch(op) { + case builtin_plus: + r += c; + check_overflow: + if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) + goto inexact; + break; + case builtin_minus: + r -= c; + goto check_overflow; + break; + case builtin_times: + t = (int64_t) r * (int64_t) c; + if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) + goto inexact; + r = (int32_t) t; + break; + case builtin_divide: + if (c != 0 && (r % c) == 0) + r /= c; + else + goto inexact; + break; + case builtin_quotient: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero"); + if (r % c != 0 && (c < 0) != (r < 0)) + r = r / c - 1; + else + r = r / c; + break; + case builtin_remainder: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero"); + r %= c; + break; + case builtin_modulo: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero"); + r %= c; + if ((r < 0) != (c < 0)) + r += c; + break; + default: + break; + } + ret = ao_scheme_integer_poly(r); + } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { + float r, c; + inexact: + r = ao_scheme_poly_number(ret); + c = ao_scheme_poly_number(car); + switch(op) { + case builtin_plus: + r += c; + break; + case builtin_minus: + r -= c; + break; + case builtin_times: + r *= c; + break; + case builtin_divide: + r /= c; + break; + case builtin_quotient: + case builtin_remainder: + case builtin_modulo: + return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); + default: + break; + } + ret = ao_scheme_float_get(r); + } + + else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) + ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), + ao_scheme_poly_string(car))); + else + return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); + } + return ret; +} + +ao_poly +ao_scheme_do_plus(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_plus); +} + +ao_poly +ao_scheme_do_minus(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_minus); +} + +ao_poly +ao_scheme_do_times(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_times); +} + +ao_poly +ao_scheme_do_divide(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_divide); +} + +ao_poly +ao_scheme_do_quotient(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_quotient); +} + +ao_poly +ao_scheme_do_modulo(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_modulo); +} + +ao_poly +ao_scheme_do_remainder(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_remainder); +} + +ao_poly +ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) +{ + ao_poly left; + + if (!cons) + return _ao_scheme_bool_true; + + left = cons->car; + for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { + ao_poly right = cons->car; + + if (op == builtin_equal) { + if (left != right) + return _ao_scheme_bool_false; + } else { + uint8_t lt = ao_scheme_poly_type(left); + uint8_t rt = ao_scheme_poly_type(right); + if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) { + int32_t l = ao_scheme_poly_integer(left); + int32_t r = ao_scheme_poly_integer(right); + + switch (op) { + case builtin_less: + if (!(l < r)) + return _ao_scheme_bool_false; + break; + case builtin_greater: + if (!(l > r)) + return _ao_scheme_bool_false; + break; + case builtin_less_equal: + if (!(l <= r)) + return _ao_scheme_bool_false; + break; + case builtin_greater_equal: + if (!(l >= r)) + return _ao_scheme_bool_false; + break; + default: + break; + } + } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { + int c = strcmp(ao_scheme_poly_string(left), + ao_scheme_poly_string(right)); + switch (op) { + case builtin_less: + if (!(c < 0)) + return _ao_scheme_bool_false; + break; + case builtin_greater: + if (!(c > 0)) + return _ao_scheme_bool_false; + break; + case builtin_less_equal: + if (!(c <= 0)) + return _ao_scheme_bool_false; + break; + case builtin_greater_equal: + if (!(c >= 0)) + return _ao_scheme_bool_false; + break; + default: + break; + } + } + } + left = right; + } + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_equal); +} + +ao_poly +ao_scheme_do_less(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_less); +} + +ao_poly +ao_scheme_do_greater(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_greater); +} + +ao_poly +ao_scheme_do_less_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_less_equal); +} + +ao_poly +ao_scheme_do_greater_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_greater_equal); +} + +ao_poly +ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_flush_output(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0)) + return AO_SCHEME_NIL; + ao_scheme_os_flush(); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_led(struct ao_scheme_cons *cons) +{ + ao_poly led; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + led = ao_scheme_arg(cons, 0); + ao_scheme_os_led(ao_scheme_poly_int(led)); + return led; +} + +ao_poly +ao_scheme_do_delay(struct ao_scheme_cons *cons) +{ + ao_poly delay; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + delay = ao_scheme_arg(cons, 0); + ao_scheme_os_delay(ao_scheme_poly_int(delay)); + return delay; +} + +ao_poly +ao_scheme_do_eval(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1)) + return AO_SCHEME_NIL; + ao_scheme_stack->state = eval_sexpr; + return cons->car; +} + +ao_poly +ao_scheme_do_apply(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX)) + return AO_SCHEME_NIL; + ao_scheme_stack->state = eval_apply; + return ao_scheme_cons_poly(cons); +} + +ao_poly +ao_scheme_do_read(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0)) + return AO_SCHEME_NIL; + return ao_scheme_read(); +} + +ao_poly +ao_scheme_do_collect(struct ao_scheme_cons *cons) +{ + int free; + (void) cons; + free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + return ao_scheme_int_poly(free); +} + +ao_poly +ao_scheme_do_nullp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL) + return _ao_scheme_bool_true; + else + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_not(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false) + return _ao_scheme_bool_true; + else + return _ao_scheme_bool_false; +} + +static ao_poly +ao_scheme_do_typep(int type, struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_pairp(struct ao_scheme_cons *cons) +{ + ao_poly v; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + v = ao_scheme_arg(cons, 0); + if (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_integerp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +ao_poly +ao_scheme_do_numberp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + case AO_SCHEME_FLOAT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +ao_poly +ao_scheme_do_stringp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_STRING, cons); +} + +ao_poly +ao_scheme_do_symbolp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_ATOM, cons); +} + +ao_poly +ao_scheme_do_booleanp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_BOOL, cons); +} + +ao_poly +ao_scheme_do_procedurep(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_BUILTIN: + case AO_SCHEME_LAMBDA: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +/* This one is special -- a list is either nil or + * a 'proper' list with only cons cells + */ +ao_poly +ao_scheme_do_listp(struct ao_scheme_cons *cons) +{ + ao_poly v; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + v = ao_scheme_arg(cons, 0); + for (;;) { + if (v == AO_SCHEME_NIL) + return _ao_scheme_bool_true; + if (ao_scheme_poly_type(v) != AO_SCHEME_CONS) + return _ao_scheme_bool_false; + v = ao_scheme_poly_cons(v)->cdr; + } +} + +ao_poly +ao_scheme_do_set_car(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name)); +} + +ao_poly +ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_read_char(struct ao_scheme_cons *cons) +{ + int c; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + c = getchar(); + return ao_scheme_int_poly(c); +} + +ao_poly +ao_scheme_do_write_char(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0))); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_exit(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + ao_scheme_exception |= AO_SCHEME_EXIT; + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) +{ + int jiffy; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + jiffy = ao_scheme_os_jiffy(); + return (ao_scheme_int_poly(jiffy)); +} + +ao_poly +ao_scheme_do_current_second(struct ao_scheme_cons *cons) +{ + int second; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND; + return (ao_scheme_int_poly(second)); +} + +ao_poly +ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); +} + +#define AO_SCHEME_BUILTIN_FUNCS +#include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt new file mode 100644 index 00000000..cb65e252 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.txt @@ -0,0 +1,68 @@ +f_lambda eval +f_lambda read +nlambda lambda +nlambda nlambda +nlambda macro +f_lambda car +f_lambda cdr +f_lambda cons +f_lambda last +f_lambda length +nlambda quote +atom quasiquote +atom unquote +atom unquote_splicing unquote-splicing +f_lambda set +macro setq set! +f_lambda def +nlambda cond +nlambda begin +nlambda while +f_lambda write +f_lambda display +f_lambda plus + +f_lambda minus - +f_lambda times * +f_lambda divide / +f_lambda modulo modulo % +f_lambda remainder +f_lambda quotient +f_lambda equal = eq? eqv? +f_lambda less < +f_lambda greater > +f_lambda less_equal <= +f_lambda greater_equal >= +f_lambda list_to_string list->string +f_lambda string_to_list string->list +f_lambda flush_output flush-output +f_lambda delay +f_lambda led +f_lambda save +f_lambda restore +f_lambda call_cc call-with-current-continuation call/cc +f_lambda collect +f_lambda nullp null? +f_lambda not +f_lambda listp list? +f_lambda pairp pair? +f_lambda integerp integer? exact? exact-integer? +f_lambda numberp number? real? +f_lambda booleanp boolean? +f_lambda set_car set-car! +f_lambda set_cdr set-cdr! +f_lambda symbolp symbol? +f_lambda symbol_to_string symbol->string +f_lambda string_to_symbol string->symbol +f_lambda stringp string? +f_lambda procedurep procedure? +lambda apply +f_lambda read_char read-char +f_lambda write_char write-char +f_lambda exit +f_lambda current_jiffy current-jiffy +f_lambda current_second current-second +f_lambda jiffies_per_second jiffies-per-second +f_lambda finitep finite? +f_lambda infinitep infinite? +f_lambda inexactp inexact? +f_lambda sqrt diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c new file mode 100644 index 00000000..03dad956 --- /dev/null +++ b/src/scheme/ao_scheme_cons.c @@ -0,0 +1,201 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static void cons_mark(void *addr) +{ + struct ao_scheme_cons *cons = addr; + + for (;;) { + ao_poly cdr = cons->cdr; + + ao_scheme_poly_mark(cons->car, 1); + if (!cdr) + break; + if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + ao_scheme_poly_mark(cdr, 1); + break; + } + cons = ao_scheme_poly_cons(cdr); + if (ao_scheme_mark_memory(&ao_scheme_cons_type, cons)) + break; + } +} + +static int cons_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_cons); +} + +static void cons_move(void *addr) +{ + struct ao_scheme_cons *cons = addr; + + if (!cons) + return; + + for (;;) { + ao_poly cdr; + struct ao_scheme_cons *c; + int ret; + + MDBG_MOVE("cons_move start %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); + (void) ao_scheme_poly_move(&cons->car, 1); + cdr = cons->cdr; + if (!cdr) + break; + if (ao_scheme_poly_base_type(cdr) != AO_SCHEME_CONS) { + (void) ao_scheme_poly_move(&cons->cdr, 0); + break; + } + c = ao_scheme_poly_cons(cdr); + ret = ao_scheme_move_memory(&ao_scheme_cons_type, (void **) &c); + if (c != ao_scheme_poly_cons(cons->cdr)) + cons->cdr = ao_scheme_cons_poly(c); + MDBG_MOVE("cons_move end %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); + if (ret) + break; + cons = c; + } +} + +const struct ao_scheme_type ao_scheme_cons_type = { + .mark = cons_mark, + .size = cons_size, + .move = cons_move, + .name = "cons", +}; + +struct ao_scheme_cons *ao_scheme_cons_free_list; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr) +{ + struct ao_scheme_cons *cons; + + if (ao_scheme_cons_free_list) { + cons = ao_scheme_cons_free_list; + ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr); + } else { + ao_scheme_poly_stash(0, car); + ao_scheme_poly_stash(1, cdr); + cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); + cdr = ao_scheme_poly_fetch(1); + car = ao_scheme_poly_fetch(0); + if (!cons) + return NULL; + } + cons->car = car; + cons->cdr = cdr; + return cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons) +{ + ao_poly cdr = cons->cdr; + if (cdr == AO_SCHEME_NIL) + return NULL; + if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + (void) ao_scheme_error(AO_SCHEME_INVALID, "improper list"); + return NULL; + } + return ao_scheme_poly_cons(cdr); +} + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr) +{ + return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); +} + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons) +{ +#if DBG_FREE_CONS + ao_scheme_cons_check(cons); +#endif + while (cons) { + ao_poly cdr = cons->cdr; + cons->cdr = ao_scheme_cons_poly(ao_scheme_cons_free_list); + ao_scheme_cons_free_list = cons; + cons = ao_scheme_poly_cons(cdr); + } +} + +void +ao_scheme_cons_write(ao_poly c) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + ao_poly cdr; + int first = 1; + + printf("("); + while (cons) { + if (!first) + printf(" "); + ao_scheme_poly_write(cons->car); + cdr = cons->cdr; + if (cdr == c) { + printf(" ..."); + break; + } + if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { + cons = ao_scheme_poly_cons(cdr); + first = 0; + } else { + printf(" . "); + ao_scheme_poly_write(cdr); + cons = NULL; + } + } + printf(")"); +} + +void +ao_scheme_cons_display(ao_poly c) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + ao_poly cdr; + + while (cons) { + ao_scheme_poly_display(cons->car); + cdr = cons->cdr; + if (cdr == c) { + printf("..."); + break; + } + if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) + cons = ao_scheme_poly_cons(cdr); + else { + ao_scheme_poly_display(cdr); + cons = NULL; + } + } +} + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_scheme_poly_cons(cons->cdr); + } + return len; +} diff --git a/src/scheme/ao_scheme_const.lisp b/src/scheme/ao_scheme_const.lisp new file mode 100644 index 00000000..422bdd63 --- /dev/null +++ b/src/scheme/ao_scheme_const.lisp @@ -0,0 +1,813 @@ +; +; Copyright © 2016 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; Lisp code placed in ROM + + ; return a list containing all of the arguments +(def (quote list) (lambda l l)) + +(def (quote def!) + (macro (name value) + (list + def + (list quote name) + value) + ) + ) + +(begin + (def! append + (lambda args + (def! append-list + (lambda (a b) + (cond ((null? a) b) + (else (cons (car a) (append-list (cdr a) b))) + ) + ) + ) + + (def! append-lists + (lambda (lists) + (cond ((null? lists) lists) + ((null? (cdr lists)) (car lists)) + (else (append-list (car lists) (append-lists (cdr lists)))) + ) + ) + ) + (append-lists args) + ) + ) + 'append) + +(append '(a b c) '(d e f) '(g h i)) + + ; boolean operators + +(begin + (def! or + (macro l + (def! _or + (lambda (l) + (cond ((null? l) #f) + ((null? (cdr l)) + (car l)) + (else + (list + cond + (list + (car l)) + (list + 'else + (_or (cdr l)) + ) + ) + ) + ) + ) + ) + (_or l))) + 'or) + + ; execute to resolve macros + +(or #f #t) + +(begin + (def! and + (macro l + (def! _and + (lambda (l) + (cond ((null? l) #t) + ((null? (cdr l)) + (car l)) + (else + (list + cond + (list + (car l) + (_and (cdr l)) + ) + ) + ) + ) + ) + ) + (_and l) + ) + ) + 'and) + + ; execute to resolve macros + +(and #t #f) + +(begin + (def! quasiquote + (macro (x) + (def! constant? + ; A constant value is either a pair starting with quote, + ; or anything which is neither a pair nor a symbol + + (lambda (exp) + (cond ((pair? exp) + (eq? (car exp) 'quote) + ) + (else + (not (symbol? exp)) + ) + ) + ) + ) + (def! combine-skeletons + (lambda (left right exp) + (cond + ((and (constant? left) (constant? right)) + (cond ((and (eqv? (eval left) (car exp)) + (eqv? (eval right) (cdr exp))) + (list 'quote exp) + ) + (else + (list 'quote (cons (eval left) (eval right))) + ) + ) + ) + ((null? right) + (list 'list left) + ) + ((and (pair? right) (eq? (car right) 'list)) + (cons 'list (cons left (cdr right))) + ) + (else + (list 'cons left right) + ) + ) + ) + ) + + (def! expand-quasiquote + (lambda (exp nesting) + (cond + + ; non cons -- constants + ; themselves, others are + ; quoted + + ((not (pair? exp)) + (cond ((constant? exp) + exp + ) + (else + (list 'quote exp) + ) + ) + ) + + ; check for an unquote exp and + ; add the param unquoted + + ((and (eq? (car exp) 'unquote) (= (length exp) 2)) + (cond ((= nesting 0) + (car (cdr exp)) + ) + (else + (combine-skeletons ''unquote + (expand-quasiquote (cdr exp) (- nesting 1)) + exp)) + ) + ) + + ; nested quasi-quote -- + ; construct the right + ; expression + + ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) + (combine-skeletons ''quasiquote + (expand-quasiquote (cdr exp) (+ nesting 1)) + exp)) + + ; check for an + ; unquote-splicing member, + ; compute the expansion of the + ; value and append the rest of + ; the quasiquote result to it + + ((and (pair? (car exp)) + (eq? (car (car exp)) 'unquote-splicing) + (= (length (car exp)) 2)) + (cond ((= nesting 0) + (list 'append (car (cdr (car exp))) + (expand-quasiquote (cdr exp) nesting)) + ) + (else + (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) + (expand-quasiquote (cdr exp) nesting) + exp)) + ) + ) + + ; for other lists, just glue + ; the expansion of the first + ; element to the expansion of + ; the rest of the list + + (else (combine-skeletons (expand-quasiquote (car exp) nesting) + (expand-quasiquote (cdr exp) nesting) + exp) + ) + ) + ) + ) + (def! result (expand-quasiquote x 0)) + result + ) + ) + 'quasiquote) + + ; + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated. + ; + ; Also accepts the alternate + ; form for defining lambdas of + ; (define (name x y z) sexprs ...) + ; + +(begin + (def! define + (macro (first . rest) + ; check for alternate lambda definition form + + (cond ((list? first) + (set! rest + (append + (list + 'lambda + (cdr first)) + rest)) + (set! first (car first)) + ) + (else + (set! rest (car rest)) + ) + ) + (def! result `(,begin + (,def (,quote ,first) ,rest) + (,quote ,first)) + ) + result + ) + ) + 'define + ) + + ; basic list accessors + +(define (caar l) (car (car l))) + +(define (cadr l) (car (cdr l))) + +(define (cdar l) (cdr (car l))) + +(define (caddr l) (car (cdr (cdr l)))) + + ; (if ) + ; (if 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + + ; simple math operators + +(define zero? (macro (value) `(eq? ,value 0))) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value) `(> ,value 0))) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value) `(< ,value 0))) + +(negative? 12) +(negative? -12) + +(define (abs x) (if (>= x 0) x (- x))) + +(abs 12) +(abs -12) + +(define max (lambda (first . rest) + (while (not (null? rest)) + (cond ((< first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(max 1 2 3) +(max 3 2 1) + +(define min (lambda (first . rest) + (while (not (null? rest)) + (cond ((> first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(min 1 2 3) +(min 3 2 1) + +(define (even? x) (zero? (% x 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(define (odd? x) (not (even? x))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + + +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x (- k 1))) + ) + ) + +(define (list-ref x k) + (car (list-tail x k)) + ) + + ; define a set of local + ; variables all at once and + ; then evaluate a list of + ; sexprs + ; + ; (let (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let ((x 1) (y)) (set! y (+ x 1)) y) + +(define let + (macro (vars . exprs) + (define (make-names vars) + (cond ((not (null? vars)) + (cons (car (car vars)) + (make-names (cdr vars)))) + (else ()) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (make-vals vars) + (cond ((not (null? vars)) + (cons (cond ((null? (cdr (car vars))) ()) + (else + (car (cdr (car vars)))) + ) + (make-vals (cdr vars)))) + (else ()) + ) + ) + ; prepend the set operations + ; to the expressions + + ; build the lambda. + + `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) + ) + ) + + +(let ((x 1) (y)) (set! y 2) (+ x y)) + + ; define a set of local + ; variables one at a time and + ; then evaluate a list of + ; sexprs + ; + ; (let* (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let* ((x 1) (y)) (set! y (+ x 1)) y) + +(define let* + (macro (vars . exprs) + + ; + ; make the list of names in the let + ; + + (define (make-names vars) + (cond ((not (null? vars)) + (cons (car (car vars)) + (make-names (cdr vars)))) + (else ()) + ) + ) + + ; the set of expressions is + ; the list of set expressions + ; pre-pended to the + ; expressions to evaluate + + (define (make-exprs vars exprs) + (cond ((null? vars) exprs) + (else + (cons + (list set + (list quote + (car (car vars)) + ) + (cond ((null? (cdr (car vars))) ()) + (else (cadr (car vars)))) + ) + (make-exprs (cdr vars) exprs) + ) + ) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (make-nils vars) + (cond ((null? vars) ()) + (else (cons () (make-nils (cdr vars)))) + ) + ) + ; build the lambda. + + `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) + ) + ) + +(let* ((x 1) (y x)) (+ x y)) + +(define when (macro (test . l) `(cond (,test ,@l)))) + +(when #t (write 'when)) + +(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) + +(unless #f (write 'unless)) + +(define (reverse list) + (let ((result ())) + (while (not (null? list)) + (set! result (cons (car list) result)) + (set! list (cdr list)) + ) + result) + ) + +(reverse '(1 2 3)) + +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x) (- k 1)))) + +(list-tail '(1 2 3) 2) + +(define (list-ref x k) (car (list-tail x k))) + +(list-ref '(1 2 3) 2) + + ; recursive equality + +(define (equal? a b) + (cond ((eq? a b) #t) + ((and (pair? a) (pair? b)) + (and (equal? (car a) (car b)) + (equal? (cdr a) (cdr b))) + ) + (else #f) + ) + ) + +(equal? '(a b c) '(a b c)) +(equal? '(a b c) '(a b b)) + +(define member (lambda (obj list . test?) + (cond ((null? list) + #f + ) + (else + (if (null? test?) (set! test? equal?) (set! test? (car test?))) + (if (test? obj (car list)) + list + (member obj (cdr list) test?)) + ) + ) + ) + ) + +(member '(2) '((1) (2) (3))) + +(member '(4) '((1) (2) (3))) + +(define (memq obj list) (member obj list eq?)) + +(memq 2 '(1 2 3)) + +(memq 4 '(1 2 3)) + +(memq '(2) '((1) (2) (3))) + +(define (memv obj list) (member obj list eqv?)) + +(memv 2 '(1 2 3)) + +(memv 4 '(1 2 3)) + +(memv '(2) '((1) (2) (3))) + +(define (_assoc obj list test?) + (if (null? list) + #f + (if (test? obj (caar list)) + (car list) + (_assoc obj (cdr list) test?) + ) + ) + ) + +(define (assq obj list) (_assoc obj list eq?)) +(define (assv obj list) (_assoc obj list eqv?)) +(define (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") + +(define (char-upper-case? c) (<= #\A c #\Z)) + +(char-upper-case? #\a) +(char-upper-case? #\B) +(char-upper-case? #\0) +(char-upper-case? #\space) + +(define (char-lower-case? c) (<= #\a c #\a)) + +(char-lower-case? #\a) +(char-lower-case? #\B) +(char-lower-case? #\0) +(char-lower-case? #\space) + +(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) + +(char-alphabetic? #\a) +(char-alphabetic? #\B) +(char-alphabetic? #\0) +(char-alphabetic? #\space) + +(define (char-numeric? c) (<= #\0 c #\9)) + +(char-numeric? #\a) +(char-numeric? #\B) +(char-numeric? #\0) +(char-numeric? #\space) + +(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) + +(char-whitespace? #\a) +(char-whitespace? #\B) +(char-whitespace? #\0) +(char-whitespace? #\space) + +(define (char->integer c) c) +(define (integer->char c) char-integer) + +(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) + +(char-upcase #\a) +(char-upcase #\B) +(char-upcase #\0) +(char-upcase #\space) + +(define (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 (lambda chars (list->string chars))) + +(display "apply\n") +(apply cons '(a b)) + +(define map + (lambda (proc . lists) + (define (args lists) + (cond ((null? lists) ()) + (else + (cons (caar lists) (args (cdr lists))) + ) + ) + ) + (define (next lists) + (cond ((null? lists) ()) + (else + (cons (cdr (car lists)) (next (cdr lists))) + ) + ) + ) + (define (domap lists) + (cond ((null? (car lists)) ()) + (else + (cons (apply proc (args lists)) (domap (next lists))) + ) + ) + ) + (domap lists) + ) + ) + +(map cadr '((a b) (d e) (g h))) + +(define for-each (lambda (proc . lists) + (apply map proc lists) + #t)) + +(for-each display '("hello" " " "world" "\n")) + +(define (_string-ml strings) + (if (null? strings) () + (cons (string->list (car strings)) (_string-ml (cdr strings))) + ) + ) + +(define string-map (lambda (proc . strings) + (list->string (apply map proc (_string-ml strings)))))) + +(string-map (lambda (x) (+ 1 x)) "HAL") + +(define string-for-each (lambda (proc . strings) + (apply for-each proc (_string-ml strings)))) + +(string-for-each write-char "IBM\n") + +(define (newline) (write-char #\newline)) + +(newline) + +(call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (write "test" x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t)) + + + ; `q -> (quote q) + ; `(q) -> (append (quote (q))) + ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) + ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) + + + +`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) + + +(define repeat + (macro (count . rest) + (define counter '__count__) + (cond ((pair? count) + (set! counter (car count)) + (set! count (cadr count)) + ) + ) + `(let ((,counter 0) + (__max__ ,count) + ) + (while (< ,counter __max__) + ,@rest + (set! ,counter (+ ,counter 1)) + ) + ) + ) + ) + +(repeat 2 (write 'hello)) +(repeat (x 3) (write 'goodbye x)) + +(define case + (macro (test . l) + ; construct the body of the + ; case, dealing with the + ; lambda version ( => lambda) + + (define (_unarrow l) + (cond ((null? l) l) + ((eq? (car l) '=>) `(( ,(cadr l) __key__))) + (else l)) + ) + + ; Build the case elements, which is + ; simply a list of cond clauses + + (define (_case l) + + (cond ((null? l) ()) + + ; else case + + ((eq? (caar l) 'else) + `((else ,@(_unarrow (cdr (car l)))))) + + ; regular case + + (else + (cons + `((eqv? ,(caar l) __key__) + ,@(_unarrow (cdr (car l)))) + (_case (cdr l))) + ) + ) + ) + + ; now construct the overall + ; expression, using a lambda + ; to hold the computed value + ; of the test expression + + `((lambda (__key__) + (cond ,@(_case l))) ,test) + ) + ) + +(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) + +;(define number->string (lambda (arg . opt) +; (let ((base (if (null? opt) 10 (car opt))) + ; +; + diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c new file mode 100644 index 00000000..d580a2c0 --- /dev/null +++ b/src/scheme/ao_scheme_error.c @@ -0,0 +1,139 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last) +{ + int first = 1; + printf("\t\t%s(", name); + if (ao_scheme_poly_type(poly) == AO_SCHEME_CONS) { + if (poly) { + while (poly) { + struct ao_scheme_cons *cons = ao_scheme_poly_cons(poly); + if (!first) + printf("\t\t "); + else + first = 0; + ao_scheme_poly_write(cons->car); + printf("\n"); + if (poly == last) + break; + poly = cons->cdr; + } + printf("\t\t )\n"); + } else + printf(")\n"); + } else { + ao_scheme_poly_write(poly); + printf("\n"); + } +} + +static void tabs(int indent) +{ + while (indent--) + printf("\t"); +} + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame) +{ + int f; + + tabs(indent); + printf ("%s{", name); + if (frame) { + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + if (frame->type & AO_SCHEME_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_SCHEME_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) { + tabs(indent); + printf(" "); + } + ao_scheme_poly_write(vals->vals[f].atom); + printf(" = "); + ao_scheme_poly_write(vals->vals[f].val); + printf("\n"); + } + if (frame->prev) + ao_scheme_error_frame(indent + 1, "prev: ", ao_scheme_poly_frame(frame->prev)); + frame->type &= ~AO_SCHEME_FRAME_PRINT; + } + tabs(indent); + printf(" }\n"); + } else + printf ("}\n"); +} + +void +ao_scheme_vprintf(char *format, va_list args) +{ + char c; + + while ((c = *format++) != '\0') { + if (c == '%') { + switch (c = *format++) { + case 'v': + ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int)); + break; + case 'p': + printf("%p", va_arg(args, void *)); + break; + case 'd': + printf("%d", va_arg(args, int)); + break; + case 's': + printf("%s", va_arg(args, char *)); + break; + default: + putchar(c); + break; + } + } else + putchar(c); + } +} + +void +ao_scheme_printf(char *format, ...) +{ + va_list args; + va_start(args, format); + ao_scheme_vprintf(format, args); + va_end(args); +} + +ao_poly +ao_scheme_error(int error, char *format, ...) +{ + va_list args; + + ao_scheme_exception |= error; + va_start(args, format); + ao_scheme_vprintf(format, args); + putchar('\n'); + va_end(args); + ao_scheme_printf("Value: %v\n", ao_scheme_v); + ao_scheme_printf("Frame: %v\n", ao_scheme_frame_poly(ao_scheme_frame_current)); + printf("Stack:\n"); + ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)); + ao_scheme_printf("Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global)); + return AO_SCHEME_NIL; +} diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c new file mode 100644 index 00000000..9b3cf63e --- /dev/null +++ b/src/scheme/ao_scheme_eval.c @@ -0,0 +1,578 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +struct ao_scheme_stack *ao_scheme_stack; +ao_poly ao_scheme_v; +uint8_t ao_scheme_skip_cons_free; + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *c) +{ + ao_scheme_stack->state = eval_cond; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(c); + return AO_SCHEME_NIL; +} + +static int +func_type(ao_poly func) +{ + if (func == AO_SCHEME_NIL) + return ao_scheme_error(AO_SCHEME_INVALID, "func is nil"); + switch (ao_scheme_poly_type(func)) { + case AO_SCHEME_BUILTIN: + return ao_scheme_poly_builtin(func)->args & AO_SCHEME_FUNC_MASK; + case AO_SCHEME_LAMBDA: + return ao_scheme_poly_lambda(func)->args; + case AO_SCHEME_STACK: + return AO_SCHEME_FUNC_LAMBDA; + default: + ao_scheme_error(AO_SCHEME_INVALID, "not a func"); + return -1; + } +} + +/* + * Flattened eval to avoid stack issues + */ + +/* + * Evaluate an s-expression + * + * For a list, evaluate all of the elements and + * then execute the resulting function call. + * + * Each element of the list is evaluated in + * a clean stack context. + * + * The current stack state is set to 'formal' so that + * when the evaluation is complete, the value + * will get appended to the values list. + * + * For other types, compute the value directly. + */ + +static int +ao_scheme_eval_sexpr(void) +{ + DBGI("sexpr: %v\n", ao_scheme_v); + switch (ao_scheme_poly_type(ao_scheme_v)) { + case AO_SCHEME_CONS: + if (ao_scheme_v == AO_SCHEME_NIL) { + if (!ao_scheme_stack->values) { + /* + * empty list evaluates to empty list + */ + ao_scheme_v = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_val; + } else { + /* + * done with arguments, go execute it + */ + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; + ao_scheme_stack->state = eval_exec; + } + } else { + if (!ao_scheme_stack->values) + ao_scheme_stack->list = ao_scheme_v; + /* + * Evaluate another argument and then switch + * to 'formal' to add the value to the values + * list + */ + ao_scheme_stack->sexprs = ao_scheme_v; + ao_scheme_stack->state = eval_formal; + if (!ao_scheme_stack_push()) + return 0; + /* + * push will reset the state to 'sexpr', which + * will evaluate the expression + */ + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; + } + break; + case AO_SCHEME_ATOM: + DBGI("..frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + ao_scheme_v = ao_scheme_atom_get(ao_scheme_v); + /* fall through */ + case AO_SCHEME_BOOL: + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + case AO_SCHEME_FLOAT: + case AO_SCHEME_STRING: + case AO_SCHEME_BUILTIN: + case AO_SCHEME_LAMBDA: + ao_scheme_stack->state = eval_val; + break; + } + DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG("\n"); + return 1; +} + +/* + * A value has been computed. + * + * If the value was computed from a macro, + * then we want to reset the current context + * to evaluate the macro result again. + * + * If not a macro, then pop the stack. + * If the stack is empty, we're done. + * Otherwise, the stack will contain + * the next state. + */ + +static int +ao_scheme_eval_val(void) +{ + DBGI("val: "); DBG_POLY(ao_scheme_v); DBG("\n"); + /* + * Value computed, pop the stack + * to figure out what to do with the value + */ + ao_scheme_stack_pop(); + DBGI("..state %d\n", ao_scheme_stack ? ao_scheme_stack->state : -1); + return 1; +} + +/* + * A formal has been computed. + * + * If this is the first formal, then check to see if we've got a + * lamda, macro or nlambda. + * + * For lambda, go compute another formal. This will terminate + * when the sexpr state sees nil. + * + * For macro/nlambda, we're done, so move the sexprs into the values + * and go execute it. + * + * Macros have an additional step of saving a stack frame holding the + * macro value execution context, which then gets the result of the + * macro to run + */ + +static int +ao_scheme_eval_formal(void) +{ + ao_poly formal; + struct ao_scheme_stack *prev; + + DBGI("formal: "); DBG_POLY(ao_scheme_v); DBG("\n"); + + /* Check what kind of function we've got */ + if (!ao_scheme_stack->values) { + switch (func_type(ao_scheme_v)) { + case AO_SCHEME_FUNC_LAMBDA: + DBGI(".. lambda\n"); + break; + case AO_SCHEME_FUNC_MACRO: + /* Evaluate the result once more */ + ao_scheme_stack->state = eval_macro; + if (!ao_scheme_stack_push()) + return 0; + + /* After the function returns, take that + * value and re-evaluate it + */ + prev = ao_scheme_poly_stack(ao_scheme_stack->prev); + ao_scheme_stack->sexprs = prev->sexprs; + + DBGI(".. start macro\n"); + DBGI("\t.. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI("\t.. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); + DBG_FRAMES(); + + /* fall through ... */ + case AO_SCHEME_FUNC_NLAMBDA: + DBGI(".. nlambda or macro\n"); + + /* use the raw sexprs as values */ + ao_scheme_stack->values = ao_scheme_stack->sexprs; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_exec; + + /* ready to execute now */ + return 1; + case -1: + return 0; + } + } + + /* Append formal to list of values */ + formal = ao_scheme__cons(ao_scheme_v, AO_SCHEME_NIL); + if (!formal) + return 0; + + if (ao_scheme_stack->values_tail) + ao_scheme_poly_cons(ao_scheme_stack->values_tail)->cdr = formal; + else + ao_scheme_stack->values = formal; + ao_scheme_stack->values_tail = formal; + + DBGI(".. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); + + /* + * Step to the next argument, if this is last, then + * 'sexpr' will end up switching to 'exec' + */ + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + + ao_scheme_stack->state = eval_sexpr; + + DBGI(".. "); DBG_POLY(ao_scheme_v); DBG("\n"); + return 1; +} + +/* + * Start executing a function call + * + * Most builtins are easy, just call the function. + * 'cond' is magic; it sticks the list of clauses + * in 'sexprs' and switches to 'cond' state. That + * bit of magic is done in ao_scheme_set_cond. + * + * Lambdas build a new frame to hold the locals and + * then re-use the current stack context to evaluate + * the s-expression from the lambda. + */ + +static int +ao_scheme_eval_exec(void) +{ + ao_poly v; + struct ao_scheme_builtin *builtin; + + DBGI("exec: "); DBG_POLY(ao_scheme_v); DBG(" values "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); + ao_scheme_stack->sexprs = AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_v)) { + case AO_SCHEME_BUILTIN: + ao_scheme_stack->state = eval_val; + builtin = ao_scheme_poly_builtin(ao_scheme_v); + v = ao_scheme_func(builtin) ( + ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr)); + DBG_DO(if (!ao_scheme_exception && ao_scheme_poly_builtin(ao_scheme_v)->func == builtin_set) { + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + ao_poly atom = ao_scheme_arg(cons, 1); + ao_poly val = ao_scheme_arg(cons, 2); + DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); + }); + builtin = ao_scheme_poly_builtin(ao_scheme_v); + if (builtin && (builtin->args & AO_SCHEME_FUNC_FREE_ARGS) && !ao_scheme_stack_marked(ao_scheme_stack) && !ao_scheme_skip_cons_free) { + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_cons_free(cons); + } + + ao_scheme_v = v; + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG ("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + break; + case AO_SCHEME_LAMBDA: + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + ao_scheme_stack->state = eval_begin; + v = ao_scheme_lambda_eval(); + ao_scheme_stack->sexprs = v; + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + DBGI(".. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + break; + case AO_SCHEME_STACK: + DBGI(".. stack "); DBG_POLY(ao_scheme_v); DBG("\n"); + ao_scheme_v = ao_scheme_stack_eval(); + DBGI(".. value "); DBG_POLY(ao_scheme_v); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + break; + } + ao_scheme_skip_cons_free = 0; + return 1; +} + +/* + * Finish setting up the apply evaluation + * + * The value is the list to execute + */ +static int +ao_scheme_eval_apply(void) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_v); + struct ao_scheme_cons *cdr, *prev; + + /* Glue the arguments into the right shape. That's all but the last + * concatenated onto the last + */ + cdr = cons; + for (;;) { + prev = cdr; + cdr = ao_scheme_poly_cons(prev->cdr); + if (cdr->cdr == AO_SCHEME_NIL) + break; + } + DBGI("before mangling: "); DBG_POLY(ao_scheme_v); DBG("\n"); + prev->cdr = cdr->car; + ao_scheme_stack->values = ao_scheme_v; + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; + DBGI("apply: "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); + ao_scheme_stack->state = eval_exec; + ao_scheme_skip_cons_free = 1; + return 1; +} + +/* + * Start evaluating the next cond clause + * + * If the list of clauses is empty, then + * the result of the cond is nil. + * + * Otherwise, set the current stack state to 'cond_test' and create a + * new stack context to evaluate the test s-expression. Once that's + * complete, we'll land in 'cond_test' to finish the clause. + */ +static int +ao_scheme_eval_cond(void) +{ + DBGI("cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + if (!ao_scheme_stack->sexprs) { + ao_scheme_v = _ao_scheme_bool_false; + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; + if (!ao_scheme_v || ao_scheme_poly_type(ao_scheme_v) != AO_SCHEME_CONS) { + ao_scheme_error(AO_SCHEME_INVALID, "invalid cond clause"); + return 0; + } + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; + if (ao_scheme_v == _ao_scheme_atom_else) + ao_scheme_v = _ao_scheme_bool_true; + ao_scheme_stack->state = eval_cond_test; + if (!ao_scheme_stack_push()) + return 0; + } + return 1; +} + +/* + * Finish a cond clause. + * + * Check the value from the test expression, if + * non-nil, then set up to evaluate the value expression. + * + * Otherwise, step to the next clause and go back to the 'cond' + * state + */ +static int +ao_scheme_eval_cond_test(void) +{ + DBGI("cond_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + if (ao_scheme_v != _ao_scheme_bool_false) { + struct ao_scheme_cons *car = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car); + ao_poly c = car->cdr; + + if (c) { + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = c; + } else + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + DBGI("next cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + ao_scheme_stack->state = eval_cond; + } + return 1; +} + +/* + * Evaluate a list of sexprs, returning the value from the last one. + * + * ao_scheme_begin records the list in stack->sexprs, so we just need to + * walk that list. Set ao_scheme_v to the car of the list and jump to + * eval_sexpr. When that's done, it will land in eval_val. For all but + * the last, leave a stack frame with eval_begin set so that we come + * back here. For the last, don't add a stack frame so that we can + * just continue on. + */ +static int +ao_scheme_eval_begin(void) +{ + DBGI("begin: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + + if (!ao_scheme_stack->sexprs) { + ao_scheme_v = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; + ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + + /* If there are more sexprs to do, then come back here, otherwise + * return the value of the last one by just landing in eval_sexpr + */ + if (ao_scheme_stack->sexprs) { + ao_scheme_stack->state = eval_begin; + if (!ao_scheme_stack_push()) + return 0; + } + ao_scheme_stack->state = eval_sexpr; + } + return 1; +} + +/* + * Conditionally execute a list of sexprs while the first is true + */ +static int +ao_scheme_eval_while(void) +{ + DBGI("while: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + + ao_scheme_stack->values = ao_scheme_v; + if (!ao_scheme_stack->sexprs) { + ao_scheme_v = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; + ao_scheme_stack->state = eval_while_test; + if (!ao_scheme_stack_push()) + return 0; + } + return 1; +} + +/* + * Check the while condition, terminate the loop if nil. Otherwise keep going + */ +static int +ao_scheme_eval_while_test(void) +{ + DBGI("while_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + + if (ao_scheme_v != _ao_scheme_bool_false) { + ao_scheme_stack->values = ao_scheme_v; + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + ao_scheme_stack->state = eval_while; + if (!ao_scheme_stack_push()) + return 0; + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = ao_scheme_v; + } + else + { + ao_scheme_stack->state = eval_val; + ao_scheme_v = ao_scheme_stack->values; + } + return 1; +} + +/* + * Replace the original sexpr with the macro expansion, then + * execute that + */ +static int +ao_scheme_eval_macro(void) +{ + DBGI("macro: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + + if (ao_scheme_v == AO_SCHEME_NIL) + ao_scheme_abort(); + if (ao_scheme_poly_type(ao_scheme_v) == AO_SCHEME_CONS) { + *ao_scheme_poly_cons(ao_scheme_stack->sexprs) = *ao_scheme_poly_cons(ao_scheme_v); + ao_scheme_v = ao_scheme_stack->sexprs; + DBGI("sexprs rewritten to: "); DBG_POLY(ao_scheme_v); DBG("\n"); + } + ao_scheme_stack->sexprs = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_sexpr; + return 1; +} + +static int (*const evals[])(void) = { + [eval_sexpr] = ao_scheme_eval_sexpr, + [eval_val] = ao_scheme_eval_val, + [eval_formal] = ao_scheme_eval_formal, + [eval_exec] = ao_scheme_eval_exec, + [eval_apply] = ao_scheme_eval_apply, + [eval_cond] = ao_scheme_eval_cond, + [eval_cond_test] = ao_scheme_eval_cond_test, + [eval_begin] = ao_scheme_eval_begin, + [eval_while] = ao_scheme_eval_while, + [eval_while_test] = ao_scheme_eval_while_test, + [eval_macro] = ao_scheme_eval_macro, +}; + +const char * const ao_scheme_state_names[] = { + [eval_sexpr] = "sexpr", + [eval_val] = "val", + [eval_formal] = "formal", + [eval_exec] = "exec", + [eval_apply] = "apply", + [eval_cond] = "cond", + [eval_cond_test] = "cond_test", + [eval_begin] = "begin", + [eval_while] = "while", + [eval_while_test] = "while_test", + [eval_macro] = "macro", +}; + +/* + * Called at restore time to reset all execution state + */ + +void +ao_scheme_eval_clear_globals(void) +{ + ao_scheme_stack = NULL; + ao_scheme_frame_current = NULL; + ao_scheme_v = AO_SCHEME_NIL; +} + +int +ao_scheme_eval_restart(void) +{ + return ao_scheme_stack_push(); +} + +ao_poly +ao_scheme_eval(ao_poly _v) +{ + ao_scheme_v = _v; + + ao_scheme_frame_init(); + + if (!ao_scheme_stack_push()) + return AO_SCHEME_NIL; + + while (ao_scheme_stack) { + if (!(*evals[ao_scheme_stack->state])() || ao_scheme_exception) { + ao_scheme_stack_clear(); + return AO_SCHEME_NIL; + } + } + DBG_DO(if (ao_scheme_frame_current) {DBGI("frame left as "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n");}); + ao_scheme_frame_current = NULL; + return ao_scheme_v; +} diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c new file mode 100644 index 00000000..541f0264 --- /dev/null +++ b/src/scheme/ao_scheme_float.c @@ -0,0 +1,148 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +static void float_mark(void *addr) +{ + (void) addr; +} + +static int float_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_scheme_float); +} + +static void float_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_float_type = { + .mark = float_mark, + .size = float_size, + .move = float_move, + .name = "float", +}; + +void +ao_scheme_float_write(ao_poly p) +{ + struct ao_scheme_float *f = ao_scheme_poly_float(p); + float v = f->value; + + if (isnanf(v)) + printf("+nan.0"); + else if (isinff(v)) { + if (v < 0) + printf("-"); + else + printf("+"); + printf("inf.0"); + } else + printf ("%g", f->value); +} + +float +ao_scheme_poly_number(ao_poly p) +{ + switch (ao_scheme_poly_base_type(p)) { + case AO_SCHEME_INT: + return ao_scheme_poly_int(p); + case AO_SCHEME_OTHER: + switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { + case AO_SCHEME_BIGINT: + return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + case AO_SCHEME_FLOAT: + return ao_scheme_poly_float(p)->value; + } + } + return NAN; +} + +ao_poly +ao_scheme_float_get(float value) +{ + struct ao_scheme_float *f; + + f = ao_scheme_alloc(sizeof (struct ao_scheme_float)); + f->type = AO_SCHEME_FLOAT; + f->value = value; + return ao_scheme_float_poly(f); +} + +ao_poly +ao_scheme_do_inexactp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == AO_SCHEME_FLOAT) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_finitep(struct ao_scheme_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + value = ao_scheme_arg(cons, 0); + switch (ao_scheme_poly_type(value)) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + return _ao_scheme_bool_true; + case AO_SCHEME_FLOAT: + f = ao_scheme_poly_float(value)->value; + if (!isnan(f) && !isinf(f)) + return _ao_scheme_bool_true; + } + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_infinitep(struct ao_scheme_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + value = ao_scheme_arg(cons, 0); + switch (ao_scheme_poly_type(value)) { + case AO_SCHEME_FLOAT: + f = ao_scheme_poly_float(value)->value; + if (isinf(f)) + return _ao_scheme_bool_true; + } + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_sqrt(struct ao_scheme_cons *cons) +{ + ao_poly value; + + if (!ao_scheme_check_argc(_ao_scheme_atom_sqrt, cons, 1, 1)) + return AO_SCHEME_NIL; + value = ao_scheme_arg(cons, 0); + if (!ao_scheme_number_typep(ao_scheme_poly_type(value))) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: non-numeric", ao_scheme_poly_atom(_ao_scheme_atom_sqrt)->name); + return ao_scheme_float_get(sqrtf(ao_scheme_poly_number(value))); +} diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c new file mode 100644 index 00000000..e5d481e7 --- /dev/null +++ b/src/scheme/ao_scheme_frame.c @@ -0,0 +1,330 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static inline int +frame_vals_num_size(int num) +{ + return sizeof (struct ao_scheme_frame_vals) + num * sizeof (struct ao_scheme_val); +} + +static int +frame_vals_size(void *addr) +{ + struct ao_scheme_frame_vals *vals = addr; + return frame_vals_num_size(vals->size); +} + +static void +frame_vals_mark(void *addr) +{ + struct ao_scheme_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_scheme_val *v = &vals->vals[f]; + + ao_scheme_poly_mark(v->val, 0); + MDBG_MOVE("frame mark atom %s %d val %d at %d ", + ao_scheme_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_scheme_ref(v->atom)), + MDBG_OFFSET(ao_scheme_ref(v->val)), f); + MDBG_DO(ao_scheme_poly_write(v->val)); + MDBG_DO(printf("\n")); + } +} + +static void +frame_vals_move(void *addr) +{ + struct ao_scheme_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_scheme_val *v = &vals->vals[f]; + + ao_scheme_poly_move(&v->atom, 0); + ao_scheme_poly_move(&v->val, 0); + MDBG_MOVE("frame move atom %s %d val %d at %d\n", + ao_scheme_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_scheme_ref(v->atom)), + MDBG_OFFSET(ao_scheme_ref(v->val)), f); + } +} + +const struct ao_scheme_type ao_scheme_frame_vals_type = { + .mark = frame_vals_mark, + .size = frame_vals_size, + .move = frame_vals_move, + .name = "frame_vals" +}; + +static int +frame_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_frame); +} + +static void +frame_mark(void *addr) +{ + struct ao_scheme_frame *frame = addr; + + for (;;) { + MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); + if (!AO_SCHEME_IS_POOL(frame)) + break; + ao_scheme_poly_mark(frame->vals, 0); + frame = ao_scheme_poly_frame(frame->prev); + MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); + if (!frame) + break; + if (ao_scheme_mark_memory(&ao_scheme_frame_type, frame)) + break; + } +} + +static void +frame_move(void *addr) +{ + struct ao_scheme_frame *frame = addr; + + for (;;) { + struct ao_scheme_frame *prev; + int ret; + + MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); + if (!AO_SCHEME_IS_POOL(frame)) + break; + ao_scheme_poly_move(&frame->vals, 0); + prev = ao_scheme_poly_frame(frame->prev); + if (!prev) + break; + ret = ao_scheme_move_memory(&ao_scheme_frame_type, (void **) &prev); + if (prev != ao_scheme_poly_frame(frame->prev)) { + MDBG_MOVE("frame prev moved from %d to %d\n", + MDBG_OFFSET(ao_scheme_poly_frame(frame->prev)), + MDBG_OFFSET(prev)); + frame->prev = ao_scheme_frame_poly(prev); + } + if (ret) + break; + frame = prev; + } +} + +const struct ao_scheme_type ao_scheme_frame_type = { + .mark = frame_mark, + .size = frame_size, + .move = frame_move, + .name = "frame", +}; + +void +ao_scheme_frame_write(ao_poly p) +{ + struct ao_scheme_frame *frame = ao_scheme_poly_frame(p); + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int f; + + printf ("{"); + if (frame) { + if (frame->type & AO_SCHEME_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_SCHEME_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) + printf(", "); + ao_scheme_poly_write(vals->vals[f].atom); + printf(" = "); + ao_scheme_poly_write(vals->vals[f].val); + } + if (frame->prev) + ao_scheme_poly_write(frame->prev); + frame->type &= ~AO_SCHEME_FRAME_PRINT; + } + } + printf("}"); +} + +static int +ao_scheme_frame_find(struct ao_scheme_frame *frame, int top, ao_poly atom) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = 0; + int r = top - 1; + + while (l <= r) { + int m = (l + r) >> 1; + if (vals->vals[m].atom < atom) + l = m + 1; + else + r = m - 1; + } + return l; +} + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = ao_scheme_frame_find(frame, frame->num, atom); + + if (l >= frame->num) + return NULL; + + if (vals->vals[l].atom != atom) + return NULL; + return &vals->vals[l].val; +} + +struct ao_scheme_frame *ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +static struct ao_scheme_frame_vals * +ao_scheme_frame_vals_new(int num) +{ + struct ao_scheme_frame_vals *vals; + + vals = ao_scheme_alloc(frame_vals_num_size(num)); + if (!vals) + return NULL; + vals->type = AO_SCHEME_FRAME_VALS; + vals->size = num; + memset(vals->vals, '\0', num * sizeof (struct ao_scheme_val)); + return vals; +} + +struct ao_scheme_frame * +ao_scheme_frame_new(int num) +{ + struct ao_scheme_frame *frame; + struct ao_scheme_frame_vals *vals; + + if (num < AO_SCHEME_FRAME_FREE && (frame = ao_scheme_frame_free_list[num])) { + ao_scheme_frame_free_list[num] = ao_scheme_poly_frame(frame->prev); + vals = ao_scheme_poly_frame_vals(frame->vals); + } else { + frame = ao_scheme_alloc(sizeof (struct ao_scheme_frame)); + if (!frame) + return NULL; + frame->type = AO_SCHEME_FRAME; + frame->num = 0; + frame->prev = AO_SCHEME_NIL; + frame->vals = AO_SCHEME_NIL; + ao_scheme_frame_stash(0, frame); + vals = ao_scheme_frame_vals_new(num); + frame = ao_scheme_frame_fetch(0); + if (!vals) + return NULL; + frame->vals = ao_scheme_frame_vals_poly(vals); + frame->num = num; + } + frame->prev = AO_SCHEME_NIL; + return frame; +} + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame) +{ + if (!frame) + return AO_SCHEME_NIL; + frame->type |= AO_SCHEME_FRAME_MARK; + return ao_scheme_frame_poly(frame); +} + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame) +{ + if (frame && !ao_scheme_frame_marked(frame)) { + int num = frame->num; + if (num < AO_SCHEME_FRAME_FREE) { + struct ao_scheme_frame_vals *vals; + + vals = ao_scheme_poly_frame_vals(frame->vals); + memset(vals->vals, '\0', vals->size * sizeof (struct ao_scheme_val)); + frame->prev = ao_scheme_frame_poly(ao_scheme_frame_free_list[num]); + ao_scheme_frame_free_list[num] = frame; + } + } +} + +static struct ao_scheme_frame * +ao_scheme_frame_realloc(struct ao_scheme_frame *frame, int new_num) +{ + struct ao_scheme_frame_vals *vals; + struct ao_scheme_frame_vals *new_vals; + int copy; + + if (new_num == frame->num) + return frame; + ao_scheme_frame_stash(0, frame); + new_vals = ao_scheme_frame_vals_new(new_num); + frame = ao_scheme_frame_fetch(0); + if (!new_vals) + return NULL; + vals = ao_scheme_poly_frame_vals(frame->vals); + copy = new_num; + if (copy > frame->num) + copy = frame->num; + memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_scheme_val)); + frame->vals = ao_scheme_frame_vals_poly(new_vals); + frame->num = new_num; + return frame; +} + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = ao_scheme_frame_find(frame, num, atom); + + memmove(&vals->vals[l+1], + &vals->vals[l], + (num - l) * sizeof (struct ao_scheme_val)); + vals->vals[l].atom = atom; + vals->vals[l].val = val; +} + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val) +{ + ao_poly *ref = frame ? ao_scheme_frame_ref(frame, atom) : NULL; + + if (!ref) { + int f = frame->num; + ao_scheme_poly_stash(0, atom); + ao_scheme_poly_stash(1, val); + frame = ao_scheme_frame_realloc(frame, f + 1); + val = ao_scheme_poly_fetch(1); + atom = ao_scheme_poly_fetch(0); + if (!frame) + return AO_SCHEME_NIL; + ao_scheme_frame_bind(frame, frame->num - 1, atom, val); + } else + *ref = val; + return val; +} + +struct ao_scheme_frame *ao_scheme_frame_global; +struct ao_scheme_frame *ao_scheme_frame_current; + +void +ao_scheme_frame_init(void) +{ + if (!ao_scheme_frame_global) + ao_scheme_frame_global = ao_scheme_frame_new(0); +} diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c new file mode 100644 index 00000000..350a5d35 --- /dev/null +++ b/src/scheme/ao_scheme_int.c @@ -0,0 +1,79 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +void +ao_scheme_int_write(ao_poly p) +{ + int i = ao_scheme_poly_int(p); + printf("%d", i); +} + +int32_t +ao_scheme_poly_integer(ao_poly p) +{ + switch (ao_scheme_poly_base_type(p)) { + case AO_SCHEME_INT: + return ao_scheme_poly_int(p); + case AO_SCHEME_OTHER: + if (ao_scheme_other_type(ao_scheme_poly_other(p)) == AO_SCHEME_BIGINT) + return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + } + return AO_SCHEME_NOT_INTEGER; +} + +ao_poly +ao_scheme_integer_poly(int32_t p) +{ + struct ao_scheme_bigint *bi; + + if (AO_SCHEME_MIN_INT <= p && p <= AO_SCHEME_MAX_INT) + return ao_scheme_int_poly(p); + bi = ao_scheme_alloc(sizeof (struct ao_scheme_bigint)); + bi->value = ao_scheme_int_bigint(p); + return ao_scheme_bigint_poly(bi); +} + +static void bigint_mark(void *addr) +{ + (void) addr; +} + +static int bigint_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_scheme_bigint); +} + +static void bigint_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_bigint_type = { + .mark = bigint_mark, + .size = bigint_size, + .move = bigint_move, + .name = "bigint", +}; + +void +ao_scheme_bigint_write(ao_poly p) +{ + struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); + + printf("%d", ao_scheme_bigint_int(bi->value)); +} diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c new file mode 100644 index 00000000..ec6f858c --- /dev/null +++ b/src/scheme/ao_scheme_lambda.c @@ -0,0 +1,208 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_scheme.h" + +int +lambda_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_lambda); +} + +void +lambda_mark(void *addr) +{ + struct ao_scheme_lambda *lambda = addr; + + ao_scheme_poly_mark(lambda->code, 0); + ao_scheme_poly_mark(lambda->frame, 0); +} + +void +lambda_move(void *addr) +{ + struct ao_scheme_lambda *lambda = addr; + + ao_scheme_poly_move(&lambda->code, 0); + ao_scheme_poly_move(&lambda->frame, 0); +} + +const struct ao_scheme_type ao_scheme_lambda_type = { + .size = lambda_size, + .mark = lambda_mark, + .move = lambda_move, + .name = "lambda", +}; + +void +ao_scheme_lambda_write(ao_poly poly) +{ + struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(poly); + struct ao_scheme_cons *cons = ao_scheme_poly_cons(lambda->code); + + printf("("); + printf("%s", ao_scheme_args_name(lambda->args)); + while (cons) { + printf(" "); + ao_scheme_poly_write(cons->car); + cons = ao_scheme_poly_cons(cons->cdr); + } + printf(")"); +} + +ao_poly +ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args) +{ + struct ao_scheme_lambda *lambda; + ao_poly formal; + struct ao_scheme_cons *cons; + + formal = ao_scheme_arg(code, 0); + while (formal != AO_SCHEME_NIL) { + switch (ao_scheme_poly_type(formal)) { + case AO_SCHEME_CONS: + cons = ao_scheme_poly_cons(formal); + if (ao_scheme_poly_type(cons->car) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", cons->car); + formal = cons->cdr; + break; + case AO_SCHEME_ATOM: + formal = AO_SCHEME_NIL; + break; + default: + return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", formal); + } + } + + ao_scheme_cons_stash(0, code); + lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); + code = ao_scheme_cons_fetch(0); + if (!lambda) + return AO_SCHEME_NIL; + + lambda->type = AO_SCHEME_LAMBDA; + lambda->args = args; + lambda->code = ao_scheme_cons_poly(code); + lambda->frame = ao_scheme_frame_mark(ao_scheme_frame_current); + DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); + DBG_STACK(); + return ao_scheme_lambda_poly(lambda); +} + +ao_poly +ao_scheme_do_lambda(struct ao_scheme_cons *cons) +{ + return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_LAMBDA); +} + +ao_poly +ao_scheme_do_nlambda(struct ao_scheme_cons *cons) +{ + return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_NLAMBDA); +} + +ao_poly +ao_scheme_do_macro(struct ao_scheme_cons *cons) +{ + return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_MACRO); +} + +ao_poly +ao_scheme_lambda_eval(void) +{ + struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(ao_scheme_v); + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + struct ao_scheme_cons *code = ao_scheme_poly_cons(lambda->code); + ao_poly formals; + struct ao_scheme_frame *next_frame; + int args_wanted; + ao_poly varargs = AO_SCHEME_NIL; + int args_provided; + int f; + struct ao_scheme_cons *vals; + + DBGI("lambda "); DBG_POLY(ao_scheme_lambda_poly(lambda)); DBG("\n"); + + args_wanted = 0; + for (formals = ao_scheme_arg(code, 0); + ao_scheme_is_pair(formals); + formals = ao_scheme_poly_cons(formals)->cdr) + ++args_wanted; + if (formals != AO_SCHEME_NIL) { + if (ao_scheme_poly_type(formals) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "bad lambda form"); + varargs = formals; + } + + /* Create a frame to hold the variables + */ + args_provided = ao_scheme_cons_length(cons) - 1; + if (varargs == AO_SCHEME_NIL) { + if (args_wanted != args_provided) + return ao_scheme_error(AO_SCHEME_INVALID, "need %d args, got %d", args_wanted, args_provided); + } else { + if (args_provided < args_wanted) + return ao_scheme_error(AO_SCHEME_INVALID, "need at least %d args, got %d", args_wanted, args_provided); + } + + ao_scheme_poly_stash(1, varargs); + next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); + varargs = ao_scheme_poly_fetch(1); + if (!next_frame) + return AO_SCHEME_NIL; + + /* Re-fetch all of the values in case something moved */ + lambda = ao_scheme_poly_lambda(ao_scheme_v); + cons = ao_scheme_poly_cons(ao_scheme_stack->values); + code = ao_scheme_poly_cons(lambda->code); + formals = ao_scheme_arg(code, 0); + vals = ao_scheme_poly_cons(cons->cdr); + + next_frame->prev = lambda->frame; + ao_scheme_frame_current = next_frame; + ao_scheme_stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); + + for (f = 0; f < args_wanted; f++) { + struct ao_scheme_cons *arg = ao_scheme_poly_cons(formals); + DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + ao_scheme_frame_bind(next_frame, f, arg->car, vals->car); + formals = arg->cdr; + vals = ao_scheme_poly_cons(vals->cdr); + } + if (varargs) { + DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_scheme_cons_poly(vals)); DBG("\n"); + /* + * Bind the rest of the arguments to the final parameter + */ + ao_scheme_frame_bind(next_frame, f, varargs, ao_scheme_cons_poly(vals)); + } else { + /* + * Mark the cons cells from the actuals as freed for immediate re-use, unless + * the actuals point into the source function (nlambdas and macros), or if the + * stack containing them was copied as a part of a continuation + */ + if (lambda->args == AO_SCHEME_FUNC_LAMBDA && !ao_scheme_stack_marked(ao_scheme_stack)) { + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_cons_free(cons); + } + } + DBGI("eval frame: "); DBG_POLY(ao_scheme_frame_poly(next_frame)); DBG("\n"); + DBG_STACK(); + DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); + return code->cdr; +} diff --git a/src/scheme/ao_scheme_lex.c b/src/scheme/ao_scheme_lex.c new file mode 100644 index 00000000..266b1fc0 --- /dev/null +++ b/src/scheme/ao_scheme_lex.c @@ -0,0 +1,16 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin new file mode 100644 index 00000000..8e9c2c0b --- /dev/null +++ b/src/scheme/ao_scheme_make_builtin @@ -0,0 +1,190 @@ +#!/usr/bin/nickle + +typedef struct { + string type; + string c_name; + string[*] lisp_names; +} builtin_t; + +string[string] type_map = { + "lambda" => "LAMBDA", + "nlambda" => "NLAMBDA", + "macro" => "MACRO", + "f_lambda" => "F_LAMBDA", + "atom" => "atom", +}; + +string[*] +make_lisp(string[*] tokens) +{ + string[...] lisp = {}; + + if (dim(tokens) < 3) + return (string[1]) { tokens[dim(tokens) - 1] }; + return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; +} + +builtin_t +read_builtin(file f) { + string line = File::fgets(f); + string[*] tokens = String::wordsplit(line, " \t"); + + return (builtin_t) { + .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", + .c_name = dim(tokens) > 1 ? tokens[1] : "#", + .lisp_names = make_lisp(tokens), + }; +} + +builtin_t[*] +read_builtins(file f) { + builtin_t[...] builtins = {}; + + while (!File::end(f)) { + builtin_t b = read_builtin(f); + + if (b.type[0] != '#') + builtins[dim(builtins)] = b; + } + return builtins; +} + +bool is_atom(builtin_t b) = b.type == "atom"; + +void +dump_ids(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_ID\n"); + printf("#undef AO_SCHEME_BUILTIN_ID\n"); + printf("enum ao_scheme_builtin_id {\n"); + for (int i = 0; i < dim(builtins); i++) + if (!is_atom(builtins[i])) + printf("\tbuiltin_%s,\n", builtins[i].c_name); + printf("\t_builtin_last\n"); + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_ID */\n"); +} + +void +dump_casename(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_CASENAME\n"); + printf("#undef AO_SCHEME_BUILTIN_CASENAME\n"); + printf("static char *ao_scheme_builtin_name(enum ao_scheme_builtin_id b) {\n"); + printf("\tswitch(b) {\n"); + for (int i = 0; i < dim(builtins); i++) + if (!is_atom(builtins[i])) + printf("\tcase builtin_%s: return ao_scheme_poly_atom(_atom(\"%s\"))->name;\n", + builtins[i].c_name, builtins[i].lisp_names[0]); + printf("\tdefault: return \"???\";\n"); + printf("\t}\n"); + printf("}\n"); + printf("#endif /* AO_SCHEME_BUILTIN_CASENAME */\n"); +} + +void +cify_lisp(string l) { + for (int j = 0; j < String::length(l); j++) { + int c= l[j]; + if (Ctype::isalnum(c) || c == '_') + printf("%c", c); + else + printf("%02x", c); + } +} + +void +dump_arrayname(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_ARRAYNAME\n"); + printf("#undef AO_SCHEME_BUILTIN_ARRAYNAME\n"); + printf("static const ao_poly builtin_names[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + if (!is_atom(builtins[i])) { + printf("\t[builtin_%s] = _ao_scheme_atom_", + builtins[i].c_name); + cify_lisp(builtins[i].lisp_names[0]); + printf(",\n"); + } + } + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_ARRAYNAME */\n"); +} + +void +dump_funcs(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_FUNCS\n"); + printf("#undef AO_SCHEME_BUILTIN_FUNCS\n"); + printf("const ao_scheme_func_t ao_scheme_builtins[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + if (!is_atom(builtins[i])) + printf("\t[builtin_%s] = ao_scheme_do_%s,\n", + builtins[i].c_name, + builtins[i].c_name); + } + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_FUNCS */\n"); +} + +void +dump_decls(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_DECLS\n"); + printf("#undef AO_SCHEME_BUILTIN_DECLS\n"); + for (int i = 0; i < dim(builtins); i++) { + if (!is_atom(builtins[i])) { + printf("ao_poly\n"); + printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n", + builtins[i].c_name); + } + } + printf("#endif /* AO_SCHEME_BUILTIN_DECLS */\n"); +} + +void +dump_consts(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_CONSTS\n"); + printf("#undef AO_SCHEME_BUILTIN_CONSTS\n"); + printf("struct builtin_func funcs[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + if (!is_atom(builtins[i])) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf ("\t{ .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", + builtins[i].lisp_names[j], + builtins[i].type, + builtins[i].c_name); + } + } + } + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_CONSTS */\n"); +} + +void +dump_atoms(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_ATOMS\n"); + printf("#undef AO_SCHEME_BUILTIN_ATOMS\n"); + for (int i = 0; i < dim(builtins); i++) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf("#define _ao_scheme_atom_"); + cify_lisp(builtins[i].lisp_names[j]); + printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); + } + } + printf("#endif /* AO_SCHEME_BUILTIN_ATOMS */\n"); +} + +void main() { + if (dim(argv) < 2) { + File::fprintf(stderr, "usage: %s \n", argv[0]); + exit(1); + } + twixt(file f = File::open(argv[1], "r"); File::close(f)) { + builtin_t[*] builtins = read_builtins(f); + dump_ids(builtins); + dump_casename(builtins); + dump_arrayname(builtins); + dump_funcs(builtins); + dump_decls(builtins); + dump_consts(builtins); + dump_atoms(builtins); + } +} + +main(); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c new file mode 100644 index 00000000..cf42ec52 --- /dev/null +++ b/src/scheme/ao_scheme_make_const.c @@ -0,0 +1,395 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include +#include +#include +#include + +static struct ao_scheme_builtin * +ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { + struct ao_scheme_builtin *b = ao_scheme_alloc(sizeof (struct ao_scheme_builtin)); + + b->type = AO_SCHEME_BUILTIN; + b->func = func; + b->args = args; + return b; +} + +struct builtin_func { + char *name; + int args; + enum ao_scheme_builtin_id func; +}; + +#define AO_SCHEME_BUILTIN_CONSTS +#include "ao_scheme_builtin.h" + +#define N_FUNC (sizeof funcs / sizeof funcs[0]) + +struct ao_scheme_frame *globals; + +static int +is_atom(int offset) +{ + struct ao_scheme_atom *a; + + for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) + if (((uint8_t *) a->name - ao_scheme_const) == offset) + return strlen(a->name); + return 0; +} + +#define AO_FEC_CRC_INIT 0xffff + +static inline uint16_t +ao_fec_crc_byte(uint8_t byte, uint16_t crc) +{ + uint8_t bit; + + for (bit = 0; bit < 8; bit++) { + if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) + crc = (crc << 1) ^ 0x8005; + else + crc = (crc << 1); + byte <<= 1; + } + return crc; +} + +uint16_t +ao_fec_crc(const uint8_t *bytes, uint8_t len) +{ + uint16_t crc = AO_FEC_CRC_INIT; + + while (len--) + crc = ao_fec_crc_byte(*bytes++, crc); + return crc; +} + +struct ao_scheme_macro_stack { + struct ao_scheme_macro_stack *next; + ao_poly p; +}; + +struct ao_scheme_macro_stack *macro_stack; + +int +ao_scheme_macro_push(ao_poly p) +{ + struct ao_scheme_macro_stack *m = macro_stack; + + while (m) { + if (m->p == p) + return 1; + m = m->next; + } + m = malloc (sizeof (struct ao_scheme_macro_stack)); + m->p = p; + m->next = macro_stack; + macro_stack = m; + return 0; +} + +void +ao_scheme_macro_pop(void) +{ + struct ao_scheme_macro_stack *m = macro_stack; + + macro_stack = m->next; + free(m); +} + +#define DBG_MACRO 0 +#if DBG_MACRO +int macro_scan_depth; + +void indent(void) +{ + int i; + for (i = 0; i < macro_scan_depth; i++) + printf(" "); +} +#define MACRO_DEBUG(a) a +#else +#define MACRO_DEBUG(a) +#endif + +ao_poly +ao_has_macro(ao_poly p); + +ao_poly +ao_macro_test_get(ao_poly atom) +{ + ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + if (ref) + return *ref; + return AO_SCHEME_NIL; +} + +ao_poly +ao_is_macro(ao_poly p) +{ + struct ao_scheme_builtin *builtin; + struct ao_scheme_lambda *lambda; + ao_poly ret; + + MACRO_DEBUG(indent(); printf ("is macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); + switch (ao_scheme_poly_type(p)) { + case AO_SCHEME_ATOM: + if (ao_scheme_macro_push(p)) + ret = AO_SCHEME_NIL; + else { + if (ao_is_macro(ao_macro_test_get(p))) + ret = p; + else + ret = AO_SCHEME_NIL; + ao_scheme_macro_pop(); + } + break; + case AO_SCHEME_CONS: + ret = ao_has_macro(p); + break; + case AO_SCHEME_BUILTIN: + builtin = ao_scheme_poly_builtin(p); + if ((builtin->args & AO_SCHEME_FUNC_MASK) == AO_SCHEME_FUNC_MACRO) + ret = p; + else + ret = 0; + break; + + case AO_SCHEME_LAMBDA: + lambda = ao_scheme_poly_lambda(p); + if (lambda->args == AO_SCHEME_FUNC_MACRO) + ret = p; + else + ret = ao_has_macro(lambda->code); + break; + default: + ret = AO_SCHEME_NIL; + break; + } + MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_scheme_poly_write(ret); printf("\n")); + return ret; +} + +ao_poly +ao_has_macro(ao_poly p) +{ + struct ao_scheme_cons *cons; + struct ao_scheme_lambda *lambda; + ao_poly m; + ao_poly list; + + if (p == AO_SCHEME_NIL) + return AO_SCHEME_NIL; + + MACRO_DEBUG(indent(); printf("has macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); + switch (ao_scheme_poly_type(p)) { + case AO_SCHEME_LAMBDA: + lambda = ao_scheme_poly_lambda(p); + p = ao_has_macro(lambda->code); + break; + case AO_SCHEME_CONS: + cons = ao_scheme_poly_cons(p); + if ((p = ao_is_macro(cons->car))) + break; + + list = cons->cdr; + p = AO_SCHEME_NIL; + while (list != AO_SCHEME_NIL && ao_scheme_poly_type(list) == AO_SCHEME_CONS) { + cons = ao_scheme_poly_cons(list); + m = ao_has_macro(cons->car); + if (m) { + p = m; + break; + } + list = cons->cdr; + } + break; + + default: + p = AO_SCHEME_NIL; + break; + } + MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_scheme_poly_write(p); printf("\n")); + return p; +} + +int +ao_scheme_read_eval_abort(void) +{ + ao_poly in, out = AO_SCHEME_NIL; + for(;;) { + in = ao_scheme_read(); + if (in == _ao_scheme_atom_eof) + break; + out = ao_scheme_eval(in); + if (ao_scheme_exception) + return 0; + ao_scheme_poly_write(out); + putchar ('\n'); + } + return 1; +} + +static FILE *in; +static FILE *out; + +int +ao_scheme_getc(void) +{ + return getc(in); +} + +static const struct option options[] = { + { .name = "out", .has_arg = 1, .val = 'o' }, + { 0, 0, 0, 0 } +}; + +static void usage(char *program) +{ + fprintf(stderr, "usage: %s [--out=] [input]\n", program); + exit(1); +} + +int +main(int argc, char **argv) +{ + int f, o; + ao_poly val; + struct ao_scheme_atom *a; + struct ao_scheme_builtin *b; + int in_atom = 0; + char *out_name = NULL; + int c; + enum ao_scheme_builtin_id prev_func; + + in = stdin; + out = stdout; + + while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { + switch (c) { + case 'o': + out_name = optarg; + break; + default: + usage(argv[0]); + break; + } + } + + ao_scheme_frame_init(); + + /* Boolean values #f and #t */ + ao_scheme_bool_get(0); + ao_scheme_bool_get(1); + + prev_func = _builtin_last; + for (f = 0; f < (int) N_FUNC; f++) { + if (funcs[f].func != prev_func) + b = ao_scheme_make_builtin(funcs[f].func, funcs[f].args); + a = ao_scheme_atom_intern(funcs[f].name); + ao_scheme_atom_def(ao_scheme_atom_poly(a), + ao_scheme_builtin_poly(b)); + } + + /* end of file value */ + a = ao_scheme_atom_intern("eof"); + ao_scheme_atom_def(ao_scheme_atom_poly(a), + ao_scheme_atom_poly(a)); + + /* 'else' */ + a = ao_scheme_atom_intern("else"); + + if (argv[optind]){ + in = fopen(argv[optind], "r"); + if (!in) { + perror(argv[optind]); + exit(1); + } + } + if (!ao_scheme_read_eval_abort()) { + fprintf(stderr, "eval failed\n"); + exit(1); + } + + /* Reduce to referenced values */ + ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + + for (f = 0; f < ao_scheme_frame_global->num; f++) { + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(ao_scheme_frame_global->vals); + val = ao_has_macro(vals->vals[f].val); + if (val != AO_SCHEME_NIL) { + printf("error: function %s contains unresolved macro: ", + ao_scheme_poly_atom(vals->vals[f].atom)->name); + ao_scheme_poly_write(val); + printf("\n"); + exit(1); + } + } + + if (out_name) { + out = fopen(out_name, "w"); + if (!out) { + perror(out_name); + exit(1); + } + } + + fprintf(out, "/* Generated file, do not edit */\n\n"); + + fprintf(out, "#define AO_SCHEME_POOL_CONST %d\n", ao_scheme_top); + fprintf(out, "extern const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4)));\n"); + fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_scheme_atom_poly(ao_scheme_atoms)); + fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_scheme_frame_poly(ao_scheme_frame_global)); + fprintf(out, "#define ao_scheme_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_scheme_const, ao_scheme_top)); + + fprintf(out, "#define _ao_scheme_bool_false 0x%04x\n", ao_scheme_bool_poly(ao_scheme_false)); + fprintf(out, "#define _ao_scheme_bool_true 0x%04x\n", ao_scheme_bool_poly(ao_scheme_true)); + + for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) { + char *n = a->name, c; + fprintf(out, "#define _ao_scheme_atom_"); + while ((c = *n++)) { + if (isalnum(c)) + fprintf(out, "%c", c); + else + fprintf(out, "%02x", c); + } + fprintf(out, " 0x%04x\n", ao_scheme_atom_poly(a)); + } + fprintf(out, "#ifdef AO_SCHEME_CONST_BITS\n"); + fprintf(out, "const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute((aligned(4))) = {"); + for (o = 0; o < ao_scheme_top; o++) { + uint8_t c; + if ((o & 0xf) == 0) + fprintf(out, "\n\t"); + else + fprintf(out, " "); + c = ao_scheme_const[o]; + if (!in_atom) + in_atom = is_atom(o); + if (in_atom) { + fprintf(out, " '%c',", c); + in_atom--; + } else { + fprintf(out, "0x%02x,", c); + } + } + fprintf(out, "\n};\n"); + fprintf(out, "#endif /* AO_SCHEME_CONST_BITS */\n"); + exit(0); +} diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c new file mode 100644 index 00000000..acc726c8 --- /dev/null +++ b/src/scheme/ao_scheme_mem.c @@ -0,0 +1,968 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#define AO_SCHEME_CONST_BITS + +#include "ao_scheme.h" +#include +#include + +#ifdef AO_SCHEME_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + +#include +uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#undef AO_SCHEME_POOL +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#else + +uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); + +#endif + +#ifndef DBG_MEM_STATS +#define DBG_MEM_STATS DBG_MEM +#endif + +#if DBG_MEM +int dbg_move_depth; +int dbg_mem = DBG_MEM_START; +int dbg_validate = 0; + +struct ao_scheme_record { + struct ao_scheme_record *next; + const struct ao_scheme_type *type; + void *addr; + int size; +}; + +static struct ao_scheme_record *record_head, **record_tail; + +static void +ao_scheme_record_free(struct ao_scheme_record *record) +{ + while (record) { + struct ao_scheme_record *next = record->next; + free(record); + record = next; + } +} + +static void +ao_scheme_record_reset(void) +{ + ao_scheme_record_free(record_head); + record_head = NULL; + record_tail = &record_head; +} + +static void +ao_scheme_record(const struct ao_scheme_type *type, + void *addr, + int size) +{ + struct ao_scheme_record *r = malloc(sizeof (struct ao_scheme_record)); + + r->next = NULL; + r->type = type; + r->addr = addr; + r->size = size; + *record_tail = r; + record_tail = &r->next; +} + +static struct ao_scheme_record * +ao_scheme_record_save(void) +{ + struct ao_scheme_record *r = record_head; + + record_head = NULL; + record_tail = &record_head; + return r; +} + +static void +ao_scheme_record_compare(char *where, + struct ao_scheme_record *a, + struct ao_scheme_record *b) +{ + while (a && b) { + if (a->type != b->type || a->size != b->size) { + printf("%s record difers %d %s %d -> %d %s %d\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_scheme_abort(); + } + a = a->next; + b = b->next; + } + if (a) { + printf("%s record differs %d %s %d -> NULL\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size); + ao_scheme_abort(); + } + if (b) { + printf("%s record differs NULL -> %d %s %d\n", + where, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_scheme_abort(); + } +} + +#else +#define ao_scheme_record_reset() +#endif + +uint8_t ao_scheme_exception; + +struct ao_scheme_root { + const struct ao_scheme_type *type; + void **addr; +}; + +static struct ao_scheme_cons *save_cons[2]; +static char *save_string[2]; +static struct ao_scheme_frame *save_frame[1]; +static ao_poly save_poly[3]; + +static const struct ao_scheme_root ao_scheme_root[] = { + { + .type = &ao_scheme_cons_type, + .addr = (void **) &save_cons[0], + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &save_cons[1], + }, + { + .type = &ao_scheme_string_type, + .addr = (void **) &save_string[0], + }, + { + .type = &ao_scheme_string_type, + .addr = (void **) &save_string[1], + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &save_frame[0], + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[0] + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[1] + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[2] + }, + { + .type = &ao_scheme_atom_type, + .addr = (void **) &ao_scheme_atoms + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &ao_scheme_frame_global, + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &ao_scheme_frame_current, + }, + { + .type = &ao_scheme_stack_type, + .addr = (void **) &ao_scheme_stack, + }, + { + .type = NULL, + .addr = (void **) (void *) &ao_scheme_v, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_cons, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_cons_tail, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_stack, + }, +#ifdef AO_SCHEME_MAKE_CONST + { + .type = &ao_scheme_bool_type, + .addr = (void **) &ao_scheme_false, + }, + { + .type = &ao_scheme_bool_type, + .addr = (void **) &ao_scheme_true, + }, +#endif +}; + +#define AO_SCHEME_ROOT (sizeof (ao_scheme_root) / sizeof (ao_scheme_root[0])) + +static const void ** const ao_scheme_cache[] = { + (const void **) &ao_scheme_cons_free_list, + (const void **) &ao_scheme_stack_free_list, + (const void **) &ao_scheme_frame_free_list[0], + (const void **) &ao_scheme_frame_free_list[1], + (const void **) &ao_scheme_frame_free_list[2], + (const void **) &ao_scheme_frame_free_list[3], + (const void **) &ao_scheme_frame_free_list[4], + (const void **) &ao_scheme_frame_free_list[5], +}; + +#if AO_SCHEME_FRAME_FREE != 6 +#error Unexpected AO_SCHEME_FRAME_FREE value +#endif + +#define AO_SCHEME_CACHE (sizeof (ao_scheme_cache) / sizeof (ao_scheme_cache[0])) + +#define AO_SCHEME_BUSY_SIZE ((AO_SCHEME_POOL + 31) / 32) + +static uint8_t ao_scheme_busy[AO_SCHEME_BUSY_SIZE]; +static uint8_t ao_scheme_cons_note[AO_SCHEME_BUSY_SIZE]; +static uint8_t ao_scheme_cons_last[AO_SCHEME_BUSY_SIZE]; +static uint8_t ao_scheme_cons_noted; + +uint16_t ao_scheme_top; + +struct ao_scheme_chunk { + uint16_t old_offset; + union { + uint16_t size; + uint16_t new_offset; + }; +}; + +#define AO_SCHEME_NCHUNK 64 + +static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK]; + +/* Offset of an address within the pool. */ +static inline uint16_t pool_offset(void *addr) { +#if DBG_MEM + if (!AO_SCHEME_IS_POOL(addr)) + ao_scheme_abort(); +#endif + return ((uint8_t *) addr) - ao_scheme_pool; +} + +static inline void mark(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + tag[byte] |= (1 << bit); +} + +static inline void clear(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + tag[byte] &= ~(1 << bit); +} + +static inline int busy(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + return (tag[byte] >> bit) & 1; +} + +static inline int min(int a, int b) { return a < b ? a : b; } +static inline int max(int a, int b) { return a > b ? a : b; } + +static inline int limit(int offset) { + return min(AO_SCHEME_POOL, max(offset, 0)); +} + +static void +note_cons(uint16_t offset) +{ + MDBG_MOVE("note cons %d\n", offset); + ao_scheme_cons_noted = 1; + mark(ao_scheme_cons_note, offset); +} + +static uint16_t chunk_low, chunk_high; +static uint16_t chunk_first, chunk_last; + +static int +find_chunk(uint16_t offset) +{ + int l, r; + /* Binary search for the location */ + l = chunk_first; + r = chunk_last - 1; + while (l <= r) { + int m = (l + r) >> 1; + if (ao_scheme_chunk[m].old_offset < offset) + l = m + 1; + else + r = m - 1; + } + return l; +} + +static void +note_chunk(uint16_t offset, uint16_t size) +{ + int l; + + if (offset < chunk_low || chunk_high <= offset) + return; + + l = find_chunk(offset); + + /* + * The correct location is always in 'l', with r = l-1 being + * the entry before the right one + */ + +#if DBG_MEM + /* Off the right side */ + if (l >= AO_SCHEME_NCHUNK) + ao_scheme_abort(); + + /* Off the left side */ + if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset) + ao_scheme_abort(); +#endif + + /* Shuffle existing entries right */ + int end = min(AO_SCHEME_NCHUNK, chunk_last + 1); + + memmove(&ao_scheme_chunk[l+1], + &ao_scheme_chunk[l], + (end - (l+1)) * sizeof (struct ao_scheme_chunk)); + + /* Add new entry */ + ao_scheme_chunk[l].old_offset = offset; + ao_scheme_chunk[l].size = size; + + /* Increment the number of elements up to the size of the array */ + if (chunk_last < AO_SCHEME_NCHUNK) + chunk_last++; + + /* Set the top address if the array is full */ + if (chunk_last == AO_SCHEME_NCHUNK) + chunk_high = ao_scheme_chunk[AO_SCHEME_NCHUNK-1].old_offset + + ao_scheme_chunk[AO_SCHEME_NCHUNK-1].size; +} + +static void +reset_chunks(void) +{ + chunk_high = ao_scheme_top; + chunk_last = 0; + chunk_first = 0; +} + +/* + * Walk all referenced objects calling functions on each one + */ + +static void +walk(int (*visit_addr)(const struct ao_scheme_type *type, void **addr), + int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) +{ + int i; + + ao_scheme_record_reset(); + memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); + memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); + ao_scheme_cons_noted = 0; + for (i = 0; i < (int) AO_SCHEME_ROOT; i++) { + if (ao_scheme_root[i].type) { + void **a = ao_scheme_root[i].addr, *v; + if (a && (v = *a)) { + MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); + visit_addr(ao_scheme_root[i].type, a); + } + } else { + ao_poly *a = (ao_poly *) ao_scheme_root[i].addr, p; + if (a && (p = *a)) { + MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_scheme_ref(p))); + visit_poly(a, 0); + } + } + } + while (ao_scheme_cons_noted) { + memcpy(ao_scheme_cons_last, ao_scheme_cons_note, sizeof (ao_scheme_cons_note)); + memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); + ao_scheme_cons_noted = 0; + for (i = 0; i < AO_SCHEME_POOL; i += 4) { + if (busy(ao_scheme_cons_last, i)) { + void *v = ao_scheme_pool + i; + MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); + visit_addr(&ao_scheme_cons_type, &v); + } + } + } +} + +#if MDBG_DUMP +static void +dump_busy(void) +{ + int i; + MDBG_MOVE("busy:"); + for (i = 0; i < ao_scheme_top; i += 4) { + if ((i & 0xff) == 0) { + MDBG_MORE("\n"); + MDBG_MOVE("%s", ""); + } + else if ((i & 0x1f) == 0) + MDBG_MORE(" "); + if (busy(ao_scheme_busy, i)) + MDBG_MORE("*"); + else + MDBG_MORE("-"); + } + MDBG_MORE ("\n"); +} +#define DUMP_BUSY() dump_busy() +#else +#define DUMP_BUSY() +#endif + +static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = { + [AO_SCHEME_CONS] = &ao_scheme_cons_type, + [AO_SCHEME_INT] = NULL, + [AO_SCHEME_STRING] = &ao_scheme_string_type, + [AO_SCHEME_OTHER] = (void *) 0x1, + [AO_SCHEME_ATOM] = &ao_scheme_atom_type, + [AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type, + [AO_SCHEME_FRAME] = &ao_scheme_frame_type, + [AO_SCHEME_FRAME_VALS] = &ao_scheme_frame_vals_type, + [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, + [AO_SCHEME_STACK] = &ao_scheme_stack_type, + [AO_SCHEME_BOOL] = &ao_scheme_bool_type, + [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, + [AO_SCHEME_FLOAT] = &ao_scheme_float_type, +}; + +static int +ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref) +{ + return ao_scheme_mark(type, *ref); +} + +static int +ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) +{ + return ao_scheme_poly_mark(*p, do_note_cons); +} + +#if DBG_MEM_STATS +int ao_scheme_collects[2]; +int ao_scheme_freed[2]; +int ao_scheme_loops[2]; +#endif + +int ao_scheme_last_top; + +int +ao_scheme_collect(uint8_t style) +{ + int i; + int top; +#if DBG_MEM_STATS + int loops = 0; +#endif +#if DBG_MEM + struct ao_scheme_record *mark_record = NULL, *move_record = NULL; + + MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); +#endif + MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + + /* The first time through, we're doing a full collect */ + if (ao_scheme_last_top == 0) + style = AO_SCHEME_COLLECT_FULL; + + /* Clear references to all caches */ + for (i = 0; i < (int) AO_SCHEME_CACHE; i++) + *ao_scheme_cache[i] = NULL; + if (style == AO_SCHEME_COLLECT_FULL) { + chunk_low = top = 0; + } else { + chunk_low = top = ao_scheme_last_top; + } + for (;;) { +#if DBG_MEM_STATS + loops++; +#endif + MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); + /* Find the sizes of the first chunk of objects to move */ + reset_chunks(); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +#if DBG_MEM + + ao_scheme_record_free(mark_record); + mark_record = ao_scheme_record_save(); + if (mark_record && move_record) + ao_scheme_record_compare("mark", move_record, mark_record); +#endif + + DUMP_BUSY(); + + /* Find the first moving object */ + for (i = 0; i < chunk_last; i++) { + uint16_t size = ao_scheme_chunk[i].size; + +#if DBG_MEM + if (!size) + ao_scheme_abort(); +#endif + + if (ao_scheme_chunk[i].old_offset > top) + break; + + MDBG_MOVE("chunk %d %d not moving\n", + ao_scheme_chunk[i].old_offset, + ao_scheme_chunk[i].size); +#if DBG_MEM + if (ao_scheme_chunk[i].old_offset != top) + ao_scheme_abort(); +#endif + top += size; + } + + /* + * Limit amount of chunk array used in mapping moves + * to the active region + */ + chunk_first = i; + chunk_low = ao_scheme_chunk[i].old_offset; + + /* Copy all of the objects */ + for (; i < chunk_last; i++) { + uint16_t size = ao_scheme_chunk[i].size; + +#if DBG_MEM + if (!size) + ao_scheme_abort(); +#endif + + MDBG_MOVE("chunk %d %d -> %d\n", + ao_scheme_chunk[i].old_offset, + size, + top); + ao_scheme_chunk[i].new_offset = top; + + memmove(&ao_scheme_pool[top], + &ao_scheme_pool[ao_scheme_chunk[i].old_offset], + size); + + top += size; + } + + if (chunk_first < chunk_last) { + /* Relocate all references to the objects */ + walk(ao_scheme_move, ao_scheme_poly_move); + +#if DBG_MEM + ao_scheme_record_free(move_record); + move_record = ao_scheme_record_save(); + if (mark_record && move_record) + ao_scheme_record_compare("move", mark_record, move_record); +#endif + } + + /* If we ran into the end of the heap, then + * there's no need to keep walking + */ + if (chunk_last != AO_SCHEME_NCHUNK) + break; + + /* Next loop starts right above this loop */ + chunk_low = chunk_high; + } + +#if DBG_MEM_STATS + /* Collect stats */ + ++ao_scheme_collects[style]; + ao_scheme_freed[style] += ao_scheme_top - top; + ao_scheme_loops[style] += loops; +#endif + + ao_scheme_top = top; + if (style == AO_SCHEME_COLLECT_FULL) + ao_scheme_last_top = top; + + MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref)); + + return AO_SCHEME_POOL - ao_scheme_top; +} + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons) +{ + ao_poly cdr; + int offset; + + chunk_low = 0; + reset_chunks(); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); + while (cons) { + if (!AO_SCHEME_IS_POOL(cons)) + break; + offset = pool_offset(cons); + if (busy(ao_scheme_busy, offset)) { + ao_scheme_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_scheme_cons_poly(cons), ao_scheme_cons_poly(cons)); + abort(); + } + cdr = cons->cdr; + if (!ao_scheme_is_pair(cdr)) + break; + cons = ao_scheme_poly_cons(cdr); + } +} +#endif + +/* + * Mark interfaces for objects + */ + + +/* + * Mark a block of memory with an explicit size + */ + +int +ao_scheme_mark_block(void *addr, int size) +{ + int offset; + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + offset = pool_offset(addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; + } + mark(ao_scheme_busy, offset); + note_chunk(offset, size); + return 0; +} + +/* + * Note a reference to memory and collect information about a few + * object sizes at a time + */ + +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) +{ + int offset; + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + offset = pool_offset(addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; + } + mark(ao_scheme_busy, offset); + note_chunk(offset, ao_scheme_size(type, addr)); + return 0; +} + +/* + * Mark an object and all that it refereces + */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr) +{ + int ret; + MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE_IN(); + ret = ao_scheme_mark_memory(type, addr); + if (!ret) { + MDBG_MOVE("mark recurse\n"); + type->mark(addr); + } + MDBG_MOVE_OUT(); + return ret; +} + +/* + * Mark an object, unless it is a cons cell and + * do_note_cons is set. In that case, just + * set a bit in the cons note array; those + * will be marked in a separate pass to avoid + * deep recursion in the collector + */ +int +ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) +{ + uint8_t type; + void *addr; + + type = ao_scheme_poly_base_type(p); + + if (type == AO_SCHEME_INT) + return 1; + + addr = ao_scheme_ref(p); + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + if (type == AO_SCHEME_CONS && do_note_cons) { + note_cons(pool_offset(addr)); + return 1; + } else { + if (type == AO_SCHEME_OTHER) + type = ao_scheme_other_type(addr); + + const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM + if (!lisp_type) + ao_scheme_abort(); +#endif + + return ao_scheme_mark(lisp_type, addr); + } +} + +/* + * Find the current location of an object + * based on the original location. For unmoved + * objects, this is simple. For moved objects, + * go search for it + */ + +static uint16_t +move_map(uint16_t offset) +{ + int l; + + if (offset < chunk_low || chunk_high <= offset) + return offset; + + l = find_chunk(offset); + +#if DBG_MEM + if (ao_scheme_chunk[l].old_offset != offset) + ao_scheme_abort(); +#endif + return ao_scheme_chunk[l].new_offset; +} + +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) +{ + void *addr = *ref; + uint16_t offset, orig_offset; + + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + (void) type; + + MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); + orig_offset = pool_offset(addr); + offset = move_map(orig_offset); + if (offset != orig_offset) { + MDBG_MOVE("update ref %d %d -> %d\n", + AO_SCHEME_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, + orig_offset, offset); + *ref = ao_scheme_pool + offset; + } + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already moved\n"); + return 1; + } + mark(ao_scheme_busy, offset); + MDBG_DO(ao_scheme_record(type, addr, ao_scheme_size(type, addr))); + return 0; +} + +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref) +{ + int ret; + MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); + MDBG_MOVE_IN(); + ret = ao_scheme_move_memory(type, ref); + if (!ret) { + MDBG_MOVE("move recurse\n"); + type->move(*ref); + } + MDBG_MOVE_OUT(); + return ret; +} + +int +ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) +{ + uint8_t type; + ao_poly p = *ref; + int ret; + void *addr; + uint16_t offset, orig_offset; + uint8_t base_type; + + base_type = type = ao_scheme_poly_base_type(p); + + if (type == AO_SCHEME_INT) + return 1; + + addr = ao_scheme_ref(p); + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + orig_offset = pool_offset(addr); + offset = move_map(orig_offset); + + if (type == AO_SCHEME_CONS && do_note_cons) { + note_cons(orig_offset); + ret = 1; + } else { + if (type == AO_SCHEME_OTHER) + type = ao_scheme_other_type(ao_scheme_pool + offset); + + const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM + if (!lisp_type) + ao_scheme_abort(); +#endif + + ret = ao_scheme_move(lisp_type, &addr); + } + + /* Re-write the poly value */ + if (offset != orig_offset) { + ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, base_type); + MDBG_MOVE("poly %d moved %d -> %d\n", + type, orig_offset, offset); + *ref = np; + } + return ret; +} + +#if DBG_MEM +void +ao_scheme_validate(void) +{ + chunk_low = 0; + memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +} + +int dbg_allocs; + +#endif + +void * +ao_scheme_alloc(int size) +{ + void *addr; + + MDBG_DO(++dbg_allocs); + MDBG_DO(if (dbg_validate) ao_scheme_validate()); + size = ao_scheme_size_round(size); + if (AO_SCHEME_POOL - ao_scheme_top < size && + ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size && + ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size) + { + ao_scheme_error(AO_SCHEME_OOM, "out of memory"); + return NULL; + } + addr = ao_scheme_pool + ao_scheme_top; + ao_scheme_top += size; + MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); + return addr; +} + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons) +{ + assert(save_cons[id] == 0); + save_cons[id] = cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id) +{ + struct ao_scheme_cons *cons = save_cons[id]; + save_cons[id] = NULL; + return cons; +} + +void +ao_scheme_poly_stash(int id, ao_poly poly) +{ + assert(save_poly[id] == AO_SCHEME_NIL); + save_poly[id] = poly; +} + +ao_poly +ao_scheme_poly_fetch(int id) +{ + ao_poly poly = save_poly[id]; + save_poly[id] = AO_SCHEME_NIL; + return poly; +} + +void +ao_scheme_string_stash(int id, char *string) +{ + assert(save_string[id] == NULL); + save_string[id] = string; +} + +char * +ao_scheme_string_fetch(int id) +{ + char *string = save_string[id]; + save_string[id] = NULL; + return string; +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame) +{ + assert(save_frame[id] == NULL); + save_frame[id] = frame; +} + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id) +{ + struct ao_scheme_frame *frame = save_frame[id]; + save_frame[id] = NULL; + return frame; +} diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c new file mode 100644 index 00000000..d726321c --- /dev/null +++ b/src/scheme/ao_scheme_poly.c @@ -0,0 +1,118 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +struct ao_scheme_funcs { + void (*write)(ao_poly); + void (*display)(ao_poly); +}; + +static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { + [AO_SCHEME_CONS] = { + .write = ao_scheme_cons_write, + .display = ao_scheme_cons_display, + }, + [AO_SCHEME_STRING] = { + .write = ao_scheme_string_write, + .display = ao_scheme_string_display, + }, + [AO_SCHEME_INT] = { + .write = ao_scheme_int_write, + .display = ao_scheme_int_write, + }, + [AO_SCHEME_ATOM] = { + .write = ao_scheme_atom_write, + .display = ao_scheme_atom_write, + }, + [AO_SCHEME_BUILTIN] = { + .write = ao_scheme_builtin_write, + .display = ao_scheme_builtin_write, + }, + [AO_SCHEME_FRAME] = { + .write = ao_scheme_frame_write, + .display = ao_scheme_frame_write, + }, + [AO_SCHEME_FRAME_VALS] = { + .write = NULL, + .display = NULL, + }, + [AO_SCHEME_LAMBDA] = { + .write = ao_scheme_lambda_write, + .display = ao_scheme_lambda_write, + }, + [AO_SCHEME_STACK] = { + .write = ao_scheme_stack_write, + .display = ao_scheme_stack_write, + }, + [AO_SCHEME_BOOL] = { + .write = ao_scheme_bool_write, + .display = ao_scheme_bool_write, + }, + [AO_SCHEME_BIGINT] = { + .write = ao_scheme_bigint_write, + .display = ao_scheme_bigint_write, + }, + [AO_SCHEME_FLOAT] = { + .write = ao_scheme_float_write, + .display = ao_scheme_float_write, + }, +}; + +static const struct ao_scheme_funcs * +funcs(ao_poly p) +{ + uint8_t type = ao_scheme_poly_type(p); + + if (type < AO_SCHEME_NUM_TYPE) + return &ao_scheme_funcs[type]; + return NULL; +} + +void +ao_scheme_poly_write(ao_poly p) +{ + const struct ao_scheme_funcs *f = funcs(p); + + if (f && f->write) + f->write(p); +} + +void +ao_scheme_poly_display(ao_poly p) +{ + const struct ao_scheme_funcs *f = funcs(p); + + if (f && f->display) + f->display(p); +} + +void * +ao_scheme_ref(ao_poly poly) { + if (poly == AO_SCHEME_NIL) + return NULL; + if (poly & AO_SCHEME_CONST) + return (void *) (ao_scheme_const + (poly & AO_SCHEME_REF_MASK) - 4); + return (void *) (ao_scheme_pool + (poly & AO_SCHEME_REF_MASK) - 4); +} + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type) { + const uint8_t *a = addr; + if (a == NULL) + return AO_SCHEME_NIL; + if (AO_SCHEME_IS_CONST(a)) + return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; + return (a - ao_scheme_pool + 4) | type; +} diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c new file mode 100644 index 00000000..6b1e9d66 --- /dev/null +++ b/src/scheme/ao_scheme_read.c @@ -0,0 +1,655 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include "ao_scheme_read.h" +#include +#include + +static const uint16_t lex_classes[128] = { + IGNORE, /* ^@ */ + IGNORE, /* ^A */ + IGNORE, /* ^B */ + IGNORE, /* ^C */ + IGNORE, /* ^D */ + IGNORE, /* ^E */ + IGNORE, /* ^F */ + IGNORE, /* ^G */ + IGNORE, /* ^H */ + WHITE, /* ^I */ + WHITE, /* ^J */ + WHITE, /* ^K */ + WHITE, /* ^L */ + WHITE, /* ^M */ + IGNORE, /* ^N */ + IGNORE, /* ^O */ + IGNORE, /* ^P */ + IGNORE, /* ^Q */ + IGNORE, /* ^R */ + IGNORE, /* ^S */ + IGNORE, /* ^T */ + IGNORE, /* ^U */ + IGNORE, /* ^V */ + IGNORE, /* ^W */ + IGNORE, /* ^X */ + IGNORE, /* ^Y */ + IGNORE, /* ^Z */ + IGNORE, /* ^[ */ + IGNORE, /* ^\ */ + IGNORE, /* ^] */ + IGNORE, /* ^^ */ + IGNORE, /* ^_ */ + PRINTABLE|WHITE, /* */ + PRINTABLE, /* ! */ + PRINTABLE|STRINGC, /* " */ + PRINTABLE|POUND, /* # */ + PRINTABLE, /* $ */ + PRINTABLE, /* % */ + PRINTABLE, /* & */ + PRINTABLE|SPECIAL, /* ' */ + PRINTABLE|SPECIAL, /* ( */ + PRINTABLE|SPECIAL, /* ) */ + PRINTABLE, /* * */ + PRINTABLE|SIGN, /* + */ + PRINTABLE|SPECIAL, /* , */ + PRINTABLE|SIGN, /* - */ + PRINTABLE|DOTC|FLOATC, /* . */ + PRINTABLE, /* / */ + PRINTABLE|DIGIT, /* 0 */ + PRINTABLE|DIGIT, /* 1 */ + PRINTABLE|DIGIT, /* 2 */ + PRINTABLE|DIGIT, /* 3 */ + PRINTABLE|DIGIT, /* 4 */ + PRINTABLE|DIGIT, /* 5 */ + PRINTABLE|DIGIT, /* 6 */ + PRINTABLE|DIGIT, /* 7 */ + PRINTABLE|DIGIT, /* 8 */ + PRINTABLE|DIGIT, /* 9 */ + PRINTABLE, /* : */ + PRINTABLE|COMMENT, /* ; */ + PRINTABLE, /* < */ + PRINTABLE, /* = */ + PRINTABLE, /* > */ + PRINTABLE, /* ? */ + PRINTABLE, /* @ */ + PRINTABLE, /* A */ + PRINTABLE, /* B */ + PRINTABLE, /* C */ + PRINTABLE, /* D */ + PRINTABLE|FLOATC, /* E */ + PRINTABLE, /* F */ + PRINTABLE, /* G */ + PRINTABLE, /* H */ + PRINTABLE, /* I */ + PRINTABLE, /* J */ + PRINTABLE, /* K */ + PRINTABLE, /* L */ + PRINTABLE, /* M */ + PRINTABLE, /* N */ + PRINTABLE, /* O */ + PRINTABLE, /* P */ + PRINTABLE, /* Q */ + PRINTABLE, /* R */ + PRINTABLE, /* S */ + PRINTABLE, /* T */ + PRINTABLE, /* U */ + PRINTABLE, /* V */ + PRINTABLE, /* W */ + PRINTABLE, /* X */ + PRINTABLE, /* Y */ + PRINTABLE, /* Z */ + PRINTABLE, /* [ */ + PRINTABLE|BACKSLASH, /* \ */ + PRINTABLE, /* ] */ + PRINTABLE, /* ^ */ + PRINTABLE, /* _ */ + PRINTABLE|SPECIAL, /* ` */ + PRINTABLE, /* a */ + PRINTABLE, /* b */ + PRINTABLE, /* c */ + PRINTABLE, /* d */ + PRINTABLE|FLOATC, /* e */ + PRINTABLE, /* f */ + PRINTABLE, /* g */ + PRINTABLE, /* h */ + PRINTABLE, /* i */ + PRINTABLE, /* j */ + PRINTABLE, /* k */ + PRINTABLE, /* l */ + PRINTABLE, /* m */ + PRINTABLE, /* n */ + PRINTABLE, /* o */ + PRINTABLE, /* p */ + PRINTABLE, /* q */ + PRINTABLE, /* r */ + PRINTABLE, /* s */ + PRINTABLE, /* t */ + PRINTABLE, /* u */ + PRINTABLE, /* v */ + PRINTABLE, /* w */ + PRINTABLE, /* x */ + PRINTABLE, /* y */ + PRINTABLE, /* z */ + PRINTABLE, /* { */ + PRINTABLE, /* | */ + PRINTABLE, /* } */ + PRINTABLE, /* ~ */ + IGNORE, /* ^? */ +}; + +static int lex_unget_c; + +static inline int +lex_get() +{ + int c; + if (lex_unget_c) { + c = lex_unget_c; + lex_unget_c = 0; + } else { + c = ao_scheme_getc(); + } + return c; +} + +static inline void +lex_unget(int c) +{ + if (c != EOF) + 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) +{ + int c; + int v; + int count; + + c = lex_get(); + if (c == EOF) { + lex_class = ENDOFFILE; + return 0; + } + lex_class = 0; + c &= 0x7f; + switch (c) { + case 'n': + return '\n'; + case 'f': + return '\f'; + case 'b': + return '\b'; + case 'r': + return '\r'; + case 'v': + return '\v'; + case 't': + return '\t'; + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + v = c - '0'; + count = 1; + while (count <= 3) { + c = lex_get(); + if (c == EOF) + return EOF; + c &= 0x7f; + if (c < '0' || '7' < c) { + lex_unget(c); + break; + } + v = (v << 3) + c - '0'; + ++count; + } + return v; + default: + return c; + } +} + +#define AO_SCHEME_TOKEN_MAX 32 + +static char token_string[AO_SCHEME_TOKEN_MAX]; +static int32_t token_int; +static int token_len; +static float token_float; + +static inline void add_token(int c) { + if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) + token_string[token_len++] = c; +} + +static inline void del_token(void) { + if (token_len > 0) + token_len--; +} + +static inline void end_token(void) { + token_string[token_len] = '\0'; +} + +struct namedfloat { + const char *name; + float value; +}; + +static const struct namedfloat namedfloats[] = { + { .name = "+inf.0", .value = INFINITY }, + { .name = "-inf.0", .value = -INFINITY }, + { .name = "+nan.0", .value = NAN }, + { .name = "-nan.0", .value = NAN }, +}; + +#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) + +static int +_lex(void) +{ + int c; + + token_len = 0; + for (;;) { + c = lexc(); + if (lex_class & ENDOFFILE) + return END; + + if (lex_class & WHITE) + continue; + + if (lex_class & COMMENT) { + while ((c = lexc()) != '\n') { + if (lex_class & ENDOFFILE) + return END; + } + continue; + } + + if (lex_class & (SPECIAL|DOTC)) { + add_token(c); + end_token(); + switch (c) { + case '(': + case '[': + return OPEN; + case ')': + case ']': + return CLOSE; + case '\'': + return QUOTE; + case '.': + return DOT; + case '`': + return QUASIQUOTE; + case ',': + c = lexc(); + if (c == '@') { + add_token(c); + end_token(); + return UNQUOTE_SPLICING; + } else { + lex_unget(c); + return UNQUOTE; + } + } + } + if (lex_class & POUND) { + c = lexc(); + switch (c) { + case 't': + add_token(c); + 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_scheme_error(AO_SCHEME_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; + } + add_token(c); + } + } + if (lex_class & PRINTABLE) { + int isfloat; + int hasdigit; + int isneg; + int isint; + int epos; + + isfloat = 1; + isint = 1; + hasdigit = 0; + token_int = 0; + isneg = 0; + epos = 0; + for (;;) { + if (!(lex_class & NUMBER)) { + isint = 0; + isfloat = 0; + } else { + if (!(lex_class & INTEGER)) + isint = 0; + if (token_len != epos && + (lex_class & SIGN)) + { + isint = 0; + isfloat = 0; + } + if (c == '-') + isneg = 1; + if (c == '.' && epos != 0) + isfloat = 0; + if (c == 'e' || c == 'E') { + if (token_len == 0) + isfloat = 0; + else + epos = token_len + 1; + } + if (lex_class & DIGIT) { + hasdigit = 1; + if (isint) + token_int = token_int * 10 + c - '0'; + } + } + add_token (c); + c = lexc (); + if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { + unsigned int u; +// if (lex_class & ENDOFFILE) +// clearerr (f); + lex_unget(c); + end_token (); + if (isint && hasdigit) { + if (isneg) + token_int = -token_int; + return NUM; + } + if (isfloat && hasdigit) { + token_float = strtof(token_string, NULL); + return FLOAT; + } + for (u = 0; u < NUM_NAMED_FLOATS; u++) + if (!strcmp(namedfloats[u].name, token_string)) { + token_float = namedfloats[u].value; + return FLOAT; + } + return NAME; + } + } + } + } +} + +static inline int lex(void) +{ + int parse_token = _lex(); + RDBGI("token %d (%s)\n", parse_token, token_string); + return parse_token; +} + +static int parse_token; + +struct ao_scheme_cons *ao_scheme_read_cons; +struct ao_scheme_cons *ao_scheme_read_cons_tail; +struct ao_scheme_cons *ao_scheme_read_stack; + +#define READ_IN_QUOTE 0x01 +#define READ_SAW_DOT 0x02 +#define READ_DONE_DOT 0x04 + +static int +push_read_stack(int cons, int read_state) +{ + RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); + RDBG_IN(); + if (cons) { + ao_scheme_read_stack = ao_scheme_cons_cons(ao_scheme_cons_poly(ao_scheme_read_cons), + ao_scheme__cons(ao_scheme_int_poly(read_state), + ao_scheme_cons_poly(ao_scheme_read_stack))); + if (!ao_scheme_read_stack) + return 0; + } + ao_scheme_read_cons = NULL; + ao_scheme_read_cons_tail = NULL; + return 1; +} + +static int +pop_read_stack(int cons) +{ + int read_state = 0; + if (cons) { + ao_scheme_read_cons = ao_scheme_poly_cons(ao_scheme_read_stack->car); + ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); + read_state = ao_scheme_poly_int(ao_scheme_read_stack->car); + ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); + for (ao_scheme_read_cons_tail = ao_scheme_read_cons; + ao_scheme_read_cons_tail && ao_scheme_read_cons_tail->cdr; + ao_scheme_read_cons_tail = ao_scheme_poly_cons(ao_scheme_read_cons_tail->cdr)) + ; + } else { + ao_scheme_read_cons = 0; + ao_scheme_read_cons_tail = 0; + ao_scheme_read_stack = 0; + } + RDBG_OUT(); + RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); + return read_state; +} + +ao_poly +ao_scheme_read(void) +{ + struct ao_scheme_atom *atom; + char *string; + int cons; + int read_state; + ao_poly v = AO_SCHEME_NIL; + + cons = 0; + read_state = 0; + ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; + for (;;) { + parse_token = lex(); + while (parse_token == OPEN) { + if (!push_read_stack(cons, read_state)) + return AO_SCHEME_NIL; + cons++; + read_state = 0; + parse_token = lex(); + } + + switch (parse_token) { + case END: + default: + if (cons) + ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); + return _ao_scheme_atom_eof; + break; + case NAME: + atom = ao_scheme_atom_intern(token_string); + if (atom) + v = ao_scheme_atom_poly(atom); + else + v = AO_SCHEME_NIL; + break; + case NUM: + v = ao_scheme_integer_poly(token_int); + break; + case FLOAT: + v = ao_scheme_float_get(token_float); + break; + case BOOL: + if (token_string[0] == 't') + v = _ao_scheme_bool_true; + else + v = _ao_scheme_bool_false; + break; + case STRING: + string = ao_scheme_string_copy(token_string); + if (string) + v = ao_scheme_string_poly(string); + else + v = AO_SCHEME_NIL; + break; + case QUOTE: + case QUASIQUOTE: + case UNQUOTE: + case UNQUOTE_SPLICING: + if (!push_read_stack(cons, read_state)) + return AO_SCHEME_NIL; + cons++; + read_state = READ_IN_QUOTE; + switch (parse_token) { + case QUOTE: + v = _ao_scheme_atom_quote; + break; + case QUASIQUOTE: + v = _ao_scheme_atom_quasiquote; + break; + case UNQUOTE: + v = _ao_scheme_atom_unquote; + break; + case UNQUOTE_SPLICING: + v = _ao_scheme_atom_unquote2dsplicing; + break; + } + break; + case CLOSE: + if (!cons) { + v = AO_SCHEME_NIL; + break; + } + v = ao_scheme_cons_poly(ao_scheme_read_cons); + --cons; + read_state = pop_read_stack(cons); + break; + case DOT: + if (!cons) { + ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); + return AO_SCHEME_NIL; + } + if (!ao_scheme_read_cons) { + ao_scheme_error(AO_SCHEME_INVALID, ". first in cons"); + return AO_SCHEME_NIL; + } + read_state |= READ_SAW_DOT; + continue; + } + + /* loop over QUOTE ends */ + for (;;) { + if (!cons) + return v; + + if (read_state & READ_DONE_DOT) { + ao_scheme_error(AO_SCHEME_INVALID, ". not last in cons"); + return AO_SCHEME_NIL; + } + + if (read_state & READ_SAW_DOT) { + read_state |= READ_DONE_DOT; + ao_scheme_read_cons_tail->cdr = v; + } else { + struct ao_scheme_cons *read = ao_scheme_cons_cons(v, AO_SCHEME_NIL); + if (!read) + return AO_SCHEME_NIL; + + if (ao_scheme_read_cons_tail) + ao_scheme_read_cons_tail->cdr = ao_scheme_cons_poly(read); + else + ao_scheme_read_cons = read; + ao_scheme_read_cons_tail = read; + } + + if (!(read_state & READ_IN_QUOTE) || !ao_scheme_read_cons->cdr) + break; + + v = ao_scheme_cons_poly(ao_scheme_read_cons); + --cons; + read_state = pop_read_stack(cons); + } + } + return v; +} diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h new file mode 100644 index 00000000..e9508835 --- /dev/null +++ b/src/scheme/ao_scheme_read.h @@ -0,0 +1,58 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#ifndef _AO_SCHEME_READ_H_ +#define _AO_SCHEME_READ_H_ + +/* + * token classes + */ + +# define END 0 +# define NAME 1 +# define OPEN 2 +# define CLOSE 3 +# define QUOTE 4 +# define QUASIQUOTE 5 +# define UNQUOTE 6 +# define UNQUOTE_SPLICING 7 +# define STRING 8 +# define NUM 9 +# define FLOAT 10 +# define DOT 11 +# define BOOL 12 + +/* + * character classes + */ + +# define PRINTABLE 0x0001 /* \t \n ' ' - ~ */ +# define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */ +# define DOTC 0x0004 /* . */ +# define WHITE 0x0008 /* ' ' \t \n */ +# define DIGIT 0x0010 /* [0-9] */ +# define SIGN 0x0020 /* +- */ +# define FLOATC 0x0040 /* . e E */ +# define ENDOFFILE 0x0080 /* end of file */ +# define COMMENT 0x0100 /* ; */ +# define IGNORE 0x0200 /* \0 - ' ' */ +# define BACKSLASH 0x0400 /* \ */ +# define STRINGC 0x0800 /* " */ +# define POUND 0x1000 /* # */ + +# define NOTNAME (STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) +# define INTEGER (DIGIT|SIGN) +# define NUMBER (INTEGER|FLOATC) + +#endif /* _AO_SCHEME_READ_H_ */ diff --git a/src/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c new file mode 100644 index 00000000..9dbce5f2 --- /dev/null +++ b/src/scheme/ao_scheme_rep.c @@ -0,0 +1,36 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +ao_poly +ao_scheme_read_eval_print(void) +{ + ao_poly in, out = AO_SCHEME_NIL; + for(;;) { + in = ao_scheme_read(); + if (in == _ao_scheme_atom_eof) + break; + out = ao_scheme_eval(in); + if (ao_scheme_exception) { + if (ao_scheme_exception & AO_SCHEME_EXIT) + break; + ao_scheme_exception = 0; + } else { + ao_scheme_poly_write(out); + putchar ('\n'); + } + } + return out; +} diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c new file mode 100644 index 00000000..af9345b8 --- /dev/null +++ b/src/scheme/ao_scheme_save.c @@ -0,0 +1,77 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +ao_poly +ao_scheme_do_save(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) + return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE + struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + + ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + os->atoms = ao_scheme_atom_poly(ao_scheme_atoms); + os->globals = ao_scheme_frame_poly(ao_scheme_frame_global); + os->const_checksum = ao_scheme_const_checksum; + os->const_checksum_inv = (uint16_t) ~ao_scheme_const_checksum; + + if (ao_scheme_os_save()) + return _ao_scheme_bool_true; +#endif + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_restore(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) + return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE + struct ao_scheme_os_save save; + struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + + if (!ao_scheme_os_restore_save(&save, AO_SCHEME_POOL)) + return ao_scheme_error(AO_SCHEME_INVALID, "header restore failed"); + + if (save.const_checksum != ao_scheme_const_checksum || + save.const_checksum_inv != (uint16_t) ~ao_scheme_const_checksum) + { + return ao_scheme_error(AO_SCHEME_INVALID, "image is corrupted or stale"); + } + + if (ao_scheme_os_restore()) { + + ao_scheme_atoms = ao_scheme_poly_atom(os->atoms); + ao_scheme_frame_global = ao_scheme_poly_frame(os->globals); + + /* Clear the eval global variabls */ + ao_scheme_eval_clear_globals(); + + /* Reset the allocator */ + ao_scheme_top = AO_SCHEME_POOL; + ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + + /* Re-create the evaluator stack */ + if (!ao_scheme_eval_restart()) + return _ao_scheme_bool_false; + + return _ao_scheme_bool_true; + } +#endif + return _ao_scheme_bool_false; +} diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c new file mode 100644 index 00000000..d19dd6d6 --- /dev/null +++ b/src/scheme/ao_scheme_stack.c @@ -0,0 +1,280 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +const struct ao_scheme_type ao_scheme_stack_type; + +static int +stack_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_stack); +} + +static void +stack_mark(void *addr) +{ + struct ao_scheme_stack *stack = addr; + for (;;) { + ao_scheme_poly_mark(stack->sexprs, 0); + ao_scheme_poly_mark(stack->values, 0); + /* no need to mark values_tail */ + ao_scheme_poly_mark(stack->frame, 0); + ao_scheme_poly_mark(stack->list, 0); + stack = ao_scheme_poly_stack(stack->prev); + if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack)) + break; + } +} + +static void +stack_move(void *addr) +{ + struct ao_scheme_stack *stack = addr; + + while (stack) { + struct ao_scheme_stack *prev; + int ret; + (void) ao_scheme_poly_move(&stack->sexprs, 0); + (void) ao_scheme_poly_move(&stack->values, 0); + (void) ao_scheme_poly_move(&stack->values_tail, 0); + (void) ao_scheme_poly_move(&stack->frame, 0); + (void) ao_scheme_poly_move(&stack->list, 0); + prev = ao_scheme_poly_stack(stack->prev); + if (!prev) + break; + ret = ao_scheme_move_memory(&ao_scheme_stack_type, (void **) &prev); + if (prev != ao_scheme_poly_stack(stack->prev)) + stack->prev = ao_scheme_stack_poly(prev); + if (ret) + break; + stack = prev; + } +} + +const struct ao_scheme_type ao_scheme_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move, + .name = "stack" +}; + +struct ao_scheme_stack *ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack) +{ + stack->state = eval_sexpr; + stack->sexprs = AO_SCHEME_NIL; + stack->values = AO_SCHEME_NIL; + stack->values_tail = AO_SCHEME_NIL; +} + +static struct ao_scheme_stack * +ao_scheme_stack_new(void) +{ + struct ao_scheme_stack *stack; + + if (ao_scheme_stack_free_list) { + stack = ao_scheme_stack_free_list; + ao_scheme_stack_free_list = ao_scheme_poly_stack(stack->prev); + } else { + stack = ao_scheme_alloc(sizeof (struct ao_scheme_stack)); + if (!stack) + return 0; + stack->type = AO_SCHEME_STACK; + } + ao_scheme_stack_reset(stack); + return stack; +} + +int +ao_scheme_stack_push(void) +{ + struct ao_scheme_stack *stack; + + stack = ao_scheme_stack_new(); + + if (!stack) + return 0; + + stack->prev = ao_scheme_stack_poly(ao_scheme_stack); + stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); + stack->list = AO_SCHEME_NIL; + + ao_scheme_stack = stack; + + DBGI("stack push\n"); + DBG_FRAMES(); + DBG_IN(); + return 1; +} + +void +ao_scheme_stack_pop(void) +{ + ao_poly prev; + struct ao_scheme_frame *prev_frame; + + if (!ao_scheme_stack) + return; + prev = ao_scheme_stack->prev; + if (!ao_scheme_stack_marked(ao_scheme_stack)) { + ao_scheme_stack->prev = ao_scheme_stack_poly(ao_scheme_stack_free_list); + ao_scheme_stack_free_list = ao_scheme_stack; + } + + ao_scheme_stack = ao_scheme_poly_stack(prev); + prev_frame = ao_scheme_frame_current; + if (ao_scheme_stack) + ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + else + ao_scheme_frame_current = NULL; + if (ao_scheme_frame_current != prev_frame) + ao_scheme_frame_free(prev_frame); + DBG_OUT(); + DBGI("stack pop\n"); + DBG_FRAMES(); +} + +void +ao_scheme_stack_clear(void) +{ + ao_scheme_stack = NULL; + ao_scheme_frame_current = NULL; + ao_scheme_v = AO_SCHEME_NIL; +} + +void +ao_scheme_stack_write(ao_poly poly) +{ + struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + + while (s) { + if (s->type & AO_SCHEME_STACK_PRINT) { + printf("[recurse...]"); + return; + } + s->type |= AO_SCHEME_STACK_PRINT; + printf("\t[\n"); + printf("\t\texpr: "); ao_scheme_poly_write(s->list); printf("\n"); + printf("\t\tstate: %s\n", ao_scheme_state_names[s->state]); + ao_scheme_error_poly ("values: ", s->values, s->values_tail); + ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL); + ao_scheme_error_frame(2, "frame: ", ao_scheme_poly_frame(s->frame)); + printf("\t]\n"); + s->type &= ~AO_SCHEME_STACK_PRINT; + s = ao_scheme_poly_stack(s->prev); + } +} + +/* + * Copy a stack, being careful to keep everybody referenced + */ +static struct ao_scheme_stack * +ao_scheme_stack_copy(struct ao_scheme_stack *old) +{ + struct ao_scheme_stack *new = NULL; + struct ao_scheme_stack *n, *prev = NULL; + + while (old) { + ao_scheme_stack_stash(0, old); + ao_scheme_stack_stash(1, new); + ao_scheme_stack_stash(2, prev); + n = ao_scheme_stack_new(); + prev = ao_scheme_stack_fetch(2); + new = ao_scheme_stack_fetch(1); + old = ao_scheme_stack_fetch(0); + if (!n) + return NULL; + + ao_scheme_stack_mark(old); + ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame)); + *n = *old; + + if (prev) + prev->prev = ao_scheme_stack_poly(n); + else + new = n; + prev = n; + + old = ao_scheme_poly_stack(old->prev); + } + return new; +} + +/* + * Evaluate a continuation invocation + */ +ao_poly +ao_scheme_stack_eval(void) +{ + struct ao_scheme_stack *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); + if (!new) + return AO_SCHEME_NIL; + + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + + if (!cons || !cons->cdr) + return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value"); + + new->state = eval_val; + + ao_scheme_stack = new; + ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + + return ao_scheme_poly_cons(cons->cdr)->car; +} + +/* + * Call with current continuation. This calls a lambda, passing + * it a single argument which is the current continuation + */ +ao_poly +ao_scheme_do_call_cc(struct ao_scheme_cons *cons) +{ + struct ao_scheme_stack *new; + ao_poly v; + + /* Make sure the single parameter is a lambda */ + if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0)) + return AO_SCHEME_NIL; + + /* go get the lambda */ + ao_scheme_v = ao_scheme_arg(cons, 0); + + /* Note that the whole call chain now has + * a reference to it which may escape + */ + new = ao_scheme_stack_copy(ao_scheme_stack); + if (!new) + return AO_SCHEME_NIL; + + /* re-fetch cons after the allocation */ + cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr); + + /* Reset the arg list to the current stack, + * and call the lambda + */ + + cons->car = ao_scheme_stack_poly(new); + cons->cdr = AO_SCHEME_NIL; + v = ao_scheme_lambda_eval(); + ao_scheme_stack->sexprs = v; + ao_scheme_stack->state = eval_begin; + return AO_SCHEME_NIL; +} diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c new file mode 100644 index 00000000..e25306cb --- /dev/null +++ b/src/scheme/ao_scheme_string.c @@ -0,0 +1,161 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_scheme.h" + +static void string_mark(void *addr) +{ + (void) addr; +} + +static int string_size(void *addr) +{ + if (!addr) + return 0; + return strlen(addr) + 1; +} + +static void string_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_string_type = { + .mark = string_mark, + .size = string_size, + .move = string_move, + .name = "string", +}; + +char * +ao_scheme_string_copy(char *a) +{ + int alen = strlen(a); + + ao_scheme_string_stash(0, a); + char *r = ao_scheme_alloc(alen + 1); + a = ao_scheme_string_fetch(0); + if (!r) + return NULL; + strcpy(r, a); + return r; +} + +char * +ao_scheme_string_cat(char *a, char *b) +{ + int alen = strlen(a); + int blen = strlen(b); + + ao_scheme_string_stash(0, a); + ao_scheme_string_stash(1, b); + char *r = ao_scheme_alloc(alen + blen + 1); + a = ao_scheme_string_fetch(0); + b = ao_scheme_string_fetch(1); + if (!r) + return NULL; + strcpy(r, a); + strcpy(r+alen, b); + return r; +} + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons) +{ + int len = ao_scheme_cons_length(cons); + ao_scheme_cons_stash(0, cons); + char *r = ao_scheme_alloc(len + 1); + cons = ao_scheme_cons_fetch(0); + char *s = r; + + while (cons) { + if (!ao_scheme_integer_typep(ao_scheme_poly_type(cons->car))) + return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack"); + *s++ = ao_scheme_poly_integer(cons->car); + cons = ao_scheme_poly_cons(cons->cdr); + } + *s++ = 0; + return ao_scheme_string_poly(r); +} + +ao_poly +ao_scheme_string_unpack(char *a) +{ + struct ao_scheme_cons *cons = NULL, *tail = NULL; + int c; + int i; + + for (i = 0; (c = a[i]); i++) { + ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(1, tail); + ao_scheme_string_stash(0, a); + struct ao_scheme_cons *n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL); + a = ao_scheme_string_fetch(0); + cons = ao_scheme_cons_fetch(0); + tail = ao_scheme_cons_fetch(1); + + if (!n) { + cons = NULL; + break; + } + if (tail) + tail->cdr = ao_scheme_cons_poly(n); + else + cons = n; + tail = n; + } + return ao_scheme_cons_poly(cons); +} + +void +ao_scheme_string_write(ao_poly p) +{ + char *s = ao_scheme_poly_string(p); + char c; + + putchar('"'); + while ((c = *s++)) { + switch (c) { + case '\n': + printf ("\\n"); + break; + case '\r': + printf ("\\r"); + break; + case '\t': + printf ("\\t"); + break; + default: + if (c < ' ') + printf("\\%03o", c); + else + putchar(c); + break; + } + } + putchar('"'); +} + +void +ao_scheme_string_display(ao_poly p) +{ + char *s = ao_scheme_poly_string(p); + char c; + + while ((c = *s++)) + putchar(c); +} diff --git a/src/scheme/make-const/.gitignore b/src/scheme/make-const/.gitignore new file mode 100644 index 00000000..bcd57242 --- /dev/null +++ b/src/scheme/make-const/.gitignore @@ -0,0 +1 @@ +ao_scheme_make_const diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile new file mode 100644 index 00000000..caf7acbe --- /dev/null +++ b/src/scheme/make-const/Makefile @@ -0,0 +1,26 @@ +include ../Makefile-inc + +vpath %.o . +vpath %.c .. +vpath %.h .. + +SRCS=$(SCHEME_SRCS) ao_scheme_make_const.c +HDRS=$(SCHEME_HDRS) ao_scheme_os.h + +OBJS=$(SRCS:.c=.o) + +CC=cc +CFLAGS=-DAO_SCHEME_MAKE_CONST -O0 -g -I. -Wall -Wextra + +.c.o: + $(CC) -c $(CFLAGS) $< -o $@ + +all: ao_scheme_make_const + +ao_scheme_make_const: $(OBJS) + $(CC) $(CFLAGS) -o $@ $^ -lm + +clean: + rm -f $(OBJS) ao_scheme_make_const + +$(OBJS): $(SCHEME_HDRS) diff --git a/src/scheme/make-const/ao_scheme_os.h b/src/scheme/make-const/ao_scheme_os.h new file mode 100644 index 00000000..f06bbbb1 --- /dev/null +++ b/src/scheme/make-const/ao_scheme_os.h @@ -0,0 +1,63 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ + +#include +#include +#include + +extern int ao_scheme_getc(void); + +static inline void +ao_scheme_os_flush(void) { + fflush(stdout); +} + +static inline void +ao_scheme_abort(void) +{ + abort(); +} + +static inline void +ao_scheme_os_led(int led) +{ + printf("leds set to 0x%x\n", led); +} + +#define AO_SCHEME_JIFFIES_PER_SECOND 100 + +static inline void +ao_scheme_os_delay(int jiffies) +{ + struct timespec ts = { + .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) + }; + nanosleep(&ts, NULL); +} + +static inline int +ao_scheme_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); +} +#endif diff --git a/src/test/ao_lisp_os.h b/src/test/ao_lisp_os.h deleted file mode 100644 index ebd16bb4..00000000 --- a/src/test/ao_lisp_os.h +++ /dev/null @@ -1,68 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ - -#include -#include -#include - -#define AO_LISP_POOL_TOTAL 16384 -#define AO_LISP_SAVE 1 -#define DBG_MEM_STATS 1 - -extern int ao_lisp_getc(void); - -static inline void -ao_lisp_os_flush() { - fflush(stdout); -} - -static inline void -ao_lisp_abort(void) -{ - abort(); -} - -static inline void -ao_lisp_os_led(int led) -{ - printf("leds set to 0x%x\n", led); -} - -#define AO_LISP_JIFFIES_PER_SECOND 100 - -static inline void -ao_lisp_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_lisp_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); -} - -#endif diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c deleted file mode 100644 index 68e3a202..00000000 --- a/src/test/ao_lisp_test.c +++ /dev/null @@ -1,134 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -static FILE *ao_lisp_file; -static int newline = 1; - -static char save_file[] = "lisp.image"; - -int -ao_lisp_os_save(void) -{ - FILE *save = fopen(save_file, "w"); - - if (!save) { - perror(save_file); - return 0; - } - fwrite(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, save); - fclose(save); - return 1; -} - -int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - fseek(restore, offset, SEEK_SET); - ret = fread(save, sizeof (struct ao_lisp_os_save), 1, restore); - fclose(restore); - if (ret != 1) - return 0; - return 1; -} - -int -ao_lisp_os_restore(void) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - ret = fread(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, restore); - fclose(restore); - if (ret != AO_LISP_POOL_TOTAL) - return 0; - return 1; -} - -int -ao_lisp_getc(void) -{ - int c; - - if (ao_lisp_file) - return getc(ao_lisp_file); - - if (newline) { - printf("> "); - newline = 0; - } - c = getchar(); - if (c == '\n') - newline = 1; - return c; -} - -int -main (int argc, char **argv) -{ - while (*++argv) { - ao_lisp_file = fopen(*argv, "r"); - if (!ao_lisp_file) { - perror(*argv); - exit(1); - } - ao_lisp_read_eval_print(); - fclose(ao_lisp_file); - ao_lisp_file = NULL; - } - ao_lisp_read_eval_print(); - - printf ("collects: full: %d incremental %d\n", - ao_lisp_collects[AO_LISP_COLLECT_FULL], - ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - - printf ("freed: full %d incremental %d\n", - ao_lisp_freed[AO_LISP_COLLECT_FULL], - ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL]); - - printf("loops: full %d incremental %d\n", - ao_lisp_loops[AO_LISP_COLLECT_FULL], - ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); - - printf("loops per collect: full %f incremental %f\n", - (double) ao_lisp_loops[AO_LISP_COLLECT_FULL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], - (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - - printf("freed per collect: full %f incremental %f\n", - (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], - (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - - printf("freed per loop: full %f incremental %f\n", - (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / - (double) ao_lisp_loops[AO_LISP_COLLECT_FULL], - (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / - (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); -} diff --git a/src/test/ao_scheme_os.h b/src/test/ao_scheme_os.h new file mode 100644 index 00000000..ebd16bb4 --- /dev/null +++ b/src/test/ao_scheme_os.h @@ -0,0 +1,68 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_LISP_OS_H_ +#define _AO_LISP_OS_H_ + +#include +#include +#include + +#define AO_LISP_POOL_TOTAL 16384 +#define AO_LISP_SAVE 1 +#define DBG_MEM_STATS 1 + +extern int ao_lisp_getc(void); + +static inline void +ao_lisp_os_flush() { + fflush(stdout); +} + +static inline void +ao_lisp_abort(void) +{ + abort(); +} + +static inline void +ao_lisp_os_led(int led) +{ + printf("leds set to 0x%x\n", led); +} + +#define AO_LISP_JIFFIES_PER_SECOND 100 + +static inline void +ao_lisp_os_delay(int jiffies) +{ + struct timespec ts = { + .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) + }; + nanosleep(&ts, NULL); +} + +static inline int +ao_lisp_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); +} + +#endif diff --git a/src/test/ao_scheme_test.c b/src/test/ao_scheme_test.c new file mode 100644 index 00000000..68e3a202 --- /dev/null +++ b/src/test/ao_scheme_test.c @@ -0,0 +1,134 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_lisp.h" +#include + +static FILE *ao_lisp_file; +static int newline = 1; + +static char save_file[] = "lisp.image"; + +int +ao_lisp_os_save(void) +{ + FILE *save = fopen(save_file, "w"); + + if (!save) { + perror(save_file); + return 0; + } + fwrite(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, save); + fclose(save); + return 1; +} + +int +ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + fseek(restore, offset, SEEK_SET); + ret = fread(save, sizeof (struct ao_lisp_os_save), 1, restore); + fclose(restore); + if (ret != 1) + return 0; + return 1; +} + +int +ao_lisp_os_restore(void) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + ret = fread(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, restore); + fclose(restore); + if (ret != AO_LISP_POOL_TOTAL) + return 0; + return 1; +} + +int +ao_lisp_getc(void) +{ + int c; + + if (ao_lisp_file) + return getc(ao_lisp_file); + + if (newline) { + printf("> "); + newline = 0; + } + c = getchar(); + if (c == '\n') + newline = 1; + return c; +} + +int +main (int argc, char **argv) +{ + while (*++argv) { + ao_lisp_file = fopen(*argv, "r"); + if (!ao_lisp_file) { + perror(*argv); + exit(1); + } + ao_lisp_read_eval_print(); + fclose(ao_lisp_file); + ao_lisp_file = NULL; + } + ao_lisp_read_eval_print(); + + printf ("collects: full: %d incremental %d\n", + ao_lisp_collects[AO_LISP_COLLECT_FULL], + ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); + + printf ("freed: full %d incremental %d\n", + ao_lisp_freed[AO_LISP_COLLECT_FULL], + ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL]); + + printf("loops: full %d incremental %d\n", + ao_lisp_loops[AO_LISP_COLLECT_FULL], + ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); + + printf("loops per collect: full %f incremental %f\n", + (double) ao_lisp_loops[AO_LISP_COLLECT_FULL] / + (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], + (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL] / + (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); + + printf("freed per collect: full %f incremental %f\n", + (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / + (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], + (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / + (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); + + printf("freed per loop: full %f incremental %f\n", + (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / + (double) ao_lisp_loops[AO_LISP_COLLECT_FULL], + (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / + (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); +} -- cgit v1.2.3