diff options
Diffstat (limited to 'src/lisp')
-rw-r--r-- | src/lisp/.gitignore | 2 | ||||
-rw-r--r-- | src/lisp/Makefile | 22 | ||||
-rw-r--r-- | src/lisp/Makefile-inc | 22 | ||||
-rw-r--r-- | src/lisp/Makefile-lisp | 4 | ||||
-rw-r--r-- | src/lisp/ao_lisp.h | 793 | ||||
-rw-r--r-- | src/lisp/ao_lisp_atom.c | 165 | ||||
-rw-r--r-- | src/lisp/ao_lisp_builtin.c | 619 | ||||
-rw-r--r-- | src/lisp/ao_lisp_cons.c | 143 | ||||
-rw-r--r-- | src/lisp/ao_lisp_const.lisp | 184 | ||||
-rw-r--r-- | src/lisp/ao_lisp_error.c | 102 | ||||
-rw-r--r-- | src/lisp/ao_lisp_eval.c | 531 | ||||
-rw-r--r-- | src/lisp/ao_lisp_frame.c | 293 | ||||
-rw-r--r-- | src/lisp/ao_lisp_int.c | 22 | ||||
-rw-r--r-- | src/lisp/ao_lisp_lambda.c | 196 | ||||
-rw-r--r-- | src/lisp/ao_lisp_lex.c | 16 | ||||
-rw-r--r-- | src/lisp/ao_lisp_make_const.c | 423 | ||||
-rw-r--r-- | src/lisp/ao_lisp_mem.c | 880 | ||||
-rw-r--r-- | src/lisp/ao_lisp_os.h | 53 | ||||
-rw-r--r-- | src/lisp/ao_lisp_poly.c | 102 | ||||
-rw-r--r-- | src/lisp/ao_lisp_read.c | 498 | ||||
-rw-r--r-- | src/lisp/ao_lisp_read.h | 49 | ||||
-rw-r--r-- | src/lisp/ao_lisp_rep.c | 34 | ||||
-rw-r--r-- | src/lisp/ao_lisp_save.c | 76 | ||||
-rw-r--r-- | src/lisp/ao_lisp_stack.c | 278 | ||||
-rw-r--r-- | src/lisp/ao_lisp_string.c | 158 |
25 files changed, 5665 insertions, 0 deletions
diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore new file mode 100644 index 00000000..76a555ea --- /dev/null +++ b/src/lisp/.gitignore @@ -0,0 +1,2 @@ +ao_lisp_make_const +ao_lisp_const.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile new file mode 100644 index 00000000..25796ec5 --- /dev/null +++ b/src/lisp/Makefile @@ -0,0 +1,22 @@ +all: ao_lisp_const.h + +clean: + rm -f ao_lisp_const.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 + +include Makefile-inc +SRCS=$(LISP_SRCS) + +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) + +$(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc new file mode 100644 index 00000000..126deeb0 --- /dev/null +++ b/src/lisp/Makefile-inc @@ -0,0 +1,22 @@ +LISP_SRCS=\ + ao_lisp_make_const.c\ + 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_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 diff --git a/src/lisp/Makefile-lisp b/src/lisp/Makefile-lisp new file mode 100644 index 00000000..998c7673 --- /dev/null +++ b/src/lisp/Makefile-lisp @@ -0,0 +1,4 @@ +include ../lisp/Makefile-inc + +ao_lisp_const.h: $(LISP_SRCS) $(LISP_HDRS) + +cd ../lisp && make $@ diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h new file mode 100644 index 00000000..980514cc --- /dev/null +++ b/src/lisp/ao_lisp.h @@ -0,0 +1,793 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 + +#include <stdint.h> +#include <string.h> +#include <ao_lisp_os.h> + +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 _ao_lisp_atom_quote _atom("quote") +#define _ao_lisp_atom_set _atom("set") +#define _ao_lisp_atom_setq _atom("setq") +#define _ao_lisp_atom_t _atom("t") +#define _ao_lisp_atom_car _atom("car") +#define _ao_lisp_atom_cdr _atom("cdr") +#define _ao_lisp_atom_cons _atom("cons") +#define _ao_lisp_atom_last _atom("last") +#define _ao_lisp_atom_length _atom("length") +#define _ao_lisp_atom_cond _atom("cond") +#define _ao_lisp_atom_lambda _atom("lambda") +#define _ao_lisp_atom_led _atom("led") +#define _ao_lisp_atom_delay _atom("delay") +#define _ao_lisp_atom_pack _atom("pack") +#define _ao_lisp_atom_unpack _atom("unpack") +#define _ao_lisp_atom_flush _atom("flush") +#define _ao_lisp_atom_eval _atom("eval") +#define _ao_lisp_atom_read _atom("read") +#define _ao_lisp_atom_eof _atom("eof") +#define _ao_lisp_atom_save _atom("save") +#define _ao_lisp_atom_restore _atom("restore") +#define _ao_lisp_atom_call2fcc _atom("call/cc") +#define _ao_lisp_atom_collect _atom("collect") +#define _ao_lisp_atom_symbolp _atom("symbol?") +#define _ao_lisp_atom_builtin _atom("builtin?") +#define _ao_lisp_atom_symbolp _atom("symbol?") +#define _ao_lisp_atom_symbolp _atom("symbol?") +#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_LAMBDA 7 +#define AO_LISP_STACK 8 +#define AO_LISP_NUM_TYPE 9 + +/* 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_EOF 0x10 + +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_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 { + uint8_t type; + uint8_t num; + ao_poly prev; + struct ao_lisp_val vals[]; +}; + +/* 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); +} + +enum eval_state { + eval_sexpr, /* Evaluate an sexpr */ + eval_val, /* Value computed */ + eval_formal, /* Formal computed */ + eval_exec, /* Start a lambda evaluation */ + eval_cond, /* Start next cond clause */ + eval_cond_test, /* Check cond condition */ + eval_progn, /* Start next progn 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_LEXPR 3 + +#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) +#define AO_LISP_FUNC_F_LEXPR (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LEXPR) + +struct ao_lisp_builtin { + uint8_t type; + uint8_t args; + uint16_t func; +}; + +enum ao_lisp_builtin_id { + builtin_eval, + builtin_read, + builtin_lambda, + builtin_lexpr, + builtin_nlambda, + builtin_macro, + builtin_car, + builtin_cdr, + builtin_cons, + builtin_last, + builtin_length, + builtin_quote, + builtin_set, + builtin_setq, + builtin_cond, + builtin_progn, + builtin_while, + builtin_print, + builtin_patom, + builtin_plus, + builtin_minus, + builtin_times, + builtin_divide, + builtin_mod, + builtin_equal, + builtin_less, + builtin_greater, + builtin_less_equal, + builtin_greater_equal, + builtin_pack, + builtin_unpack, + builtin_flush, + builtin_delay, + builtin_led, + builtin_save, + builtin_restore, + builtin_call_cc, + builtin_collect, + _builtin_last +}; + +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 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 int +ao_lisp_poly_int(ao_poly poly) +{ + return (int) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); +} + +static inline ao_poly +ao_lisp_int_poly(int i) +{ + return ((ao_poly) i << 2) | AO_LISP_INT; +} + +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); +} + +/* 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); + +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)); +} + +/* cons */ +extern const struct ao_lisp_type ao_lisp_cons_type; + +struct ao_lisp_cons * +ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *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_print(ao_poly); + +void +ao_lisp_cons_patom(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_print(ao_poly s); + +void +ao_lisp_string_patom(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_print(ao_poly a); + +struct ao_lisp_atom * +ao_lisp_atom_intern(char *name); + +ao_poly * +ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom); + +ao_poly +ao_lisp_atom_get(ao_poly atom); + +ao_poly +ao_lisp_atom_set(ao_poly atom, ao_poly val); + +/* int */ +void +ao_lisp_int_print(ao_poly i); + +/* prim */ +void +ao_lisp_poly_print(ao_poly p); + +void +ao_lisp_poly_patom(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); + +/* builtin */ +void +ao_lisp_builtin_print(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; + +#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); + +int +ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); + +void +ao_lisp_frame_print(ao_poly p); + +/* 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_print(ao_poly lambda); + +ao_poly +ao_lisp_lambda(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_lexpr(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_nlambda(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_macro(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_lambda_eval(void); + +/* save */ + +ao_poly +ao_lisp_save(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_restore(struct ao_lisp_cons *cons); + +/* 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_print(ao_poly stack); + +ao_poly +ao_lisp_stack_eval(void); + +ao_poly +ao_lisp_call_cc(struct ao_lisp_cons *cons); + +/* error */ + +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, ...); + +/* debugging macros */ + +#if DBG_EVAL +#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(...) 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 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)) +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 + +#define DBG_MEM_START 1 + +#if DBG_MEM + +#include <assert.h> +extern int dbg_move_depth; +#define MDBG_DUMP 1 +#define MDBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) + +extern int dbg_mem; + +#define MDBG_DO(a) 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 new file mode 100644 index 00000000..8c9e8ed1 --- /dev/null +++ b/src/lisp/ao_lisp_atom.c @@ -0,0 +1,165 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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; +} + +struct ao_lisp_frame *ao_lisp_frame_global; +struct ao_lisp_frame *ao_lisp_frame_current; + +static void +ao_lisp_atom_init(void) +{ + if (!ao_lisp_frame_global) + ao_lisp_frame_global = ao_lisp_frame_new(0); +} + +ao_poly * +ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) +{ + ao_poly *ref; + ao_lisp_atom_init(); + while (frame) { + ref = ao_lisp_frame_ref(frame, atom); + if (ref) + return ref; + frame = ao_lisp_poly_frame(frame->prev); + } + if (ao_lisp_frame_global) { + ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); + if (ref) + return ref; + } + return NULL; +} + +ao_poly +ao_lisp_atom_get(ao_poly atom) +{ + ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + + if (!ref && ao_lisp_frame_global) + ref = ao_lisp_frame_ref(ao_lisp_frame_global, 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(ao_lisp_frame_current, atom); + + if (!ref && ao_lisp_frame_global) + ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); + if (ref) + *ref = val; + else + ao_lisp_frame_add(&ao_lisp_frame_global, atom, val); + return val; +} + +void +ao_lisp_atom_print(ao_poly a) +{ + struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); + printf("%s", atom->name); +} diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c new file mode 100644 index 00000000..902f60e2 --- /dev/null +++ b/src/lisp/ao_lisp_builtin.c @@ -0,0 +1,619 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 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 +char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { + (void) b; + return "???"; +} +char *ao_lisp_args_name(uint8_t args) { + (void) args; + return "???"; +} +#else +static const ao_poly builtin_names[] = { + [builtin_eval] = _ao_lisp_atom_eval, + [builtin_read] = _ao_lisp_atom_read, + [builtin_lambda] = _ao_lisp_atom_lambda, + [builtin_lexpr] = _ao_lisp_atom_lexpr, + [builtin_nlambda] = _ao_lisp_atom_nlambda, + [builtin_macro] = _ao_lisp_atom_macro, + [builtin_car] = _ao_lisp_atom_car, + [builtin_cdr] = _ao_lisp_atom_cdr, + [builtin_cons] = _ao_lisp_atom_cons, + [builtin_last] = _ao_lisp_atom_last, + [builtin_length] = _ao_lisp_atom_length, + [builtin_quote] = _ao_lisp_atom_quote, + [builtin_set] = _ao_lisp_atom_set, + [builtin_setq] = _ao_lisp_atom_setq, + [builtin_cond] = _ao_lisp_atom_cond, + [builtin_progn] = _ao_lisp_atom_progn, + [builtin_while] = _ao_lisp_atom_while, + [builtin_print] = _ao_lisp_atom_print, + [builtin_patom] = _ao_lisp_atom_patom, + [builtin_plus] = _ao_lisp_atom_2b, + [builtin_minus] = _ao_lisp_atom_2d, + [builtin_times] = _ao_lisp_atom_2a, + [builtin_divide] = _ao_lisp_atom_2f, + [builtin_mod] = _ao_lisp_atom_25, + [builtin_equal] = _ao_lisp_atom_3d, + [builtin_less] = _ao_lisp_atom_3c, + [builtin_greater] = _ao_lisp_atom_3e, + [builtin_less_equal] = _ao_lisp_atom_3c3d, + [builtin_greater_equal] = _ao_lisp_atom_3e3d, + [builtin_pack] = _ao_lisp_atom_pack, + [builtin_unpack] = _ao_lisp_atom_unpack, + [builtin_flush] = _ao_lisp_atom_flush, + [builtin_delay] = _ao_lisp_atom_delay, + [builtin_led] = _ao_lisp_atom_led, + [builtin_save] = _ao_lisp_atom_save, + [builtin_restore] = _ao_lisp_atom_restore, + [builtin_call_cc] = _ao_lisp_atom_call2fcc, + [builtin_collect] = _ao_lisp_atom_collect, +#if 0 + [builtin_symbolp] = _ao_lisp_atom_symbolp, + [builtin_listp] = _ao_lisp_atom_listp, + [builtin_stringp] = _ao_lisp_atom_stringp, + [builtin_numberp] = _ao_lisp_atom_numberp, +#endif +}; + +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_LEXPR] = _ao_lisp_atom_lexpr, + [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_print(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_poly_cons(cons->cdr); + } + 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_atom_t; +} + +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_poly_cons(cons->cdr); + } + 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: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc); + return _ao_lisp_atom_t; +} + +ao_poly +ao_lisp_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_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_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; + if (!ao_lisp_check_argt(_ao_lisp_atom_cons, cons, 1, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + car = ao_lisp_arg(cons, 0); + cdr = ao_lisp_arg(cons, 1); + return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr))); +} + +ao_poly +ao_lisp_last(struct ao_lisp_cons *cons) +{ + ao_poly l; + 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); + if (!list->cdr) + return list->car; + l = list->cdr; + } + return AO_LISP_NIL; +} + +ao_poly +ao_lisp_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_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_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_setq(struct ao_lisp_cons *cons) +{ + struct ao_lisp_cons *expand = 0; + if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) + return AO_LISP_NIL; + expand = ao_lisp_cons_cons(_ao_lisp_atom_set, + ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote, + ao_lisp_cons_cons(cons->car, NULL))), + ao_lisp_poly_cons(cons->cdr))); + return ao_lisp_cons_poly(expand); +} + +ao_poly +ao_lisp_cond(struct ao_lisp_cons *cons) +{ + ao_lisp_set_cond(cons); + return AO_LISP_NIL; +} + +ao_poly +ao_lisp_progn(struct ao_lisp_cons *cons) +{ + ao_lisp_stack->state = eval_progn; + ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); + return AO_LISP_NIL; +} + +ao_poly +ao_lisp_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_print(struct ao_lisp_cons *cons) +{ + ao_poly val = AO_LISP_NIL; + while (cons) { + val = cons->car; + ao_lisp_poly_print(val); + cons = ao_lisp_poly_cons(cons->cdr); + if (cons) + printf(" "); + } + printf("\n"); + return val; +} + +ao_poly +ao_lisp_patom(struct ao_lisp_cons *cons) +{ + ao_poly val = AO_LISP_NIL; + while (cons) { + val = cons->car; + ao_lisp_poly_patom(val); + cons = ao_lisp_poly_cons(cons->cdr); + } + return val; +} + +ao_poly +ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) +{ + ao_poly ret = AO_LISP_NIL; + + while (cons) { + ao_poly car = cons->car; + uint8_t rt = ao_lisp_poly_type(ret); + uint8_t ct = ao_lisp_poly_type(car); + + cons = ao_lisp_poly_cons(cons->cdr); + + if (rt == AO_LISP_NIL) + ret = car; + + else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { + int r = ao_lisp_poly_int(ret); + int c = ao_lisp_poly_int(car); + + switch(op) { + case builtin_plus: + r += c; + break; + case builtin_minus: + r -= c; + break; + case builtin_times: + r *= c; + break; + case builtin_divide: + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); + r /= c; + break; + case builtin_mod: + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); + r %= c; + break; + default: + break; + } + ret = ao_lisp_int_poly(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_plus(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_plus); +} + +ao_poly +ao_lisp_minus(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_minus); +} + +ao_poly +ao_lisp_times(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_times); +} + +ao_poly +ao_lisp_divide(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_divide); +} + +ao_poly +ao_lisp_mod(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_mod); +} + +ao_poly +ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) +{ + ao_poly left; + + if (!cons) + return _ao_lisp_atom_t; + + left = cons->car; + cons = ao_lisp_poly_cons(cons->cdr); + while (cons) { + ao_poly right = cons->car; + + if (op == builtin_equal) { + if (left != right) + return AO_LISP_NIL; + } 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); + + switch (op) { + case builtin_less: + if (!(l < r)) + return AO_LISP_NIL; + break; + case builtin_greater: + if (!(l > r)) + return AO_LISP_NIL; + break; + case builtin_less_equal: + if (!(l <= r)) + return AO_LISP_NIL; + break; + case builtin_greater_equal: + if (!(l >= r)) + return AO_LISP_NIL; + 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_NIL; + break; + case builtin_greater: + if (!(c > 0)) + return AO_LISP_NIL; + break; + case builtin_less_equal: + if (!(c <= 0)) + return AO_LISP_NIL; + break; + case builtin_greater_equal: + if (!(c >= 0)) + return AO_LISP_NIL; + break; + default: + break; + } + } + } + left = right; + cons = ao_lisp_poly_cons(cons->cdr); + } + return _ao_lisp_atom_t; +} + +ao_poly +ao_lisp_equal(struct ao_lisp_cons *cons) +{ + return ao_lisp_compare(cons, builtin_equal); +} + +ao_poly +ao_lisp_less(struct ao_lisp_cons *cons) +{ + return ao_lisp_compare(cons, builtin_less); +} + +ao_poly +ao_lisp_greater(struct ao_lisp_cons *cons) +{ + return ao_lisp_compare(cons, builtin_greater); +} + +ao_poly +ao_lisp_less_equal(struct ao_lisp_cons *cons) +{ + return ao_lisp_compare(cons, builtin_less_equal); +} + +ao_poly +ao_lisp_greater_equal(struct ao_lisp_cons *cons) +{ + return ao_lisp_compare(cons, builtin_greater_equal); +} + +ao_poly +ao_lisp_pack(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_pack, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_pack, 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_unpack(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_unpack, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_unpack, 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_flush(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_flush, cons, 0, 0)) + return AO_LISP_NIL; + ao_lisp_os_flush(); + return _ao_lisp_atom_t; +} + +ao_poly +ao_lisp_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_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_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); +} + +const ao_lisp_func_t ao_lisp_builtins[] = { + [builtin_eval] = ao_lisp_do_eval, + [builtin_read] = ao_lisp_do_read, + [builtin_lambda] = ao_lisp_lambda, + [builtin_lexpr] = ao_lisp_lexpr, + [builtin_nlambda] = ao_lisp_nlambda, + [builtin_macro] = ao_lisp_macro, + [builtin_car] = ao_lisp_car, + [builtin_cdr] = ao_lisp_cdr, + [builtin_cons] = ao_lisp_cons, + [builtin_last] = ao_lisp_last, + [builtin_length] = ao_lisp_length, + [builtin_quote] = ao_lisp_quote, + [builtin_set] = ao_lisp_set, + [builtin_setq] = ao_lisp_setq, + [builtin_cond] = ao_lisp_cond, + [builtin_progn] = ao_lisp_progn, + [builtin_while] = ao_lisp_while, + [builtin_print] = ao_lisp_print, + [builtin_patom] = ao_lisp_patom, + [builtin_plus] = ao_lisp_plus, + [builtin_minus] = ao_lisp_minus, + [builtin_times] = ao_lisp_times, + [builtin_divide] = ao_lisp_divide, + [builtin_mod] = ao_lisp_mod, + [builtin_equal] = ao_lisp_equal, + [builtin_less] = ao_lisp_less, + [builtin_greater] = ao_lisp_greater, + [builtin_less_equal] = ao_lisp_less_equal, + [builtin_greater_equal] = ao_lisp_greater_equal, + [builtin_pack] = ao_lisp_pack, + [builtin_unpack] = ao_lisp_unpack, + [builtin_flush] = ao_lisp_flush, + [builtin_led] = ao_lisp_led, + [builtin_delay] = ao_lisp_delay, + [builtin_save] = ao_lisp_save, + [builtin_restore] = ao_lisp_restore, + [builtin_call_cc] = ao_lisp_call_cc, + [builtin_collect] = ao_lisp_do_collect, +}; + diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c new file mode 100644 index 00000000..d2b60c9a --- /dev/null +++ b/src/lisp/ao_lisp_cons.c @@ -0,0 +1,143 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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_lisp_poly_mark(cons->car, 1); + cons = ao_lisp_poly_cons(cons->cdr); + if (!cons) + break; + 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 (;;) { + struct ao_lisp_cons *cdr; + 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 = ao_lisp_poly_cons(cons->cdr); + if (!cdr) + break; + ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &cdr); + if (cdr != ao_lisp_poly_cons(cons->cdr)) + cons->cdr = ao_lisp_cons_poly(cdr); + 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 = cdr; + } +} + +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, struct ao_lisp_cons *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_cons_stash(0, cdr); + cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); + car = ao_lisp_poly_fetch(0); + cdr = ao_lisp_cons_fetch(0); + if (!cons) + return NULL; + } + cons->car = car; + cons->cdr = ao_lisp_cons_poly(cdr); + return cons; +} + +void +ao_lisp_cons_free(struct ao_lisp_cons *cons) +{ + 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_print(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_print(cons->car); + cons = ao_lisp_poly_cons(cons->cdr); + first = 0; + } + printf(")"); +} + +void +ao_lisp_cons_patom(ao_poly c) +{ + struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); + + while (cons) { + ao_lisp_poly_patom(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 new file mode 100644 index 00000000..3c8fd21b --- /dev/null +++ b/src/lisp/ao_lisp_const.lisp @@ -0,0 +1,184 @@ +; +; Copyright © 2016 Keith Packard <keithp@keithp.com> +; +; 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 + +(set (quote list) (lexpr (l) l)) + + ; + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated + ; + +(setq def (macro (name val rest) + (list + 'progn + (list + 'set + (list 'quote name) + val) + (list 'quote name) + ) + ) + ) + + ; + ; A slightly more convenient form + ; for defining lambdas. + ; + ; (defun <name> (<params>) s-exprs) + ; + +(def defun (macro (name args exprs) + (list + def + name + (cons 'lambda (cons args exprs)) + ) + ) + ) + + ; basic list accessors + + +(defun cadr (l) (car (cdr l))) + +(defun caddr (l) (car (cdr (cdr l)))) + +(defun nth (list n) + (cond ((= n 0) (car list)) + ((nth (cdr list) (1- n))) + ) + ) + + ; simple math operators + +(defun 1+ (x) (+ x 1)) +(defun 1- (x) (- x 1)) + + ; define a set of local + ; variables 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)) (setq y (+ x 1)) y) + +(def let (macro (vars exprs) + ((lambda (make-names make-exprs make-nils) + + ; + ; make the list of names in the let + ; + + (setq make-names (lambda (vars) + (cond (vars + (cons (car (car vars)) + (make-names (cdr vars)))) + ) + ) + ) + + ; the set of expressions is + ; the list of set expressions + ; pre-pended to the + ; expressions to evaluate + + (setq make-exprs (lambda (vars exprs) + (cond (vars (cons + (list set + (list quote + (car (car vars)) + ) + (cadr (car vars)) + ) + (make-exprs (cdr vars) exprs) + ) + ) + (exprs) + ) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (setq make-nils (lambda (vars) + (cond (vars (cons nil (make-nils (cdr vars)))) + ) + ) + ) + ; prepend the set operations + ; to the expressions + + (setq exprs (make-exprs vars exprs)) + + ; build the lambda. + + (cons (cons 'lambda (cons (make-names vars) exprs)) + (make-nils vars) + ) + ) + () + () + () + ) + ) + ) + + ; boolean operators + +(def or (lexpr (l) + (let ((ret nil)) + (while l + (cond ((setq ret (car l)) + (setq l nil)) + ((setq l (cdr l))))) + ret + ) + ) + ) + + ; execute to resolve macros + +(or nil t) + +(def and (lexpr (l) + (let ((ret t)) + (while l + (cond ((setq ret (car l)) + (setq l (cdr l))) + ((setq ret (setq l nil))) + ) + ) + ret + ) + ) + ) + + ; execute to resolve macros + +(and t nil) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c new file mode 100644 index 00000000..54a9be10 --- /dev/null +++ b/src/lisp/ao_lisp_error.c @@ -0,0 +1,102 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 <stdarg.h> + +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_print(cons->car); + printf("\n"); + if (poly == last) + break; + poly = cons->cdr; + } + printf("\t\t )\n"); + } else + printf(")\n"); + } else { + ao_lisp_poly_print(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) { + 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_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->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"); +} + + +ao_poly +ao_lisp_error(int error, char *format, ...) +{ + va_list args; + + ao_lisp_exception |= error; + va_start(args, format); + vprintf(format, args); + va_end(args); + printf("\n"); + printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); + printf("Stack:\n"); + ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)); + printf("Globals:\n\t"); + ao_lisp_frame_print(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 new file mode 100644 index 00000000..3be7c9c4 --- /dev/null +++ b/src/lisp/ao_lisp_eval.c @@ -0,0 +1,531 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 <assert.h> + +struct ao_lisp_stack *ao_lisp_stack; +ao_poly ao_lisp_v; + +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: "); DBG_POLY(ao_lisp_v); DBG("\n"); + 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_INT: + 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/lexpr or macro/nlambda. + * + * For lambda/lexpr, 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: + case AO_LISP_FUNC_LEXPR: + DBGI(".. lambda or lexpr\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(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. 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_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); + 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->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack)) + ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); + + 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_progn; + 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; + } + 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_NIL; + 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; + 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) { + 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_progn; + 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_progn 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_progn 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_progn(void) +{ + DBGI("progn: "); 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_progn; + 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_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_progn; + 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_cond] = ao_lisp_eval_cond, + [eval_cond_test] = ao_lisp_eval_cond_test, + [eval_progn] = ao_lisp_eval_progn, + [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[] = { + "sexpr", + "val", + "formal", + "exec", + "cond", + "cond_test", + "progn", +}; + +/* + * 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; + + 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_frame.c b/src/lisp/ao_lisp_frame.c new file mode 100644 index 00000000..05f6d253 --- /dev/null +++ b/src/lisp/ao_lisp_frame.c @@ -0,0 +1,293 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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_num_size(int num) +{ + return sizeof (struct ao_lisp_frame) + num * sizeof (struct ao_lisp_val); +} + +static int +frame_size(void *addr) +{ + struct ao_lisp_frame *frame = addr; + return frame_num_size(frame->num); +} + +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); + } + 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; + int f; + + for (;;) { + struct ao_lisp_frame *prev; + int ret; + + 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); + } + 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_print(ao_poly p) +{ + struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); + 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_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + } + if (frame->prev) + ao_lisp_poly_print(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) +{ + int l = 0; + int r = top - 1; + while (l <= r) { + int m = (l + r) >> 1; + if (frame->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) +{ + int l = ao_lisp_frame_find(frame, frame->num, atom); + + if (l >= frame->num) + return NULL; + + if (frame->vals[l].atom != atom) + return NULL; + return &frame->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; +} + +ao_poly +ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) +{ + 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 *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; + +struct ao_lisp_frame * +ao_lisp_frame_new(int num) +{ + struct ao_lisp_frame *frame; + + 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)); + if (!frame) + return NULL; + } + frame->type = AO_LISP_FRAME; + frame->num = num; + frame->prev = AO_LISP_NIL; + memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); + 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 (!ao_lisp_frame_marked(frame)) { + int num = frame->num; + if (num < AO_LISP_FRAME_FREE) { + 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_ref, int new_num) +{ + struct ao_lisp_frame *frame = *frame_ref; + struct ao_lisp_frame *new; + int copy; + + if (new_num == frame->num) + return frame; + new = ao_lisp_frame_new(new_num); + if (!new) + return NULL; + /* + * Re-fetch the frame as it may have moved + * during the allocation + */ + frame = *frame_ref; + 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; +} + +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); + + memmove(&frame->vals[l+1], + &frame->vals[l], + (num - l) * sizeof (struct ao_lisp_val)); + frame->vals[l].atom = atom; + frame->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; + ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; + + if (!ref) { + int f; + ao_lisp_poly_stash(0, atom); + ao_lisp_poly_stash(1, val); + if (frame) { + f = frame->num; + frame = ao_lisp_frame_realloc(frame_ref, f + 1); + } else { + f = 0; + frame = ao_lisp_frame_new(1); + } + 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); + } else + *ref = val; + return 1; +} diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c new file mode 100644 index 00000000..77f65e95 --- /dev/null +++ b/src/lisp/ao_lisp_int.c @@ -0,0 +1,22 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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_print(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 new file mode 100644 index 00000000..526863c5 --- /dev/null +++ b/src/lisp/ao_lisp_lambda.c @@ -0,0 +1,196 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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_print(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_print(cons->car); + cons = ao_lisp_poly_cons(cons->cdr); + } + printf(")"); +} + +ao_poly +ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) +{ + ao_lisp_cons_stash(0, code); + struct ao_lisp_lambda *lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); + code = ao_lisp_cons_fetch(0); + struct ao_lisp_cons *arg; + int f; + + if (!lambda) + return AO_LISP_NIL; + + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + f = 0; + arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + while (arg) { + if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f); + arg = ao_lisp_poly_cons(arg->cdr); + f++; + } + + 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_lambda(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); +} + +ao_poly +ao_lisp_lexpr(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR); +} + +ao_poly +ao_lisp_nlambda(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); +} + +ao_poly +ao_lisp_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); + struct ao_lisp_cons *args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + struct ao_lisp_frame *next_frame; + int args_wanted; + int args_provided; + int f; + struct ao_lisp_cons *vals; + + DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); + + args_wanted = ao_lisp_cons_length(args); + + /* Create a frame to hold the variables + */ + args_provided = ao_lisp_cons_length(cons) - 1; + if (lambda->args == AO_LISP_FUNC_LAMBDA) { + 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 - 1) + return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided); + } + + next_frame = ao_lisp_frame_new(args_wanted); + + /* 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); + args = ao_lisp_poly_cons(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); + + switch (lambda->args) { + case AO_LISP_FUNC_LAMBDA: + for (f = 0; f < args_wanted; f++) { + DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + ao_lisp_frame_bind(next_frame, f, args->car, vals->car); + args = ao_lisp_poly_cons(args->cdr); + vals = ao_lisp_poly_cons(vals->cdr); + } + if (!ao_lisp_stack_marked(ao_lisp_stack)) + ao_lisp_cons_free(cons); + cons = NULL; + break; + case AO_LISP_FUNC_LEXPR: + case AO_LISP_FUNC_NLAMBDA: + case AO_LISP_FUNC_MACRO: + for (f = 0; f < args_wanted - 1; f++) { + DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + ao_lisp_frame_bind(next_frame, f, args->car, vals->car); + args = ao_lisp_poly_cons(args->cdr); + vals = ao_lisp_poly_cons(vals->cdr); + } + DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); + ao_lisp_frame_bind(next_frame, f, args->car, ao_lisp_cons_poly(vals)); + break; + default: + break; + } + 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 new file mode 100644 index 00000000..fe7c47f4 --- /dev/null +++ b/src/lisp/ao_lisp_lex.c @@ -0,0 +1,16 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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_const.c b/src/lisp/ao_lisp_make_const.c new file mode 100644 index 00000000..49f989e6 --- /dev/null +++ b/src/lisp/ao_lisp_make_const.c @@ -0,0 +1,423 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 <stdlib.h> +#include <ctype.h> +#include <unistd.h> +#include <getopt.h> + +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; + int func; +}; + +struct builtin_func funcs[] = { + { .name = "eval", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_eval }, + { .name = "read", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_read }, + { .name = "lambda", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_lambda }, + { .name = "lexpr", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_lexpr }, + { .name = "nlambda", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_nlambda }, + { .name = "macro", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_macro }, + { .name = "car", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_car }, + { .name = "cdr", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_cdr }, + { .name = "cons", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_cons }, + { .name = "last", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_last }, + { .name = "length", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_length }, + { .name = "quote", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_quote }, + { .name = "set", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_set }, + { .name = "setq", .args = AO_LISP_FUNC_MACRO, .func = builtin_setq }, + { .name = "cond", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_cond }, + { .name = "progn", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_progn }, + { .name = "while", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_while }, + { .name = "print", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_print }, + { .name = "patom", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_patom }, + { .name = "+", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_plus }, + { .name = "-", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_minus }, + { .name = "*", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_times }, + { .name = "/", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_divide }, + { .name = "%", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_mod }, + { .name = "=", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_equal }, + { .name = "<", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_less }, + { .name = ">", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_greater }, + { .name = "<=", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_less_equal }, + { .name = ">=", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_greater_equal }, + { .name = "pack", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_pack }, + { .name = "unpack", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_unpack }, + { .name = "flush", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_flush }, + { .name = "delay", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_delay }, + { .name = "led", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_led }, + { .name = "save", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_save }, + { .name = "restore", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_restore }, + { .name = "call/cc", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_call_cc }, + { .name = "collect", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_collect }, +}; + +#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(ao_lisp_frame_global, 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_print(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_print(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; + + 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); + 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; + + cons = ao_lisp_poly_cons(cons->cdr); + p = AO_LISP_NIL; + while (cons) { + m = ao_has_macro(cons->car); + if (m) { + p = m; + break; + } + cons = ao_lisp_poly_cons(cons->cdr); + } + break; + + default: + p = AO_LISP_NIL; + break; + } + MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_lisp_poly_print(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_print(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=<output>] [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; + + 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; + } + } + + for (f = 0; f < (int) N_FUNC; f++) { + 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)); + } + + /* boolean constants */ + ao_lisp_atom_set(ao_lisp_atom_poly(ao_lisp_atom_intern("nil")), + AO_LISP_NIL); + a = ao_lisp_atom_intern("t"); + ao_lisp_atom_set(ao_lisp_atom_poly(a), + ao_lisp_atom_poly(a)); + + /* end of file value */ + a = ao_lisp_atom_intern("eof"); + ao_lisp_atom_set(ao_lisp_atom_poly(a), + ao_lisp_atom_poly(a)); + + 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++) { + val = ao_has_macro(ao_lisp_frame_global->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_print(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)); + + + 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 new file mode 100644 index 00000000..d067ea07 --- /dev/null +++ b/src/lisp/ao_lisp_mem.c @@ -0,0 +1,880 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 <stdio.h> + +#ifdef AO_LISP_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + +#include <stdlib.h> +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 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 = 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, + }, +}; + +#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 const *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_LAMBDA] = &ao_lisp_lambda_type, + [AO_LISP_STACK] = &ao_lisp_stack_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 + + /* 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; +} + +/* + * Mark interfaces for objects + */ + +/* + * 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; + return addr; +} + +void +ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) +{ + 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) +{ + 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) +{ + save_string[id] = string; +} + +char * +ao_lisp_string_fetch(int id) +{ + char *string = save_string[id]; + save_string[id] = NULL; + return string; +} + diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h new file mode 100644 index 00000000..5fa3686b --- /dev/null +++ b/src/lisp/ao_lisp_os.h @@ -0,0 +1,53 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 <stdio.h> +#include <stdlib.h> +#include <time.h> + +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); +} + +static inline void +ao_lisp_os_delay(int delay) +{ + struct timespec ts = { + .tv_sec = delay / 1000, + .tv_nsec = (delay % 1000) * 1000000, + }; + nanosleep(&ts, NULL); +} +#endif diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c new file mode 100644 index 00000000..fb3b06fe --- /dev/null +++ b/src/lisp/ao_lisp_poly.c @@ -0,0 +1,102 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 (*print)(ao_poly); + void (*patom)(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, + }, + [AO_LISP_STRING] = { + .print = ao_lisp_string_print, + .patom = ao_lisp_string_patom, + }, + [AO_LISP_INT] = { + .print = ao_lisp_int_print, + .patom = ao_lisp_int_print, + }, + [AO_LISP_ATOM] = { + .print = ao_lisp_atom_print, + .patom = ao_lisp_atom_print, + }, + [AO_LISP_BUILTIN] = { + .print = ao_lisp_builtin_print, + .patom = ao_lisp_builtin_print, + }, + [AO_LISP_FRAME] = { + .print = ao_lisp_frame_print, + .patom = ao_lisp_frame_print, + }, + [AO_LISP_LAMBDA] = { + .print = ao_lisp_lambda_print, + .patom = ao_lisp_lambda_print, + }, + [AO_LISP_STACK] = { + .print = ao_lisp_stack_print, + .patom = ao_lisp_stack_print, + }, +}; + +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_print(ao_poly p) +{ + const struct ao_lisp_funcs *f = funcs(p); + + if (f && f->print) + f->print(p); +} + +void +ao_lisp_poly_patom(ao_poly p) +{ + const struct ao_lisp_funcs *f = funcs(p); + + if (f && f->patom) + f->patom(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 new file mode 100644 index 00000000..84ef2a61 --- /dev/null +++ b/src/lisp/ao_lisp_read.c @@ -0,0 +1,498 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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" + +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|COMMENT, /* # */ + PRINTABLE, /* $ */ + PRINTABLE, /* % */ + PRINTABLE, /* & */ + PRINTABLE|QUOTEC, /* ' */ + PRINTABLE|BRA, /* ( */ + PRINTABLE|KET, /* ) */ + PRINTABLE, /* * */ + PRINTABLE|SIGN, /* + */ + PRINTABLE, /* , */ + PRINTABLE|SIGN, /* - */ + PRINTABLE, /* . */ + 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, /* 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, /* ` */ + PRINTABLE, /* a */ + PRINTABLE, /* b */ + PRINTABLE, /* c */ + PRINTABLE, /* d */ + PRINTABLE, /* 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|VBAR, /* | */ + PRINTABLE, /* } */ + PRINTABLE|TWIDDLE, /* ~ */ + 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 int +lex_quoted (void) +{ + int c; + int v; + int count; + + c = lex_get(); + if (c == EOF) + return EOF; + 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; + } +} + +static uint16_t lex_class; + +static int +lexc(void) +{ + int c; + do { + c = lex_get(); + if (c == EOF) { + lex_class = ENDOFFILE; + c = 0; + } else { + c &= 0x7f; + lex_class = lex_classes[c]; + if (lex_class & BACKSLASH) { + c = lex_quoted(); + if (c == EOF) + lex_class = ENDOFFILE; + else + lex_class = PRINTABLE; + } + } + } while (lex_class & IGNORE); + return c; +} + +#define AO_LISP_TOKEN_MAX 32 + +static char token_string[AO_LISP_TOKEN_MAX]; +static int token_int; +static int token_len; + +static inline void add_token(int c) { + if (c && token_len < AO_LISP_TOKEN_MAX - 1) + token_string[token_len++] = c; +} + +static inline void end_token(void) { + token_string[token_len] = '\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 & (BRA|KET|QUOTEC)) { + add_token(c); + end_token(); + switch (c) { + case '(': + return OPEN; + case ')': + return CLOSE; + case '\'': + return QUOTE; + } + } + if (lex_class & TWIDDLE) { + token_int = lexc(); + return NUM; + } + if (lex_class & STRINGC) { + for (;;) { + c = lexc(); + if (lex_class & (STRINGC|ENDOFFILE)) { + end_token(); + return STRING; + } + add_token(c); + } + } + if (lex_class & PRINTABLE) { + int isnum; + int hasdigit; + int isneg; + + isnum = 1; + hasdigit = 0; + token_int = 0; + isneg = 0; + for (;;) { + if (!(lex_class & NUMBER)) { + isnum = 0; + } else { + if (token_len != 0 && + (lex_class & SIGN)) + { + isnum = 0; + } + if (c == '-') + isneg = 1; + if (lex_class & DIGIT) { + hasdigit = 1; + if (isnum) + token_int = token_int * 10 + c - '0'; + } + } + add_token (c); + c = lexc (); + if (lex_class & (NOTNAME)) { +// if (lex_class & ENDOFFILE) +// clearerr (f); + lex_unget(c); + end_token (); + if (isnum && hasdigit) { + if (isneg) + token_int = -token_int; + return NUM; + } + return NAME; + } + } + + } + } +} + +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; + +static int +push_read_stack(int cons, int in_quote) +{ + DBGI("push read stack %p %d\n", ao_lisp_read_cons, in_quote); + DBG_IN(); + if (cons) { + ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), + ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), + 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 in_quote = 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); + in_quote = 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; + } + DBG_OUT(); + DBGI("pop read stack %p %d\n", ao_lisp_read_cons, in_quote); + return in_quote; +} + +ao_poly +ao_lisp_read(void) +{ + struct ao_lisp_atom *atom; + char *string; + int cons; + int in_quote; + ao_poly v; + + parse_token = lex(); + DBGI("token %d (%s)\n", parse_token, token_string); + + cons = 0; + in_quote = 0; + ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; + for (;;) { + while (parse_token == OPEN) { + if (!push_read_stack(cons, in_quote)) + return AO_LISP_NIL; + cons++; + in_quote = 0; + parse_token = lex(); + DBGI("token %d (%s)\n", parse_token, token_string); + } + + 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_int_poly(token_int); + 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: + if (!push_read_stack(cons, in_quote)) + return AO_LISP_NIL; + cons++; + in_quote = 1; + v = _ao_lisp_atom_quote; + break; + case CLOSE: + if (!cons) { + v = AO_LISP_NIL; + break; + } + v = ao_lisp_cons_poly(ao_lisp_read_cons); + --cons; + in_quote = pop_read_stack(cons); + break; + } + + /* loop over QUOTE ends */ + for (;;) { + if (!cons) + return v; + + struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); + 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 (!in_quote || !ao_lisp_read_cons->cdr) + break; + + v = ao_lisp_cons_poly(ao_lisp_read_cons); + --cons; + in_quote = pop_read_stack(cons); + } + + parse_token = lex(); + DBGI("token %d (%s)\n", parse_token, token_string); + } + return v; +} diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h new file mode 100644 index 00000000..1c994d56 --- /dev/null +++ b/src/lisp/ao_lisp_read.h @@ -0,0 +1,49 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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_ + +# define END 0 +# define NAME 1 +# define OPEN 2 +# define CLOSE 3 +# define QUOTE 4 +# define STRING 5 +# define NUM 6 + +/* + * character classes + */ + +# define PRINTABLE 0x00000001 /* \t \n ' ' - '~' */ +# define QUOTED 0x00000002 /* \ anything */ +# define BRA 0x00000004 /* ( [ { */ +# define KET 0x00000008 /* ) ] } */ +# define WHITE 0x00000010 /* ' ' \t \n */ +# define DIGIT 0x00000020 /* [0-9] */ +# define SIGN 0x00000040 /* +- */ +# define ENDOFFILE 0x00000080 /* end of file */ +# define COMMENT 0x00000100 /* ; # */ +# define IGNORE 0x00000200 /* \0 - ' ' */ +# define QUOTEC 0x00000400 /* ' */ +# define BACKSLASH 0x00000800 /* \ */ +# define VBAR 0x00001000 /* | */ +# define TWIDDLE 0x00002000 /* ~ */ +# define STRINGC 0x00004000 /* " */ + +# define NOTNAME (STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA) +# define NUMBER (DIGIT|SIGN) + +#endif /* _AO_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c new file mode 100644 index 00000000..3be95d44 --- /dev/null +++ b/src/lisp/ao_lisp_rep.c @@ -0,0 +1,34 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 || in == AO_LISP_NIL) + break; + out = ao_lisp_eval(in); + if (ao_lisp_exception) { + ao_lisp_exception = 0; + } else { + ao_lisp_poly_print(out); + putchar ('\n'); + } + } + return out; +} diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c new file mode 100644 index 00000000..4f850fb9 --- /dev/null +++ b/src/lisp/ao_lisp_save.c @@ -0,0 +1,76 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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_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_atom_t; +#endif + return AO_LISP_NIL; +} + +ao_poly +ao_lisp_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_NIL; + return _ao_lisp_atom_t; + } +#endif + return AO_LISP_NIL; +} diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c new file mode 100644 index 00000000..53adf432 --- /dev/null +++ b/src/lisp/ao_lisp_stack.c @@ -0,0 +1,278 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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 = 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_print(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_print(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_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_progn; + return AO_LISP_NIL; +} diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c new file mode 100644 index 00000000..cd7b27a9 --- /dev/null +++ b/src/lisp/ao_lisp_string.c @@ -0,0 +1,158 @@ +/* + * Copyright © 2016 Keith Packard <keithp@keithp.com> + * + * 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_poly_type(cons->car) != AO_LISP_INT) + return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); + *s++ = ao_lisp_poly_int(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), NULL); + 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_print(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: + putchar(c); + break; + } + } + putchar('"'); +} + +void +ao_lisp_string_patom(ao_poly p) +{ + char *s = ao_lisp_poly_string(p); + char c; + + while ((c = *s++)) + putchar(c); +} |