diff options
author | Keith Packard <keithp@keithp.com> | 2017-12-05 10:29:13 -0800 |
---|---|---|
committer | Keith Packard <keithp@keithp.com> | 2017-12-05 10:30:32 -0800 |
commit | 195cbeec19a6a44f309a9040d727d37fe4e2ec97 (patch) | |
tree | ac417ad545a391da52b845b378b7655fc42d5cf4 /src/scheme | |
parent | 9dbc686ad7d3289dc0f9bcf4a973f71100e02ded (diff) |
altos/scheme: Rename to 'scheme', clean up build
Constant block is now built in a subdir to avoid messing up source
directory.
Renamed to ao_scheme to reflect language target.
Signed-off-by: Keith Packard <keithp@keithp.com>
Diffstat (limited to 'src/scheme')
32 files changed, 7700 insertions, 0 deletions
diff --git a/src/scheme/.gitignore b/src/scheme/.gitignore new file mode 100644 index 00000000..ee72cb9d --- /dev/null +++ b/src/scheme/.gitignore @@ -0,0 +1,2 @@ +ao_scheme_const.h +ao_scheme_builtin.h diff --git a/src/scheme/Makefile b/src/scheme/Makefile new file mode 100644 index 00000000..d8e4b553 --- /dev/null +++ b/src/scheme/Makefile @@ -0,0 +1,16 @@ +all: ao_scheme_builtin.h ao_scheme_const.h + +clean: + +cd make-const && make clean + rm -f ao_scheme_const.h ao_scheme_builtin.h + +ao_scheme_const.h: ao_scheme_const.lisp make-const/ao_scheme_make_const + make-const/ao_scheme_make_const -o $@ ao_scheme_const.lisp + +ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt + nickle ao_scheme_make_builtin ao_scheme_builtin.txt > $@ + +make-const/ao_scheme_make_const: FRC + +cd make-const && make ao_scheme_make_const + +FRC: diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc new file mode 100644 index 00000000..d23ee3d7 --- /dev/null +++ b/src/scheme/Makefile-inc @@ -0,0 +1,24 @@ +SCHEME_SRCS=\ + ao_scheme_mem.c \ + ao_scheme_cons.c \ + ao_scheme_string.c \ + ao_scheme_atom.c \ + ao_scheme_int.c \ + ao_scheme_poly.c \ + ao_scheme_bool.c \ + ao_scheme_float.c \ + ao_scheme_builtin.c \ + ao_scheme_read.c \ + ao_scheme_frame.c \ + ao_scheme_lambda.c \ + ao_scheme_eval.c \ + ao_scheme_rep.c \ + ao_scheme_save.c \ + ao_scheme_stack.c \ + ao_scheme_error.c + +SCHEME_HDRS=\ + ao_scheme.h \ + ao_scheme_os.h \ + ao_scheme_read.h \ + ao_scheme_builtin.h diff --git a/src/scheme/Makefile-scheme b/src/scheme/Makefile-scheme new file mode 100644 index 00000000..2427cffa --- /dev/null +++ b/src/scheme/Makefile-scheme @@ -0,0 +1,4 @@ +include ../lisp/Makefile-inc + +ao_scheme_const.h: $(LISP_SRCS) $(LISP_HDRS) + +cd ../lisp && make $@ diff --git a/src/scheme/README b/src/scheme/README new file mode 100644 index 00000000..98932b44 --- /dev/null +++ b/src/scheme/README @@ -0,0 +1,10 @@ +This follows the R7RS with the following known exceptions: + +* No vectors or bytevectors +* Characters are just numbers +* No dynamic-wind or exceptions +* No environments +* No ports +* No syntax-rules; (have classic macros) +* No record types +* No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h new file mode 100644 index 00000000..4589f8a5 --- /dev/null +++ b/src/scheme/ao_scheme.h @@ -0,0 +1,928 @@ +/* + * Copyright © 2016 Keith Packard <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_SCHEME_H_ +#define _AO_SCHEME_H_ + +#define DBG_MEM 0 +#define DBG_EVAL 0 +#define DBG_READ 0 +#define DBG_FREE_CONS 0 +#define NDEBUG 1 + +#include <stdint.h> +#include <string.h> +#include <ao_scheme_os.h> +#ifndef __BYTE_ORDER +#include <endian.h> +#endif + +typedef uint16_t ao_poly; +typedef int16_t ao_signed_poly; + +#ifdef AO_SCHEME_SAVE + +struct ao_scheme_os_save { + ao_poly atoms; + ao_poly globals; + uint16_t const_checksum; + uint16_t const_checksum_inv; +}; + +#define AO_SCHEME_POOL_EXTRA (sizeof(struct ao_scheme_os_save)) +#define AO_SCHEME_POOL ((int) (AO_SCHEME_POOL_TOTAL - AO_SCHEME_POOL_EXTRA)) + +int +ao_scheme_os_save(void); + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset); + +int +ao_scheme_os_restore(void); + +#endif + +#ifdef AO_SCHEME_MAKE_CONST +#define AO_SCHEME_POOL_CONST 16384 +extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#define _atom(n) ao_scheme_atom_poly(ao_scheme_atom_intern(n)) +#define _bool(v) ao_scheme_bool_poly(ao_scheme_bool_get(v)) + +#define _ao_scheme_bool_true _bool(1) +#define _ao_scheme_bool_false _bool(0) + +#define _ao_scheme_atom_eof _atom("eof") +#define _ao_scheme_atom_else _atom("else") + +#define AO_SCHEME_BUILTIN_ATOMS +#include "ao_scheme_builtin.h" + +#else +#include "ao_scheme_const.h" +#ifndef AO_SCHEME_POOL +#define AO_SCHEME_POOL 3072 +#endif +extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); +#endif + +/* Primitive types */ +#define AO_SCHEME_CONS 0 +#define AO_SCHEME_INT 1 +#define AO_SCHEME_STRING 2 +#define AO_SCHEME_OTHER 3 + +#define AO_SCHEME_TYPE_MASK 0x0003 +#define AO_SCHEME_TYPE_SHIFT 2 +#define AO_SCHEME_REF_MASK 0x7ffc +#define AO_SCHEME_CONST 0x8000 + +/* These have a type value at the start of the struct */ +#define AO_SCHEME_ATOM 4 +#define AO_SCHEME_BUILTIN 5 +#define AO_SCHEME_FRAME 6 +#define AO_SCHEME_FRAME_VALS 7 +#define AO_SCHEME_LAMBDA 8 +#define AO_SCHEME_STACK 9 +#define AO_SCHEME_BOOL 10 +#define AO_SCHEME_BIGINT 11 +#define AO_SCHEME_FLOAT 12 +#define AO_SCHEME_NUM_TYPE 13 + +/* Leave two bits for types to use as they please */ +#define AO_SCHEME_OTHER_TYPE_MASK 0x3f + +#define AO_SCHEME_NIL 0 + +extern uint16_t ao_scheme_top; + +#define AO_SCHEME_OOM 0x01 +#define AO_SCHEME_DIVIDE_BY_ZERO 0x02 +#define AO_SCHEME_INVALID 0x04 +#define AO_SCHEME_UNDEFINED 0x08 +#define AO_SCHEME_REDEFINED 0x10 +#define AO_SCHEME_EOF 0x20 +#define AO_SCHEME_EXIT 0x40 + +extern uint8_t ao_scheme_exception; + +static inline int +ao_scheme_is_const(ao_poly poly) { + return poly & AO_SCHEME_CONST; +} + +#define AO_SCHEME_IS_CONST(a) (ao_scheme_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_const + AO_SCHEME_POOL_CONST) +#define AO_SCHEME_IS_POOL(a) (ao_scheme_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_pool + AO_SCHEME_POOL) +#define AO_SCHEME_IS_INT(p) (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) + +void * +ao_scheme_ref(ao_poly poly); + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type); + +struct ao_scheme_type { + int (*size)(void *addr); + void (*mark)(void *addr); + void (*move)(void *addr); + char name[]; +}; + +struct ao_scheme_cons { + ao_poly car; + ao_poly cdr; +}; + +struct ao_scheme_atom { + uint8_t type; + uint8_t pad[1]; + ao_poly next; + char name[]; +}; + +struct ao_scheme_val { + ao_poly atom; + ao_poly val; +}; + +struct ao_scheme_frame_vals { + uint8_t type; + uint8_t size; + struct ao_scheme_val vals[]; +}; + +struct ao_scheme_frame { + uint8_t type; + uint8_t num; + ao_poly prev; + ao_poly vals; +}; + +struct ao_scheme_bool { + uint8_t type; + uint8_t value; + uint16_t pad; +}; + +struct ao_scheme_bigint { + uint32_t value; +}; + +struct ao_scheme_float { + uint8_t type; + uint8_t pad1; + uint16_t pad2; + float value; +}; + +#if __BYTE_ORDER == __LITTLE_ENDIAN +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { + return AO_SCHEME_BIGINT | (i << 8); +} +static inline int32_t +ao_scheme_bigint_int(uint32_t bi) { + return (int32_t) bi >> 8; +} +#else +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { + return (uint32_t) (i & 0xffffff) | (AO_SCHEME_BIGINT << 24); +} +static inlint int32_t +ao_scheme_bigint_int(uint32_t bi) { + return (int32_t) (bi << 8) >> 8; +} +#endif + +#define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) +#define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) +#define AO_SCHEME_MIN_BIGINT (-(1 << 24)) +#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1) + +#define AO_SCHEME_NOT_INTEGER 0x7fffffff + +/* Set on type when the frame escapes the lambda */ +#define AO_SCHEME_FRAME_MARK 0x80 +#define AO_SCHEME_FRAME_PRINT 0x40 + +static inline int ao_scheme_frame_marked(struct ao_scheme_frame *f) { + return f->type & AO_SCHEME_FRAME_MARK; +} + +static inline struct ao_scheme_frame * +ao_scheme_poly_frame(ao_poly poly) { + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_poly(struct ao_scheme_frame *frame) { + return ao_scheme_poly(frame, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_frame_vals * +ao_scheme_poly_frame_vals(ao_poly poly) { + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_vals_poly(struct ao_scheme_frame_vals *vals) { + return ao_scheme_poly(vals, AO_SCHEME_OTHER); +} + +enum eval_state { + eval_sexpr, /* Evaluate an sexpr */ + eval_val, /* Value computed */ + eval_formal, /* Formal computed */ + eval_exec, /* Start a lambda evaluation */ + eval_apply, /* Execute apply */ + eval_cond, /* Start next cond clause */ + eval_cond_test, /* Check cond condition */ + eval_begin, /* Start next begin entry */ + eval_while, /* Start while condition */ + eval_while_test, /* Check while condition */ + eval_macro, /* Finished with macro generation */ +}; + +struct ao_scheme_stack { + uint8_t type; /* AO_SCHEME_STACK */ + uint8_t state; /* enum eval_state */ + ao_poly prev; /* previous stack frame */ + ao_poly sexprs; /* expressions to evaluate */ + ao_poly values; /* values computed */ + ao_poly values_tail; /* end of the values list for easy appending */ + ao_poly frame; /* current lookup frame */ + ao_poly list; /* most recent function call */ +}; + +#define AO_SCHEME_STACK_MARK 0x80 /* set on type when a reference has been taken */ +#define AO_SCHEME_STACK_PRINT 0x40 /* stack is being printed */ + +static inline int ao_scheme_stack_marked(struct ao_scheme_stack *s) { + return s->type & AO_SCHEME_STACK_MARK; +} + +static inline void ao_scheme_stack_mark(struct ao_scheme_stack *s) { + s->type |= AO_SCHEME_STACK_MARK; +} + +static inline struct ao_scheme_stack * +ao_scheme_poly_stack(ao_poly p) +{ + return ao_scheme_ref(p); +} + +static inline ao_poly +ao_scheme_stack_poly(struct ao_scheme_stack *stack) +{ + return ao_scheme_poly(stack, AO_SCHEME_OTHER); +} + +extern ao_poly ao_scheme_v; + +#define AO_SCHEME_FUNC_LAMBDA 0 +#define AO_SCHEME_FUNC_NLAMBDA 1 +#define AO_SCHEME_FUNC_MACRO 2 + +#define AO_SCHEME_FUNC_FREE_ARGS 0x80 +#define AO_SCHEME_FUNC_MASK 0x7f + +#define AO_SCHEME_FUNC_F_LAMBDA (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_LAMBDA) +#define AO_SCHEME_FUNC_F_NLAMBDA (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_NLAMBDA) +#define AO_SCHEME_FUNC_F_MACRO (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_MACRO) + +struct ao_scheme_builtin { + uint8_t type; + uint8_t args; + uint16_t func; +}; + +#define AO_SCHEME_BUILTIN_ID +#include "ao_scheme_builtin.h" + +typedef ao_poly (*ao_scheme_func_t)(struct ao_scheme_cons *cons); + +extern const ao_scheme_func_t ao_scheme_builtins[]; + +static inline ao_scheme_func_t +ao_scheme_func(struct ao_scheme_builtin *b) +{ + return ao_scheme_builtins[b->func]; +} + +struct ao_scheme_lambda { + uint8_t type; + uint8_t args; + ao_poly code; + ao_poly frame; +}; + +static inline struct ao_scheme_lambda * +ao_scheme_poly_lambda(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_lambda_poly(struct ao_scheme_lambda *lambda) +{ + return ao_scheme_poly(lambda, AO_SCHEME_OTHER); +} + +static inline void * +ao_scheme_poly_other(ao_poly poly) { + return ao_scheme_ref(poly); +} + +static inline uint8_t +ao_scheme_other_type(void *other) { +#if DBG_MEM + if ((*((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK) >= AO_SCHEME_NUM_TYPE) + ao_scheme_abort(); +#endif + return *((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK; +} + +static inline ao_poly +ao_scheme_other_poly(const void *other) +{ + return ao_scheme_poly(other, AO_SCHEME_OTHER); +} + +static inline int +ao_scheme_size_round(int size) +{ + return (size + 3) & ~3; +} + +static inline int +ao_scheme_size(const struct ao_scheme_type *type, void *addr) +{ + return ao_scheme_size_round(type->size(addr)); +} + +#define AO_SCHEME_OTHER_POLY(other) ((ao_poly)(other) + AO_SCHEME_OTHER) + +static inline int ao_scheme_poly_base_type(ao_poly poly) { + return poly & AO_SCHEME_TYPE_MASK; +} + +static inline int ao_scheme_poly_type(ao_poly poly) { + int type = poly & AO_SCHEME_TYPE_MASK; + if (type == AO_SCHEME_OTHER) + return ao_scheme_other_type(ao_scheme_poly_other(poly)); + return type; +} + +static inline int +ao_scheme_is_cons(ao_poly poly) { + return (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline int +ao_scheme_is_pair(ao_poly poly) { + return poly != AO_SCHEME_NIL && (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline struct ao_scheme_cons * +ao_scheme_poly_cons(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_cons_poly(struct ao_scheme_cons *cons) +{ + return ao_scheme_poly(cons, AO_SCHEME_CONS); +} + +static inline int32_t +ao_scheme_poly_int(ao_poly poly) +{ + return (int32_t) ((ao_signed_poly) poly >> AO_SCHEME_TYPE_SHIFT); +} + +static inline ao_poly +ao_scheme_int_poly(int32_t i) +{ + return ((ao_poly) i << 2) | AO_SCHEME_INT; +} + +static inline struct ao_scheme_bigint * +ao_scheme_poly_bigint(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) +{ + return ao_scheme_poly(bi, AO_SCHEME_OTHER); +} + +static inline char * +ao_scheme_poly_string(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_string_poly(char *s) +{ + return ao_scheme_poly(s, AO_SCHEME_STRING); +} + +static inline struct ao_scheme_atom * +ao_scheme_poly_atom(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_atom_poly(struct ao_scheme_atom *a) +{ + return ao_scheme_poly(a, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_builtin * +ao_scheme_poly_builtin(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_builtin_poly(struct ao_scheme_builtin *b) +{ + return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline ao_poly +ao_scheme_bool_poly(struct ao_scheme_bool *b) +{ + return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_bool * +ao_scheme_poly_bool(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_float_poly(struct ao_scheme_float *f) +{ + return ao_scheme_poly(f, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_float * +ao_scheme_poly_float(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* memory functions */ + +extern int ao_scheme_collects[2]; +extern int ao_scheme_freed[2]; +extern int ao_scheme_loops[2]; + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr); + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); + +void * +ao_scheme_move_map(void *addr); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); + +void * +ao_scheme_alloc(int size); + +#define AO_SCHEME_COLLECT_FULL 1 +#define AO_SCHEME_COLLECT_INCREMENTAL 0 + +int +ao_scheme_collect(uint8_t style); + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons); +#endif + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id); + +void +ao_scheme_poly_stash(int id, ao_poly poly); + +ao_poly +ao_scheme_poly_fetch(int id); + +void +ao_scheme_string_stash(int id, char *string); + +char * +ao_scheme_string_fetch(int id); + +static inline void +ao_scheme_stack_stash(int id, struct ao_scheme_stack *stack) { + ao_scheme_poly_stash(id, ao_scheme_stack_poly(stack)); +} + +static inline struct ao_scheme_stack * +ao_scheme_stack_fetch(int id) { + return ao_scheme_poly_stack(ao_scheme_poly_fetch(id)); +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame); + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id); + +/* bool */ + +extern const struct ao_scheme_type ao_scheme_bool_type; + +void +ao_scheme_bool_write(ao_poly v); + +#ifdef AO_SCHEME_MAKE_CONST +struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; + +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value); +#endif + +/* cons */ +extern const struct ao_scheme_type ao_scheme_cons_type; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr); + +/* Return a cons or NULL for a proper list, else error */ +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr); + +extern struct ao_scheme_cons *ao_scheme_cons_free_list; + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons); + +void +ao_scheme_cons_write(ao_poly); + +void +ao_scheme_cons_display(ao_poly); + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons); + +/* string */ +extern const struct ao_scheme_type ao_scheme_string_type; + +char * +ao_scheme_string_copy(char *a); + +char * +ao_scheme_string_cat(char *a, char *b); + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme_string_unpack(char *a); + +void +ao_scheme_string_write(ao_poly s); + +void +ao_scheme_string_display(ao_poly s); + +/* atom */ +extern const struct ao_scheme_type ao_scheme_atom_type; + +extern struct ao_scheme_atom *ao_scheme_atoms; +extern struct ao_scheme_frame *ao_scheme_frame_global; +extern struct ao_scheme_frame *ao_scheme_frame_current; + +void +ao_scheme_atom_write(ao_poly a); + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name); + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref); + +ao_poly +ao_scheme_atom_get(ao_poly atom); + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val); + +/* int */ +void +ao_scheme_int_write(ao_poly i); + +int32_t +ao_scheme_poly_integer(ao_poly p); + +ao_poly +ao_scheme_integer_poly(int32_t i); + +static inline int +ao_scheme_integer_typep(uint8_t t) +{ + return (t == AO_SCHEME_INT) || (t == AO_SCHEME_BIGINT); +} + +void +ao_scheme_bigint_write(ao_poly i); + +extern const struct ao_scheme_type ao_scheme_bigint_type; +/* prim */ +void +ao_scheme_poly_write(ao_poly p); + +void +ao_scheme_poly_display(ao_poly p); + +int +ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); + +/* returns 1 if the object has already been moved */ +int +ao_scheme_poly_move(ao_poly *p, uint8_t note_cons); + +/* eval */ + +void +ao_scheme_eval_clear_globals(void); + +int +ao_scheme_eval_restart(void); + +ao_poly +ao_scheme_eval(ao_poly p); + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *cons); + +/* float */ +extern const struct ao_scheme_type ao_scheme_float_type; + +void +ao_scheme_float_write(ao_poly p); + +ao_poly +ao_scheme_float_get(float value); + +static inline uint8_t +ao_scheme_number_typep(uint8_t t) +{ + return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* builtin */ +void +ao_scheme_builtin_write(ao_poly b); + +extern const struct ao_scheme_type ao_scheme_builtin_type; + +/* Check argument count */ +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max); + +/* Check argument type */ +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok); + +/* Fetch an arg (nil if off the end) */ +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc); + +char * +ao_scheme_args_name(uint8_t args); + +/* read */ +extern struct ao_scheme_cons *ao_scheme_read_cons; +extern struct ao_scheme_cons *ao_scheme_read_cons_tail; +extern struct ao_scheme_cons *ao_scheme_read_stack; + +ao_poly +ao_scheme_read(void); + +/* rep */ +ao_poly +ao_scheme_read_eval_print(void); + +/* frame */ +extern const struct ao_scheme_type ao_scheme_frame_type; +extern const struct ao_scheme_type ao_scheme_frame_vals_type; + +#define AO_SCHEME_FRAME_FREE 6 + +extern struct ao_scheme_frame *ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame); + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom); + +struct ao_scheme_frame * +ao_scheme_frame_new(int num); + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame); + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val); + +void +ao_scheme_frame_write(ao_poly p); + +void +ao_scheme_frame_init(void); + +/* lambda */ +extern const struct ao_scheme_type ao_scheme_lambda_type; + +extern const char * const ao_scheme_state_names[]; + +struct ao_scheme_lambda * +ao_scheme_lambda_new(ao_poly cons); + +void +ao_scheme_lambda_write(ao_poly lambda); + +ao_poly +ao_scheme_lambda_eval(void); + +/* stack */ + +extern const struct ao_scheme_type ao_scheme_stack_type; +extern struct ao_scheme_stack *ao_scheme_stack; +extern struct ao_scheme_stack *ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack); + +int +ao_scheme_stack_push(void); + +void +ao_scheme_stack_pop(void); + +void +ao_scheme_stack_clear(void); + +void +ao_scheme_stack_write(ao_poly stack); + +ao_poly +ao_scheme_stack_eval(void); + +/* error */ + +void +ao_scheme_vprintf(char *format, va_list args); + +void +ao_scheme_printf(char *format, ...); + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last); + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame); + +ao_poly +ao_scheme_error(int error, char *format, ...); + +/* builtins */ + +#define AO_SCHEME_BUILTIN_DECLS +#include "ao_scheme_builtin.h" + +/* debugging macros */ + +#if DBG_EVAL || DBG_READ || DBG_MEM +#define DBG_CODE 1 +int ao_scheme_stack_depth; +#define DBG_DO(a) a +#define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_scheme_stack_depth; _s++) printf(" "); } while(0) +#define DBG_IN() (++ao_scheme_stack_depth) +#define DBG_OUT() (--ao_scheme_stack_depth) +#define DBG_RESET() (ao_scheme_stack_depth = 0) +#define DBG(...) ao_scheme_printf(__VA_ARGS__) +#define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#define DBG_CONS(a) ao_scheme_cons_write(ao_scheme_cons_poly(a)) +#define DBG_POLY(a) ao_scheme_poly_write(a) +#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) +#define DBG_STACK() ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)) +static inline void +ao_scheme_frames_dump(void) +{ + struct ao_scheme_stack *s; + DBGI(".. current frame: "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + for (s = ao_scheme_stack; s; s = ao_scheme_poly_stack(s->prev)) { + DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); + } +} +#define DBG_FRAMES() ao_scheme_frames_dump() +#else +#define DBG_DO(a) +#define DBG_INDENT() +#define DBG_IN() +#define DBG_OUT() +#define DBG(...) +#define DBGI(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#define DBG_RESET() +#define DBG_STACK() +#define DBG_FRAMES() +#endif + +#if DBG_READ +#define RDBGI(...) DBGI(__VA_ARGS__) +#define RDBG_IN() DBG_IN() +#define RDBG_OUT() DBG_OUT() +#else +#define RDBGI(...) +#define RDBG_IN() +#define RDBG_OUT() +#endif + +#define DBG_MEM_START 1 + +#if DBG_MEM + +#include <assert.h> +extern int dbg_move_depth; +#define MDBG_DUMP 1 +#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_scheme_pool) : -1) + +extern int dbg_mem; + +#define MDBG_DO(a) DBG_DO(a) +#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) +#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) +#define MDBG_MOVE_IN() (dbg_move_depth++) +#define MDBG_MOVE_OUT() (assert(--dbg_move_depth >= 0)) + +#else + +#define MDBG_DO(a) +#define MDBG_MOVE(...) +#define MDBG_MORE(...) +#define MDBG_MOVE_IN() +#define MDBG_MOVE_OUT() + +#endif + +#endif /* _AO_SCHEME_H_ */ diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c new file mode 100644 index 00000000..cb32b7fe --- /dev/null +++ b/src/scheme/ao_scheme_atom.c @@ -0,0 +1,167 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" + +static int name_size(char *name) +{ + return sizeof(struct ao_scheme_atom) + strlen(name) + 1; +} + +static int atom_size(void *addr) +{ + struct ao_scheme_atom *atom = addr; + if (!atom) + return 0; + return name_size(atom->name); +} + +static void atom_mark(void *addr) +{ + struct ao_scheme_atom *atom = addr; + + for (;;) { + atom = ao_scheme_poly_atom(atom->next); + if (!atom) + break; + if (ao_scheme_mark_memory(&ao_scheme_atom_type, atom)) + break; + } +} + +static void atom_move(void *addr) +{ + struct ao_scheme_atom *atom = addr; + int ret; + + for (;;) { + struct ao_scheme_atom *next = ao_scheme_poly_atom(atom->next); + + if (!next) + break; + ret = ao_scheme_move_memory(&ao_scheme_atom_type, (void **) &next); + if (next != ao_scheme_poly_atom(atom->next)) + atom->next = ao_scheme_atom_poly(next); + if (ret) + break; + atom = next; + } +} + +const struct ao_scheme_type ao_scheme_atom_type = { + .mark = atom_mark, + .size = atom_size, + .move = atom_move, + .name = "atom" +}; + +struct ao_scheme_atom *ao_scheme_atoms; + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name) +{ + struct ao_scheme_atom *atom; + + for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { + if (!strcmp(atom->name, name)) + return atom; + } +#ifdef ao_builtin_atoms + for (atom = ao_scheme_poly_atom(ao_builtin_atoms); atom; atom = ao_scheme_poly_atom(atom->next)) { + if (!strcmp(atom->name, name)) + return atom; + } +#endif + ao_scheme_string_stash(0, name); + atom = ao_scheme_alloc(name_size(name)); + name = ao_scheme_string_fetch(0); + if (atom) { + atom->type = AO_SCHEME_ATOM; + atom->next = ao_scheme_atom_poly(ao_scheme_atoms); + ao_scheme_atoms = atom; + strcpy(atom->name, name); + } + return atom; +} + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref) +{ + ao_poly *ref; + struct ao_scheme_frame *frame; + + for (frame = ao_scheme_frame_current; frame; frame = ao_scheme_poly_frame(frame->prev)) { + ref = ao_scheme_frame_ref(frame, atom); + if (ref) { + if (frame_ref) + *frame_ref = frame; + return ref; + } + } + ref = ao_scheme_frame_ref(ao_scheme_frame_global, atom); + if (ref) + if (frame_ref) + *frame_ref = ao_scheme_frame_global; + return ref; +} + +ao_poly +ao_scheme_atom_get(ao_poly atom) +{ + ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + +#ifdef ao_builtin_frame + if (!ref) + ref = ao_scheme_frame_ref(ao_scheme_poly_frame(ao_builtin_frame), atom); +#endif + if (ref) + return *ref; + return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); +} + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val) +{ + ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + + if (!ref) + return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); + *ref = val; + return val; +} + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val) +{ + struct ao_scheme_frame *frame; + ao_poly *ref = ao_scheme_atom_ref(atom, &frame); + + if (ref) { + if (frame == ao_scheme_frame_current) + return ao_scheme_error(AO_SCHEME_REDEFINED, "attempt to redefine atom %s", ao_scheme_poly_atom(atom)->name); + *ref = val; + return val; + } + return ao_scheme_frame_add(ao_scheme_frame_current ? ao_scheme_frame_current : ao_scheme_frame_global, atom, val); +} + +void +ao_scheme_atom_write(ao_poly a) +{ + struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); + printf("%s", atom->name); +} diff --git a/src/scheme/ao_scheme_bool.c b/src/scheme/ao_scheme_bool.c new file mode 100644 index 00000000..c1e880ca --- /dev/null +++ b/src/scheme/ao_scheme_bool.c @@ -0,0 +1,73 @@ +/* + * Copyright © 2017 Keith Packard <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_scheme.h" + +static void bool_mark(void *addr) +{ + (void) addr; +} + +static int bool_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_bool); +} + +static void bool_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_bool_type = { + .mark = bool_mark, + .size = bool_size, + .move = bool_move, + .name = "bool" +}; + +void +ao_scheme_bool_write(ao_poly v) +{ + struct ao_scheme_bool *b = ao_scheme_poly_bool(v); + + if (b->value) + printf("#t"); + else + printf("#f"); +} + +#ifdef AO_SCHEME_MAKE_CONST + +struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; + +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value) +{ + struct ao_scheme_bool **b; + + if (value) + b = &ao_scheme_true; + else + b = &ao_scheme_false; + + if (!*b) { + *b = ao_scheme_alloc(sizeof (struct ao_scheme_bool)); + (*b)->type = AO_SCHEME_BOOL; + (*b)->value = value; + } + return *b; +} + +#endif diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c new file mode 100644 index 00000000..49f218f6 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.c @@ -0,0 +1,868 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" +#include <limits.h> +#include <math.h> + +static int +builtin_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_builtin); +} + +static void +builtin_mark(void *addr) +{ + (void) addr; +} + +static void +builtin_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_builtin_type = { + .size = builtin_size, + .mark = builtin_mark, + .move = builtin_move +}; + +#ifdef AO_SCHEME_MAKE_CONST + +#define AO_SCHEME_BUILTIN_CASENAME +#include "ao_scheme_builtin.h" + +char *ao_scheme_args_name(uint8_t args) { + args &= AO_SCHEME_FUNC_MASK; + switch (args) { + case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name; + case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name; + case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name; + default: return "???"; + } +} +#else + +#define AO_SCHEME_BUILTIN_ARRAYNAME +#include "ao_scheme_builtin.h" + +static char * +ao_scheme_builtin_name(enum ao_scheme_builtin_id b) { + if (b < _builtin_last) + return ao_scheme_poly_atom(builtin_names[b])->name; + return "???"; +} + +static const ao_poly ao_scheme_args_atoms[] = { + [AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda, + [AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda, + [AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro, +}; + +char * +ao_scheme_args_name(uint8_t args) +{ + args &= AO_SCHEME_FUNC_MASK; + if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0]) + return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name; + return "(unknown)"; +} +#endif + +void +ao_scheme_builtin_write(ao_poly b) +{ + struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); + printf("%s", ao_scheme_builtin_name(builtin->func)); +} + +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max) +{ + int argc = 0; + + while (cons && argc <= max) { + argc++; + cons = ao_scheme_cons_cdr(cons); + } + if (argc < min || argc > max) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc) +{ + if (!cons) + return AO_SCHEME_NIL; + while (argc--) { + if (!cons) + return AO_SCHEME_NIL; + cons = ao_scheme_cons_cdr(cons); + } + return cons->car; +} + +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok) +{ + ao_poly car = ao_scheme_arg(cons, argc); + + if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: arg %d invalid type %v", ao_scheme_poly_atom(name)->name, argc, car); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_car(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(cons->car)->car; +} + +ao_poly +ao_scheme_do_cdr(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(cons->car)->cdr; +} + +ao_poly +ao_scheme_do_cons(struct ao_scheme_cons *cons) +{ + ao_poly car, cdr; + if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2)) + return AO_SCHEME_NIL; + car = ao_scheme_arg(cons, 0); + cdr = ao_scheme_arg(cons, 1); + return ao_scheme__cons(car, cdr); +} + +ao_poly +ao_scheme_do_last(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *list; + if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0)); + list; + list = ao_scheme_cons_cdr(list)) + { + if (!list->cdr) + return list->car; + } + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_length(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_quote(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1)) + return AO_SCHEME_NIL; + return ao_scheme_arg(cons, 0); +} + +ao_poly +ao_scheme_do_set(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_def(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_setq(struct ao_scheme_cons *cons) +{ + ao_poly name; + if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2)) + return AO_SCHEME_NIL; + name = cons->car; + if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name); + if (!ao_scheme_atom_ref(name, NULL)) + return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name); + return ao_scheme__cons(_ao_scheme_atom_set, + ao_scheme__cons(ao_scheme__cons(_ao_scheme_atom_quote, + ao_scheme__cons(name, AO_SCHEME_NIL)), + cons->cdr)); +} + +ao_poly +ao_scheme_do_cond(struct ao_scheme_cons *cons) +{ + ao_scheme_set_cond(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_begin(struct ao_scheme_cons *cons) +{ + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_while(struct ao_scheme_cons *cons) +{ + ao_scheme_stack->state = eval_while; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_write(struct ao_scheme_cons *cons) +{ + ao_poly val = AO_SCHEME_NIL; + while (cons) { + val = cons->car; + ao_scheme_poly_write(val); + cons = ao_scheme_cons_cdr(cons); + if (cons) + printf(" "); + } + printf("\n"); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_display(struct ao_scheme_cons *cons) +{ + ao_poly val = AO_SCHEME_NIL; + while (cons) { + val = cons->car; + ao_scheme_poly_display(val); + cons = ao_scheme_cons_cdr(cons); + } + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) +{ + struct ao_scheme_cons *cons = cons; + ao_poly ret = AO_SCHEME_NIL; + + for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) { + ao_poly car = cons->car; + uint8_t rt = ao_scheme_poly_type(ret); + uint8_t ct = ao_scheme_poly_type(car); + + if (cons == orig_cons) { + ret = car; + if (cons->cdr == AO_SCHEME_NIL) { + switch (op) { + case builtin_minus: + if (ao_scheme_integer_typep(ct)) + ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); + else if (ct == AO_SCHEME_FLOAT) + ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); + break; + case builtin_divide: + if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) + ; + else if (ao_scheme_number_typep(ct)) { + float v = ao_scheme_poly_number(ret); + ret = ao_scheme_float_get(1/v); + } + break; + default: + break; + } + } + } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { + int32_t r = ao_scheme_poly_integer(ret); + int32_t c = ao_scheme_poly_integer(car); + int64_t t; + + switch(op) { + case builtin_plus: + r += c; + check_overflow: + if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) + goto inexact; + break; + case builtin_minus: + r -= c; + goto check_overflow; + break; + case builtin_times: + t = (int64_t) r * (int64_t) c; + if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) + goto inexact; + r = (int32_t) t; + break; + case builtin_divide: + if (c != 0 && (r % c) == 0) + r /= c; + else + goto inexact; + break; + case builtin_quotient: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero"); + if (r % c != 0 && (c < 0) != (r < 0)) + r = r / c - 1; + else + r = r / c; + break; + case builtin_remainder: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero"); + r %= c; + break; + case builtin_modulo: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero"); + r %= c; + if ((r < 0) != (c < 0)) + r += c; + break; + default: + break; + } + ret = ao_scheme_integer_poly(r); + } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { + float r, c; + inexact: + r = ao_scheme_poly_number(ret); + c = ao_scheme_poly_number(car); + switch(op) { + case builtin_plus: + r += c; + break; + case builtin_minus: + r -= c; + break; + case builtin_times: + r *= c; + break; + case builtin_divide: + r /= c; + break; + case builtin_quotient: + case builtin_remainder: + case builtin_modulo: + return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); + default: + break; + } + ret = ao_scheme_float_get(r); + } + + else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) + ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), + ao_scheme_poly_string(car))); + else + return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); + } + return ret; +} + +ao_poly +ao_scheme_do_plus(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_plus); +} + +ao_poly +ao_scheme_do_minus(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_minus); +} + +ao_poly +ao_scheme_do_times(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_times); +} + +ao_poly +ao_scheme_do_divide(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_divide); +} + +ao_poly +ao_scheme_do_quotient(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_quotient); +} + +ao_poly +ao_scheme_do_modulo(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_modulo); +} + +ao_poly +ao_scheme_do_remainder(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_remainder); +} + +ao_poly +ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) +{ + ao_poly left; + + if (!cons) + return _ao_scheme_bool_true; + + left = cons->car; + for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { + ao_poly right = cons->car; + + if (op == builtin_equal) { + if (left != right) + return _ao_scheme_bool_false; + } else { + uint8_t lt = ao_scheme_poly_type(left); + uint8_t rt = ao_scheme_poly_type(right); + if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) { + int32_t l = ao_scheme_poly_integer(left); + int32_t r = ao_scheme_poly_integer(right); + + switch (op) { + case builtin_less: + if (!(l < r)) + return _ao_scheme_bool_false; + break; + case builtin_greater: + if (!(l > r)) + return _ao_scheme_bool_false; + break; + case builtin_less_equal: + if (!(l <= r)) + return _ao_scheme_bool_false; + break; + case builtin_greater_equal: + if (!(l >= r)) + return _ao_scheme_bool_false; + break; + default: + break; + } + } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { + int c = strcmp(ao_scheme_poly_string(left), + ao_scheme_poly_string(right)); + switch (op) { + case builtin_less: + if (!(c < 0)) + return _ao_scheme_bool_false; + break; + case builtin_greater: + if (!(c > 0)) + return _ao_scheme_bool_false; + break; + case builtin_less_equal: + if (!(c <= 0)) + return _ao_scheme_bool_false; + break; + case builtin_greater_equal: + if (!(c >= 0)) + return _ao_scheme_bool_false; + break; + default: + break; + } + } + } + left = right; + } + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_equal); +} + +ao_poly +ao_scheme_do_less(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_less); +} + +ao_poly +ao_scheme_do_greater(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_greater); +} + +ao_poly +ao_scheme_do_less_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_less_equal); +} + +ao_poly +ao_scheme_do_greater_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_greater_equal); +} + +ao_poly +ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_flush_output(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0)) + return AO_SCHEME_NIL; + ao_scheme_os_flush(); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_led(struct ao_scheme_cons *cons) +{ + ao_poly led; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + led = ao_scheme_arg(cons, 0); + ao_scheme_os_led(ao_scheme_poly_int(led)); + return led; +} + +ao_poly +ao_scheme_do_delay(struct ao_scheme_cons *cons) +{ + ao_poly delay; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + delay = ao_scheme_arg(cons, 0); + ao_scheme_os_delay(ao_scheme_poly_int(delay)); + return delay; +} + +ao_poly +ao_scheme_do_eval(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1)) + return AO_SCHEME_NIL; + ao_scheme_stack->state = eval_sexpr; + return cons->car; +} + +ao_poly +ao_scheme_do_apply(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX)) + return AO_SCHEME_NIL; + ao_scheme_stack->state = eval_apply; + return ao_scheme_cons_poly(cons); +} + +ao_poly +ao_scheme_do_read(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0)) + return AO_SCHEME_NIL; + return ao_scheme_read(); +} + +ao_poly +ao_scheme_do_collect(struct ao_scheme_cons *cons) +{ + int free; + (void) cons; + free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + return ao_scheme_int_poly(free); +} + +ao_poly +ao_scheme_do_nullp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL) + return _ao_scheme_bool_true; + else + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_not(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false) + return _ao_scheme_bool_true; + else + return _ao_scheme_bool_false; +} + +static ao_poly +ao_scheme_do_typep(int type, struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_pairp(struct ao_scheme_cons *cons) +{ + ao_poly v; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + v = ao_scheme_arg(cons, 0); + if (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_integerp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +ao_poly +ao_scheme_do_numberp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + case AO_SCHEME_FLOAT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +ao_poly +ao_scheme_do_stringp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_STRING, cons); +} + +ao_poly +ao_scheme_do_symbolp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_ATOM, cons); +} + +ao_poly +ao_scheme_do_booleanp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_BOOL, cons); +} + +ao_poly +ao_scheme_do_procedurep(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_BUILTIN: + case AO_SCHEME_LAMBDA: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +/* This one is special -- a list is either nil or + * a 'proper' list with only cons cells + */ +ao_poly +ao_scheme_do_listp(struct ao_scheme_cons *cons) +{ + ao_poly v; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + v = ao_scheme_arg(cons, 0); + for (;;) { + if (v == AO_SCHEME_NIL) + return _ao_scheme_bool_true; + if (ao_scheme_poly_type(v) != AO_SCHEME_CONS) + return _ao_scheme_bool_false; + v = ao_scheme_poly_cons(v)->cdr; + } +} + +ao_poly +ao_scheme_do_set_car(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name)); +} + +ao_poly +ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_read_char(struct ao_scheme_cons *cons) +{ + int c; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + c = getchar(); + return ao_scheme_int_poly(c); +} + +ao_poly +ao_scheme_do_write_char(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0))); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_exit(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + ao_scheme_exception |= AO_SCHEME_EXIT; + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) +{ + int jiffy; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + jiffy = ao_scheme_os_jiffy(); + return (ao_scheme_int_poly(jiffy)); +} + +ao_poly +ao_scheme_do_current_second(struct ao_scheme_cons *cons) +{ + int second; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND; + return (ao_scheme_int_poly(second)); +} + +ao_poly +ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); +} + +#define AO_SCHEME_BUILTIN_FUNCS +#include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt new file mode 100644 index 00000000..cb65e252 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.txt @@ -0,0 +1,68 @@ +f_lambda eval +f_lambda read +nlambda lambda +nlambda nlambda +nlambda macro +f_lambda car +f_lambda cdr +f_lambda cons +f_lambda last +f_lambda length +nlambda quote +atom quasiquote +atom unquote +atom unquote_splicing unquote-splicing +f_lambda set +macro setq set! +f_lambda def +nlambda cond +nlambda begin +nlambda while +f_lambda write +f_lambda display +f_lambda plus + +f_lambda minus - +f_lambda times * +f_lambda divide / +f_lambda modulo modulo % +f_lambda remainder +f_lambda quotient +f_lambda equal = eq? eqv? +f_lambda less < +f_lambda greater > +f_lambda less_equal <= +f_lambda greater_equal >= +f_lambda list_to_string list->string +f_lambda string_to_list string->list +f_lambda flush_output flush-output +f_lambda delay +f_lambda led +f_lambda save +f_lambda restore +f_lambda call_cc call-with-current-continuation call/cc +f_lambda collect +f_lambda nullp null? +f_lambda not +f_lambda listp list? +f_lambda pairp pair? +f_lambda integerp integer? exact? exact-integer? +f_lambda numberp number? real? +f_lambda booleanp boolean? +f_lambda set_car set-car! +f_lambda set_cdr set-cdr! +f_lambda symbolp symbol? +f_lambda symbol_to_string symbol->string +f_lambda string_to_symbol string->symbol +f_lambda stringp string? +f_lambda procedurep procedure? +lambda apply +f_lambda read_char read-char +f_lambda write_char write-char +f_lambda exit +f_lambda current_jiffy current-jiffy +f_lambda current_second current-second +f_lambda jiffies_per_second jiffies-per-second +f_lambda finitep finite? +f_lambda infinitep infinite? +f_lambda inexactp inexact? +f_lambda sqrt diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c new file mode 100644 index 00000000..03dad956 --- /dev/null +++ b/src/scheme/ao_scheme_cons.c @@ -0,0 +1,201 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" + +static void cons_mark(void *addr) +{ + struct ao_scheme_cons *cons = addr; + + for (;;) { + ao_poly cdr = cons->cdr; + + ao_scheme_poly_mark(cons->car, 1); + if (!cdr) + break; + if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + ao_scheme_poly_mark(cdr, 1); + break; + } + cons = ao_scheme_poly_cons(cdr); + if (ao_scheme_mark_memory(&ao_scheme_cons_type, cons)) + break; + } +} + +static int cons_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_cons); +} + +static void cons_move(void *addr) +{ + struct ao_scheme_cons *cons = addr; + + if (!cons) + return; + + for (;;) { + ao_poly cdr; + struct ao_scheme_cons *c; + int ret; + + MDBG_MOVE("cons_move start %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); + (void) ao_scheme_poly_move(&cons->car, 1); + cdr = cons->cdr; + if (!cdr) + break; + if (ao_scheme_poly_base_type(cdr) != AO_SCHEME_CONS) { + (void) ao_scheme_poly_move(&cons->cdr, 0); + break; + } + c = ao_scheme_poly_cons(cdr); + ret = ao_scheme_move_memory(&ao_scheme_cons_type, (void **) &c); + if (c != ao_scheme_poly_cons(cons->cdr)) + cons->cdr = ao_scheme_cons_poly(c); + MDBG_MOVE("cons_move end %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); + if (ret) + break; + cons = c; + } +} + +const struct ao_scheme_type ao_scheme_cons_type = { + .mark = cons_mark, + .size = cons_size, + .move = cons_move, + .name = "cons", +}; + +struct ao_scheme_cons *ao_scheme_cons_free_list; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr) +{ + struct ao_scheme_cons *cons; + + if (ao_scheme_cons_free_list) { + cons = ao_scheme_cons_free_list; + ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr); + } else { + ao_scheme_poly_stash(0, car); + ao_scheme_poly_stash(1, cdr); + cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); + cdr = ao_scheme_poly_fetch(1); + car = ao_scheme_poly_fetch(0); + if (!cons) + return NULL; + } + cons->car = car; + cons->cdr = cdr; + return cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons) +{ + ao_poly cdr = cons->cdr; + if (cdr == AO_SCHEME_NIL) + return NULL; + if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + (void) ao_scheme_error(AO_SCHEME_INVALID, "improper list"); + return NULL; + } + return ao_scheme_poly_cons(cdr); +} + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr) +{ + return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); +} + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons) +{ +#if DBG_FREE_CONS + ao_scheme_cons_check(cons); +#endif + while (cons) { + ao_poly cdr = cons->cdr; + cons->cdr = ao_scheme_cons_poly(ao_scheme_cons_free_list); + ao_scheme_cons_free_list = cons; + cons = ao_scheme_poly_cons(cdr); + } +} + +void +ao_scheme_cons_write(ao_poly c) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + ao_poly cdr; + int first = 1; + + printf("("); + while (cons) { + if (!first) + printf(" "); + ao_scheme_poly_write(cons->car); + cdr = cons->cdr; + if (cdr == c) { + printf(" ..."); + break; + } + if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { + cons = ao_scheme_poly_cons(cdr); + first = 0; + } else { + printf(" . "); + ao_scheme_poly_write(cdr); + cons = NULL; + } + } + printf(")"); +} + +void +ao_scheme_cons_display(ao_poly c) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + ao_poly cdr; + + while (cons) { + ao_scheme_poly_display(cons->car); + cdr = cons->cdr; + if (cdr == c) { + printf("..."); + break; + } + if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) + cons = ao_scheme_poly_cons(cdr); + else { + ao_scheme_poly_display(cdr); + cons = NULL; + } + } +} + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_scheme_poly_cons(cons->cdr); + } + return len; +} diff --git a/src/scheme/ao_scheme_const.lisp b/src/scheme/ao_scheme_const.lisp new file mode 100644 index 00000000..422bdd63 --- /dev/null +++ b/src/scheme/ao_scheme_const.lisp @@ -0,0 +1,813 @@ +; +; Copyright © 2016 Keith Packard <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 +(def (quote list) (lambda l l)) + +(def (quote def!) + (macro (name value) + (list + def + (list quote name) + value) + ) + ) + +(begin + (def! append + (lambda args + (def! append-list + (lambda (a b) + (cond ((null? a) b) + (else (cons (car a) (append-list (cdr a) b))) + ) + ) + ) + + (def! append-lists + (lambda (lists) + (cond ((null? lists) lists) + ((null? (cdr lists)) (car lists)) + (else (append-list (car lists) (append-lists (cdr lists)))) + ) + ) + ) + (append-lists args) + ) + ) + 'append) + +(append '(a b c) '(d e f) '(g h i)) + + ; boolean operators + +(begin + (def! or + (macro l + (def! _or + (lambda (l) + (cond ((null? l) #f) + ((null? (cdr l)) + (car l)) + (else + (list + cond + (list + (car l)) + (list + 'else + (_or (cdr l)) + ) + ) + ) + ) + ) + ) + (_or l))) + 'or) + + ; execute to resolve macros + +(or #f #t) + +(begin + (def! and + (macro l + (def! _and + (lambda (l) + (cond ((null? l) #t) + ((null? (cdr l)) + (car l)) + (else + (list + cond + (list + (car l) + (_and (cdr l)) + ) + ) + ) + ) + ) + ) + (_and l) + ) + ) + 'and) + + ; execute to resolve macros + +(and #t #f) + +(begin + (def! quasiquote + (macro (x) + (def! constant? + ; A constant value is either a pair starting with quote, + ; or anything which is neither a pair nor a symbol + + (lambda (exp) + (cond ((pair? exp) + (eq? (car exp) 'quote) + ) + (else + (not (symbol? exp)) + ) + ) + ) + ) + (def! combine-skeletons + (lambda (left right exp) + (cond + ((and (constant? left) (constant? right)) + (cond ((and (eqv? (eval left) (car exp)) + (eqv? (eval right) (cdr exp))) + (list 'quote exp) + ) + (else + (list 'quote (cons (eval left) (eval right))) + ) + ) + ) + ((null? right) + (list 'list left) + ) + ((and (pair? right) (eq? (car right) 'list)) + (cons 'list (cons left (cdr right))) + ) + (else + (list 'cons left right) + ) + ) + ) + ) + + (def! expand-quasiquote + (lambda (exp nesting) + (cond + + ; non cons -- constants + ; themselves, others are + ; quoted + + ((not (pair? exp)) + (cond ((constant? exp) + exp + ) + (else + (list 'quote exp) + ) + ) + ) + + ; check for an unquote exp and + ; add the param unquoted + + ((and (eq? (car exp) 'unquote) (= (length exp) 2)) + (cond ((= nesting 0) + (car (cdr exp)) + ) + (else + (combine-skeletons ''unquote + (expand-quasiquote (cdr exp) (- nesting 1)) + exp)) + ) + ) + + ; nested quasi-quote -- + ; construct the right + ; expression + + ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) + (combine-skeletons ''quasiquote + (expand-quasiquote (cdr exp) (+ nesting 1)) + exp)) + + ; check for an + ; unquote-splicing member, + ; compute the expansion of the + ; value and append the rest of + ; the quasiquote result to it + + ((and (pair? (car exp)) + (eq? (car (car exp)) 'unquote-splicing) + (= (length (car exp)) 2)) + (cond ((= nesting 0) + (list 'append (car (cdr (car exp))) + (expand-quasiquote (cdr exp) nesting)) + ) + (else + (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) + (expand-quasiquote (cdr exp) nesting) + exp)) + ) + ) + + ; for other lists, just glue + ; the expansion of the first + ; element to the expansion of + ; the rest of the list + + (else (combine-skeletons (expand-quasiquote (car exp) nesting) + (expand-quasiquote (cdr exp) nesting) + exp) + ) + ) + ) + ) + (def! result (expand-quasiquote x 0)) + result + ) + ) + 'quasiquote) + + ; + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated. + ; + ; Also accepts the alternate + ; form for defining lambdas of + ; (define (name x y z) sexprs ...) + ; + +(begin + (def! define + (macro (first . rest) + ; check for alternate lambda definition form + + (cond ((list? first) + (set! rest + (append + (list + 'lambda + (cdr first)) + rest)) + (set! first (car first)) + ) + (else + (set! rest (car rest)) + ) + ) + (def! result `(,begin + (,def (,quote ,first) ,rest) + (,quote ,first)) + ) + result + ) + ) + 'define + ) + + ; basic list accessors + +(define (caar l) (car (car l))) + +(define (cadr l) (car (cdr l))) + +(define (cdar l) (cdr (car l))) + +(define (caddr l) (car (cdr (cdr l)))) + + ; (if <condition> <if-true>) + ; (if <condition> <if-true> <if-false) + +(define if + (macro (test . args) + (cond ((null? (cdr args)) + `(cond (,test ,(car args))) + ) + (else + `(cond (,test ,(car args)) + (else ,(cadr args))) + ) + ) + ) + ) + +(if (> 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + + ; simple math operators + +(define zero? (macro (value) `(eq? ,value 0))) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value) `(> ,value 0))) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value) `(< ,value 0))) + +(negative? 12) +(negative? -12) + +(define (abs x) (if (>= x 0) x (- x))) + +(abs 12) +(abs -12) + +(define max (lambda (first . rest) + (while (not (null? rest)) + (cond ((< first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(max 1 2 3) +(max 3 2 1) + +(define min (lambda (first . rest) + (while (not (null? rest)) + (cond ((> first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(min 1 2 3) +(min 3 2 1) + +(define (even? x) (zero? (% x 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(define (odd? x) (not (even? x))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + + +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x (- k 1))) + ) + ) + +(define (list-ref x k) + (car (list-tail x k)) + ) + + ; define a set of local + ; variables all at once and + ; then evaluate a list of + ; sexprs + ; + ; (let (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let ((x 1) (y)) (set! y (+ x 1)) y) + +(define let + (macro (vars . exprs) + (define (make-names vars) + (cond ((not (null? vars)) + (cons (car (car vars)) + (make-names (cdr vars)))) + (else ()) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (make-vals vars) + (cond ((not (null? vars)) + (cons (cond ((null? (cdr (car vars))) ()) + (else + (car (cdr (car vars)))) + ) + (make-vals (cdr vars)))) + (else ()) + ) + ) + ; prepend the set operations + ; to the expressions + + ; build the lambda. + + `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) + ) + ) + + +(let ((x 1) (y)) (set! y 2) (+ x y)) + + ; define a set of local + ; variables one at a time and + ; then evaluate a list of + ; sexprs + ; + ; (let* (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let* ((x 1) (y)) (set! y (+ x 1)) y) + +(define let* + (macro (vars . exprs) + + ; + ; make the list of names in the let + ; + + (define (make-names vars) + (cond ((not (null? vars)) + (cons (car (car vars)) + (make-names (cdr vars)))) + (else ()) + ) + ) + + ; the set of expressions is + ; the list of set expressions + ; pre-pended to the + ; expressions to evaluate + + (define (make-exprs vars exprs) + (cond ((null? vars) exprs) + (else + (cons + (list set + (list quote + (car (car vars)) + ) + (cond ((null? (cdr (car vars))) ()) + (else (cadr (car vars)))) + ) + (make-exprs (cdr vars) exprs) + ) + ) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (make-nils vars) + (cond ((null? vars) ()) + (else (cons () (make-nils (cdr vars)))) + ) + ) + ; build the lambda. + + `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) + ) + ) + +(let* ((x 1) (y x)) (+ x y)) + +(define when (macro (test . l) `(cond (,test ,@l)))) + +(when #t (write 'when)) + +(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) + +(unless #f (write 'unless)) + +(define (reverse list) + (let ((result ())) + (while (not (null? list)) + (set! result (cons (car list) result)) + (set! list (cdr list)) + ) + result) + ) + +(reverse '(1 2 3)) + +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x) (- k 1)))) + +(list-tail '(1 2 3) 2) + +(define (list-ref x k) (car (list-tail x k))) + +(list-ref '(1 2 3) 2) + + ; recursive equality + +(define (equal? a b) + (cond ((eq? a b) #t) + ((and (pair? a) (pair? b)) + (and (equal? (car a) (car b)) + (equal? (cdr a) (cdr b))) + ) + (else #f) + ) + ) + +(equal? '(a b c) '(a b c)) +(equal? '(a b c) '(a b b)) + +(define member (lambda (obj list . test?) + (cond ((null? list) + #f + ) + (else + (if (null? test?) (set! test? equal?) (set! test? (car test?))) + (if (test? obj (car list)) + list + (member obj (cdr list) test?)) + ) + ) + ) + ) + +(member '(2) '((1) (2) (3))) + +(member '(4) '((1) (2) (3))) + +(define (memq obj list) (member obj list eq?)) + +(memq 2 '(1 2 3)) + +(memq 4 '(1 2 3)) + +(memq '(2) '((1) (2) (3))) + +(define (memv obj list) (member obj list eqv?)) + +(memv 2 '(1 2 3)) + +(memv 4 '(1 2 3)) + +(memv '(2) '((1) (2) (3))) + +(define (_assoc obj list test?) + (if (null? list) + #f + (if (test? obj (caar list)) + (car list) + (_assoc obj (cdr list) test?) + ) + ) + ) + +(define (assq obj list) (_assoc obj list eq?)) +(define (assv obj list) (_assoc obj list eqv?)) +(define (assoc obj list) (_assoc obj list equal?)) + +(assq 'a '((a 1) (b 2) (c 3))) +(assv 'b '((a 1) (b 2) (c 3))) +(assoc '(c) '((a 1) (b 2) ((c) 3))) + +(define char? integer?) + +(char? #\q) +(char? "h") + +(define (char-upper-case? c) (<= #\A c #\Z)) + +(char-upper-case? #\a) +(char-upper-case? #\B) +(char-upper-case? #\0) +(char-upper-case? #\space) + +(define (char-lower-case? c) (<= #\a c #\a)) + +(char-lower-case? #\a) +(char-lower-case? #\B) +(char-lower-case? #\0) +(char-lower-case? #\space) + +(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) + +(char-alphabetic? #\a) +(char-alphabetic? #\B) +(char-alphabetic? #\0) +(char-alphabetic? #\space) + +(define (char-numeric? c) (<= #\0 c #\9)) + +(char-numeric? #\a) +(char-numeric? #\B) +(char-numeric? #\0) +(char-numeric? #\space) + +(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) + +(char-whitespace? #\a) +(char-whitespace? #\B) +(char-whitespace? #\0) +(char-whitespace? #\space) + +(define (char->integer c) c) +(define (integer->char c) char-integer) + +(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) + +(char-upcase #\a) +(char-upcase #\B) +(char-upcase #\0) +(char-upcase #\space) + +(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) + +(char-downcase #\a) +(char-downcase #\B) +(char-downcase #\0) +(char-downcase #\space) + +(define string (lambda chars (list->string chars))) + +(display "apply\n") +(apply cons '(a b)) + +(define map + (lambda (proc . lists) + (define (args lists) + (cond ((null? lists) ()) + (else + (cons (caar lists) (args (cdr lists))) + ) + ) + ) + (define (next lists) + (cond ((null? lists) ()) + (else + (cons (cdr (car lists)) (next (cdr lists))) + ) + ) + ) + (define (domap lists) + (cond ((null? (car lists)) ()) + (else + (cons (apply proc (args lists)) (domap (next lists))) + ) + ) + ) + (domap lists) + ) + ) + +(map cadr '((a b) (d e) (g h))) + +(define for-each (lambda (proc . lists) + (apply map proc lists) + #t)) + +(for-each display '("hello" " " "world" "\n")) + +(define (_string-ml strings) + (if (null? strings) () + (cons (string->list (car strings)) (_string-ml (cdr strings))) + ) + ) + +(define string-map (lambda (proc . strings) + (list->string (apply map proc (_string-ml strings)))))) + +(string-map (lambda (x) (+ 1 x)) "HAL") + +(define string-for-each (lambda (proc . strings) + (apply for-each proc (_string-ml strings)))) + +(string-for-each write-char "IBM\n") + +(define (newline) (write-char #\newline)) + +(newline) + +(call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (write "test" x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t)) + + + ; `q -> (quote q) + ; `(q) -> (append (quote (q))) + ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) + ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) + + + +`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) + + +(define repeat + (macro (count . rest) + (define counter '__count__) + (cond ((pair? count) + (set! counter (car count)) + (set! count (cadr count)) + ) + ) + `(let ((,counter 0) + (__max__ ,count) + ) + (while (< ,counter __max__) + ,@rest + (set! ,counter (+ ,counter 1)) + ) + ) + ) + ) + +(repeat 2 (write 'hello)) +(repeat (x 3) (write 'goodbye x)) + +(define case + (macro (test . l) + ; construct the body of the + ; case, dealing with the + ; lambda version ( => lambda) + + (define (_unarrow l) + (cond ((null? l) l) + ((eq? (car l) '=>) `(( ,(cadr l) __key__))) + (else l)) + ) + + ; Build the case elements, which is + ; simply a list of cond clauses + + (define (_case l) + + (cond ((null? l) ()) + + ; else case + + ((eq? (caar l) 'else) + `((else ,@(_unarrow (cdr (car l)))))) + + ; regular case + + (else + (cons + `((eqv? ,(caar l) __key__) + ,@(_unarrow (cdr (car l)))) + (_case (cdr l))) + ) + ) + ) + + ; now construct the overall + ; expression, using a lambda + ; to hold the computed value + ; of the test expression + + `((lambda (__key__) + (cond ,@(_case l))) ,test) + ) + ) + +(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) + +;(define number->string (lambda (arg . opt) +; (let ((base (if (null? opt) 10 (car opt))) + ; +; + diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c new file mode 100644 index 00000000..d580a2c0 --- /dev/null +++ b/src/scheme/ao_scheme_error.c @@ -0,0 +1,139 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" +#include <stdarg.h> + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last) +{ + int first = 1; + printf("\t\t%s(", name); + if (ao_scheme_poly_type(poly) == AO_SCHEME_CONS) { + if (poly) { + while (poly) { + struct ao_scheme_cons *cons = ao_scheme_poly_cons(poly); + if (!first) + printf("\t\t "); + else + first = 0; + ao_scheme_poly_write(cons->car); + printf("\n"); + if (poly == last) + break; + poly = cons->cdr; + } + printf("\t\t )\n"); + } else + printf(")\n"); + } else { + ao_scheme_poly_write(poly); + printf("\n"); + } +} + +static void tabs(int indent) +{ + while (indent--) + printf("\t"); +} + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame) +{ + int f; + + tabs(indent); + printf ("%s{", name); + if (frame) { + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + if (frame->type & AO_SCHEME_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_SCHEME_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) { + tabs(indent); + printf(" "); + } + ao_scheme_poly_write(vals->vals[f].atom); + printf(" = "); + ao_scheme_poly_write(vals->vals[f].val); + printf("\n"); + } + if (frame->prev) + ao_scheme_error_frame(indent + 1, "prev: ", ao_scheme_poly_frame(frame->prev)); + frame->type &= ~AO_SCHEME_FRAME_PRINT; + } + tabs(indent); + printf(" }\n"); + } else + printf ("}\n"); +} + +void +ao_scheme_vprintf(char *format, va_list args) +{ + char c; + + while ((c = *format++) != '\0') { + if (c == '%') { + switch (c = *format++) { + case 'v': + ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int)); + break; + case 'p': + printf("%p", va_arg(args, void *)); + break; + case 'd': + printf("%d", va_arg(args, int)); + break; + case 's': + printf("%s", va_arg(args, char *)); + break; + default: + putchar(c); + break; + } + } else + putchar(c); + } +} + +void +ao_scheme_printf(char *format, ...) +{ + va_list args; + va_start(args, format); + ao_scheme_vprintf(format, args); + va_end(args); +} + +ao_poly +ao_scheme_error(int error, char *format, ...) +{ + va_list args; + + ao_scheme_exception |= error; + va_start(args, format); + ao_scheme_vprintf(format, args); + putchar('\n'); + va_end(args); + ao_scheme_printf("Value: %v\n", ao_scheme_v); + ao_scheme_printf("Frame: %v\n", ao_scheme_frame_poly(ao_scheme_frame_current)); + printf("Stack:\n"); + ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)); + ao_scheme_printf("Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global)); + return AO_SCHEME_NIL; +} diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c new file mode 100644 index 00000000..9b3cf63e --- /dev/null +++ b/src/scheme/ao_scheme_eval.c @@ -0,0 +1,578 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" +#include <assert.h> + +struct ao_scheme_stack *ao_scheme_stack; +ao_poly ao_scheme_v; +uint8_t ao_scheme_skip_cons_free; + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *c) +{ + ao_scheme_stack->state = eval_cond; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(c); + return AO_SCHEME_NIL; +} + +static int +func_type(ao_poly func) +{ + if (func == AO_SCHEME_NIL) + return ao_scheme_error(AO_SCHEME_INVALID, "func is nil"); + switch (ao_scheme_poly_type(func)) { + case AO_SCHEME_BUILTIN: + return ao_scheme_poly_builtin(func)->args & AO_SCHEME_FUNC_MASK; + case AO_SCHEME_LAMBDA: + return ao_scheme_poly_lambda(func)->args; + case AO_SCHEME_STACK: + return AO_SCHEME_FUNC_LAMBDA; + default: + ao_scheme_error(AO_SCHEME_INVALID, "not a func"); + return -1; + } +} + +/* + * Flattened eval to avoid stack issues + */ + +/* + * Evaluate an s-expression + * + * For a list, evaluate all of the elements and + * then execute the resulting function call. + * + * Each element of the list is evaluated in + * a clean stack context. + * + * The current stack state is set to 'formal' so that + * when the evaluation is complete, the value + * will get appended to the values list. + * + * For other types, compute the value directly. + */ + +static int +ao_scheme_eval_sexpr(void) +{ + DBGI("sexpr: %v\n", ao_scheme_v); + switch (ao_scheme_poly_type(ao_scheme_v)) { + case AO_SCHEME_CONS: + if (ao_scheme_v == AO_SCHEME_NIL) { + if (!ao_scheme_stack->values) { + /* + * empty list evaluates to empty list + */ + ao_scheme_v = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_val; + } else { + /* + * done with arguments, go execute it + */ + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; + ao_scheme_stack->state = eval_exec; + } + } else { + if (!ao_scheme_stack->values) + ao_scheme_stack->list = ao_scheme_v; + /* + * Evaluate another argument and then switch + * to 'formal' to add the value to the values + * list + */ + ao_scheme_stack->sexprs = ao_scheme_v; + ao_scheme_stack->state = eval_formal; + if (!ao_scheme_stack_push()) + return 0; + /* + * push will reset the state to 'sexpr', which + * will evaluate the expression + */ + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; + } + break; + case AO_SCHEME_ATOM: + DBGI("..frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + ao_scheme_v = ao_scheme_atom_get(ao_scheme_v); + /* fall through */ + case AO_SCHEME_BOOL: + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + case AO_SCHEME_FLOAT: + case AO_SCHEME_STRING: + case AO_SCHEME_BUILTIN: + case AO_SCHEME_LAMBDA: + ao_scheme_stack->state = eval_val; + break; + } + DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG("\n"); + return 1; +} + +/* + * A value has been computed. + * + * If the value was computed from a macro, + * then we want to reset the current context + * to evaluate the macro result again. + * + * If not a macro, then pop the stack. + * If the stack is empty, we're done. + * Otherwise, the stack will contain + * the next state. + */ + +static int +ao_scheme_eval_val(void) +{ + DBGI("val: "); DBG_POLY(ao_scheme_v); DBG("\n"); + /* + * Value computed, pop the stack + * to figure out what to do with the value + */ + ao_scheme_stack_pop(); + DBGI("..state %d\n", ao_scheme_stack ? ao_scheme_stack->state : -1); + return 1; +} + +/* + * A formal has been computed. + * + * If this is the first formal, then check to see if we've got a + * lamda, macro or nlambda. + * + * For lambda, go compute another formal. This will terminate + * when the sexpr state sees nil. + * + * For macro/nlambda, we're done, so move the sexprs into the values + * and go execute it. + * + * Macros have an additional step of saving a stack frame holding the + * macro value execution context, which then gets the result of the + * macro to run + */ + +static int +ao_scheme_eval_formal(void) +{ + ao_poly formal; + struct ao_scheme_stack *prev; + + DBGI("formal: "); DBG_POLY(ao_scheme_v); DBG("\n"); + + /* Check what kind of function we've got */ + if (!ao_scheme_stack->values) { + switch (func_type(ao_scheme_v)) { + case AO_SCHEME_FUNC_LAMBDA: + DBGI(".. lambda\n"); + break; + case AO_SCHEME_FUNC_MACRO: + /* Evaluate the result once more */ + ao_scheme_stack->state = eval_macro; + if (!ao_scheme_stack_push()) + return 0; + + /* After the function returns, take that + * value and re-evaluate it + */ + prev = ao_scheme_poly_stack(ao_scheme_stack->prev); + ao_scheme_stack->sexprs = prev->sexprs; + + DBGI(".. start macro\n"); + DBGI("\t.. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI("\t.. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); + DBG_FRAMES(); + + /* fall through ... */ + case AO_SCHEME_FUNC_NLAMBDA: + DBGI(".. nlambda or macro\n"); + + /* use the raw sexprs as values */ + ao_scheme_stack->values = ao_scheme_stack->sexprs; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_exec; + + /* ready to execute now */ + return 1; + case -1: + return 0; + } + } + + /* Append formal to list of values */ + formal = ao_scheme__cons(ao_scheme_v, AO_SCHEME_NIL); + if (!formal) + return 0; + + if (ao_scheme_stack->values_tail) + ao_scheme_poly_cons(ao_scheme_stack->values_tail)->cdr = formal; + else + ao_scheme_stack->values = formal; + ao_scheme_stack->values_tail = formal; + + DBGI(".. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); + + /* + * Step to the next argument, if this is last, then + * 'sexpr' will end up switching to 'exec' + */ + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + + ao_scheme_stack->state = eval_sexpr; + + DBGI(".. "); DBG_POLY(ao_scheme_v); DBG("\n"); + return 1; +} + +/* + * Start executing a function call + * + * Most builtins are easy, just call the function. + * 'cond' is magic; it sticks the list of clauses + * in 'sexprs' and switches to 'cond' state. That + * bit of magic is done in ao_scheme_set_cond. + * + * Lambdas build a new frame to hold the locals and + * then re-use the current stack context to evaluate + * the s-expression from the lambda. + */ + +static int +ao_scheme_eval_exec(void) +{ + ao_poly v; + struct ao_scheme_builtin *builtin; + + DBGI("exec: "); DBG_POLY(ao_scheme_v); DBG(" values "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); + ao_scheme_stack->sexprs = AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_v)) { + case AO_SCHEME_BUILTIN: + ao_scheme_stack->state = eval_val; + builtin = ao_scheme_poly_builtin(ao_scheme_v); + v = ao_scheme_func(builtin) ( + ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr)); + DBG_DO(if (!ao_scheme_exception && ao_scheme_poly_builtin(ao_scheme_v)->func == builtin_set) { + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + ao_poly atom = ao_scheme_arg(cons, 1); + ao_poly val = ao_scheme_arg(cons, 2); + DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); + }); + builtin = ao_scheme_poly_builtin(ao_scheme_v); + if (builtin && (builtin->args & AO_SCHEME_FUNC_FREE_ARGS) && !ao_scheme_stack_marked(ao_scheme_stack) && !ao_scheme_skip_cons_free) { + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_cons_free(cons); + } + + ao_scheme_v = v; + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG ("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + break; + case AO_SCHEME_LAMBDA: + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + ao_scheme_stack->state = eval_begin; + v = ao_scheme_lambda_eval(); + ao_scheme_stack->sexprs = v; + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + DBGI(".. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + break; + case AO_SCHEME_STACK: + DBGI(".. stack "); DBG_POLY(ao_scheme_v); DBG("\n"); + ao_scheme_v = ao_scheme_stack_eval(); + DBGI(".. value "); DBG_POLY(ao_scheme_v); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + break; + } + ao_scheme_skip_cons_free = 0; + return 1; +} + +/* + * Finish setting up the apply evaluation + * + * The value is the list to execute + */ +static int +ao_scheme_eval_apply(void) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_v); + struct ao_scheme_cons *cdr, *prev; + + /* Glue the arguments into the right shape. That's all but the last + * concatenated onto the last + */ + cdr = cons; + for (;;) { + prev = cdr; + cdr = ao_scheme_poly_cons(prev->cdr); + if (cdr->cdr == AO_SCHEME_NIL) + break; + } + DBGI("before mangling: "); DBG_POLY(ao_scheme_v); DBG("\n"); + prev->cdr = cdr->car; + ao_scheme_stack->values = ao_scheme_v; + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; + DBGI("apply: "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); + ao_scheme_stack->state = eval_exec; + ao_scheme_skip_cons_free = 1; + return 1; +} + +/* + * Start evaluating the next cond clause + * + * If the list of clauses is empty, then + * the result of the cond is nil. + * + * Otherwise, set the current stack state to 'cond_test' and create a + * new stack context to evaluate the test s-expression. Once that's + * complete, we'll land in 'cond_test' to finish the clause. + */ +static int +ao_scheme_eval_cond(void) +{ + DBGI("cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + if (!ao_scheme_stack->sexprs) { + ao_scheme_v = _ao_scheme_bool_false; + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; + if (!ao_scheme_v || ao_scheme_poly_type(ao_scheme_v) != AO_SCHEME_CONS) { + ao_scheme_error(AO_SCHEME_INVALID, "invalid cond clause"); + return 0; + } + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; + if (ao_scheme_v == _ao_scheme_atom_else) + ao_scheme_v = _ao_scheme_bool_true; + ao_scheme_stack->state = eval_cond_test; + if (!ao_scheme_stack_push()) + return 0; + } + return 1; +} + +/* + * Finish a cond clause. + * + * Check the value from the test expression, if + * non-nil, then set up to evaluate the value expression. + * + * Otherwise, step to the next clause and go back to the 'cond' + * state + */ +static int +ao_scheme_eval_cond_test(void) +{ + DBGI("cond_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + if (ao_scheme_v != _ao_scheme_bool_false) { + struct ao_scheme_cons *car = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car); + ao_poly c = car->cdr; + + if (c) { + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = c; + } else + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + DBGI("next cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + ao_scheme_stack->state = eval_cond; + } + return 1; +} + +/* + * Evaluate a list of sexprs, returning the value from the last one. + * + * ao_scheme_begin records the list in stack->sexprs, so we just need to + * walk that list. Set ao_scheme_v to the car of the list and jump to + * eval_sexpr. When that's done, it will land in eval_val. For all but + * the last, leave a stack frame with eval_begin set so that we come + * back here. For the last, don't add a stack frame so that we can + * just continue on. + */ +static int +ao_scheme_eval_begin(void) +{ + DBGI("begin: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + + if (!ao_scheme_stack->sexprs) { + ao_scheme_v = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; + ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + + /* If there are more sexprs to do, then come back here, otherwise + * return the value of the last one by just landing in eval_sexpr + */ + if (ao_scheme_stack->sexprs) { + ao_scheme_stack->state = eval_begin; + if (!ao_scheme_stack_push()) + return 0; + } + ao_scheme_stack->state = eval_sexpr; + } + return 1; +} + +/* + * Conditionally execute a list of sexprs while the first is true + */ +static int +ao_scheme_eval_while(void) +{ + DBGI("while: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + + ao_scheme_stack->values = ao_scheme_v; + if (!ao_scheme_stack->sexprs) { + ao_scheme_v = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; + ao_scheme_stack->state = eval_while_test; + if (!ao_scheme_stack_push()) + return 0; + } + return 1; +} + +/* + * Check the while condition, terminate the loop if nil. Otherwise keep going + */ +static int +ao_scheme_eval_while_test(void) +{ + DBGI("while_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + + if (ao_scheme_v != _ao_scheme_bool_false) { + ao_scheme_stack->values = ao_scheme_v; + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + ao_scheme_stack->state = eval_while; + if (!ao_scheme_stack_push()) + return 0; + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = ao_scheme_v; + } + else + { + ao_scheme_stack->state = eval_val; + ao_scheme_v = ao_scheme_stack->values; + } + return 1; +} + +/* + * Replace the original sexpr with the macro expansion, then + * execute that + */ +static int +ao_scheme_eval_macro(void) +{ + DBGI("macro: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + + if (ao_scheme_v == AO_SCHEME_NIL) + ao_scheme_abort(); + if (ao_scheme_poly_type(ao_scheme_v) == AO_SCHEME_CONS) { + *ao_scheme_poly_cons(ao_scheme_stack->sexprs) = *ao_scheme_poly_cons(ao_scheme_v); + ao_scheme_v = ao_scheme_stack->sexprs; + DBGI("sexprs rewritten to: "); DBG_POLY(ao_scheme_v); DBG("\n"); + } + ao_scheme_stack->sexprs = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_sexpr; + return 1; +} + +static int (*const evals[])(void) = { + [eval_sexpr] = ao_scheme_eval_sexpr, + [eval_val] = ao_scheme_eval_val, + [eval_formal] = ao_scheme_eval_formal, + [eval_exec] = ao_scheme_eval_exec, + [eval_apply] = ao_scheme_eval_apply, + [eval_cond] = ao_scheme_eval_cond, + [eval_cond_test] = ao_scheme_eval_cond_test, + [eval_begin] = ao_scheme_eval_begin, + [eval_while] = ao_scheme_eval_while, + [eval_while_test] = ao_scheme_eval_while_test, + [eval_macro] = ao_scheme_eval_macro, +}; + +const char * const ao_scheme_state_names[] = { + [eval_sexpr] = "sexpr", + [eval_val] = "val", + [eval_formal] = "formal", + [eval_exec] = "exec", + [eval_apply] = "apply", + [eval_cond] = "cond", + [eval_cond_test] = "cond_test", + [eval_begin] = "begin", + [eval_while] = "while", + [eval_while_test] = "while_test", + [eval_macro] = "macro", +}; + +/* + * Called at restore time to reset all execution state + */ + +void +ao_scheme_eval_clear_globals(void) +{ + ao_scheme_stack = NULL; + ao_scheme_frame_current = NULL; + ao_scheme_v = AO_SCHEME_NIL; +} + +int +ao_scheme_eval_restart(void) +{ + return ao_scheme_stack_push(); +} + +ao_poly +ao_scheme_eval(ao_poly _v) +{ + ao_scheme_v = _v; + + ao_scheme_frame_init(); + + if (!ao_scheme_stack_push()) + return AO_SCHEME_NIL; + + while (ao_scheme_stack) { + if (!(*evals[ao_scheme_stack->state])() || ao_scheme_exception) { + ao_scheme_stack_clear(); + return AO_SCHEME_NIL; + } + } + DBG_DO(if (ao_scheme_frame_current) {DBGI("frame left as "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n");}); + ao_scheme_frame_current = NULL; + return ao_scheme_v; +} diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c new file mode 100644 index 00000000..541f0264 --- /dev/null +++ b/src/scheme/ao_scheme_float.c @@ -0,0 +1,148 @@ +/* + * Copyright © 2017 Keith Packard <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_scheme.h" +#include <math.h> + +static void float_mark(void *addr) +{ + (void) addr; +} + +static int float_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_scheme_float); +} + +static void float_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_float_type = { + .mark = float_mark, + .size = float_size, + .move = float_move, + .name = "float", +}; + +void +ao_scheme_float_write(ao_poly p) +{ + struct ao_scheme_float *f = ao_scheme_poly_float(p); + float v = f->value; + + if (isnanf(v)) + printf("+nan.0"); + else if (isinff(v)) { + if (v < 0) + printf("-"); + else + printf("+"); + printf("inf.0"); + } else + printf ("%g", f->value); +} + +float +ao_scheme_poly_number(ao_poly p) +{ + switch (ao_scheme_poly_base_type(p)) { + case AO_SCHEME_INT: + return ao_scheme_poly_int(p); + case AO_SCHEME_OTHER: + switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { + case AO_SCHEME_BIGINT: + return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + case AO_SCHEME_FLOAT: + return ao_scheme_poly_float(p)->value; + } + } + return NAN; +} + +ao_poly +ao_scheme_float_get(float value) +{ + struct ao_scheme_float *f; + + f = ao_scheme_alloc(sizeof (struct ao_scheme_float)); + f->type = AO_SCHEME_FLOAT; + f->value = value; + return ao_scheme_float_poly(f); +} + +ao_poly +ao_scheme_do_inexactp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == AO_SCHEME_FLOAT) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_finitep(struct ao_scheme_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + value = ao_scheme_arg(cons, 0); + switch (ao_scheme_poly_type(value)) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + return _ao_scheme_bool_true; + case AO_SCHEME_FLOAT: + f = ao_scheme_poly_float(value)->value; + if (!isnan(f) && !isinf(f)) + return _ao_scheme_bool_true; + } + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_infinitep(struct ao_scheme_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + value = ao_scheme_arg(cons, 0); + switch (ao_scheme_poly_type(value)) { + case AO_SCHEME_FLOAT: + f = ao_scheme_poly_float(value)->value; + if (isinf(f)) + return _ao_scheme_bool_true; + } + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_sqrt(struct ao_scheme_cons *cons) +{ + ao_poly value; + + if (!ao_scheme_check_argc(_ao_scheme_atom_sqrt, cons, 1, 1)) + return AO_SCHEME_NIL; + value = ao_scheme_arg(cons, 0); + if (!ao_scheme_number_typep(ao_scheme_poly_type(value))) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: non-numeric", ao_scheme_poly_atom(_ao_scheme_atom_sqrt)->name); + return ao_scheme_float_get(sqrtf(ao_scheme_poly_number(value))); +} diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c new file mode 100644 index 00000000..e5d481e7 --- /dev/null +++ b/src/scheme/ao_scheme_frame.c @@ -0,0 +1,330 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" + +static inline int +frame_vals_num_size(int num) +{ + return sizeof (struct ao_scheme_frame_vals) + num * sizeof (struct ao_scheme_val); +} + +static int +frame_vals_size(void *addr) +{ + struct ao_scheme_frame_vals *vals = addr; + return frame_vals_num_size(vals->size); +} + +static void +frame_vals_mark(void *addr) +{ + struct ao_scheme_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_scheme_val *v = &vals->vals[f]; + + ao_scheme_poly_mark(v->val, 0); + MDBG_MOVE("frame mark atom %s %d val %d at %d ", + ao_scheme_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_scheme_ref(v->atom)), + MDBG_OFFSET(ao_scheme_ref(v->val)), f); + MDBG_DO(ao_scheme_poly_write(v->val)); + MDBG_DO(printf("\n")); + } +} + +static void +frame_vals_move(void *addr) +{ + struct ao_scheme_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_scheme_val *v = &vals->vals[f]; + + ao_scheme_poly_move(&v->atom, 0); + ao_scheme_poly_move(&v->val, 0); + MDBG_MOVE("frame move atom %s %d val %d at %d\n", + ao_scheme_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_scheme_ref(v->atom)), + MDBG_OFFSET(ao_scheme_ref(v->val)), f); + } +} + +const struct ao_scheme_type ao_scheme_frame_vals_type = { + .mark = frame_vals_mark, + .size = frame_vals_size, + .move = frame_vals_move, + .name = "frame_vals" +}; + +static int +frame_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_frame); +} + +static void +frame_mark(void *addr) +{ + struct ao_scheme_frame *frame = addr; + + for (;;) { + MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); + if (!AO_SCHEME_IS_POOL(frame)) + break; + ao_scheme_poly_mark(frame->vals, 0); + frame = ao_scheme_poly_frame(frame->prev); + MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); + if (!frame) + break; + if (ao_scheme_mark_memory(&ao_scheme_frame_type, frame)) + break; + } +} + +static void +frame_move(void *addr) +{ + struct ao_scheme_frame *frame = addr; + + for (;;) { + struct ao_scheme_frame *prev; + int ret; + + MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); + if (!AO_SCHEME_IS_POOL(frame)) + break; + ao_scheme_poly_move(&frame->vals, 0); + prev = ao_scheme_poly_frame(frame->prev); + if (!prev) + break; + ret = ao_scheme_move_memory(&ao_scheme_frame_type, (void **) &prev); + if (prev != ao_scheme_poly_frame(frame->prev)) { + MDBG_MOVE("frame prev moved from %d to %d\n", + MDBG_OFFSET(ao_scheme_poly_frame(frame->prev)), + MDBG_OFFSET(prev)); + frame->prev = ao_scheme_frame_poly(prev); + } + if (ret) + break; + frame = prev; + } +} + +const struct ao_scheme_type ao_scheme_frame_type = { + .mark = frame_mark, + .size = frame_size, + .move = frame_move, + .name = "frame", +}; + +void +ao_scheme_frame_write(ao_poly p) +{ + struct ao_scheme_frame *frame = ao_scheme_poly_frame(p); + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int f; + + printf ("{"); + if (frame) { + if (frame->type & AO_SCHEME_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_SCHEME_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) + printf(", "); + ao_scheme_poly_write(vals->vals[f].atom); + printf(" = "); + ao_scheme_poly_write(vals->vals[f].val); + } + if (frame->prev) + ao_scheme_poly_write(frame->prev); + frame->type &= ~AO_SCHEME_FRAME_PRINT; + } + } + printf("}"); +} + +static int +ao_scheme_frame_find(struct ao_scheme_frame *frame, int top, ao_poly atom) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = 0; + int r = top - 1; + + while (l <= r) { + int m = (l + r) >> 1; + if (vals->vals[m].atom < atom) + l = m + 1; + else + r = m - 1; + } + return l; +} + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = ao_scheme_frame_find(frame, frame->num, atom); + + if (l >= frame->num) + return NULL; + + if (vals->vals[l].atom != atom) + return NULL; + return &vals->vals[l].val; +} + +struct ao_scheme_frame *ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +static struct ao_scheme_frame_vals * +ao_scheme_frame_vals_new(int num) +{ + struct ao_scheme_frame_vals *vals; + + vals = ao_scheme_alloc(frame_vals_num_size(num)); + if (!vals) + return NULL; + vals->type = AO_SCHEME_FRAME_VALS; + vals->size = num; + memset(vals->vals, '\0', num * sizeof (struct ao_scheme_val)); + return vals; +} + +struct ao_scheme_frame * +ao_scheme_frame_new(int num) +{ + struct ao_scheme_frame *frame; + struct ao_scheme_frame_vals *vals; + + if (num < AO_SCHEME_FRAME_FREE && (frame = ao_scheme_frame_free_list[num])) { + ao_scheme_frame_free_list[num] = ao_scheme_poly_frame(frame->prev); + vals = ao_scheme_poly_frame_vals(frame->vals); + } else { + frame = ao_scheme_alloc(sizeof (struct ao_scheme_frame)); + if (!frame) + return NULL; + frame->type = AO_SCHEME_FRAME; + frame->num = 0; + frame->prev = AO_SCHEME_NIL; + frame->vals = AO_SCHEME_NIL; + ao_scheme_frame_stash(0, frame); + vals = ao_scheme_frame_vals_new(num); + frame = ao_scheme_frame_fetch(0); + if (!vals) + return NULL; + frame->vals = ao_scheme_frame_vals_poly(vals); + frame->num = num; + } + frame->prev = AO_SCHEME_NIL; + return frame; +} + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame) +{ + if (!frame) + return AO_SCHEME_NIL; + frame->type |= AO_SCHEME_FRAME_MARK; + return ao_scheme_frame_poly(frame); +} + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame) +{ + if (frame && !ao_scheme_frame_marked(frame)) { + int num = frame->num; + if (num < AO_SCHEME_FRAME_FREE) { + struct ao_scheme_frame_vals *vals; + + vals = ao_scheme_poly_frame_vals(frame->vals); + memset(vals->vals, '\0', vals->size * sizeof (struct ao_scheme_val)); + frame->prev = ao_scheme_frame_poly(ao_scheme_frame_free_list[num]); + ao_scheme_frame_free_list[num] = frame; + } + } +} + +static struct ao_scheme_frame * +ao_scheme_frame_realloc(struct ao_scheme_frame *frame, int new_num) +{ + struct ao_scheme_frame_vals *vals; + struct ao_scheme_frame_vals *new_vals; + int copy; + + if (new_num == frame->num) + return frame; + ao_scheme_frame_stash(0, frame); + new_vals = ao_scheme_frame_vals_new(new_num); + frame = ao_scheme_frame_fetch(0); + if (!new_vals) + return NULL; + vals = ao_scheme_poly_frame_vals(frame->vals); + copy = new_num; + if (copy > frame->num) + copy = frame->num; + memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_scheme_val)); + frame->vals = ao_scheme_frame_vals_poly(new_vals); + frame->num = new_num; + return frame; +} + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = ao_scheme_frame_find(frame, num, atom); + + memmove(&vals->vals[l+1], + &vals->vals[l], + (num - l) * sizeof (struct ao_scheme_val)); + vals->vals[l].atom = atom; + vals->vals[l].val = val; +} + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val) +{ + ao_poly *ref = frame ? ao_scheme_frame_ref(frame, atom) : NULL; + + if (!ref) { + int f = frame->num; + ao_scheme_poly_stash(0, atom); + ao_scheme_poly_stash(1, val); + frame = ao_scheme_frame_realloc(frame, f + 1); + val = ao_scheme_poly_fetch(1); + atom = ao_scheme_poly_fetch(0); + if (!frame) + return AO_SCHEME_NIL; + ao_scheme_frame_bind(frame, frame->num - 1, atom, val); + } else + *ref = val; + return val; +} + +struct ao_scheme_frame *ao_scheme_frame_global; +struct ao_scheme_frame *ao_scheme_frame_current; + +void +ao_scheme_frame_init(void) +{ + if (!ao_scheme_frame_global) + ao_scheme_frame_global = ao_scheme_frame_new(0); +} diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c new file mode 100644 index 00000000..350a5d35 --- /dev/null +++ b/src/scheme/ao_scheme_int.c @@ -0,0 +1,79 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" + +void +ao_scheme_int_write(ao_poly p) +{ + int i = ao_scheme_poly_int(p); + printf("%d", i); +} + +int32_t +ao_scheme_poly_integer(ao_poly p) +{ + switch (ao_scheme_poly_base_type(p)) { + case AO_SCHEME_INT: + return ao_scheme_poly_int(p); + case AO_SCHEME_OTHER: + if (ao_scheme_other_type(ao_scheme_poly_other(p)) == AO_SCHEME_BIGINT) + return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + } + return AO_SCHEME_NOT_INTEGER; +} + +ao_poly +ao_scheme_integer_poly(int32_t p) +{ + struct ao_scheme_bigint *bi; + + if (AO_SCHEME_MIN_INT <= p && p <= AO_SCHEME_MAX_INT) + return ao_scheme_int_poly(p); + bi = ao_scheme_alloc(sizeof (struct ao_scheme_bigint)); + bi->value = ao_scheme_int_bigint(p); + return ao_scheme_bigint_poly(bi); +} + +static void bigint_mark(void *addr) +{ + (void) addr; +} + +static int bigint_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_scheme_bigint); +} + +static void bigint_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_bigint_type = { + .mark = bigint_mark, + .size = bigint_size, + .move = bigint_move, + .name = "bigint", +}; + +void +ao_scheme_bigint_write(ao_poly p) +{ + struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); + + printf("%d", ao_scheme_bigint_int(bi->value)); +} diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c new file mode 100644 index 00000000..ec6f858c --- /dev/null +++ b/src/scheme/ao_scheme_lambda.c @@ -0,0 +1,208 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" + +int +lambda_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_lambda); +} + +void +lambda_mark(void *addr) +{ + struct ao_scheme_lambda *lambda = addr; + + ao_scheme_poly_mark(lambda->code, 0); + ao_scheme_poly_mark(lambda->frame, 0); +} + +void +lambda_move(void *addr) +{ + struct ao_scheme_lambda *lambda = addr; + + ao_scheme_poly_move(&lambda->code, 0); + ao_scheme_poly_move(&lambda->frame, 0); +} + +const struct ao_scheme_type ao_scheme_lambda_type = { + .size = lambda_size, + .mark = lambda_mark, + .move = lambda_move, + .name = "lambda", +}; + +void +ao_scheme_lambda_write(ao_poly poly) +{ + struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(poly); + struct ao_scheme_cons *cons = ao_scheme_poly_cons(lambda->code); + + printf("("); + printf("%s", ao_scheme_args_name(lambda->args)); + while (cons) { + printf(" "); + ao_scheme_poly_write(cons->car); + cons = ao_scheme_poly_cons(cons->cdr); + } + printf(")"); +} + +ao_poly +ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args) +{ + struct ao_scheme_lambda *lambda; + ao_poly formal; + struct ao_scheme_cons *cons; + + formal = ao_scheme_arg(code, 0); + while (formal != AO_SCHEME_NIL) { + switch (ao_scheme_poly_type(formal)) { + case AO_SCHEME_CONS: + cons = ao_scheme_poly_cons(formal); + if (ao_scheme_poly_type(cons->car) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", cons->car); + formal = cons->cdr; + break; + case AO_SCHEME_ATOM: + formal = AO_SCHEME_NIL; + break; + default: + return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", formal); + } + } + + ao_scheme_cons_stash(0, code); + lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); + code = ao_scheme_cons_fetch(0); + if (!lambda) + return AO_SCHEME_NIL; + + lambda->type = AO_SCHEME_LAMBDA; + lambda->args = args; + lambda->code = ao_scheme_cons_poly(code); + lambda->frame = ao_scheme_frame_mark(ao_scheme_frame_current); + DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); + DBG_STACK(); + return ao_scheme_lambda_poly(lambda); +} + +ao_poly +ao_scheme_do_lambda(struct ao_scheme_cons *cons) +{ + return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_LAMBDA); +} + +ao_poly +ao_scheme_do_nlambda(struct ao_scheme_cons *cons) +{ + return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_NLAMBDA); +} + +ao_poly +ao_scheme_do_macro(struct ao_scheme_cons *cons) +{ + return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_MACRO); +} + +ao_poly +ao_scheme_lambda_eval(void) +{ + struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(ao_scheme_v); + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + struct ao_scheme_cons *code = ao_scheme_poly_cons(lambda->code); + ao_poly formals; + struct ao_scheme_frame *next_frame; + int args_wanted; + ao_poly varargs = AO_SCHEME_NIL; + int args_provided; + int f; + struct ao_scheme_cons *vals; + + DBGI("lambda "); DBG_POLY(ao_scheme_lambda_poly(lambda)); DBG("\n"); + + args_wanted = 0; + for (formals = ao_scheme_arg(code, 0); + ao_scheme_is_pair(formals); + formals = ao_scheme_poly_cons(formals)->cdr) + ++args_wanted; + if (formals != AO_SCHEME_NIL) { + if (ao_scheme_poly_type(formals) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "bad lambda form"); + varargs = formals; + } + + /* Create a frame to hold the variables + */ + args_provided = ao_scheme_cons_length(cons) - 1; + if (varargs == AO_SCHEME_NIL) { + if (args_wanted != args_provided) + return ao_scheme_error(AO_SCHEME_INVALID, "need %d args, got %d", args_wanted, args_provided); + } else { + if (args_provided < args_wanted) + return ao_scheme_error(AO_SCHEME_INVALID, "need at least %d args, got %d", args_wanted, args_provided); + } + + ao_scheme_poly_stash(1, varargs); + next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); + varargs = ao_scheme_poly_fetch(1); + if (!next_frame) + return AO_SCHEME_NIL; + + /* Re-fetch all of the values in case something moved */ + lambda = ao_scheme_poly_lambda(ao_scheme_v); + cons = ao_scheme_poly_cons(ao_scheme_stack->values); + code = ao_scheme_poly_cons(lambda->code); + formals = ao_scheme_arg(code, 0); + vals = ao_scheme_poly_cons(cons->cdr); + + next_frame->prev = lambda->frame; + ao_scheme_frame_current = next_frame; + ao_scheme_stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); + + for (f = 0; f < args_wanted; f++) { + struct ao_scheme_cons *arg = ao_scheme_poly_cons(formals); + DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + ao_scheme_frame_bind(next_frame, f, arg->car, vals->car); + formals = arg->cdr; + vals = ao_scheme_poly_cons(vals->cdr); + } + if (varargs) { + DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_scheme_cons_poly(vals)); DBG("\n"); + /* + * Bind the rest of the arguments to the final parameter + */ + ao_scheme_frame_bind(next_frame, f, varargs, ao_scheme_cons_poly(vals)); + } else { + /* + * Mark the cons cells from the actuals as freed for immediate re-use, unless + * the actuals point into the source function (nlambdas and macros), or if the + * stack containing them was copied as a part of a continuation + */ + if (lambda->args == AO_SCHEME_FUNC_LAMBDA && !ao_scheme_stack_marked(ao_scheme_stack)) { + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_cons_free(cons); + } + } + DBGI("eval frame: "); DBG_POLY(ao_scheme_frame_poly(next_frame)); DBG("\n"); + DBG_STACK(); + DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); + return code->cdr; +} diff --git a/src/scheme/ao_scheme_lex.c b/src/scheme/ao_scheme_lex.c new file mode 100644 index 00000000..266b1fc0 --- /dev/null +++ b/src/scheme/ao_scheme_lex.c @@ -0,0 +1,16 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" + diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin new file mode 100644 index 00000000..8e9c2c0b --- /dev/null +++ b/src/scheme/ao_scheme_make_builtin @@ -0,0 +1,190 @@ +#!/usr/bin/nickle + +typedef struct { + string type; + string c_name; + string[*] lisp_names; +} builtin_t; + +string[string] type_map = { + "lambda" => "LAMBDA", + "nlambda" => "NLAMBDA", + "macro" => "MACRO", + "f_lambda" => "F_LAMBDA", + "atom" => "atom", +}; + +string[*] +make_lisp(string[*] tokens) +{ + string[...] lisp = {}; + + if (dim(tokens) < 3) + return (string[1]) { tokens[dim(tokens) - 1] }; + return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; +} + +builtin_t +read_builtin(file f) { + string line = File::fgets(f); + string[*] tokens = String::wordsplit(line, " \t"); + + return (builtin_t) { + .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", + .c_name = dim(tokens) > 1 ? tokens[1] : "#", + .lisp_names = make_lisp(tokens), + }; +} + +builtin_t[*] +read_builtins(file f) { + builtin_t[...] builtins = {}; + + while (!File::end(f)) { + builtin_t b = read_builtin(f); + + if (b.type[0] != '#') + builtins[dim(builtins)] = b; + } + return builtins; +} + +bool is_atom(builtin_t b) = b.type == "atom"; + +void +dump_ids(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_ID\n"); + printf("#undef AO_SCHEME_BUILTIN_ID\n"); + printf("enum ao_scheme_builtin_id {\n"); + for (int i = 0; i < dim(builtins); i++) + if (!is_atom(builtins[i])) + printf("\tbuiltin_%s,\n", builtins[i].c_name); + printf("\t_builtin_last\n"); + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_ID */\n"); +} + +void +dump_casename(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_CASENAME\n"); + printf("#undef AO_SCHEME_BUILTIN_CASENAME\n"); + printf("static char *ao_scheme_builtin_name(enum ao_scheme_builtin_id b) {\n"); + printf("\tswitch(b) {\n"); + for (int i = 0; i < dim(builtins); i++) + if (!is_atom(builtins[i])) + printf("\tcase builtin_%s: return ao_scheme_poly_atom(_atom(\"%s\"))->name;\n", + builtins[i].c_name, builtins[i].lisp_names[0]); + printf("\tdefault: return \"???\";\n"); + printf("\t}\n"); + printf("}\n"); + printf("#endif /* AO_SCHEME_BUILTIN_CASENAME */\n"); +} + +void +cify_lisp(string l) { + for (int j = 0; j < String::length(l); j++) { + int c= l[j]; + if (Ctype::isalnum(c) || c == '_') + printf("%c", c); + else + printf("%02x", c); + } +} + +void +dump_arrayname(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_ARRAYNAME\n"); + printf("#undef AO_SCHEME_BUILTIN_ARRAYNAME\n"); + printf("static const ao_poly builtin_names[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + if (!is_atom(builtins[i])) { + printf("\t[builtin_%s] = _ao_scheme_atom_", + builtins[i].c_name); + cify_lisp(builtins[i].lisp_names[0]); + printf(",\n"); + } + } + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_ARRAYNAME */\n"); +} + +void +dump_funcs(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_FUNCS\n"); + printf("#undef AO_SCHEME_BUILTIN_FUNCS\n"); + printf("const ao_scheme_func_t ao_scheme_builtins[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + if (!is_atom(builtins[i])) + printf("\t[builtin_%s] = ao_scheme_do_%s,\n", + builtins[i].c_name, + builtins[i].c_name); + } + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_FUNCS */\n"); +} + +void +dump_decls(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_DECLS\n"); + printf("#undef AO_SCHEME_BUILTIN_DECLS\n"); + for (int i = 0; i < dim(builtins); i++) { + if (!is_atom(builtins[i])) { + printf("ao_poly\n"); + printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n", + builtins[i].c_name); + } + } + printf("#endif /* AO_SCHEME_BUILTIN_DECLS */\n"); +} + +void +dump_consts(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_CONSTS\n"); + printf("#undef AO_SCHEME_BUILTIN_CONSTS\n"); + printf("struct builtin_func funcs[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + if (!is_atom(builtins[i])) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf ("\t{ .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", + builtins[i].lisp_names[j], + builtins[i].type, + builtins[i].c_name); + } + } + } + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_CONSTS */\n"); +} + +void +dump_atoms(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_ATOMS\n"); + printf("#undef AO_SCHEME_BUILTIN_ATOMS\n"); + for (int i = 0; i < dim(builtins); i++) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf("#define _ao_scheme_atom_"); + cify_lisp(builtins[i].lisp_names[j]); + printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); + } + } + printf("#endif /* AO_SCHEME_BUILTIN_ATOMS */\n"); +} + +void main() { + if (dim(argv) < 2) { + File::fprintf(stderr, "usage: %s <file>\n", argv[0]); + exit(1); + } + twixt(file f = File::open(argv[1], "r"); File::close(f)) { + builtin_t[*] builtins = read_builtins(f); + dump_ids(builtins); + dump_casename(builtins); + dump_arrayname(builtins); + dump_funcs(builtins); + dump_decls(builtins); + dump_consts(builtins); + dump_atoms(builtins); + } +} + +main(); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c new file mode 100644 index 00000000..cf42ec52 --- /dev/null +++ b/src/scheme/ao_scheme_make_const.c @@ -0,0 +1,395 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" +#include <stdlib.h> +#include <ctype.h> +#include <unistd.h> +#include <getopt.h> + +static struct ao_scheme_builtin * +ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { + struct ao_scheme_builtin *b = ao_scheme_alloc(sizeof (struct ao_scheme_builtin)); + + b->type = AO_SCHEME_BUILTIN; + b->func = func; + b->args = args; + return b; +} + +struct builtin_func { + char *name; + int args; + enum ao_scheme_builtin_id func; +}; + +#define AO_SCHEME_BUILTIN_CONSTS +#include "ao_scheme_builtin.h" + +#define N_FUNC (sizeof funcs / sizeof funcs[0]) + +struct ao_scheme_frame *globals; + +static int +is_atom(int offset) +{ + struct ao_scheme_atom *a; + + for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) + if (((uint8_t *) a->name - ao_scheme_const) == offset) + return strlen(a->name); + return 0; +} + +#define AO_FEC_CRC_INIT 0xffff + +static inline uint16_t +ao_fec_crc_byte(uint8_t byte, uint16_t crc) +{ + uint8_t bit; + + for (bit = 0; bit < 8; bit++) { + if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) + crc = (crc << 1) ^ 0x8005; + else + crc = (crc << 1); + byte <<= 1; + } + return crc; +} + +uint16_t +ao_fec_crc(const uint8_t *bytes, uint8_t len) +{ + uint16_t crc = AO_FEC_CRC_INIT; + + while (len--) + crc = ao_fec_crc_byte(*bytes++, crc); + return crc; +} + +struct ao_scheme_macro_stack { + struct ao_scheme_macro_stack *next; + ao_poly p; +}; + +struct ao_scheme_macro_stack *macro_stack; + +int +ao_scheme_macro_push(ao_poly p) +{ + struct ao_scheme_macro_stack *m = macro_stack; + + while (m) { + if (m->p == p) + return 1; + m = m->next; + } + m = malloc (sizeof (struct ao_scheme_macro_stack)); + m->p = p; + m->next = macro_stack; + macro_stack = m; + return 0; +} + +void +ao_scheme_macro_pop(void) +{ + struct ao_scheme_macro_stack *m = macro_stack; + + macro_stack = m->next; + free(m); +} + +#define DBG_MACRO 0 +#if DBG_MACRO +int macro_scan_depth; + +void indent(void) +{ + int i; + for (i = 0; i < macro_scan_depth; i++) + printf(" "); +} +#define MACRO_DEBUG(a) a +#else +#define MACRO_DEBUG(a) +#endif + +ao_poly +ao_has_macro(ao_poly p); + +ao_poly +ao_macro_test_get(ao_poly atom) +{ + ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + if (ref) + return *ref; + return AO_SCHEME_NIL; +} + +ao_poly +ao_is_macro(ao_poly p) +{ + struct ao_scheme_builtin *builtin; + struct ao_scheme_lambda *lambda; + ao_poly ret; + + MACRO_DEBUG(indent(); printf ("is macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); + switch (ao_scheme_poly_type(p)) { + case AO_SCHEME_ATOM: + if (ao_scheme_macro_push(p)) + ret = AO_SCHEME_NIL; + else { + if (ao_is_macro(ao_macro_test_get(p))) + ret = p; + else + ret = AO_SCHEME_NIL; + ao_scheme_macro_pop(); + } + break; + case AO_SCHEME_CONS: + ret = ao_has_macro(p); + break; + case AO_SCHEME_BUILTIN: + builtin = ao_scheme_poly_builtin(p); + if ((builtin->args & AO_SCHEME_FUNC_MASK) == AO_SCHEME_FUNC_MACRO) + ret = p; + else + ret = 0; + break; + + case AO_SCHEME_LAMBDA: + lambda = ao_scheme_poly_lambda(p); + if (lambda->args == AO_SCHEME_FUNC_MACRO) + ret = p; + else + ret = ao_has_macro(lambda->code); + break; + default: + ret = AO_SCHEME_NIL; + break; + } + MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_scheme_poly_write(ret); printf("\n")); + return ret; +} + +ao_poly +ao_has_macro(ao_poly p) +{ + struct ao_scheme_cons *cons; + struct ao_scheme_lambda *lambda; + ao_poly m; + ao_poly list; + + if (p == AO_SCHEME_NIL) + return AO_SCHEME_NIL; + + MACRO_DEBUG(indent(); printf("has macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); + switch (ao_scheme_poly_type(p)) { + case AO_SCHEME_LAMBDA: + lambda = ao_scheme_poly_lambda(p); + p = ao_has_macro(lambda->code); + break; + case AO_SCHEME_CONS: + cons = ao_scheme_poly_cons(p); + if ((p = ao_is_macro(cons->car))) + break; + + list = cons->cdr; + p = AO_SCHEME_NIL; + while (list != AO_SCHEME_NIL && ao_scheme_poly_type(list) == AO_SCHEME_CONS) { + cons = ao_scheme_poly_cons(list); + m = ao_has_macro(cons->car); + if (m) { + p = m; + break; + } + list = cons->cdr; + } + break; + + default: + p = AO_SCHEME_NIL; + break; + } + MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_scheme_poly_write(p); printf("\n")); + return p; +} + +int +ao_scheme_read_eval_abort(void) +{ + ao_poly in, out = AO_SCHEME_NIL; + for(;;) { + in = ao_scheme_read(); + if (in == _ao_scheme_atom_eof) + break; + out = ao_scheme_eval(in); + if (ao_scheme_exception) + return 0; + ao_scheme_poly_write(out); + putchar ('\n'); + } + return 1; +} + +static FILE *in; +static FILE *out; + +int +ao_scheme_getc(void) +{ + return getc(in); +} + +static const struct option options[] = { + { .name = "out", .has_arg = 1, .val = 'o' }, + { 0, 0, 0, 0 } +}; + +static void usage(char *program) +{ + fprintf(stderr, "usage: %s [--out=<output>] [input]\n", program); + exit(1); +} + +int +main(int argc, char **argv) +{ + int f, o; + ao_poly val; + struct ao_scheme_atom *a; + struct ao_scheme_builtin *b; + int in_atom = 0; + char *out_name = NULL; + int c; + enum ao_scheme_builtin_id prev_func; + + in = stdin; + out = stdout; + + while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { + switch (c) { + case 'o': + out_name = optarg; + break; + default: + usage(argv[0]); + break; + } + } + + ao_scheme_frame_init(); + + /* Boolean values #f and #t */ + ao_scheme_bool_get(0); + ao_scheme_bool_get(1); + + prev_func = _builtin_last; + for (f = 0; f < (int) N_FUNC; f++) { + if (funcs[f].func != prev_func) + b = ao_scheme_make_builtin(funcs[f].func, funcs[f].args); + a = ao_scheme_atom_intern(funcs[f].name); + ao_scheme_atom_def(ao_scheme_atom_poly(a), + ao_scheme_builtin_poly(b)); + } + + /* end of file value */ + a = ao_scheme_atom_intern("eof"); + ao_scheme_atom_def(ao_scheme_atom_poly(a), + ao_scheme_atom_poly(a)); + + /* 'else' */ + a = ao_scheme_atom_intern("else"); + + if (argv[optind]){ + in = fopen(argv[optind], "r"); + if (!in) { + perror(argv[optind]); + exit(1); + } + } + if (!ao_scheme_read_eval_abort()) { + fprintf(stderr, "eval failed\n"); + exit(1); + } + + /* Reduce to referenced values */ + ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + + for (f = 0; f < ao_scheme_frame_global->num; f++) { + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(ao_scheme_frame_global->vals); + val = ao_has_macro(vals->vals[f].val); + if (val != AO_SCHEME_NIL) { + printf("error: function %s contains unresolved macro: ", + ao_scheme_poly_atom(vals->vals[f].atom)->name); + ao_scheme_poly_write(val); + printf("\n"); + exit(1); + } + } + + if (out_name) { + out = fopen(out_name, "w"); + if (!out) { + perror(out_name); + exit(1); + } + } + + fprintf(out, "/* Generated file, do not edit */\n\n"); + + fprintf(out, "#define AO_SCHEME_POOL_CONST %d\n", ao_scheme_top); + fprintf(out, "extern const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4)));\n"); + fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_scheme_atom_poly(ao_scheme_atoms)); + fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_scheme_frame_poly(ao_scheme_frame_global)); + fprintf(out, "#define ao_scheme_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_scheme_const, ao_scheme_top)); + + fprintf(out, "#define _ao_scheme_bool_false 0x%04x\n", ao_scheme_bool_poly(ao_scheme_false)); + fprintf(out, "#define _ao_scheme_bool_true 0x%04x\n", ao_scheme_bool_poly(ao_scheme_true)); + + for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) { + char *n = a->name, c; + fprintf(out, "#define _ao_scheme_atom_"); + while ((c = *n++)) { + if (isalnum(c)) + fprintf(out, "%c", c); + else + fprintf(out, "%02x", c); + } + fprintf(out, " 0x%04x\n", ao_scheme_atom_poly(a)); + } + fprintf(out, "#ifdef AO_SCHEME_CONST_BITS\n"); + fprintf(out, "const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute((aligned(4))) = {"); + for (o = 0; o < ao_scheme_top; o++) { + uint8_t c; + if ((o & 0xf) == 0) + fprintf(out, "\n\t"); + else + fprintf(out, " "); + c = ao_scheme_const[o]; + if (!in_atom) + in_atom = is_atom(o); + if (in_atom) { + fprintf(out, " '%c',", c); + in_atom--; + } else { + fprintf(out, "0x%02x,", c); + } + } + fprintf(out, "\n};\n"); + fprintf(out, "#endif /* AO_SCHEME_CONST_BITS */\n"); + exit(0); +} diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c new file mode 100644 index 00000000..acc726c8 --- /dev/null +++ b/src/scheme/ao_scheme_mem.c @@ -0,0 +1,968 @@ +/* + * Copyright © 2016 Keith Packard <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_SCHEME_CONST_BITS + +#include "ao_scheme.h" +#include <stdio.h> +#include <assert.h> + +#ifdef AO_SCHEME_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + +#include <stdlib.h> +uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#undef AO_SCHEME_POOL +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#else + +uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); + +#endif + +#ifndef DBG_MEM_STATS +#define DBG_MEM_STATS DBG_MEM +#endif + +#if DBG_MEM +int dbg_move_depth; +int dbg_mem = DBG_MEM_START; +int dbg_validate = 0; + +struct ao_scheme_record { + struct ao_scheme_record *next; + const struct ao_scheme_type *type; + void *addr; + int size; +}; + +static struct ao_scheme_record *record_head, **record_tail; + +static void +ao_scheme_record_free(struct ao_scheme_record *record) +{ + while (record) { + struct ao_scheme_record *next = record->next; + free(record); + record = next; + } +} + +static void +ao_scheme_record_reset(void) +{ + ao_scheme_record_free(record_head); + record_head = NULL; + record_tail = &record_head; +} + +static void +ao_scheme_record(const struct ao_scheme_type *type, + void *addr, + int size) +{ + struct ao_scheme_record *r = malloc(sizeof (struct ao_scheme_record)); + + r->next = NULL; + r->type = type; + r->addr = addr; + r->size = size; + *record_tail = r; + record_tail = &r->next; +} + +static struct ao_scheme_record * +ao_scheme_record_save(void) +{ + struct ao_scheme_record *r = record_head; + + record_head = NULL; + record_tail = &record_head; + return r; +} + +static void +ao_scheme_record_compare(char *where, + struct ao_scheme_record *a, + struct ao_scheme_record *b) +{ + while (a && b) { + if (a->type != b->type || a->size != b->size) { + printf("%s record difers %d %s %d -> %d %s %d\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_scheme_abort(); + } + a = a->next; + b = b->next; + } + if (a) { + printf("%s record differs %d %s %d -> NULL\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size); + ao_scheme_abort(); + } + if (b) { + printf("%s record differs NULL -> %d %s %d\n", + where, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_scheme_abort(); + } +} + +#else +#define ao_scheme_record_reset() +#endif + +uint8_t ao_scheme_exception; + +struct ao_scheme_root { + const struct ao_scheme_type *type; + void **addr; +}; + +static struct ao_scheme_cons *save_cons[2]; +static char *save_string[2]; +static struct ao_scheme_frame *save_frame[1]; +static ao_poly save_poly[3]; + +static const struct ao_scheme_root ao_scheme_root[] = { + { + .type = &ao_scheme_cons_type, + .addr = (void **) &save_cons[0], + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &save_cons[1], + }, + { + .type = &ao_scheme_string_type, + .addr = (void **) &save_string[0], + }, + { + .type = &ao_scheme_string_type, + .addr = (void **) &save_string[1], + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &save_frame[0], + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[0] + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[1] + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[2] + }, + { + .type = &ao_scheme_atom_type, + .addr = (void **) &ao_scheme_atoms + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &ao_scheme_frame_global, + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &ao_scheme_frame_current, + }, + { + .type = &ao_scheme_stack_type, + .addr = (void **) &ao_scheme_stack, + }, + { + .type = NULL, + .addr = (void **) (void *) &ao_scheme_v, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_cons, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_cons_tail, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_stack, + }, +#ifdef AO_SCHEME_MAKE_CONST + { + .type = &ao_scheme_bool_type, + .addr = (void **) &ao_scheme_false, + }, + { + .type = &ao_scheme_bool_type, + .addr = (void **) &ao_scheme_true, + }, +#endif +}; + +#define AO_SCHEME_ROOT (sizeof (ao_scheme_root) / sizeof (ao_scheme_root[0])) + +static const void ** const ao_scheme_cache[] = { + (const void **) &ao_scheme_cons_free_list, + (const void **) &ao_scheme_stack_free_list, + (const void **) &ao_scheme_frame_free_list[0], + (const void **) &ao_scheme_frame_free_list[1], + (const void **) &ao_scheme_frame_free_list[2], + (const void **) &ao_scheme_frame_free_list[3], + (const void **) &ao_scheme_frame_free_list[4], + (const void **) &ao_scheme_frame_free_list[5], +}; + +#if AO_SCHEME_FRAME_FREE != 6 +#error Unexpected AO_SCHEME_FRAME_FREE value +#endif + +#define AO_SCHEME_CACHE (sizeof (ao_scheme_cache) / sizeof (ao_scheme_cache[0])) + +#define AO_SCHEME_BUSY_SIZE ((AO_SCHEME_POOL + 31) / 32) + +static uint8_t ao_scheme_busy[AO_SCHEME_BUSY_SIZE]; +static uint8_t ao_scheme_cons_note[AO_SCHEME_BUSY_SIZE]; +static uint8_t ao_scheme_cons_last[AO_SCHEME_BUSY_SIZE]; +static uint8_t ao_scheme_cons_noted; + +uint16_t ao_scheme_top; + +struct ao_scheme_chunk { + uint16_t old_offset; + union { + uint16_t size; + uint16_t new_offset; + }; +}; + +#define AO_SCHEME_NCHUNK 64 + +static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK]; + +/* Offset of an address within the pool. */ +static inline uint16_t pool_offset(void *addr) { +#if DBG_MEM + if (!AO_SCHEME_IS_POOL(addr)) + ao_scheme_abort(); +#endif + return ((uint8_t *) addr) - ao_scheme_pool; +} + +static inline void mark(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + tag[byte] |= (1 << bit); +} + +static inline void clear(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + tag[byte] &= ~(1 << bit); +} + +static inline int busy(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + return (tag[byte] >> bit) & 1; +} + +static inline int min(int a, int b) { return a < b ? a : b; } +static inline int max(int a, int b) { return a > b ? a : b; } + +static inline int limit(int offset) { + return min(AO_SCHEME_POOL, max(offset, 0)); +} + +static void +note_cons(uint16_t offset) +{ + MDBG_MOVE("note cons %d\n", offset); + ao_scheme_cons_noted = 1; + mark(ao_scheme_cons_note, offset); +} + +static uint16_t chunk_low, chunk_high; +static uint16_t chunk_first, chunk_last; + +static int +find_chunk(uint16_t offset) +{ + int l, r; + /* Binary search for the location */ + l = chunk_first; + r = chunk_last - 1; + while (l <= r) { + int m = (l + r) >> 1; + if (ao_scheme_chunk[m].old_offset < offset) + l = m + 1; + else + r = m - 1; + } + return l; +} + +static void +note_chunk(uint16_t offset, uint16_t size) +{ + int l; + + if (offset < chunk_low || chunk_high <= offset) + return; + + l = find_chunk(offset); + + /* + * The correct location is always in 'l', with r = l-1 being + * the entry before the right one + */ + +#if DBG_MEM + /* Off the right side */ + if (l >= AO_SCHEME_NCHUNK) + ao_scheme_abort(); + + /* Off the left side */ + if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset) + ao_scheme_abort(); +#endif + + /* Shuffle existing entries right */ + int end = min(AO_SCHEME_NCHUNK, chunk_last + 1); + + memmove(&ao_scheme_chunk[l+1], + &ao_scheme_chunk[l], + (end - (l+1)) * sizeof (struct ao_scheme_chunk)); + + /* Add new entry */ + ao_scheme_chunk[l].old_offset = offset; + ao_scheme_chunk[l].size = size; + + /* Increment the number of elements up to the size of the array */ + if (chunk_last < AO_SCHEME_NCHUNK) + chunk_last++; + + /* Set the top address if the array is full */ + if (chunk_last == AO_SCHEME_NCHUNK) + chunk_high = ao_scheme_chunk[AO_SCHEME_NCHUNK-1].old_offset + + ao_scheme_chunk[AO_SCHEME_NCHUNK-1].size; +} + +static void +reset_chunks(void) +{ + chunk_high = ao_scheme_top; + chunk_last = 0; + chunk_first = 0; +} + +/* + * Walk all referenced objects calling functions on each one + */ + +static void +walk(int (*visit_addr)(const struct ao_scheme_type *type, void **addr), + int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) +{ + int i; + + ao_scheme_record_reset(); + memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); + memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); + ao_scheme_cons_noted = 0; + for (i = 0; i < (int) AO_SCHEME_ROOT; i++) { + if (ao_scheme_root[i].type) { + void **a = ao_scheme_root[i].addr, *v; + if (a && (v = *a)) { + MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); + visit_addr(ao_scheme_root[i].type, a); + } + } else { + ao_poly *a = (ao_poly *) ao_scheme_root[i].addr, p; + if (a && (p = *a)) { + MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_scheme_ref(p))); + visit_poly(a, 0); + } + } + } + while (ao_scheme_cons_noted) { + memcpy(ao_scheme_cons_last, ao_scheme_cons_note, sizeof (ao_scheme_cons_note)); + memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); + ao_scheme_cons_noted = 0; + for (i = 0; i < AO_SCHEME_POOL; i += 4) { + if (busy(ao_scheme_cons_last, i)) { + void *v = ao_scheme_pool + i; + MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); + visit_addr(&ao_scheme_cons_type, &v); + } + } + } +} + +#if MDBG_DUMP +static void +dump_busy(void) +{ + int i; + MDBG_MOVE("busy:"); + for (i = 0; i < ao_scheme_top; i += 4) { + if ((i & 0xff) == 0) { + MDBG_MORE("\n"); + MDBG_MOVE("%s", ""); + } + else if ((i & 0x1f) == 0) + MDBG_MORE(" "); + if (busy(ao_scheme_busy, i)) + MDBG_MORE("*"); + else + MDBG_MORE("-"); + } + MDBG_MORE ("\n"); +} +#define DUMP_BUSY() dump_busy() +#else +#define DUMP_BUSY() +#endif + +static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = { + [AO_SCHEME_CONS] = &ao_scheme_cons_type, + [AO_SCHEME_INT] = NULL, + [AO_SCHEME_STRING] = &ao_scheme_string_type, + [AO_SCHEME_OTHER] = (void *) 0x1, + [AO_SCHEME_ATOM] = &ao_scheme_atom_type, + [AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type, + [AO_SCHEME_FRAME] = &ao_scheme_frame_type, + [AO_SCHEME_FRAME_VALS] = &ao_scheme_frame_vals_type, + [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, + [AO_SCHEME_STACK] = &ao_scheme_stack_type, + [AO_SCHEME_BOOL] = &ao_scheme_bool_type, + [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, + [AO_SCHEME_FLOAT] = &ao_scheme_float_type, +}; + +static int +ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref) +{ + return ao_scheme_mark(type, *ref); +} + +static int +ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) +{ + return ao_scheme_poly_mark(*p, do_note_cons); +} + +#if DBG_MEM_STATS +int ao_scheme_collects[2]; +int ao_scheme_freed[2]; +int ao_scheme_loops[2]; +#endif + +int ao_scheme_last_top; + +int +ao_scheme_collect(uint8_t style) +{ + int i; + int top; +#if DBG_MEM_STATS + int loops = 0; +#endif +#if DBG_MEM + struct ao_scheme_record *mark_record = NULL, *move_record = NULL; + + MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); +#endif + MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + + /* The first time through, we're doing a full collect */ + if (ao_scheme_last_top == 0) + style = AO_SCHEME_COLLECT_FULL; + + /* Clear references to all caches */ + for (i = 0; i < (int) AO_SCHEME_CACHE; i++) + *ao_scheme_cache[i] = NULL; + if (style == AO_SCHEME_COLLECT_FULL) { + chunk_low = top = 0; + } else { + chunk_low = top = ao_scheme_last_top; + } + for (;;) { +#if DBG_MEM_STATS + loops++; +#endif + MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); + /* Find the sizes of the first chunk of objects to move */ + reset_chunks(); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +#if DBG_MEM + + ao_scheme_record_free(mark_record); + mark_record = ao_scheme_record_save(); + if (mark_record && move_record) + ao_scheme_record_compare("mark", move_record, mark_record); +#endif + + DUMP_BUSY(); + + /* Find the first moving object */ + for (i = 0; i < chunk_last; i++) { + uint16_t size = ao_scheme_chunk[i].size; + +#if DBG_MEM + if (!size) + ao_scheme_abort(); +#endif + + if (ao_scheme_chunk[i].old_offset > top) + break; + + MDBG_MOVE("chunk %d %d not moving\n", + ao_scheme_chunk[i].old_offset, + ao_scheme_chunk[i].size); +#if DBG_MEM + if (ao_scheme_chunk[i].old_offset != top) + ao_scheme_abort(); +#endif + top += size; + } + + /* + * Limit amount of chunk array used in mapping moves + * to the active region + */ + chunk_first = i; + chunk_low = ao_scheme_chunk[i].old_offset; + + /* Copy all of the objects */ + for (; i < chunk_last; i++) { + uint16_t size = ao_scheme_chunk[i].size; + +#if DBG_MEM + if (!size) + ao_scheme_abort(); +#endif + + MDBG_MOVE("chunk %d %d -> %d\n", + ao_scheme_chunk[i].old_offset, + size, + top); + ao_scheme_chunk[i].new_offset = top; + + memmove(&ao_scheme_pool[top], + &ao_scheme_pool[ao_scheme_chunk[i].old_offset], + size); + + top += size; + } + + if (chunk_first < chunk_last) { + /* Relocate all references to the objects */ + walk(ao_scheme_move, ao_scheme_poly_move); + +#if DBG_MEM + ao_scheme_record_free(move_record); + move_record = ao_scheme_record_save(); + if (mark_record && move_record) + ao_scheme_record_compare("move", mark_record, move_record); +#endif + } + + /* If we ran into the end of the heap, then + * there's no need to keep walking + */ + if (chunk_last != AO_SCHEME_NCHUNK) + break; + + /* Next loop starts right above this loop */ + chunk_low = chunk_high; + } + +#if DBG_MEM_STATS + /* Collect stats */ + ++ao_scheme_collects[style]; + ao_scheme_freed[style] += ao_scheme_top - top; + ao_scheme_loops[style] += loops; +#endif + + ao_scheme_top = top; + if (style == AO_SCHEME_COLLECT_FULL) + ao_scheme_last_top = top; + + MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref)); + + return AO_SCHEME_POOL - ao_scheme_top; +} + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons) +{ + ao_poly cdr; + int offset; + + chunk_low = 0; + reset_chunks(); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); + while (cons) { + if (!AO_SCHEME_IS_POOL(cons)) + break; + offset = pool_offset(cons); + if (busy(ao_scheme_busy, offset)) { + ao_scheme_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_scheme_cons_poly(cons), ao_scheme_cons_poly(cons)); + abort(); + } + cdr = cons->cdr; + if (!ao_scheme_is_pair(cdr)) + break; + cons = ao_scheme_poly_cons(cdr); + } +} +#endif + +/* + * Mark interfaces for objects + */ + + +/* + * Mark a block of memory with an explicit size + */ + +int +ao_scheme_mark_block(void *addr, int size) +{ + int offset; + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + offset = pool_offset(addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; + } + mark(ao_scheme_busy, offset); + note_chunk(offset, size); + return 0; +} + +/* + * Note a reference to memory and collect information about a few + * object sizes at a time + */ + +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) +{ + int offset; + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + offset = pool_offset(addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; + } + mark(ao_scheme_busy, offset); + note_chunk(offset, ao_scheme_size(type, addr)); + return 0; +} + +/* + * Mark an object and all that it refereces + */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr) +{ + int ret; + MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE_IN(); + ret = ao_scheme_mark_memory(type, addr); + if (!ret) { + MDBG_MOVE("mark recurse\n"); + type->mark(addr); + } + MDBG_MOVE_OUT(); + return ret; +} + +/* + * Mark an object, unless it is a cons cell and + * do_note_cons is set. In that case, just + * set a bit in the cons note array; those + * will be marked in a separate pass to avoid + * deep recursion in the collector + */ +int +ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) +{ + uint8_t type; + void *addr; + + type = ao_scheme_poly_base_type(p); + + if (type == AO_SCHEME_INT) + return 1; + + addr = ao_scheme_ref(p); + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + if (type == AO_SCHEME_CONS && do_note_cons) { + note_cons(pool_offset(addr)); + return 1; + } else { + if (type == AO_SCHEME_OTHER) + type = ao_scheme_other_type(addr); + + const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM + if (!lisp_type) + ao_scheme_abort(); +#endif + + return ao_scheme_mark(lisp_type, addr); + } +} + +/* + * Find the current location of an object + * based on the original location. For unmoved + * objects, this is simple. For moved objects, + * go search for it + */ + +static uint16_t +move_map(uint16_t offset) +{ + int l; + + if (offset < chunk_low || chunk_high <= offset) + return offset; + + l = find_chunk(offset); + +#if DBG_MEM + if (ao_scheme_chunk[l].old_offset != offset) + ao_scheme_abort(); +#endif + return ao_scheme_chunk[l].new_offset; +} + +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) +{ + void *addr = *ref; + uint16_t offset, orig_offset; + + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + (void) type; + + MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); + orig_offset = pool_offset(addr); + offset = move_map(orig_offset); + if (offset != orig_offset) { + MDBG_MOVE("update ref %d %d -> %d\n", + AO_SCHEME_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, + orig_offset, offset); + *ref = ao_scheme_pool + offset; + } + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already moved\n"); + return 1; + } + mark(ao_scheme_busy, offset); + MDBG_DO(ao_scheme_record(type, addr, ao_scheme_size(type, addr))); + return 0; +} + +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref) +{ + int ret; + MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); + MDBG_MOVE_IN(); + ret = ao_scheme_move_memory(type, ref); + if (!ret) { + MDBG_MOVE("move recurse\n"); + type->move(*ref); + } + MDBG_MOVE_OUT(); + return ret; +} + +int +ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) +{ + uint8_t type; + ao_poly p = *ref; + int ret; + void *addr; + uint16_t offset, orig_offset; + uint8_t base_type; + + base_type = type = ao_scheme_poly_base_type(p); + + if (type == AO_SCHEME_INT) + return 1; + + addr = ao_scheme_ref(p); + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + orig_offset = pool_offset(addr); + offset = move_map(orig_offset); + + if (type == AO_SCHEME_CONS && do_note_cons) { + note_cons(orig_offset); + ret = 1; + } else { + if (type == AO_SCHEME_OTHER) + type = ao_scheme_other_type(ao_scheme_pool + offset); + + const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM + if (!lisp_type) + ao_scheme_abort(); +#endif + + ret = ao_scheme_move(lisp_type, &addr); + } + + /* Re-write the poly value */ + if (offset != orig_offset) { + ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, base_type); + MDBG_MOVE("poly %d moved %d -> %d\n", + type, orig_offset, offset); + *ref = np; + } + return ret; +} + +#if DBG_MEM +void +ao_scheme_validate(void) +{ + chunk_low = 0; + memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +} + +int dbg_allocs; + +#endif + +void * +ao_scheme_alloc(int size) +{ + void *addr; + + MDBG_DO(++dbg_allocs); + MDBG_DO(if (dbg_validate) ao_scheme_validate()); + size = ao_scheme_size_round(size); + if (AO_SCHEME_POOL - ao_scheme_top < size && + ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size && + ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size) + { + ao_scheme_error(AO_SCHEME_OOM, "out of memory"); + return NULL; + } + addr = ao_scheme_pool + ao_scheme_top; + ao_scheme_top += size; + MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); + return addr; +} + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons) +{ + assert(save_cons[id] == 0); + save_cons[id] = cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id) +{ + struct ao_scheme_cons *cons = save_cons[id]; + save_cons[id] = NULL; + return cons; +} + +void +ao_scheme_poly_stash(int id, ao_poly poly) +{ + assert(save_poly[id] == AO_SCHEME_NIL); + save_poly[id] = poly; +} + +ao_poly +ao_scheme_poly_fetch(int id) +{ + ao_poly poly = save_poly[id]; + save_poly[id] = AO_SCHEME_NIL; + return poly; +} + +void +ao_scheme_string_stash(int id, char *string) +{ + assert(save_string[id] == NULL); + save_string[id] = string; +} + +char * +ao_scheme_string_fetch(int id) +{ + char *string = save_string[id]; + save_string[id] = NULL; + return string; +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame) +{ + assert(save_frame[id] == NULL); + save_frame[id] = frame; +} + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id) +{ + struct ao_scheme_frame *frame = save_frame[id]; + save_frame[id] = NULL; + return frame; +} diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c new file mode 100644 index 00000000..d726321c --- /dev/null +++ b/src/scheme/ao_scheme_poly.c @@ -0,0 +1,118 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" + +struct ao_scheme_funcs { + void (*write)(ao_poly); + void (*display)(ao_poly); +}; + +static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { + [AO_SCHEME_CONS] = { + .write = ao_scheme_cons_write, + .display = ao_scheme_cons_display, + }, + [AO_SCHEME_STRING] = { + .write = ao_scheme_string_write, + .display = ao_scheme_string_display, + }, + [AO_SCHEME_INT] = { + .write = ao_scheme_int_write, + .display = ao_scheme_int_write, + }, + [AO_SCHEME_ATOM] = { + .write = ao_scheme_atom_write, + .display = ao_scheme_atom_write, + }, + [AO_SCHEME_BUILTIN] = { + .write = ao_scheme_builtin_write, + .display = ao_scheme_builtin_write, + }, + [AO_SCHEME_FRAME] = { + .write = ao_scheme_frame_write, + .display = ao_scheme_frame_write, + }, + [AO_SCHEME_FRAME_VALS] = { + .write = NULL, + .display = NULL, + }, + [AO_SCHEME_LAMBDA] = { + .write = ao_scheme_lambda_write, + .display = ao_scheme_lambda_write, + }, + [AO_SCHEME_STACK] = { + .write = ao_scheme_stack_write, + .display = ao_scheme_stack_write, + }, + [AO_SCHEME_BOOL] = { + .write = ao_scheme_bool_write, + .display = ao_scheme_bool_write, + }, + [AO_SCHEME_BIGINT] = { + .write = ao_scheme_bigint_write, + .display = ao_scheme_bigint_write, + }, + [AO_SCHEME_FLOAT] = { + .write = ao_scheme_float_write, + .display = ao_scheme_float_write, + }, +}; + +static const struct ao_scheme_funcs * +funcs(ao_poly p) +{ + uint8_t type = ao_scheme_poly_type(p); + + if (type < AO_SCHEME_NUM_TYPE) + return &ao_scheme_funcs[type]; + return NULL; +} + +void +ao_scheme_poly_write(ao_poly p) +{ + const struct ao_scheme_funcs *f = funcs(p); + + if (f && f->write) + f->write(p); +} + +void +ao_scheme_poly_display(ao_poly p) +{ + const struct ao_scheme_funcs *f = funcs(p); + + if (f && f->display) + f->display(p); +} + +void * +ao_scheme_ref(ao_poly poly) { + if (poly == AO_SCHEME_NIL) + return NULL; + if (poly & AO_SCHEME_CONST) + return (void *) (ao_scheme_const + (poly & AO_SCHEME_REF_MASK) - 4); + return (void *) (ao_scheme_pool + (poly & AO_SCHEME_REF_MASK) - 4); +} + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type) { + const uint8_t *a = addr; + if (a == NULL) + return AO_SCHEME_NIL; + if (AO_SCHEME_IS_CONST(a)) + return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; + return (a - ao_scheme_pool + 4) | type; +} diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c new file mode 100644 index 00000000..6b1e9d66 --- /dev/null +++ b/src/scheme/ao_scheme_read.c @@ -0,0 +1,655 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" +#include "ao_scheme_read.h" +#include <math.h> +#include <stdlib.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|POUND, /* # */ + PRINTABLE, /* $ */ + PRINTABLE, /* % */ + PRINTABLE, /* & */ + PRINTABLE|SPECIAL, /* ' */ + PRINTABLE|SPECIAL, /* ( */ + PRINTABLE|SPECIAL, /* ) */ + PRINTABLE, /* * */ + PRINTABLE|SIGN, /* + */ + PRINTABLE|SPECIAL, /* , */ + PRINTABLE|SIGN, /* - */ + PRINTABLE|DOTC|FLOATC, /* . */ + PRINTABLE, /* / */ + PRINTABLE|DIGIT, /* 0 */ + PRINTABLE|DIGIT, /* 1 */ + PRINTABLE|DIGIT, /* 2 */ + PRINTABLE|DIGIT, /* 3 */ + PRINTABLE|DIGIT, /* 4 */ + PRINTABLE|DIGIT, /* 5 */ + PRINTABLE|DIGIT, /* 6 */ + PRINTABLE|DIGIT, /* 7 */ + PRINTABLE|DIGIT, /* 8 */ + PRINTABLE|DIGIT, /* 9 */ + PRINTABLE, /* : */ + PRINTABLE|COMMENT, /* ; */ + PRINTABLE, /* < */ + PRINTABLE, /* = */ + PRINTABLE, /* > */ + PRINTABLE, /* ? */ + PRINTABLE, /* @ */ + PRINTABLE, /* A */ + PRINTABLE, /* B */ + PRINTABLE, /* C */ + PRINTABLE, /* D */ + PRINTABLE|FLOATC, /* E */ + PRINTABLE, /* F */ + PRINTABLE, /* G */ + PRINTABLE, /* H */ + PRINTABLE, /* I */ + PRINTABLE, /* J */ + PRINTABLE, /* K */ + PRINTABLE, /* L */ + PRINTABLE, /* M */ + PRINTABLE, /* N */ + PRINTABLE, /* O */ + PRINTABLE, /* P */ + PRINTABLE, /* Q */ + PRINTABLE, /* R */ + PRINTABLE, /* S */ + PRINTABLE, /* T */ + PRINTABLE, /* U */ + PRINTABLE, /* V */ + PRINTABLE, /* W */ + PRINTABLE, /* X */ + PRINTABLE, /* Y */ + PRINTABLE, /* Z */ + PRINTABLE, /* [ */ + PRINTABLE|BACKSLASH, /* \ */ + PRINTABLE, /* ] */ + PRINTABLE, /* ^ */ + PRINTABLE, /* _ */ + PRINTABLE|SPECIAL, /* ` */ + PRINTABLE, /* a */ + PRINTABLE, /* b */ + PRINTABLE, /* c */ + PRINTABLE, /* d */ + PRINTABLE|FLOATC, /* e */ + PRINTABLE, /* f */ + PRINTABLE, /* g */ + PRINTABLE, /* h */ + PRINTABLE, /* i */ + PRINTABLE, /* j */ + PRINTABLE, /* k */ + PRINTABLE, /* l */ + PRINTABLE, /* m */ + PRINTABLE, /* n */ + PRINTABLE, /* o */ + PRINTABLE, /* p */ + PRINTABLE, /* q */ + PRINTABLE, /* r */ + PRINTABLE, /* s */ + PRINTABLE, /* t */ + PRINTABLE, /* u */ + PRINTABLE, /* v */ + PRINTABLE, /* w */ + PRINTABLE, /* x */ + PRINTABLE, /* y */ + PRINTABLE, /* z */ + PRINTABLE, /* { */ + PRINTABLE, /* | */ + PRINTABLE, /* } */ + PRINTABLE, /* ~ */ + IGNORE, /* ^? */ +}; + +static int lex_unget_c; + +static inline int +lex_get() +{ + int c; + if (lex_unget_c) { + c = lex_unget_c; + lex_unget_c = 0; + } else { + c = ao_scheme_getc(); + } + return c; +} + +static inline void +lex_unget(int c) +{ + if (c != EOF) + lex_unget_c = c; +} + +static uint16_t lex_class; + +static int +lexc(void) +{ + int c; + do { + c = lex_get(); + if (c == EOF) { + c = 0; + lex_class = ENDOFFILE; + } else { + c &= 0x7f; + lex_class = lex_classes[c]; + } + } while (lex_class & IGNORE); + return c; +} + +static int +lex_quoted(void) +{ + int c; + int v; + int count; + + c = lex_get(); + if (c == EOF) { + lex_class = ENDOFFILE; + return 0; + } + lex_class = 0; + c &= 0x7f; + switch (c) { + case 'n': + return '\n'; + case 'f': + return '\f'; + case 'b': + return '\b'; + case 'r': + return '\r'; + case 'v': + return '\v'; + case 't': + return '\t'; + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + v = c - '0'; + count = 1; + while (count <= 3) { + c = lex_get(); + if (c == EOF) + return EOF; + c &= 0x7f; + if (c < '0' || '7' < c) { + lex_unget(c); + break; + } + v = (v << 3) + c - '0'; + ++count; + } + return v; + default: + return c; + } +} + +#define AO_SCHEME_TOKEN_MAX 32 + +static char token_string[AO_SCHEME_TOKEN_MAX]; +static int32_t token_int; +static int token_len; +static float token_float; + +static inline void add_token(int c) { + if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) + token_string[token_len++] = c; +} + +static inline void del_token(void) { + if (token_len > 0) + token_len--; +} + +static inline void end_token(void) { + token_string[token_len] = '\0'; +} + +struct namedfloat { + const char *name; + float value; +}; + +static const struct namedfloat namedfloats[] = { + { .name = "+inf.0", .value = INFINITY }, + { .name = "-inf.0", .value = -INFINITY }, + { .name = "+nan.0", .value = NAN }, + { .name = "-nan.0", .value = NAN }, +}; + +#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) + +static int +_lex(void) +{ + int c; + + token_len = 0; + for (;;) { + c = lexc(); + if (lex_class & ENDOFFILE) + return END; + + if (lex_class & WHITE) + continue; + + if (lex_class & COMMENT) { + while ((c = lexc()) != '\n') { + if (lex_class & ENDOFFILE) + return END; + } + continue; + } + + if (lex_class & (SPECIAL|DOTC)) { + add_token(c); + end_token(); + switch (c) { + case '(': + case '[': + return OPEN; + case ')': + case ']': + return CLOSE; + case '\'': + return QUOTE; + case '.': + return DOT; + case '`': + return QUASIQUOTE; + case ',': + c = lexc(); + if (c == '@') { + add_token(c); + end_token(); + return UNQUOTE_SPLICING; + } else { + lex_unget(c); + return UNQUOTE; + } + } + } + if (lex_class & POUND) { + c = lexc(); + switch (c) { + case 't': + add_token(c); + end_token(); + return BOOL; + case 'f': + add_token(c); + end_token(); + return BOOL; + case '\\': + for (;;) { + int alphabetic; + c = lexc(); + alphabetic = (('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')); + if (token_len == 0) { + add_token(c); + if (!alphabetic) + break; + } else { + if (alphabetic) + add_token(c); + else { + lex_unget(c); + break; + } + } + } + end_token(); + if (token_len == 1) + token_int = token_string[0]; + else if (!strcmp(token_string, "space")) + token_int = ' '; + else if (!strcmp(token_string, "newline")) + token_int = '\n'; + else if (!strcmp(token_string, "tab")) + token_int = '\t'; + else if (!strcmp(token_string, "return")) + token_int = '\r'; + else if (!strcmp(token_string, "formfeed")) + token_int = '\f'; + else { + ao_scheme_error(AO_SCHEME_INVALID, "invalid character token #\\%s", token_string); + continue; + } + return NUM; + } + } + if (lex_class & STRINGC) { + for (;;) { + c = lexc(); + if (lex_class & BACKSLASH) + c = lex_quoted(); + if (lex_class & (STRINGC|ENDOFFILE)) { + end_token(); + return STRING; + } + add_token(c); + } + } + if (lex_class & PRINTABLE) { + int isfloat; + int hasdigit; + int isneg; + int isint; + int epos; + + isfloat = 1; + isint = 1; + hasdigit = 0; + token_int = 0; + isneg = 0; + epos = 0; + for (;;) { + if (!(lex_class & NUMBER)) { + isint = 0; + isfloat = 0; + } else { + if (!(lex_class & INTEGER)) + isint = 0; + if (token_len != epos && + (lex_class & SIGN)) + { + isint = 0; + isfloat = 0; + } + if (c == '-') + isneg = 1; + if (c == '.' && epos != 0) + isfloat = 0; + if (c == 'e' || c == 'E') { + if (token_len == 0) + isfloat = 0; + else + epos = token_len + 1; + } + if (lex_class & DIGIT) { + hasdigit = 1; + if (isint) + token_int = token_int * 10 + c - '0'; + } + } + add_token (c); + c = lexc (); + if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { + unsigned int u; +// if (lex_class & ENDOFFILE) +// clearerr (f); + lex_unget(c); + end_token (); + if (isint && hasdigit) { + if (isneg) + token_int = -token_int; + return NUM; + } + if (isfloat && hasdigit) { + token_float = strtof(token_string, NULL); + return FLOAT; + } + for (u = 0; u < NUM_NAMED_FLOATS; u++) + if (!strcmp(namedfloats[u].name, token_string)) { + token_float = namedfloats[u].value; + return FLOAT; + } + return NAME; + } + } + } + } +} + +static inline int lex(void) +{ + int parse_token = _lex(); + RDBGI("token %d (%s)\n", parse_token, token_string); + return parse_token; +} + +static int parse_token; + +struct ao_scheme_cons *ao_scheme_read_cons; +struct ao_scheme_cons *ao_scheme_read_cons_tail; +struct ao_scheme_cons *ao_scheme_read_stack; + +#define READ_IN_QUOTE 0x01 +#define READ_SAW_DOT 0x02 +#define READ_DONE_DOT 0x04 + +static int +push_read_stack(int cons, int read_state) +{ + RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); + RDBG_IN(); + if (cons) { + ao_scheme_read_stack = ao_scheme_cons_cons(ao_scheme_cons_poly(ao_scheme_read_cons), + ao_scheme__cons(ao_scheme_int_poly(read_state), + ao_scheme_cons_poly(ao_scheme_read_stack))); + if (!ao_scheme_read_stack) + return 0; + } + ao_scheme_read_cons = NULL; + ao_scheme_read_cons_tail = NULL; + return 1; +} + +static int +pop_read_stack(int cons) +{ + int read_state = 0; + if (cons) { + ao_scheme_read_cons = ao_scheme_poly_cons(ao_scheme_read_stack->car); + ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); + read_state = ao_scheme_poly_int(ao_scheme_read_stack->car); + ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); + for (ao_scheme_read_cons_tail = ao_scheme_read_cons; + ao_scheme_read_cons_tail && ao_scheme_read_cons_tail->cdr; + ao_scheme_read_cons_tail = ao_scheme_poly_cons(ao_scheme_read_cons_tail->cdr)) + ; + } else { + ao_scheme_read_cons = 0; + ao_scheme_read_cons_tail = 0; + ao_scheme_read_stack = 0; + } + RDBG_OUT(); + RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); + return read_state; +} + +ao_poly +ao_scheme_read(void) +{ + struct ao_scheme_atom *atom; + char *string; + int cons; + int read_state; + ao_poly v = AO_SCHEME_NIL; + + cons = 0; + read_state = 0; + ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; + for (;;) { + parse_token = lex(); + while (parse_token == OPEN) { + if (!push_read_stack(cons, read_state)) + return AO_SCHEME_NIL; + cons++; + read_state = 0; + parse_token = lex(); + } + + switch (parse_token) { + case END: + default: + if (cons) + ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); + return _ao_scheme_atom_eof; + break; + case NAME: + atom = ao_scheme_atom_intern(token_string); + if (atom) + v = ao_scheme_atom_poly(atom); + else + v = AO_SCHEME_NIL; + break; + case NUM: + v = ao_scheme_integer_poly(token_int); + break; + case FLOAT: + v = ao_scheme_float_get(token_float); + break; + case BOOL: + if (token_string[0] == 't') + v = _ao_scheme_bool_true; + else + v = _ao_scheme_bool_false; + break; + case STRING: + string = ao_scheme_string_copy(token_string); + if (string) + v = ao_scheme_string_poly(string); + else + v = AO_SCHEME_NIL; + break; + case QUOTE: + case QUASIQUOTE: + case UNQUOTE: + case UNQUOTE_SPLICING: + if (!push_read_stack(cons, read_state)) + return AO_SCHEME_NIL; + cons++; + read_state = READ_IN_QUOTE; + switch (parse_token) { + case QUOTE: + v = _ao_scheme_atom_quote; + break; + case QUASIQUOTE: + v = _ao_scheme_atom_quasiquote; + break; + case UNQUOTE: + v = _ao_scheme_atom_unquote; + break; + case UNQUOTE_SPLICING: + v = _ao_scheme_atom_unquote2dsplicing; + break; + } + break; + case CLOSE: + if (!cons) { + v = AO_SCHEME_NIL; + break; + } + v = ao_scheme_cons_poly(ao_scheme_read_cons); + --cons; + read_state = pop_read_stack(cons); + break; + case DOT: + if (!cons) { + ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); + return AO_SCHEME_NIL; + } + if (!ao_scheme_read_cons) { + ao_scheme_error(AO_SCHEME_INVALID, ". first in cons"); + return AO_SCHEME_NIL; + } + read_state |= READ_SAW_DOT; + continue; + } + + /* loop over QUOTE ends */ + for (;;) { + if (!cons) + return v; + + if (read_state & READ_DONE_DOT) { + ao_scheme_error(AO_SCHEME_INVALID, ". not last in cons"); + return AO_SCHEME_NIL; + } + + if (read_state & READ_SAW_DOT) { + read_state |= READ_DONE_DOT; + ao_scheme_read_cons_tail->cdr = v; + } else { + struct ao_scheme_cons *read = ao_scheme_cons_cons(v, AO_SCHEME_NIL); + if (!read) + return AO_SCHEME_NIL; + + if (ao_scheme_read_cons_tail) + ao_scheme_read_cons_tail->cdr = ao_scheme_cons_poly(read); + else + ao_scheme_read_cons = read; + ao_scheme_read_cons_tail = read; + } + + if (!(read_state & READ_IN_QUOTE) || !ao_scheme_read_cons->cdr) + break; + + v = ao_scheme_cons_poly(ao_scheme_read_cons); + --cons; + read_state = pop_read_stack(cons); + } + } + return v; +} diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h new file mode 100644 index 00000000..e9508835 --- /dev/null +++ b/src/scheme/ao_scheme_read.h @@ -0,0 +1,58 @@ +/* + * Copyright © 2016 Keith Packard <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_SCHEME_READ_H_ +#define _AO_SCHEME_READ_H_ + +/* + * token classes + */ + +# define END 0 +# define NAME 1 +# define OPEN 2 +# define CLOSE 3 +# define QUOTE 4 +# define QUASIQUOTE 5 +# define UNQUOTE 6 +# define UNQUOTE_SPLICING 7 +# define STRING 8 +# define NUM 9 +# define FLOAT 10 +# define DOT 11 +# define BOOL 12 + +/* + * character classes + */ + +# define PRINTABLE 0x0001 /* \t \n ' ' - ~ */ +# define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */ +# define DOTC 0x0004 /* . */ +# define WHITE 0x0008 /* ' ' \t \n */ +# define DIGIT 0x0010 /* [0-9] */ +# define SIGN 0x0020 /* +- */ +# define FLOATC 0x0040 /* . e E */ +# define ENDOFFILE 0x0080 /* end of file */ +# define COMMENT 0x0100 /* ; */ +# define IGNORE 0x0200 /* \0 - ' ' */ +# define BACKSLASH 0x0400 /* \ */ +# define STRINGC 0x0800 /* " */ +# define POUND 0x1000 /* # */ + +# define NOTNAME (STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) +# define INTEGER (DIGIT|SIGN) +# define NUMBER (INTEGER|FLOATC) + +#endif /* _AO_SCHEME_READ_H_ */ diff --git a/src/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c new file mode 100644 index 00000000..9dbce5f2 --- /dev/null +++ b/src/scheme/ao_scheme_rep.c @@ -0,0 +1,36 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" + +ao_poly +ao_scheme_read_eval_print(void) +{ + ao_poly in, out = AO_SCHEME_NIL; + for(;;) { + in = ao_scheme_read(); + if (in == _ao_scheme_atom_eof) + break; + out = ao_scheme_eval(in); + if (ao_scheme_exception) { + if (ao_scheme_exception & AO_SCHEME_EXIT) + break; + ao_scheme_exception = 0; + } else { + ao_scheme_poly_write(out); + putchar ('\n'); + } + } + return out; +} diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c new file mode 100644 index 00000000..af9345b8 --- /dev/null +++ b/src/scheme/ao_scheme_save.c @@ -0,0 +1,77 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" + +ao_poly +ao_scheme_do_save(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) + return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE + struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + + ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + os->atoms = ao_scheme_atom_poly(ao_scheme_atoms); + os->globals = ao_scheme_frame_poly(ao_scheme_frame_global); + os->const_checksum = ao_scheme_const_checksum; + os->const_checksum_inv = (uint16_t) ~ao_scheme_const_checksum; + + if (ao_scheme_os_save()) + return _ao_scheme_bool_true; +#endif + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_restore(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) + return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE + struct ao_scheme_os_save save; + struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + + if (!ao_scheme_os_restore_save(&save, AO_SCHEME_POOL)) + return ao_scheme_error(AO_SCHEME_INVALID, "header restore failed"); + + if (save.const_checksum != ao_scheme_const_checksum || + save.const_checksum_inv != (uint16_t) ~ao_scheme_const_checksum) + { + return ao_scheme_error(AO_SCHEME_INVALID, "image is corrupted or stale"); + } + + if (ao_scheme_os_restore()) { + + ao_scheme_atoms = ao_scheme_poly_atom(os->atoms); + ao_scheme_frame_global = ao_scheme_poly_frame(os->globals); + + /* Clear the eval global variabls */ + ao_scheme_eval_clear_globals(); + + /* Reset the allocator */ + ao_scheme_top = AO_SCHEME_POOL; + ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + + /* Re-create the evaluator stack */ + if (!ao_scheme_eval_restart()) + return _ao_scheme_bool_false; + + return _ao_scheme_bool_true; + } +#endif + return _ao_scheme_bool_false; +} diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c new file mode 100644 index 00000000..d19dd6d6 --- /dev/null +++ b/src/scheme/ao_scheme_stack.c @@ -0,0 +1,280 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" + +const struct ao_scheme_type ao_scheme_stack_type; + +static int +stack_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_stack); +} + +static void +stack_mark(void *addr) +{ + struct ao_scheme_stack *stack = addr; + for (;;) { + ao_scheme_poly_mark(stack->sexprs, 0); + ao_scheme_poly_mark(stack->values, 0); + /* no need to mark values_tail */ + ao_scheme_poly_mark(stack->frame, 0); + ao_scheme_poly_mark(stack->list, 0); + stack = ao_scheme_poly_stack(stack->prev); + if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack)) + break; + } +} + +static void +stack_move(void *addr) +{ + struct ao_scheme_stack *stack = addr; + + while (stack) { + struct ao_scheme_stack *prev; + int ret; + (void) ao_scheme_poly_move(&stack->sexprs, 0); + (void) ao_scheme_poly_move(&stack->values, 0); + (void) ao_scheme_poly_move(&stack->values_tail, 0); + (void) ao_scheme_poly_move(&stack->frame, 0); + (void) ao_scheme_poly_move(&stack->list, 0); + prev = ao_scheme_poly_stack(stack->prev); + if (!prev) + break; + ret = ao_scheme_move_memory(&ao_scheme_stack_type, (void **) &prev); + if (prev != ao_scheme_poly_stack(stack->prev)) + stack->prev = ao_scheme_stack_poly(prev); + if (ret) + break; + stack = prev; + } +} + +const struct ao_scheme_type ao_scheme_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move, + .name = "stack" +}; + +struct ao_scheme_stack *ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack) +{ + stack->state = eval_sexpr; + stack->sexprs = AO_SCHEME_NIL; + stack->values = AO_SCHEME_NIL; + stack->values_tail = AO_SCHEME_NIL; +} + +static struct ao_scheme_stack * +ao_scheme_stack_new(void) +{ + struct ao_scheme_stack *stack; + + if (ao_scheme_stack_free_list) { + stack = ao_scheme_stack_free_list; + ao_scheme_stack_free_list = ao_scheme_poly_stack(stack->prev); + } else { + stack = ao_scheme_alloc(sizeof (struct ao_scheme_stack)); + if (!stack) + return 0; + stack->type = AO_SCHEME_STACK; + } + ao_scheme_stack_reset(stack); + return stack; +} + +int +ao_scheme_stack_push(void) +{ + struct ao_scheme_stack *stack; + + stack = ao_scheme_stack_new(); + + if (!stack) + return 0; + + stack->prev = ao_scheme_stack_poly(ao_scheme_stack); + stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); + stack->list = AO_SCHEME_NIL; + + ao_scheme_stack = stack; + + DBGI("stack push\n"); + DBG_FRAMES(); + DBG_IN(); + return 1; +} + +void +ao_scheme_stack_pop(void) +{ + ao_poly prev; + struct ao_scheme_frame *prev_frame; + + if (!ao_scheme_stack) + return; + prev = ao_scheme_stack->prev; + if (!ao_scheme_stack_marked(ao_scheme_stack)) { + ao_scheme_stack->prev = ao_scheme_stack_poly(ao_scheme_stack_free_list); + ao_scheme_stack_free_list = ao_scheme_stack; + } + + ao_scheme_stack = ao_scheme_poly_stack(prev); + prev_frame = ao_scheme_frame_current; + if (ao_scheme_stack) + ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + else + ao_scheme_frame_current = NULL; + if (ao_scheme_frame_current != prev_frame) + ao_scheme_frame_free(prev_frame); + DBG_OUT(); + DBGI("stack pop\n"); + DBG_FRAMES(); +} + +void +ao_scheme_stack_clear(void) +{ + ao_scheme_stack = NULL; + ao_scheme_frame_current = NULL; + ao_scheme_v = AO_SCHEME_NIL; +} + +void +ao_scheme_stack_write(ao_poly poly) +{ + struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + + while (s) { + if (s->type & AO_SCHEME_STACK_PRINT) { + printf("[recurse...]"); + return; + } + s->type |= AO_SCHEME_STACK_PRINT; + printf("\t[\n"); + printf("\t\texpr: "); ao_scheme_poly_write(s->list); printf("\n"); + printf("\t\tstate: %s\n", ao_scheme_state_names[s->state]); + ao_scheme_error_poly ("values: ", s->values, s->values_tail); + ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL); + ao_scheme_error_frame(2, "frame: ", ao_scheme_poly_frame(s->frame)); + printf("\t]\n"); + s->type &= ~AO_SCHEME_STACK_PRINT; + s = ao_scheme_poly_stack(s->prev); + } +} + +/* + * Copy a stack, being careful to keep everybody referenced + */ +static struct ao_scheme_stack * +ao_scheme_stack_copy(struct ao_scheme_stack *old) +{ + struct ao_scheme_stack *new = NULL; + struct ao_scheme_stack *n, *prev = NULL; + + while (old) { + ao_scheme_stack_stash(0, old); + ao_scheme_stack_stash(1, new); + ao_scheme_stack_stash(2, prev); + n = ao_scheme_stack_new(); + prev = ao_scheme_stack_fetch(2); + new = ao_scheme_stack_fetch(1); + old = ao_scheme_stack_fetch(0); + if (!n) + return NULL; + + ao_scheme_stack_mark(old); + ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame)); + *n = *old; + + if (prev) + prev->prev = ao_scheme_stack_poly(n); + else + new = n; + prev = n; + + old = ao_scheme_poly_stack(old->prev); + } + return new; +} + +/* + * Evaluate a continuation invocation + */ +ao_poly +ao_scheme_stack_eval(void) +{ + struct ao_scheme_stack *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); + if (!new) + return AO_SCHEME_NIL; + + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + + if (!cons || !cons->cdr) + return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value"); + + new->state = eval_val; + + ao_scheme_stack = new; + ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + + return ao_scheme_poly_cons(cons->cdr)->car; +} + +/* + * Call with current continuation. This calls a lambda, passing + * it a single argument which is the current continuation + */ +ao_poly +ao_scheme_do_call_cc(struct ao_scheme_cons *cons) +{ + struct ao_scheme_stack *new; + ao_poly v; + + /* Make sure the single parameter is a lambda */ + if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0)) + return AO_SCHEME_NIL; + + /* go get the lambda */ + ao_scheme_v = ao_scheme_arg(cons, 0); + + /* Note that the whole call chain now has + * a reference to it which may escape + */ + new = ao_scheme_stack_copy(ao_scheme_stack); + if (!new) + return AO_SCHEME_NIL; + + /* re-fetch cons after the allocation */ + cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr); + + /* Reset the arg list to the current stack, + * and call the lambda + */ + + cons->car = ao_scheme_stack_poly(new); + cons->cdr = AO_SCHEME_NIL; + v = ao_scheme_lambda_eval(); + ao_scheme_stack->sexprs = v; + ao_scheme_stack->state = eval_begin; + return AO_SCHEME_NIL; +} diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c new file mode 100644 index 00000000..e25306cb --- /dev/null +++ b/src/scheme/ao_scheme_string.c @@ -0,0 +1,161 @@ +/* + * Copyright © 2016 Keith Packard <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_scheme.h" + +static void string_mark(void *addr) +{ + (void) addr; +} + +static int string_size(void *addr) +{ + if (!addr) + return 0; + return strlen(addr) + 1; +} + +static void string_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_string_type = { + .mark = string_mark, + .size = string_size, + .move = string_move, + .name = "string", +}; + +char * +ao_scheme_string_copy(char *a) +{ + int alen = strlen(a); + + ao_scheme_string_stash(0, a); + char *r = ao_scheme_alloc(alen + 1); + a = ao_scheme_string_fetch(0); + if (!r) + return NULL; + strcpy(r, a); + return r; +} + +char * +ao_scheme_string_cat(char *a, char *b) +{ + int alen = strlen(a); + int blen = strlen(b); + + ao_scheme_string_stash(0, a); + ao_scheme_string_stash(1, b); + char *r = ao_scheme_alloc(alen + blen + 1); + a = ao_scheme_string_fetch(0); + b = ao_scheme_string_fetch(1); + if (!r) + return NULL; + strcpy(r, a); + strcpy(r+alen, b); + return r; +} + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons) +{ + int len = ao_scheme_cons_length(cons); + ao_scheme_cons_stash(0, cons); + char *r = ao_scheme_alloc(len + 1); + cons = ao_scheme_cons_fetch(0); + char *s = r; + + while (cons) { + if (!ao_scheme_integer_typep(ao_scheme_poly_type(cons->car))) + return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack"); + *s++ = ao_scheme_poly_integer(cons->car); + cons = ao_scheme_poly_cons(cons->cdr); + } + *s++ = 0; + return ao_scheme_string_poly(r); +} + +ao_poly +ao_scheme_string_unpack(char *a) +{ + struct ao_scheme_cons *cons = NULL, *tail = NULL; + int c; + int i; + + for (i = 0; (c = a[i]); i++) { + ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(1, tail); + ao_scheme_string_stash(0, a); + struct ao_scheme_cons *n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL); + a = ao_scheme_string_fetch(0); + cons = ao_scheme_cons_fetch(0); + tail = ao_scheme_cons_fetch(1); + + if (!n) { + cons = NULL; + break; + } + if (tail) + tail->cdr = ao_scheme_cons_poly(n); + else + cons = n; + tail = n; + } + return ao_scheme_cons_poly(cons); +} + +void +ao_scheme_string_write(ao_poly p) +{ + char *s = ao_scheme_poly_string(p); + char c; + + putchar('"'); + while ((c = *s++)) { + switch (c) { + case '\n': + printf ("\\n"); + break; + case '\r': + printf ("\\r"); + break; + case '\t': + printf ("\\t"); + break; + default: + if (c < ' ') + printf("\\%03o", c); + else + putchar(c); + break; + } + } + putchar('"'); +} + +void +ao_scheme_string_display(ao_poly p) +{ + char *s = ao_scheme_poly_string(p); + char c; + + while ((c = *s++)) + putchar(c); +} diff --git a/src/scheme/make-const/.gitignore b/src/scheme/make-const/.gitignore new file mode 100644 index 00000000..bcd57242 --- /dev/null +++ b/src/scheme/make-const/.gitignore @@ -0,0 +1 @@ +ao_scheme_make_const diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile new file mode 100644 index 00000000..caf7acbe --- /dev/null +++ b/src/scheme/make-const/Makefile @@ -0,0 +1,26 @@ +include ../Makefile-inc + +vpath %.o . +vpath %.c .. +vpath %.h .. + +SRCS=$(SCHEME_SRCS) ao_scheme_make_const.c +HDRS=$(SCHEME_HDRS) ao_scheme_os.h + +OBJS=$(SRCS:.c=.o) + +CC=cc +CFLAGS=-DAO_SCHEME_MAKE_CONST -O0 -g -I. -Wall -Wextra + +.c.o: + $(CC) -c $(CFLAGS) $< -o $@ + +all: ao_scheme_make_const + +ao_scheme_make_const: $(OBJS) + $(CC) $(CFLAGS) -o $@ $^ -lm + +clean: + rm -f $(OBJS) ao_scheme_make_const + +$(OBJS): $(SCHEME_HDRS) diff --git a/src/scheme/make-const/ao_scheme_os.h b/src/scheme/make-const/ao_scheme_os.h new file mode 100644 index 00000000..f06bbbb1 --- /dev/null +++ b/src/scheme/make-const/ao_scheme_os.h @@ -0,0 +1,63 @@ +/* + * Copyright © 2016 Keith Packard <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_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ + +#include <stdio.h> +#include <stdlib.h> +#include <time.h> + +extern int ao_scheme_getc(void); + +static inline void +ao_scheme_os_flush(void) { + fflush(stdout); +} + +static inline void +ao_scheme_abort(void) +{ + abort(); +} + +static inline void +ao_scheme_os_led(int led) +{ + printf("leds set to 0x%x\n", led); +} + +#define AO_SCHEME_JIFFIES_PER_SECOND 100 + +static inline void +ao_scheme_os_delay(int jiffies) +{ + struct timespec ts = { + .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) + }; + nanosleep(&ts, NULL); +} + +static inline int +ao_scheme_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); +} +#endif |