From 195cbeec19a6a44f309a9040d727d37fe4e2ec97 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 10:29:13 -0800 Subject: [PATCH] altos/scheme: Rename to 'scheme', clean up build Constant block is now built in a subdir to avoid messing up source directory. Renamed to ao_scheme to reflect language target. Signed-off-by: Keith Packard --- src/lisp/.gitignore | 3 - src/lisp/Makefile | 24 - src/lisp/Makefile-inc | 24 - src/lisp/ao_lisp.h | 928 ----------------- src/lisp/ao_lisp_atom.c | 159 --- src/lisp/ao_lisp_builtin.c | 868 ---------------- src/lisp/ao_lisp_cons.c | 184 ---- src/lisp/ao_lisp_eval.c | 578 ----------- src/lisp/ao_lisp_float.c | 148 --- src/lisp/ao_lisp_frame.c | 330 ------ src/lisp/ao_lisp_int.c | 79 -- src/lisp/ao_lisp_lambda.c | 208 ---- src/lisp/ao_lisp_make_const.c | 395 ------- src/lisp/ao_lisp_mem.c | 968 ------------------ src/lisp/ao_lisp_poly.c | 118 --- src/lisp/ao_lisp_save.c | 77 -- src/lisp/ao_lisp_stack.c | 280 ----- src/scheme/.gitignore | 2 + src/scheme/Makefile | 16 + src/scheme/Makefile-inc | 24 + .../Makefile-lisp => scheme/Makefile-scheme} | 2 +- src/{lisp => scheme}/README | 3 +- src/scheme/ao_scheme.h | 928 +++++++++++++++++ src/scheme/ao_scheme_atom.c | 167 +++ .../ao_scheme_bool.c} | 28 +- src/scheme/ao_scheme_builtin.c | 868 ++++++++++++++++ .../ao_scheme_builtin.txt} | 0 src/scheme/ao_scheme_cons.c | 201 ++++ .../ao_scheme_const.lisp} | 0 .../ao_scheme_error.c} | 52 +- src/scheme/ao_scheme_eval.c | 578 +++++++++++ src/scheme/ao_scheme_float.c | 148 +++ src/scheme/ao_scheme_frame.c | 330 ++++++ src/scheme/ao_scheme_int.c | 79 ++ src/scheme/ao_scheme_lambda.c | 208 ++++ .../ao_lisp_lex.c => scheme/ao_scheme_lex.c} | 2 +- .../ao_scheme_make_builtin} | 60 +- src/scheme/ao_scheme_make_const.c | 395 +++++++ src/scheme/ao_scheme_mem.c | 968 ++++++++++++++++++ src/scheme/ao_scheme_poly.c | 118 +++ .../ao_scheme_read.c} | 136 +-- .../ao_scheme_read.h} | 6 +- .../ao_lisp_rep.c => scheme/ao_scheme_rep.c} | 20 +- src/scheme/ao_scheme_save.c | 77 ++ src/scheme/ao_scheme_stack.c | 280 +++++ .../ao_scheme_string.c} | 74 +- src/scheme/make-const/.gitignore | 1 + src/scheme/make-const/Makefile | 26 + .../make-const/ao_scheme_os.h} | 24 +- src/test/{ao_lisp_os.h => ao_scheme_os.h} | 0 src/test/{ao_lisp_test.c => ao_scheme_test.c} | 0 51 files changed, 5617 insertions(+), 5575 deletions(-) delete mode 100644 src/lisp/.gitignore delete mode 100644 src/lisp/Makefile delete mode 100644 src/lisp/Makefile-inc delete mode 100644 src/lisp/ao_lisp.h delete mode 100644 src/lisp/ao_lisp_atom.c delete mode 100644 src/lisp/ao_lisp_builtin.c delete mode 100644 src/lisp/ao_lisp_cons.c delete mode 100644 src/lisp/ao_lisp_eval.c delete mode 100644 src/lisp/ao_lisp_float.c delete mode 100644 src/lisp/ao_lisp_frame.c delete mode 100644 src/lisp/ao_lisp_int.c delete mode 100644 src/lisp/ao_lisp_lambda.c delete mode 100644 src/lisp/ao_lisp_make_const.c delete mode 100644 src/lisp/ao_lisp_mem.c delete mode 100644 src/lisp/ao_lisp_poly.c delete mode 100644 src/lisp/ao_lisp_save.c delete mode 100644 src/lisp/ao_lisp_stack.c create mode 100644 src/scheme/.gitignore create mode 100644 src/scheme/Makefile create mode 100644 src/scheme/Makefile-inc rename src/{lisp/Makefile-lisp => scheme/Makefile-scheme} (54%) rename src/{lisp => scheme}/README (67%) create mode 100644 src/scheme/ao_scheme.h create mode 100644 src/scheme/ao_scheme_atom.c rename src/{lisp/ao_lisp_bool.c => scheme/ao_scheme_bool.c} (65%) create mode 100644 src/scheme/ao_scheme_builtin.c rename src/{lisp/ao_lisp_builtin.txt => scheme/ao_scheme_builtin.txt} (100%) create mode 100644 src/scheme/ao_scheme_cons.c rename src/{lisp/ao_lisp_const.lisp => scheme/ao_scheme_const.lisp} (100%) rename src/{lisp/ao_lisp_error.c => scheme/ao_scheme_error.c} (58%) create mode 100644 src/scheme/ao_scheme_eval.c create mode 100644 src/scheme/ao_scheme_float.c create mode 100644 src/scheme/ao_scheme_frame.c create mode 100644 src/scheme/ao_scheme_int.c create mode 100644 src/scheme/ao_scheme_lambda.c rename src/{lisp/ao_lisp_lex.c => scheme/ao_scheme_lex.c} (96%) rename src/{lisp/ao_lisp_make_builtin => scheme/ao_scheme_make_builtin} (68%) create mode 100644 src/scheme/ao_scheme_make_const.c create mode 100644 src/scheme/ao_scheme_mem.c create mode 100644 src/scheme/ao_scheme_poly.c rename src/{lisp/ao_lisp_read.c => scheme/ao_scheme_read.c} (77%) rename src/{lisp/ao_lisp_read.h => scheme/ao_scheme_read.h} (94%) rename src/{lisp/ao_lisp_rep.c => scheme/ao_scheme_rep.c} (68%) create mode 100644 src/scheme/ao_scheme_save.c create mode 100644 src/scheme/ao_scheme_stack.c rename src/{lisp/ao_lisp_string.c => scheme/ao_scheme_string.c} (55%) create mode 100644 src/scheme/make-const/.gitignore create mode 100644 src/scheme/make-const/Makefile rename src/{lisp/ao_lisp_os.h => scheme/make-const/ao_scheme_os.h} (67%) rename src/test/{ao_lisp_os.h => ao_scheme_os.h} (100%) rename src/test/{ao_lisp_test.c => ao_scheme_test.c} (100%) diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore deleted file mode 100644 index 1faa9b67..00000000 --- a/src/lisp/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -ao_lisp_make_const -ao_lisp_const.h -ao_lisp_builtin.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile deleted file mode 100644 index 05f54550..00000000 --- a/src/lisp/Makefile +++ /dev/null @@ -1,24 +0,0 @@ -all: ao_lisp_builtin.h ao_lisp_const.h - -clean: - rm -f ao_lisp_const.h ao_lisp_builtin.h $(OBJS) ao_lisp_make_const - -ao_lisp_const.h: ao_lisp_const.lisp ao_lisp_make_const - ./ao_lisp_make_const -o $@ ao_lisp_const.lisp - -ao_lisp_builtin.h: ao_lisp_make_builtin ao_lisp_builtin.txt - nickle ./ao_lisp_make_builtin ao_lisp_builtin.txt > $@ - -include Makefile-inc -SRCS=$(LISP_SRCS) ao_lisp_make_const.c - -HDRS=$(LISP_HDRS) - -OBJS=$(SRCS:.c=.o) - -CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra -no-pie - -ao_lisp_make_const: $(OBJS) - $(CC) $(CFLAGS) -o $@ $(OBJS) -lm - -$(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc deleted file mode 100644 index a097f1be..00000000 --- a/src/lisp/Makefile-inc +++ /dev/null @@ -1,24 +0,0 @@ -LISP_SRCS=\ - ao_lisp_mem.c \ - ao_lisp_cons.c \ - ao_lisp_string.c \ - ao_lisp_atom.c \ - ao_lisp_int.c \ - ao_lisp_poly.c \ - ao_lisp_bool.c \ - ao_lisp_float.c \ - ao_lisp_builtin.c \ - ao_lisp_read.c \ - ao_lisp_frame.c \ - ao_lisp_lambda.c \ - ao_lisp_eval.c \ - ao_lisp_rep.c \ - ao_lisp_save.c \ - ao_lisp_stack.c \ - ao_lisp_error.c - -LISP_HDRS=\ - ao_lisp.h \ - ao_lisp_os.h \ - ao_lisp_read.h \ - ao_lisp_builtin.h diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h deleted file mode 100644 index b5e03b1e..00000000 --- a/src/lisp/ao_lisp.h +++ /dev/null @@ -1,928 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#ifndef _AO_LISP_H_ -#define _AO_LISP_H_ - -#define DBG_MEM 0 -#define DBG_EVAL 0 -#define DBG_READ 0 -#define DBG_FREE_CONS 0 -#define NDEBUG 1 - -#include -#include -#include -#ifndef __BYTE_ORDER -#include -#endif - -typedef uint16_t ao_poly; -typedef int16_t ao_signed_poly; - -#ifdef AO_LISP_SAVE - -struct ao_lisp_os_save { - ao_poly atoms; - ao_poly globals; - uint16_t const_checksum; - uint16_t const_checksum_inv; -}; - -#define AO_LISP_POOL_EXTRA (sizeof(struct ao_lisp_os_save)) -#define AO_LISP_POOL ((int) (AO_LISP_POOL_TOTAL - AO_LISP_POOL_EXTRA)) - -int -ao_lisp_os_save(void); - -int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset); - -int -ao_lisp_os_restore(void); - -#endif - -#ifdef AO_LISP_MAKE_CONST -#define AO_LISP_POOL_CONST 16384 -extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); -#define ao_lisp_pool ao_lisp_const -#define AO_LISP_POOL AO_LISP_POOL_CONST - -#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n)) -#define _bool(v) ao_lisp_bool_poly(ao_lisp_bool_get(v)) - -#define _ao_lisp_bool_true _bool(1) -#define _ao_lisp_bool_false _bool(0) - -#define _ao_lisp_atom_eof _atom("eof") -#define _ao_lisp_atom_else _atom("else") - -#define AO_LISP_BUILTIN_ATOMS -#include "ao_lisp_builtin.h" - -#else -#include "ao_lisp_const.h" -#ifndef AO_LISP_POOL -#define AO_LISP_POOL 3072 -#endif -extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); -#endif - -/* Primitive types */ -#define AO_LISP_CONS 0 -#define AO_LISP_INT 1 -#define AO_LISP_STRING 2 -#define AO_LISP_OTHER 3 - -#define AO_LISP_TYPE_MASK 0x0003 -#define AO_LISP_TYPE_SHIFT 2 -#define AO_LISP_REF_MASK 0x7ffc -#define AO_LISP_CONST 0x8000 - -/* These have a type value at the start of the struct */ -#define AO_LISP_ATOM 4 -#define AO_LISP_BUILTIN 5 -#define AO_LISP_FRAME 6 -#define AO_LISP_FRAME_VALS 7 -#define AO_LISP_LAMBDA 8 -#define AO_LISP_STACK 9 -#define AO_LISP_BOOL 10 -#define AO_LISP_BIGINT 11 -#define AO_LISP_FLOAT 12 -#define AO_LISP_NUM_TYPE 13 - -/* Leave two bits for types to use as they please */ -#define AO_LISP_OTHER_TYPE_MASK 0x3f - -#define AO_LISP_NIL 0 - -extern uint16_t ao_lisp_top; - -#define AO_LISP_OOM 0x01 -#define AO_LISP_DIVIDE_BY_ZERO 0x02 -#define AO_LISP_INVALID 0x04 -#define AO_LISP_UNDEFINED 0x08 -#define AO_LISP_REDEFINED 0x10 -#define AO_LISP_EOF 0x20 -#define AO_LISP_EXIT 0x40 - -extern uint8_t ao_lisp_exception; - -static inline int -ao_lisp_is_const(ao_poly poly) { - return poly & AO_LISP_CONST; -} - -#define AO_LISP_IS_CONST(a) (ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST) -#define AO_LISP_IS_POOL(a) (ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) -#define AO_LISP_IS_INT(p) (ao_lisp_poly_base_type(p) == AO_LISP_INT) - -void * -ao_lisp_ref(ao_poly poly); - -ao_poly -ao_lisp_poly(const void *addr, ao_poly type); - -struct ao_lisp_type { - int (*size)(void *addr); - void (*mark)(void *addr); - void (*move)(void *addr); - char name[]; -}; - -struct ao_lisp_cons { - ao_poly car; - ao_poly cdr; -}; - -struct ao_lisp_atom { - uint8_t type; - uint8_t pad[1]; - ao_poly next; - char name[]; -}; - -struct ao_lisp_val { - ao_poly atom; - ao_poly val; -}; - -struct ao_lisp_frame_vals { - uint8_t type; - uint8_t size; - struct ao_lisp_val vals[]; -}; - -struct ao_lisp_frame { - uint8_t type; - uint8_t num; - ao_poly prev; - ao_poly vals; -}; - -struct ao_lisp_bool { - uint8_t type; - uint8_t value; - uint16_t pad; -}; - -struct ao_lisp_bigint { - uint32_t value; -}; - -struct ao_lisp_float { - uint8_t type; - uint8_t pad1; - uint16_t pad2; - float value; -}; - -#if __BYTE_ORDER == __LITTLE_ENDIAN -static inline uint32_t -ao_lisp_int_bigint(int32_t i) { - return AO_LISP_BIGINT | (i << 8); -} -static inline int32_t -ao_lisp_bigint_int(uint32_t bi) { - return (int32_t) bi >> 8; -} -#else -static inline uint32_t -ao_lisp_int_bigint(int32_t i) { - return (uint32_t) (i & 0xffffff) | (AO_LISP_BIGINT << 24); -} -static inlint int32_t -ao_lisp_bigint_int(uint32_t bi) { - return (int32_t) (bi << 8) >> 8; -} -#endif - -#define AO_LISP_MIN_INT (-(1 << (15 - AO_LISP_TYPE_SHIFT))) -#define AO_LISP_MAX_INT ((1 << (15 - AO_LISP_TYPE_SHIFT)) - 1) -#define AO_LISP_MIN_BIGINT (-(1 << 24)) -#define AO_LISP_MAX_BIGINT ((1 << 24) - 1) - -#define AO_LISP_NOT_INTEGER 0x7fffffff - -/* Set on type when the frame escapes the lambda */ -#define AO_LISP_FRAME_MARK 0x80 -#define AO_LISP_FRAME_PRINT 0x40 - -static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { - return f->type & AO_LISP_FRAME_MARK; -} - -static inline struct ao_lisp_frame * -ao_lisp_poly_frame(ao_poly poly) { - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_frame_poly(struct ao_lisp_frame *frame) { - return ao_lisp_poly(frame, AO_LISP_OTHER); -} - -static inline struct ao_lisp_frame_vals * -ao_lisp_poly_frame_vals(ao_poly poly) { - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_frame_vals_poly(struct ao_lisp_frame_vals *vals) { - return ao_lisp_poly(vals, AO_LISP_OTHER); -} - -enum eval_state { - eval_sexpr, /* Evaluate an sexpr */ - eval_val, /* Value computed */ - eval_formal, /* Formal computed */ - eval_exec, /* Start a lambda evaluation */ - eval_apply, /* Execute apply */ - eval_cond, /* Start next cond clause */ - eval_cond_test, /* Check cond condition */ - eval_begin, /* Start next begin entry */ - eval_while, /* Start while condition */ - eval_while_test, /* Check while condition */ - eval_macro, /* Finished with macro generation */ -}; - -struct ao_lisp_stack { - uint8_t type; /* AO_LISP_STACK */ - uint8_t state; /* enum eval_state */ - ao_poly prev; /* previous stack frame */ - ao_poly sexprs; /* expressions to evaluate */ - ao_poly values; /* values computed */ - ao_poly values_tail; /* end of the values list for easy appending */ - ao_poly frame; /* current lookup frame */ - ao_poly list; /* most recent function call */ -}; - -#define AO_LISP_STACK_MARK 0x80 /* set on type when a reference has been taken */ -#define AO_LISP_STACK_PRINT 0x40 /* stack is being printed */ - -static inline int ao_lisp_stack_marked(struct ao_lisp_stack *s) { - return s->type & AO_LISP_STACK_MARK; -} - -static inline void ao_lisp_stack_mark(struct ao_lisp_stack *s) { - s->type |= AO_LISP_STACK_MARK; -} - -static inline struct ao_lisp_stack * -ao_lisp_poly_stack(ao_poly p) -{ - return ao_lisp_ref(p); -} - -static inline ao_poly -ao_lisp_stack_poly(struct ao_lisp_stack *stack) -{ - return ao_lisp_poly(stack, AO_LISP_OTHER); -} - -extern ao_poly ao_lisp_v; - -#define AO_LISP_FUNC_LAMBDA 0 -#define AO_LISP_FUNC_NLAMBDA 1 -#define AO_LISP_FUNC_MACRO 2 - -#define AO_LISP_FUNC_FREE_ARGS 0x80 -#define AO_LISP_FUNC_MASK 0x7f - -#define AO_LISP_FUNC_F_LAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LAMBDA) -#define AO_LISP_FUNC_F_NLAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_NLAMBDA) -#define AO_LISP_FUNC_F_MACRO (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_MACRO) - -struct ao_lisp_builtin { - uint8_t type; - uint8_t args; - uint16_t func; -}; - -#define AO_LISP_BUILTIN_ID -#include "ao_lisp_builtin.h" - -typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); - -extern const ao_lisp_func_t ao_lisp_builtins[]; - -static inline ao_lisp_func_t -ao_lisp_func(struct ao_lisp_builtin *b) -{ - return ao_lisp_builtins[b->func]; -} - -struct ao_lisp_lambda { - uint8_t type; - uint8_t args; - ao_poly code; - ao_poly frame; -}; - -static inline struct ao_lisp_lambda * -ao_lisp_poly_lambda(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_lambda_poly(struct ao_lisp_lambda *lambda) -{ - return ao_lisp_poly(lambda, AO_LISP_OTHER); -} - -static inline void * -ao_lisp_poly_other(ao_poly poly) { - return ao_lisp_ref(poly); -} - -static inline uint8_t -ao_lisp_other_type(void *other) { -#if DBG_MEM - if ((*((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK) >= AO_LISP_NUM_TYPE) - ao_lisp_abort(); -#endif - return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK; -} - -static inline ao_poly -ao_lisp_other_poly(const void *other) -{ - return ao_lisp_poly(other, AO_LISP_OTHER); -} - -static inline int -ao_lisp_size_round(int size) -{ - return (size + 3) & ~3; -} - -static inline int -ao_lisp_size(const struct ao_lisp_type *type, void *addr) -{ - return ao_lisp_size_round(type->size(addr)); -} - -#define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) - -static inline int ao_lisp_poly_base_type(ao_poly poly) { - return poly & AO_LISP_TYPE_MASK; -} - -static inline int ao_lisp_poly_type(ao_poly poly) { - int type = poly & AO_LISP_TYPE_MASK; - if (type == AO_LISP_OTHER) - return ao_lisp_other_type(ao_lisp_poly_other(poly)); - return type; -} - -static inline int -ao_lisp_is_cons(ao_poly poly) { - return (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); -} - -static inline int -ao_lisp_is_pair(ao_poly poly) { - return poly != AO_LISP_NIL && (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); -} - -static inline struct ao_lisp_cons * -ao_lisp_poly_cons(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_cons_poly(struct ao_lisp_cons *cons) -{ - return ao_lisp_poly(cons, AO_LISP_CONS); -} - -static inline int32_t -ao_lisp_poly_int(ao_poly poly) -{ - return (int32_t) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); -} - -static inline ao_poly -ao_lisp_int_poly(int32_t i) -{ - return ((ao_poly) i << 2) | AO_LISP_INT; -} - -static inline struct ao_lisp_bigint * -ao_lisp_poly_bigint(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_bigint_poly(struct ao_lisp_bigint *bi) -{ - return ao_lisp_poly(bi, AO_LISP_OTHER); -} - -static inline char * -ao_lisp_poly_string(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_string_poly(char *s) -{ - return ao_lisp_poly(s, AO_LISP_STRING); -} - -static inline struct ao_lisp_atom * -ao_lisp_poly_atom(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_atom_poly(struct ao_lisp_atom *a) -{ - return ao_lisp_poly(a, AO_LISP_OTHER); -} - -static inline struct ao_lisp_builtin * -ao_lisp_poly_builtin(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_builtin_poly(struct ao_lisp_builtin *b) -{ - return ao_lisp_poly(b, AO_LISP_OTHER); -} - -static inline ao_poly -ao_lisp_bool_poly(struct ao_lisp_bool *b) -{ - return ao_lisp_poly(b, AO_LISP_OTHER); -} - -static inline struct ao_lisp_bool * -ao_lisp_poly_bool(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_float_poly(struct ao_lisp_float *f) -{ - return ao_lisp_poly(f, AO_LISP_OTHER); -} - -static inline struct ao_lisp_float * -ao_lisp_poly_float(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -float -ao_lisp_poly_number(ao_poly p); - -/* memory functions */ - -extern int ao_lisp_collects[2]; -extern int ao_lisp_freed[2]; -extern int ao_lisp_loops[2]; - -/* returns 1 if the object was already marked */ -int -ao_lisp_mark(const struct ao_lisp_type *type, void *addr); - -/* returns 1 if the object was already marked */ -int -ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr); - -void * -ao_lisp_move_map(void *addr); - -/* returns 1 if the object was already moved */ -int -ao_lisp_move(const struct ao_lisp_type *type, void **ref); - -/* returns 1 if the object was already moved */ -int -ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref); - -void * -ao_lisp_alloc(int size); - -#define AO_LISP_COLLECT_FULL 1 -#define AO_LISP_COLLECT_INCREMENTAL 0 - -int -ao_lisp_collect(uint8_t style); - -#if DBG_FREE_CONS -void -ao_lisp_cons_check(struct ao_lisp_cons *cons); -#endif - -void -ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons); - -struct ao_lisp_cons * -ao_lisp_cons_fetch(int id); - -void -ao_lisp_poly_stash(int id, ao_poly poly); - -ao_poly -ao_lisp_poly_fetch(int id); - -void -ao_lisp_string_stash(int id, char *string); - -char * -ao_lisp_string_fetch(int id); - -static inline void -ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack) { - ao_lisp_poly_stash(id, ao_lisp_stack_poly(stack)); -} - -static inline struct ao_lisp_stack * -ao_lisp_stack_fetch(int id) { - return ao_lisp_poly_stack(ao_lisp_poly_fetch(id)); -} - -void -ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame); - -struct ao_lisp_frame * -ao_lisp_frame_fetch(int id); - -/* bool */ - -extern const struct ao_lisp_type ao_lisp_bool_type; - -void -ao_lisp_bool_write(ao_poly v); - -#ifdef AO_LISP_MAKE_CONST -struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; - -struct ao_lisp_bool * -ao_lisp_bool_get(uint8_t value); -#endif - -/* cons */ -extern const struct ao_lisp_type ao_lisp_cons_type; - -struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, ao_poly cdr); - -/* Return a cons or NULL for a proper list, else error */ -struct ao_lisp_cons * -ao_lisp_cons_cdr(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp__cons(ao_poly car, ao_poly cdr); - -extern struct ao_lisp_cons *ao_lisp_cons_free_list; - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons); - -void -ao_lisp_cons_write(ao_poly); - -void -ao_lisp_cons_display(ao_poly); - -int -ao_lisp_cons_length(struct ao_lisp_cons *cons); - -/* string */ -extern const struct ao_lisp_type ao_lisp_string_type; - -char * -ao_lisp_string_copy(char *a); - -char * -ao_lisp_string_cat(char *a, char *b); - -ao_poly -ao_lisp_string_pack(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_string_unpack(char *a); - -void -ao_lisp_string_write(ao_poly s); - -void -ao_lisp_string_display(ao_poly s); - -/* atom */ -extern const struct ao_lisp_type ao_lisp_atom_type; - -extern struct ao_lisp_atom *ao_lisp_atoms; -extern struct ao_lisp_frame *ao_lisp_frame_global; -extern struct ao_lisp_frame *ao_lisp_frame_current; - -void -ao_lisp_atom_write(ao_poly a); - -struct ao_lisp_atom * -ao_lisp_atom_intern(char *name); - -ao_poly * -ao_lisp_atom_ref(ao_poly atom); - -ao_poly -ao_lisp_atom_get(ao_poly atom); - -ao_poly -ao_lisp_atom_set(ao_poly atom, ao_poly val); - -ao_poly -ao_lisp_atom_def(ao_poly atom, ao_poly val); - -/* int */ -void -ao_lisp_int_write(ao_poly i); - -int32_t -ao_lisp_poly_integer(ao_poly p); - -ao_poly -ao_lisp_integer_poly(int32_t i); - -static inline int -ao_lisp_integer_typep(uint8_t t) -{ - return (t == AO_LISP_INT) || (t == AO_LISP_BIGINT); -} - -void -ao_lisp_bigint_write(ao_poly i); - -extern const struct ao_lisp_type ao_lisp_bigint_type; -/* prim */ -void -ao_lisp_poly_write(ao_poly p); - -void -ao_lisp_poly_display(ao_poly p); - -int -ao_lisp_poly_mark(ao_poly p, uint8_t note_cons); - -/* returns 1 if the object has already been moved */ -int -ao_lisp_poly_move(ao_poly *p, uint8_t note_cons); - -/* eval */ - -void -ao_lisp_eval_clear_globals(void); - -int -ao_lisp_eval_restart(void); - -ao_poly -ao_lisp_eval(ao_poly p); - -ao_poly -ao_lisp_set_cond(struct ao_lisp_cons *cons); - -/* float */ -extern const struct ao_lisp_type ao_lisp_float_type; - -void -ao_lisp_float_write(ao_poly p); - -ao_poly -ao_lisp_float_get(float value); - -static inline uint8_t -ao_lisp_number_typep(uint8_t t) -{ - return ao_lisp_integer_typep(t) || (t == AO_LISP_FLOAT); -} - -float -ao_lisp_poly_number(ao_poly p); - -/* builtin */ -void -ao_lisp_builtin_write(ao_poly b); - -extern const struct ao_lisp_type ao_lisp_builtin_type; - -/* Check argument count */ -ao_poly -ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max); - -/* Check argument type */ -ao_poly -ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok); - -/* Fetch an arg (nil if off the end) */ -ao_poly -ao_lisp_arg(struct ao_lisp_cons *cons, int argc); - -char * -ao_lisp_args_name(uint8_t args); - -/* read */ -extern struct ao_lisp_cons *ao_lisp_read_cons; -extern struct ao_lisp_cons *ao_lisp_read_cons_tail; -extern struct ao_lisp_cons *ao_lisp_read_stack; - -ao_poly -ao_lisp_read(void); - -/* rep */ -ao_poly -ao_lisp_read_eval_print(void); - -/* frame */ -extern const struct ao_lisp_type ao_lisp_frame_type; -extern const struct ao_lisp_type ao_lisp_frame_vals_type; - -#define AO_LISP_FRAME_FREE 6 - -extern struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; - -ao_poly -ao_lisp_frame_mark(struct ao_lisp_frame *frame); - -ao_poly * -ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); - -struct ao_lisp_frame * -ao_lisp_frame_new(int num); - -void -ao_lisp_frame_free(struct ao_lisp_frame *frame); - -void -ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val); - -ao_poly -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); - -void -ao_lisp_frame_write(ao_poly p); - -void -ao_lisp_frame_init(void); - -/* lambda */ -extern const struct ao_lisp_type ao_lisp_lambda_type; - -extern const char *ao_lisp_state_names[]; - -struct ao_lisp_lambda * -ao_lisp_lambda_new(ao_poly cons); - -void -ao_lisp_lambda_write(ao_poly lambda); - -ao_poly -ao_lisp_lambda_eval(void); - -/* stack */ - -extern const struct ao_lisp_type ao_lisp_stack_type; -extern struct ao_lisp_stack *ao_lisp_stack; -extern struct ao_lisp_stack *ao_lisp_stack_free_list; - -void -ao_lisp_stack_reset(struct ao_lisp_stack *stack); - -int -ao_lisp_stack_push(void); - -void -ao_lisp_stack_pop(void); - -void -ao_lisp_stack_clear(void); - -void -ao_lisp_stack_write(ao_poly stack); - -ao_poly -ao_lisp_stack_eval(void); - -/* error */ - -void -ao_lisp_vprintf(char *format, va_list args); - -void -ao_lisp_printf(char *format, ...); - -void -ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last); - -void -ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame); - -ao_poly -ao_lisp_error(int error, char *format, ...); - -/* builtins */ - -#define AO_LISP_BUILTIN_DECLS -#include "ao_lisp_builtin.h" - -/* debugging macros */ - -#if DBG_EVAL || DBG_READ || DBG_MEM -#define DBG_CODE 1 -int ao_lisp_stack_depth; -#define DBG_DO(a) a -#define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_lisp_stack_depth; _s++) printf(" "); } while(0) -#define DBG_IN() (++ao_lisp_stack_depth) -#define DBG_OUT() (--ao_lisp_stack_depth) -#define DBG_RESET() (ao_lisp_stack_depth = 0) -#define DBG(...) ao_lisp_printf(__VA_ARGS__) -#define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_lisp_cons_write(ao_lisp_cons_poly(a)) -#define DBG_POLY(a) ao_lisp_poly_write(a) -#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) -#define DBG_STACK() ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)) -static inline void -ao_lisp_frames_dump(void) -{ - struct ao_lisp_stack *s; - DBGI(".. current frame: "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { - DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); - } -} -#define DBG_FRAMES() ao_lisp_frames_dump() -#else -#define DBG_DO(a) -#define DBG_INDENT() -#define DBG_IN() -#define DBG_OUT() -#define DBG(...) -#define DBGI(...) -#define DBG_CONS(a) -#define DBG_POLY(a) -#define DBG_RESET() -#define DBG_STACK() -#define DBG_FRAMES() -#endif - -#if DBG_READ -#define RDBGI(...) DBGI(__VA_ARGS__) -#define RDBG_IN() DBG_IN() -#define RDBG_OUT() DBG_OUT() -#else -#define RDBGI(...) -#define RDBG_IN() -#define RDBG_OUT() -#endif - -#define DBG_MEM_START 1 - -#if DBG_MEM - -#include -extern int dbg_move_depth; -#define MDBG_DUMP 1 -#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_lisp_pool) : -1) - -extern int dbg_mem; - -#define MDBG_DO(a) DBG_DO(a) -#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) -#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) -#define MDBG_MOVE_IN() (dbg_move_depth++) -#define MDBG_MOVE_OUT() (assert(--dbg_move_depth >= 0)) - -#else - -#define MDBG_DO(a) -#define MDBG_MOVE(...) -#define MDBG_MORE(...) -#define MDBG_MOVE_IN() -#define MDBG_MOVE_OUT() - -#endif - -#endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c deleted file mode 100644 index a633c223..00000000 --- a/src/lisp/ao_lisp_atom.c +++ /dev/null @@ -1,159 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_lisp.h" - -static int name_size(char *name) -{ - return sizeof(struct ao_lisp_atom) + strlen(name) + 1; -} - -static int atom_size(void *addr) -{ - struct ao_lisp_atom *atom = addr; - if (!atom) - return 0; - return name_size(atom->name); -} - -static void atom_mark(void *addr) -{ - struct ao_lisp_atom *atom = addr; - - for (;;) { - atom = ao_lisp_poly_atom(atom->next); - if (!atom) - break; - if (ao_lisp_mark_memory(&ao_lisp_atom_type, atom)) - break; - } -} - -static void atom_move(void *addr) -{ - struct ao_lisp_atom *atom = addr; - int ret; - - for (;;) { - struct ao_lisp_atom *next = ao_lisp_poly_atom(atom->next); - - if (!next) - break; - ret = ao_lisp_move_memory(&ao_lisp_atom_type, (void **) &next); - if (next != ao_lisp_poly_atom(atom->next)) - atom->next = ao_lisp_atom_poly(next); - if (ret) - break; - atom = next; - } -} - -const struct ao_lisp_type ao_lisp_atom_type = { - .mark = atom_mark, - .size = atom_size, - .move = atom_move, - .name = "atom" -}; - -struct ao_lisp_atom *ao_lisp_atoms; - -struct ao_lisp_atom * -ao_lisp_atom_intern(char *name) -{ - struct ao_lisp_atom *atom; - - for (atom = ao_lisp_atoms; atom; atom = ao_lisp_poly_atom(atom->next)) { - if (!strcmp(atom->name, name)) - return atom; - } -#ifdef ao_builtin_atoms - for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) { - if (!strcmp(atom->name, name)) - return atom; - } -#endif - ao_lisp_string_stash(0, name); - atom = ao_lisp_alloc(name_size(name)); - name = ao_lisp_string_fetch(0); - if (atom) { - atom->type = AO_LISP_ATOM; - atom->next = ao_lisp_atom_poly(ao_lisp_atoms); - ao_lisp_atoms = atom; - strcpy(atom->name, name); - } - return atom; -} - -ao_poly * -ao_lisp_atom_ref(ao_poly atom) -{ - ao_poly *ref; - struct ao_lisp_frame *frame; - - for (frame = ao_lisp_frame_current; frame; frame = ao_lisp_poly_frame(frame->prev)) { - ref = ao_lisp_frame_ref(frame, atom); - if (ref) - return ref; - } - return ao_lisp_frame_ref(ao_lisp_frame_global, atom); -} - -ao_poly -ao_lisp_atom_get(ao_poly atom) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - -#ifdef ao_builtin_frame - if (!ref) - ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom); -#endif - if (ref) - return *ref; - return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); -} - -ao_poly -ao_lisp_atom_set(ao_poly atom, ao_poly val) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - - if (!ref) - return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); - *ref = val; - return val; -} - -ao_poly -ao_lisp_atom_def(ao_poly atom, ao_poly val) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - - if (ref) { - if (ao_lisp_frame_current) - return ao_lisp_error(AO_LISP_REDEFINED, "attempt to redefine atom %s", ao_lisp_poly_atom(atom)->name); - *ref = val; - return val; - } - return ao_lisp_frame_add(ao_lisp_frame_current ? ao_lisp_frame_current : ao_lisp_frame_global, atom, val); -} - -void -ao_lisp_atom_write(ao_poly a) -{ - struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); - printf("%s", atom->name); -} diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c deleted file mode 100644 index 6af2a6ea..00000000 --- a/src/lisp/ao_lisp_builtin.c +++ /dev/null @@ -1,868 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include -#include - -static int -builtin_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_builtin); -} - -static void -builtin_mark(void *addr) -{ - (void) addr; -} - -static void -builtin_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_builtin_type = { - .size = builtin_size, - .mark = builtin_mark, - .move = builtin_move -}; - -#ifdef AO_LISP_MAKE_CONST - -#define AO_LISP_BUILTIN_CASENAME -#include "ao_lisp_builtin.h" - -char *ao_lisp_args_name(uint8_t args) { - args &= AO_LISP_FUNC_MASK; - switch (args) { - case AO_LISP_FUNC_LAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_lambda)->name; - case AO_LISP_FUNC_NLAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_nlambda)->name; - case AO_LISP_FUNC_MACRO: return ao_lisp_poly_atom(_ao_lisp_atom_macro)->name; - default: return "???"; - } -} -#else - -#define AO_LISP_BUILTIN_ARRAYNAME -#include "ao_lisp_builtin.h" - -static char * -ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { - if (b < _builtin_last) - return ao_lisp_poly_atom(builtin_names[b])->name; - return "???"; -} - -static const ao_poly ao_lisp_args_atoms[] = { - [AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda, - [AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda, - [AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro, -}; - -char * -ao_lisp_args_name(uint8_t args) -{ - args &= AO_LISP_FUNC_MASK; - if (args < sizeof ao_lisp_args_atoms / sizeof ao_lisp_args_atoms[0]) - return ao_lisp_poly_atom(ao_lisp_args_atoms[args])->name; - return "(unknown)"; -} -#endif - -void -ao_lisp_builtin_write(ao_poly b) -{ - struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); - printf("%s", ao_lisp_builtin_name(builtin->func)); -} - -ao_poly -ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) -{ - int argc = 0; - - while (cons && argc <= max) { - argc++; - cons = ao_lisp_cons_cdr(cons); - } - if (argc < min || argc > max) - return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_arg(struct ao_lisp_cons *cons, int argc) -{ - if (!cons) - return AO_LISP_NIL; - while (argc--) { - if (!cons) - return AO_LISP_NIL; - cons = ao_lisp_cons_cdr(cons); - } - return cons->car; -} - -ao_poly -ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok) -{ - ao_poly car = ao_lisp_arg(cons, argc); - - if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type) - return ao_lisp_error(AO_LISP_INVALID, "%s: arg %d invalid type %v", ao_lisp_poly_atom(name)->name, argc, car); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_car(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_car, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(cons->car)->car; -} - -ao_poly -ao_lisp_do_cdr(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_cdr, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(cons->car)->cdr; -} - -ao_poly -ao_lisp_do_cons(struct ao_lisp_cons *cons) -{ - ao_poly car, cdr; - if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) - return AO_LISP_NIL; - car = ao_lisp_arg(cons, 0); - cdr = ao_lisp_arg(cons, 1); - return ao_lisp__cons(car, cdr); -} - -ao_poly -ao_lisp_do_last(struct ao_lisp_cons *cons) -{ - struct ao_lisp_cons *list; - if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - for (list = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); - list; - list = ao_lisp_cons_cdr(list)) - { - if (!list->cdr) - return list->car; - } - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_length(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_length, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_length, cons, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - return ao_lisp_int_poly(ao_lisp_cons_length(ao_lisp_poly_cons(ao_lisp_arg(cons, 0)))); -} - -ao_poly -ao_lisp_do_quote(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) - return AO_LISP_NIL; - return ao_lisp_arg(cons, 0); -} - -ao_poly -ao_lisp_do_set(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0)) - return AO_LISP_NIL; - - return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); -} - -ao_poly -ao_lisp_do_def(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_def, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_def, cons, 0, AO_LISP_ATOM, 0)) - return AO_LISP_NIL; - - return ao_lisp_atom_def(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); -} - -ao_poly -ao_lisp_do_setq(struct ao_lisp_cons *cons) -{ - ao_poly name; - if (!ao_lisp_check_argc(_ao_lisp_atom_set21, cons, 2, 2)) - return AO_LISP_NIL; - name = cons->car; - if (ao_lisp_poly_type(name) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom %v", name); - if (!ao_lisp_atom_ref(name)) - return ao_lisp_error(AO_LISP_INVALID, "atom %v not defined", name); - return ao_lisp__cons(_ao_lisp_atom_set, - ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, - ao_lisp__cons(name, AO_LISP_NIL)), - cons->cdr)); -} - -ao_poly -ao_lisp_do_cond(struct ao_lisp_cons *cons) -{ - ao_lisp_set_cond(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_begin(struct ao_lisp_cons *cons) -{ - ao_lisp_stack->state = eval_begin; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_while(struct ao_lisp_cons *cons) -{ - ao_lisp_stack->state = eval_while; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_write(struct ao_lisp_cons *cons) -{ - ao_poly val = AO_LISP_NIL; - while (cons) { - val = cons->car; - ao_lisp_poly_write(val); - cons = ao_lisp_cons_cdr(cons); - if (cons) - printf(" "); - } - printf("\n"); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_display(struct ao_lisp_cons *cons) -{ - ao_poly val = AO_LISP_NIL; - while (cons) { - val = cons->car; - ao_lisp_poly_display(val); - cons = ao_lisp_cons_cdr(cons); - } - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) -{ - struct ao_lisp_cons *cons = cons; - ao_poly ret = AO_LISP_NIL; - - for (cons = orig_cons; cons; cons = ao_lisp_cons_cdr(cons)) { - ao_poly car = cons->car; - uint8_t rt = ao_lisp_poly_type(ret); - uint8_t ct = ao_lisp_poly_type(car); - - if (cons == orig_cons) { - ret = car; - if (cons->cdr == AO_LISP_NIL) { - switch (op) { - case builtin_minus: - if (ao_lisp_integer_typep(ct)) - ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); - else if (ct == AO_LISP_FLOAT) - ret = ao_lisp_float_get(-ao_lisp_poly_number(ret)); - break; - case builtin_divide: - if (ao_lisp_integer_typep(ct) && ao_lisp_poly_integer(ret) == 1) - ; - else if (ao_lisp_number_typep(ct)) { - float v = ao_lisp_poly_number(ret); - ret = ao_lisp_float_get(1/v); - } - break; - default: - break; - } - } - } else if (ao_lisp_integer_typep(rt) && ao_lisp_integer_typep(ct)) { - int32_t r = ao_lisp_poly_integer(ret); - int32_t c = ao_lisp_poly_integer(car); - int64_t t; - - switch(op) { - case builtin_plus: - r += c; - check_overflow: - if (r < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < r) - goto inexact; - break; - case builtin_minus: - r -= c; - goto check_overflow; - break; - case builtin_times: - t = (int64_t) r * (int64_t) c; - if (t < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < t) - goto inexact; - r = (int32_t) t; - break; - case builtin_divide: - if (c != 0 && (r % c) == 0) - r /= c; - else - goto inexact; - break; - case builtin_quotient: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); - if (r % c != 0 && (c < 0) != (r < 0)) - r = r / c - 1; - else - r = r / c; - break; - case builtin_remainder: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); - r %= c; - break; - case builtin_modulo: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); - r %= c; - if ((r < 0) != (c < 0)) - r += c; - break; - default: - break; - } - ret = ao_lisp_integer_poly(r); - } else if (ao_lisp_number_typep(rt) && ao_lisp_number_typep(ct)) { - float r, c; - inexact: - r = ao_lisp_poly_number(ret); - c = ao_lisp_poly_number(car); - switch(op) { - case builtin_plus: - r += c; - break; - case builtin_minus: - r -= c; - break; - case builtin_times: - r *= c; - break; - case builtin_divide: - r /= c; - break; - case builtin_quotient: - case builtin_remainder: - case builtin_modulo: - return ao_lisp_error(AO_LISP_INVALID, "non-integer value in integer divide"); - default: - break; - } - ret = ao_lisp_float_get(r); - } - - else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) - ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), - ao_lisp_poly_string(car))); - else - return ao_lisp_error(AO_LISP_INVALID, "invalid args"); - } - return ret; -} - -ao_poly -ao_lisp_do_plus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_plus); -} - -ao_poly -ao_lisp_do_minus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_minus); -} - -ao_poly -ao_lisp_do_times(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_times); -} - -ao_poly -ao_lisp_do_divide(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_divide); -} - -ao_poly -ao_lisp_do_quotient(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_quotient); -} - -ao_poly -ao_lisp_do_modulo(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_modulo); -} - -ao_poly -ao_lisp_do_remainder(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_remainder); -} - -ao_poly -ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) -{ - ao_poly left; - - if (!cons) - return _ao_lisp_bool_true; - - left = cons->car; - for (cons = ao_lisp_cons_cdr(cons); cons; cons = ao_lisp_cons_cdr(cons)) { - ao_poly right = cons->car; - - if (op == builtin_equal) { - if (left != right) - return _ao_lisp_bool_false; - } else { - uint8_t lt = ao_lisp_poly_type(left); - uint8_t rt = ao_lisp_poly_type(right); - if (ao_lisp_integer_typep(lt) && ao_lisp_integer_typep(rt)) { - int32_t l = ao_lisp_poly_integer(left); - int32_t r = ao_lisp_poly_integer(right); - - switch (op) { - case builtin_less: - if (!(l < r)) - return _ao_lisp_bool_false; - break; - case builtin_greater: - if (!(l > r)) - return _ao_lisp_bool_false; - break; - case builtin_less_equal: - if (!(l <= r)) - return _ao_lisp_bool_false; - break; - case builtin_greater_equal: - if (!(l >= r)) - return _ao_lisp_bool_false; - break; - default: - break; - } - } else if (lt == AO_LISP_STRING && rt == AO_LISP_STRING) { - int c = strcmp(ao_lisp_poly_string(left), - ao_lisp_poly_string(right)); - switch (op) { - case builtin_less: - if (!(c < 0)) - return _ao_lisp_bool_false; - break; - case builtin_greater: - if (!(c > 0)) - return _ao_lisp_bool_false; - break; - case builtin_less_equal: - if (!(c <= 0)) - return _ao_lisp_bool_false; - break; - case builtin_greater_equal: - if (!(c >= 0)) - return _ao_lisp_bool_false; - break; - default: - break; - } - } - } - left = right; - } - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_equal); -} - -ao_poly -ao_lisp_do_less(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_less); -} - -ao_poly -ao_lisp_do_greater(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_greater); -} - -ao_poly -ao_lisp_do_less_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_less_equal); -} - -ao_poly -ao_lisp_do_greater_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_greater_equal); -} - -ao_poly -ao_lisp_do_list_to_string(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_list2d3estring, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_list2d3estring, cons, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - return ao_lisp_string_pack(ao_lisp_poly_cons(ao_lisp_arg(cons, 0))); -} - -ao_poly -ao_lisp_do_string_to_list(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_string2d3elist, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_string2d3elist, cons, 0, AO_LISP_STRING, 0)) - return AO_LISP_NIL; - return ao_lisp_string_unpack(ao_lisp_poly_string(ao_lisp_arg(cons, 0))); -} - -ao_poly -ao_lisp_do_flush_output(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_flush2doutput, cons, 0, 0)) - return AO_LISP_NIL; - ao_lisp_os_flush(); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_led(struct ao_lisp_cons *cons) -{ - ao_poly led; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) - return AO_LISP_NIL; - led = ao_lisp_arg(cons, 0); - ao_lisp_os_led(ao_lisp_poly_int(led)); - return led; -} - -ao_poly -ao_lisp_do_delay(struct ao_lisp_cons *cons) -{ - ao_poly delay; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) - return AO_LISP_NIL; - delay = ao_lisp_arg(cons, 0); - ao_lisp_os_delay(ao_lisp_poly_int(delay)); - return delay; -} - -ao_poly -ao_lisp_do_eval(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_eval, cons, 1, 1)) - return AO_LISP_NIL; - ao_lisp_stack->state = eval_sexpr; - return cons->car; -} - -ao_poly -ao_lisp_do_apply(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_apply, cons, 2, INT_MAX)) - return AO_LISP_NIL; - ao_lisp_stack->state = eval_apply; - return ao_lisp_cons_poly(cons); -} - -ao_poly -ao_lisp_do_read(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_read, cons, 0, 0)) - return AO_LISP_NIL; - return ao_lisp_read(); -} - -ao_poly -ao_lisp_do_collect(struct ao_lisp_cons *cons) -{ - int free; - (void) cons; - free = ao_lisp_collect(AO_LISP_COLLECT_FULL); - return ao_lisp_int_poly(free); -} - -ao_poly -ao_lisp_do_nullp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_arg(cons, 0) == AO_LISP_NIL) - return _ao_lisp_bool_true; - else - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_not(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_arg(cons, 0) == _ao_lisp_bool_false) - return _ao_lisp_bool_true; - else - return _ao_lisp_bool_false; -} - -static ao_poly -ao_lisp_do_typep(int type, struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == type) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_pairp(struct ao_lisp_cons *cons) -{ - ao_poly v; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - v = ao_lisp_arg(cons, 0); - if (v != AO_LISP_NIL && ao_lisp_poly_type(v) == AO_LISP_CONS) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_integerp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { - case AO_LISP_INT: - case AO_LISP_BIGINT: - return _ao_lisp_bool_true; - default: - return _ao_lisp_bool_false; - } -} - -ao_poly -ao_lisp_do_numberp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { - case AO_LISP_INT: - case AO_LISP_BIGINT: - case AO_LISP_FLOAT: - return _ao_lisp_bool_true; - default: - return _ao_lisp_bool_false; - } -} - -ao_poly -ao_lisp_do_stringp(struct ao_lisp_cons *cons) -{ - return ao_lisp_do_typep(AO_LISP_STRING, cons); -} - -ao_poly -ao_lisp_do_symbolp(struct ao_lisp_cons *cons) -{ - return ao_lisp_do_typep(AO_LISP_ATOM, cons); -} - -ao_poly -ao_lisp_do_booleanp(struct ao_lisp_cons *cons) -{ - return ao_lisp_do_typep(AO_LISP_BOOL, cons); -} - -ao_poly -ao_lisp_do_procedurep(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { - case AO_LISP_BUILTIN: - case AO_LISP_LAMBDA: - return _ao_lisp_bool_true; - default: - return _ao_lisp_bool_false; - } -} - -/* This one is special -- a list is either nil or - * a 'proper' list with only cons cells - */ -ao_poly -ao_lisp_do_listp(struct ao_lisp_cons *cons) -{ - ao_poly v; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - v = ao_lisp_arg(cons, 0); - for (;;) { - if (v == AO_LISP_NIL) - return _ao_lisp_bool_true; - if (ao_lisp_poly_type(v) != AO_LISP_CONS) - return _ao_lisp_bool_false; - v = ao_lisp_poly_cons(v)->cdr; - } -} - -ao_poly -ao_lisp_do_set_car(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->car = ao_lisp_arg(cons, 1); -} - -ao_poly -ao_lisp_do_set_cdr(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->cdr = ao_lisp_arg(cons, 1); -} - -ao_poly -ao_lisp_do_symbol_to_string(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_ATOM, 0)) - return AO_LISP_NIL; - return ao_lisp_string_poly(ao_lisp_string_copy(ao_lisp_poly_atom(ao_lisp_arg(cons, 0))->name)); -} - -ao_poly -ao_lisp_do_string_to_symbol(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_STRING, 0)) - return AO_LISP_NIL; - - return ao_lisp_atom_poly(ao_lisp_atom_intern(ao_lisp_poly_string(ao_lisp_arg(cons, 0)))); -} - -ao_poly -ao_lisp_do_read_char(struct ao_lisp_cons *cons) -{ - int c; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - c = getchar(); - return ao_lisp_int_poly(c); -} - -ao_poly -ao_lisp_do_write_char(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) - return AO_LISP_NIL; - putchar(ao_lisp_poly_integer(ao_lisp_arg(cons, 0))); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_exit(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - ao_lisp_exception |= AO_LISP_EXIT; - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_current_jiffy(struct ao_lisp_cons *cons) -{ - int jiffy; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - jiffy = ao_lisp_os_jiffy(); - return (ao_lisp_int_poly(jiffy)); -} - -ao_poly -ao_lisp_do_current_second(struct ao_lisp_cons *cons) -{ - int second; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - second = ao_lisp_os_jiffy() / AO_LISP_JIFFIES_PER_SECOND; - return (ao_lisp_int_poly(second)); -} - -ao_poly -ao_lisp_do_jiffies_per_second(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - return (ao_lisp_int_poly(AO_LISP_JIFFIES_PER_SECOND)); -} - -#define AO_LISP_BUILTIN_FUNCS -#include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c deleted file mode 100644 index d3b97383..00000000 --- a/src/lisp/ao_lisp_cons.c +++ /dev/null @@ -1,184 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static void cons_mark(void *addr) -{ - struct ao_lisp_cons *cons = addr; - - for (;;) { - ao_poly cdr = cons->cdr; - - ao_lisp_poly_mark(cons->car, 1); - if (!cdr) - break; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - ao_lisp_poly_mark(cdr, 1); - break; - } - cons = ao_lisp_poly_cons(cdr); - if (ao_lisp_mark_memory(&ao_lisp_cons_type, cons)) - break; - } -} - -static int cons_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_cons); -} - -static void cons_move(void *addr) -{ - struct ao_lisp_cons *cons = addr; - - if (!cons) - return; - - for (;;) { - ao_poly cdr; - struct ao_lisp_cons *c; - int ret; - - MDBG_MOVE("cons_move start %d (%d, %d)\n", - MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); - (void) ao_lisp_poly_move(&cons->car, 1); - cdr = cons->cdr; - if (!cdr) - break; - if (ao_lisp_poly_base_type(cdr) != AO_LISP_CONS) { - (void) ao_lisp_poly_move(&cons->cdr, 0); - break; - } - c = ao_lisp_poly_cons(cdr); - ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &c); - if (c != ao_lisp_poly_cons(cons->cdr)) - cons->cdr = ao_lisp_cons_poly(c); - MDBG_MOVE("cons_move end %d (%d, %d)\n", - MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); - if (ret) - break; - cons = c; - } -} - -const struct ao_lisp_type ao_lisp_cons_type = { - .mark = cons_mark, - .size = cons_size, - .move = cons_move, - .name = "cons", -}; - -struct ao_lisp_cons *ao_lisp_cons_free_list; - -struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, ao_poly cdr) -{ - struct ao_lisp_cons *cons; - - if (ao_lisp_cons_free_list) { - cons = ao_lisp_cons_free_list; - ao_lisp_cons_free_list = ao_lisp_poly_cons(cons->cdr); - } else { - ao_lisp_poly_stash(0, car); - ao_lisp_poly_stash(1, cdr); - cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); - cdr = ao_lisp_poly_fetch(1); - car = ao_lisp_poly_fetch(0); - if (!cons) - return NULL; - } - cons->car = car; - cons->cdr = cdr; - return cons; -} - -struct ao_lisp_cons * -ao_lisp_cons_cdr(struct ao_lisp_cons *cons) -{ - ao_poly cdr = cons->cdr; - if (cdr == AO_LISP_NIL) - return NULL; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - (void) ao_lisp_error(AO_LISP_INVALID, "improper list"); - return NULL; - } - return ao_lisp_poly_cons(cdr); -} - -ao_poly -ao_lisp__cons(ao_poly car, ao_poly cdr) -{ - return ao_lisp_cons_poly(ao_lisp_cons_cons(car, cdr)); -} - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons) -{ -#if DBG_FREE_CONS - ao_lisp_cons_check(cons); -#endif - while (cons) { - ao_poly cdr = cons->cdr; - cons->cdr = ao_lisp_cons_poly(ao_lisp_cons_free_list); - ao_lisp_cons_free_list = cons; - cons = ao_lisp_poly_cons(cdr); - } -} - -void -ao_lisp_cons_write(ao_poly c) -{ - struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); - int first = 1; - printf("("); - while (cons) { - if (!first) - printf(" "); - ao_lisp_poly_write(cons->car); - c = cons->cdr; - if (ao_lisp_poly_type(c) == AO_LISP_CONS) { - cons = ao_lisp_poly_cons(c); - first = 0; - } else { - printf(" . "); - ao_lisp_poly_write(c); - cons = NULL; - } - } - printf(")"); -} - -void -ao_lisp_cons_display(ao_poly c) -{ - struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); - - while (cons) { - ao_lisp_poly_display(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - } -} - -int -ao_lisp_cons_length(struct ao_lisp_cons *cons) -{ - int len = 0; - while (cons) { - len++; - cons = ao_lisp_poly_cons(cons->cdr); - } - return len; -} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c deleted file mode 100644 index c3dd2ed2..00000000 --- a/src/lisp/ao_lisp_eval.c +++ /dev/null @@ -1,578 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -struct ao_lisp_stack *ao_lisp_stack; -ao_poly ao_lisp_v; -uint8_t ao_lisp_skip_cons_free; - -ao_poly -ao_lisp_set_cond(struct ao_lisp_cons *c) -{ - ao_lisp_stack->state = eval_cond; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(c); - return AO_LISP_NIL; -} - -static int -func_type(ao_poly func) -{ - if (func == AO_LISP_NIL) - return ao_lisp_error(AO_LISP_INVALID, "func is nil"); - switch (ao_lisp_poly_type(func)) { - case AO_LISP_BUILTIN: - return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK; - case AO_LISP_LAMBDA: - return ao_lisp_poly_lambda(func)->args; - case AO_LISP_STACK: - return AO_LISP_FUNC_LAMBDA; - default: - ao_lisp_error(AO_LISP_INVALID, "not a func"); - return -1; - } -} - -/* - * Flattened eval to avoid stack issues - */ - -/* - * Evaluate an s-expression - * - * For a list, evaluate all of the elements and - * then execute the resulting function call. - * - * Each element of the list is evaluated in - * a clean stack context. - * - * The current stack state is set to 'formal' so that - * when the evaluation is complete, the value - * will get appended to the values list. - * - * For other types, compute the value directly. - */ - -static int -ao_lisp_eval_sexpr(void) -{ - DBGI("sexpr: %v\n", ao_lisp_v); - switch (ao_lisp_poly_type(ao_lisp_v)) { - case AO_LISP_CONS: - if (ao_lisp_v == AO_LISP_NIL) { - if (!ao_lisp_stack->values) { - /* - * empty list evaluates to empty list - */ - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - /* - * done with arguments, go execute it - */ - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; - ao_lisp_stack->state = eval_exec; - } - } else { - if (!ao_lisp_stack->values) - ao_lisp_stack->list = ao_lisp_v; - /* - * Evaluate another argument and then switch - * to 'formal' to add the value to the values - * list - */ - ao_lisp_stack->sexprs = ao_lisp_v; - ao_lisp_stack->state = eval_formal; - if (!ao_lisp_stack_push()) - return 0; - /* - * push will reset the state to 'sexpr', which - * will evaluate the expression - */ - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - } - break; - case AO_LISP_ATOM: - DBGI("..frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); - /* fall through */ - case AO_LISP_BOOL: - case AO_LISP_INT: - case AO_LISP_BIGINT: - case AO_LISP_FLOAT: - case AO_LISP_STRING: - case AO_LISP_BUILTIN: - case AO_LISP_LAMBDA: - ao_lisp_stack->state = eval_val; - break; - } - DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG("\n"); - return 1; -} - -/* - * A value has been computed. - * - * If the value was computed from a macro, - * then we want to reset the current context - * to evaluate the macro result again. - * - * If not a macro, then pop the stack. - * If the stack is empty, we're done. - * Otherwise, the stack will contain - * the next state. - */ - -static int -ao_lisp_eval_val(void) -{ - DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); - /* - * Value computed, pop the stack - * to figure out what to do with the value - */ - ao_lisp_stack_pop(); - DBGI("..state %d\n", ao_lisp_stack ? ao_lisp_stack->state : -1); - return 1; -} - -/* - * A formal has been computed. - * - * If this is the first formal, then check to see if we've got a - * lamda, macro or nlambda. - * - * For lambda, go compute another formal. This will terminate - * when the sexpr state sees nil. - * - * For macro/nlambda, we're done, so move the sexprs into the values - * and go execute it. - * - * Macros have an additional step of saving a stack frame holding the - * macro value execution context, which then gets the result of the - * macro to run - */ - -static int -ao_lisp_eval_formal(void) -{ - ao_poly formal; - struct ao_lisp_stack *prev; - - DBGI("formal: "); DBG_POLY(ao_lisp_v); DBG("\n"); - - /* Check what kind of function we've got */ - if (!ao_lisp_stack->values) { - switch (func_type(ao_lisp_v)) { - case AO_LISP_FUNC_LAMBDA: - DBGI(".. lambda\n"); - break; - case AO_LISP_FUNC_MACRO: - /* Evaluate the result once more */ - ao_lisp_stack->state = eval_macro; - if (!ao_lisp_stack_push()) - return 0; - - /* After the function returns, take that - * value and re-evaluate it - */ - prev = ao_lisp_poly_stack(ao_lisp_stack->prev); - ao_lisp_stack->sexprs = prev->sexprs; - - DBGI(".. start macro\n"); - DBGI("\t.. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI("\t.. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); - DBG_FRAMES(); - - /* fall through ... */ - case AO_LISP_FUNC_NLAMBDA: - DBGI(".. nlambda or macro\n"); - - /* use the raw sexprs as values */ - ao_lisp_stack->values = ao_lisp_stack->sexprs; - ao_lisp_stack->values_tail = AO_LISP_NIL; - ao_lisp_stack->state = eval_exec; - - /* ready to execute now */ - return 1; - case -1: - return 0; - } - } - - /* Append formal to list of values */ - formal = ao_lisp__cons(ao_lisp_v, AO_LISP_NIL); - if (!formal) - return 0; - - if (ao_lisp_stack->values_tail) - ao_lisp_poly_cons(ao_lisp_stack->values_tail)->cdr = formal; - else - ao_lisp_stack->values = formal; - ao_lisp_stack->values_tail = formal; - - DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); - - /* - * Step to the next argument, if this is last, then - * 'sexpr' will end up switching to 'exec' - */ - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - - ao_lisp_stack->state = eval_sexpr; - - DBGI(".. "); DBG_POLY(ao_lisp_v); DBG("\n"); - return 1; -} - -/* - * Start executing a function call - * - * Most builtins are easy, just call the function. - * 'cond' is magic; it sticks the list of clauses - * in 'sexprs' and switches to 'cond' state. That - * bit of magic is done in ao_lisp_set_cond. - * - * Lambdas build a new frame to hold the locals and - * then re-use the current stack context to evaluate - * the s-expression from the lambda. - */ - -static int -ao_lisp_eval_exec(void) -{ - ao_poly v; - struct ao_lisp_builtin *builtin; - - DBGI("exec: "); DBG_POLY(ao_lisp_v); DBG(" values "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); - ao_lisp_stack->sexprs = AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_v)) { - case AO_LISP_BUILTIN: - ao_lisp_stack->state = eval_val; - builtin = ao_lisp_poly_builtin(ao_lisp_v); - v = ao_lisp_func(builtin) ( - ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr)); - DBG_DO(if (!ao_lisp_exception && ao_lisp_poly_builtin(ao_lisp_v)->func == builtin_set) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - ao_poly atom = ao_lisp_arg(cons, 1); - ao_poly val = ao_lisp_arg(cons, 2); - DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); - }); - builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin && (builtin->args & AO_LISP_FUNC_FREE_ARGS) && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_cons_free(cons); - } - - ao_lisp_v = v; - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; - DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - break; - case AO_LISP_LAMBDA: - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - ao_lisp_stack->state = eval_begin; - v = ao_lisp_lambda_eval(); - ao_lisp_stack->sexprs = v; - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; - DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - break; - case AO_LISP_STACK: - DBGI(".. stack "); DBG_POLY(ao_lisp_v); DBG("\n"); - ao_lisp_v = ao_lisp_stack_eval(); - DBGI(".. value "); DBG_POLY(ao_lisp_v); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - break; - } - ao_lisp_skip_cons_free = 0; - return 1; -} - -/* - * Finish setting up the apply evaluation - * - * The value is the list to execute - */ -static int -ao_lisp_eval_apply(void) -{ - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_v); - struct ao_lisp_cons *cdr, *prev; - - /* Glue the arguments into the right shape. That's all but the last - * concatenated onto the last - */ - cdr = cons; - for (;;) { - prev = cdr; - cdr = ao_lisp_poly_cons(prev->cdr); - if (cdr->cdr == AO_LISP_NIL) - break; - } - DBGI("before mangling: "); DBG_POLY(ao_lisp_v); DBG("\n"); - prev->cdr = cdr->car; - ao_lisp_stack->values = ao_lisp_v; - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; - DBGI("apply: "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); - ao_lisp_stack->state = eval_exec; - ao_lisp_skip_cons_free = 1; - return 1; -} - -/* - * Start evaluating the next cond clause - * - * If the list of clauses is empty, then - * the result of the cond is nil. - * - * Otherwise, set the current stack state to 'cond_test' and create a - * new stack context to evaluate the test s-expression. Once that's - * complete, we'll land in 'cond_test' to finish the clause. - */ -static int -ao_lisp_eval_cond(void) -{ - DBGI("cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - if (!ao_lisp_stack->sexprs) { - ao_lisp_v = _ao_lisp_bool_false; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; - if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { - ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); - return 0; - } - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - if (ao_lisp_v == _ao_lisp_atom_else) - ao_lisp_v = _ao_lisp_bool_true; - ao_lisp_stack->state = eval_cond_test; - if (!ao_lisp_stack_push()) - return 0; - } - return 1; -} - -/* - * Finish a cond clause. - * - * Check the value from the test expression, if - * non-nil, then set up to evaluate the value expression. - * - * Otherwise, step to the next clause and go back to the 'cond' - * state - */ -static int -ao_lisp_eval_cond_test(void) -{ - DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - if (ao_lisp_v != _ao_lisp_bool_false) { - struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); - ao_poly c = car->cdr; - - if (c) { - ao_lisp_stack->state = eval_begin; - ao_lisp_stack->sexprs = c; - } else - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - DBGI("next cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - ao_lisp_stack->state = eval_cond; - } - return 1; -} - -/* - * Evaluate a list of sexprs, returning the value from the last one. - * - * ao_lisp_begin records the list in stack->sexprs, so we just need to - * walk that list. Set ao_lisp_v to the car of the list and jump to - * eval_sexpr. When that's done, it will land in eval_val. For all but - * the last, leave a stack frame with eval_begin set so that we come - * back here. For the last, don't add a stack frame so that we can - * just continue on. - */ -static int -ao_lisp_eval_begin(void) -{ - DBGI("begin: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - - if (!ao_lisp_stack->sexprs) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; - ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - - /* If there are more sexprs to do, then come back here, otherwise - * return the value of the last one by just landing in eval_sexpr - */ - if (ao_lisp_stack->sexprs) { - ao_lisp_stack->state = eval_begin; - if (!ao_lisp_stack_push()) - return 0; - } - ao_lisp_stack->state = eval_sexpr; - } - return 1; -} - -/* - * Conditionally execute a list of sexprs while the first is true - */ -static int -ao_lisp_eval_while(void) -{ - DBGI("while: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - - ao_lisp_stack->values = ao_lisp_v; - if (!ao_lisp_stack->sexprs) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; - ao_lisp_stack->state = eval_while_test; - if (!ao_lisp_stack_push()) - return 0; - } - return 1; -} - -/* - * Check the while condition, terminate the loop if nil. Otherwise keep going - */ -static int -ao_lisp_eval_while_test(void) -{ - DBGI("while_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - - if (ao_lisp_v != _ao_lisp_bool_false) { - ao_lisp_stack->values = ao_lisp_v; - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - ao_lisp_stack->state = eval_while; - if (!ao_lisp_stack_push()) - return 0; - ao_lisp_stack->state = eval_begin; - ao_lisp_stack->sexprs = ao_lisp_v; - } - else - { - ao_lisp_stack->state = eval_val; - ao_lisp_v = ao_lisp_stack->values; - } - return 1; -} - -/* - * Replace the original sexpr with the macro expansion, then - * execute that - */ -static int -ao_lisp_eval_macro(void) -{ - DBGI("macro: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - - if (ao_lisp_v == AO_LISP_NIL) - ao_lisp_abort(); - if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_CONS) { - *ao_lisp_poly_cons(ao_lisp_stack->sexprs) = *ao_lisp_poly_cons(ao_lisp_v); - ao_lisp_v = ao_lisp_stack->sexprs; - DBGI("sexprs rewritten to: "); DBG_POLY(ao_lisp_v); DBG("\n"); - } - ao_lisp_stack->sexprs = AO_LISP_NIL; - ao_lisp_stack->state = eval_sexpr; - return 1; -} - -static int (*const evals[])(void) = { - [eval_sexpr] = ao_lisp_eval_sexpr, - [eval_val] = ao_lisp_eval_val, - [eval_formal] = ao_lisp_eval_formal, - [eval_exec] = ao_lisp_eval_exec, - [eval_apply] = ao_lisp_eval_apply, - [eval_cond] = ao_lisp_eval_cond, - [eval_cond_test] = ao_lisp_eval_cond_test, - [eval_begin] = ao_lisp_eval_begin, - [eval_while] = ao_lisp_eval_while, - [eval_while_test] = ao_lisp_eval_while_test, - [eval_macro] = ao_lisp_eval_macro, -}; - -const char *ao_lisp_state_names[] = { - [eval_sexpr] = "sexpr", - [eval_val] = "val", - [eval_formal] = "formal", - [eval_exec] = "exec", - [eval_apply] = "apply", - [eval_cond] = "cond", - [eval_cond_test] = "cond_test", - [eval_begin] = "begin", - [eval_while] = "while", - [eval_while_test] = "while_test", - [eval_macro] = "macro", -}; - -/* - * Called at restore time to reset all execution state - */ - -void -ao_lisp_eval_clear_globals(void) -{ - ao_lisp_stack = NULL; - ao_lisp_frame_current = NULL; - ao_lisp_v = AO_LISP_NIL; -} - -int -ao_lisp_eval_restart(void) -{ - return ao_lisp_stack_push(); -} - -ao_poly -ao_lisp_eval(ao_poly _v) -{ - ao_lisp_v = _v; - - ao_lisp_frame_init(); - - if (!ao_lisp_stack_push()) - return AO_LISP_NIL; - - while (ao_lisp_stack) { - if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) { - ao_lisp_stack_clear(); - return AO_LISP_NIL; - } - } - DBG_DO(if (ao_lisp_frame_current) {DBGI("frame left as "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");}); - ao_lisp_frame_current = NULL; - return ao_lisp_v; -} diff --git a/src/lisp/ao_lisp_float.c b/src/lisp/ao_lisp_float.c deleted file mode 100644 index 0aa6f2ea..00000000 --- a/src/lisp/ao_lisp_float.c +++ /dev/null @@ -1,148 +0,0 @@ -/* - * Copyright © 2017 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -static void float_mark(void *addr) -{ - (void) addr; -} - -static int float_size(void *addr) -{ - if (!addr) - return 0; - return sizeof (struct ao_lisp_float); -} - -static void float_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_float_type = { - .mark = float_mark, - .size = float_size, - .move = float_move, - .name = "float", -}; - -void -ao_lisp_float_write(ao_poly p) -{ - struct ao_lisp_float *f = ao_lisp_poly_float(p); - float v = f->value; - - if (isnanf(v)) - printf("+nan.0"); - else if (isinff(v)) { - if (v < 0) - printf("-"); - else - printf("+"); - printf("inf.0"); - } else - printf ("%g", f->value); -} - -float -ao_lisp_poly_number(ao_poly p) -{ - switch (ao_lisp_poly_base_type(p)) { - case AO_LISP_INT: - return ao_lisp_poly_int(p); - case AO_LISP_OTHER: - switch (ao_lisp_other_type(ao_lisp_poly_other(p))) { - case AO_LISP_BIGINT: - return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); - case AO_LISP_FLOAT: - return ao_lisp_poly_float(p)->value; - } - } - return NAN; -} - -ao_poly -ao_lisp_float_get(float value) -{ - struct ao_lisp_float *f; - - f = ao_lisp_alloc(sizeof (struct ao_lisp_float)); - f->type = AO_LISP_FLOAT; - f->value = value; - return ao_lisp_float_poly(f); -} - -ao_poly -ao_lisp_do_inexactp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == AO_LISP_FLOAT) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_finitep(struct ao_lisp_cons *cons) -{ - ao_poly value; - float f; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - value = ao_lisp_arg(cons, 0); - switch (ao_lisp_poly_type(value)) { - case AO_LISP_INT: - case AO_LISP_BIGINT: - return _ao_lisp_bool_true; - case AO_LISP_FLOAT: - f = ao_lisp_poly_float(value)->value; - if (!isnan(f) && !isinf(f)) - return _ao_lisp_bool_true; - } - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_infinitep(struct ao_lisp_cons *cons) -{ - ao_poly value; - float f; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - value = ao_lisp_arg(cons, 0); - switch (ao_lisp_poly_type(value)) { - case AO_LISP_FLOAT: - f = ao_lisp_poly_float(value)->value; - if (isinf(f)) - return _ao_lisp_bool_true; - } - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_sqrt(struct ao_lisp_cons *cons) -{ - ao_poly value; - - if (!ao_lisp_check_argc(_ao_lisp_atom_sqrt, cons, 1, 1)) - return AO_LISP_NIL; - value = ao_lisp_arg(cons, 0); - if (!ao_lisp_number_typep(ao_lisp_poly_type(value))) - return ao_lisp_error(AO_LISP_INVALID, "%s: non-numeric", ao_lisp_poly_atom(_ao_lisp_atom_sqrt)->name); - return ao_lisp_float_get(sqrtf(ao_lisp_poly_number(value))); -} diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c deleted file mode 100644 index c285527e..00000000 --- a/src/lisp/ao_lisp_frame.c +++ /dev/null @@ -1,330 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static inline int -frame_vals_num_size(int num) -{ - return sizeof (struct ao_lisp_frame_vals) + num * sizeof (struct ao_lisp_val); -} - -static int -frame_vals_size(void *addr) -{ - struct ao_lisp_frame_vals *vals = addr; - return frame_vals_num_size(vals->size); -} - -static void -frame_vals_mark(void *addr) -{ - struct ao_lisp_frame_vals *vals = addr; - int f; - - for (f = 0; f < vals->size; f++) { - struct ao_lisp_val *v = &vals->vals[f]; - - ao_lisp_poly_mark(v->val, 0); - MDBG_MOVE("frame mark atom %s %d val %d at %d ", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - MDBG_DO(ao_lisp_poly_write(v->val)); - MDBG_DO(printf("\n")); - } -} - -static void -frame_vals_move(void *addr) -{ - struct ao_lisp_frame_vals *vals = addr; - int f; - - for (f = 0; f < vals->size; f++) { - struct ao_lisp_val *v = &vals->vals[f]; - - ao_lisp_poly_move(&v->atom, 0); - ao_lisp_poly_move(&v->val, 0); - MDBG_MOVE("frame move atom %s %d val %d at %d\n", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - } -} - -const struct ao_lisp_type ao_lisp_frame_vals_type = { - .mark = frame_vals_mark, - .size = frame_vals_size, - .move = frame_vals_move, - .name = "frame_vals" -}; - -static int -frame_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_frame); -} - -static void -frame_mark(void *addr) -{ - struct ao_lisp_frame *frame = addr; - - for (;;) { - MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); - if (!AO_LISP_IS_POOL(frame)) - break; - ao_lisp_poly_mark(frame->vals, 0); - frame = ao_lisp_poly_frame(frame->prev); - MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); - if (!frame) - break; - if (ao_lisp_mark_memory(&ao_lisp_frame_type, frame)) - break; - } -} - -static void -frame_move(void *addr) -{ - struct ao_lisp_frame *frame = addr; - - for (;;) { - struct ao_lisp_frame *prev; - int ret; - - MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); - if (!AO_LISP_IS_POOL(frame)) - break; - ao_lisp_poly_move(&frame->vals, 0); - prev = ao_lisp_poly_frame(frame->prev); - if (!prev) - break; - ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &prev); - if (prev != ao_lisp_poly_frame(frame->prev)) { - MDBG_MOVE("frame prev moved from %d to %d\n", - MDBG_OFFSET(ao_lisp_poly_frame(frame->prev)), - MDBG_OFFSET(prev)); - frame->prev = ao_lisp_frame_poly(prev); - } - if (ret) - break; - frame = prev; - } -} - -const struct ao_lisp_type ao_lisp_frame_type = { - .mark = frame_mark, - .size = frame_size, - .move = frame_move, - .name = "frame", -}; - -void -ao_lisp_frame_write(ao_poly p) -{ - struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int f; - - printf ("{"); - if (frame) { - if (frame->type & AO_LISP_FRAME_PRINT) - printf("recurse..."); - else { - frame->type |= AO_LISP_FRAME_PRINT; - for (f = 0; f < frame->num; f++) { - if (f != 0) - printf(", "); - ao_lisp_poly_write(vals->vals[f].atom); - printf(" = "); - ao_lisp_poly_write(vals->vals[f].val); - } - if (frame->prev) - ao_lisp_poly_write(frame->prev); - frame->type &= ~AO_LISP_FRAME_PRINT; - } - } - printf("}"); -} - -static int -ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) -{ - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int l = 0; - int r = top - 1; - - while (l <= r) { - int m = (l + r) >> 1; - if (vals->vals[m].atom < atom) - l = m + 1; - else - r = m - 1; - } - return l; -} - -ao_poly * -ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) -{ - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int l = ao_lisp_frame_find(frame, frame->num, atom); - - if (l >= frame->num) - return NULL; - - if (vals->vals[l].atom != atom) - return NULL; - return &vals->vals[l].val; -} - -struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; - -static struct ao_lisp_frame_vals * -ao_lisp_frame_vals_new(int num) -{ - struct ao_lisp_frame_vals *vals; - - vals = ao_lisp_alloc(frame_vals_num_size(num)); - if (!vals) - return NULL; - vals->type = AO_LISP_FRAME_VALS; - vals->size = num; - memset(vals->vals, '\0', num * sizeof (struct ao_lisp_val)); - return vals; -} - -struct ao_lisp_frame * -ao_lisp_frame_new(int num) -{ - struct ao_lisp_frame *frame; - struct ao_lisp_frame_vals *vals; - - if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) { - ao_lisp_frame_free_list[num] = ao_lisp_poly_frame(frame->prev); - vals = ao_lisp_poly_frame_vals(frame->vals); - } else { - frame = ao_lisp_alloc(sizeof (struct ao_lisp_frame)); - if (!frame) - return NULL; - frame->type = AO_LISP_FRAME; - frame->num = 0; - frame->prev = AO_LISP_NIL; - frame->vals = AO_LISP_NIL; - ao_lisp_frame_stash(0, frame); - vals = ao_lisp_frame_vals_new(num); - frame = ao_lisp_frame_fetch(0); - if (!vals) - return NULL; - frame->vals = ao_lisp_frame_vals_poly(vals); - frame->num = num; - } - frame->prev = AO_LISP_NIL; - return frame; -} - -ao_poly -ao_lisp_frame_mark(struct ao_lisp_frame *frame) -{ - if (!frame) - return AO_LISP_NIL; - frame->type |= AO_LISP_FRAME_MARK; - return ao_lisp_frame_poly(frame); -} - -void -ao_lisp_frame_free(struct ao_lisp_frame *frame) -{ - if (frame && !ao_lisp_frame_marked(frame)) { - int num = frame->num; - if (num < AO_LISP_FRAME_FREE) { - struct ao_lisp_frame_vals *vals; - - vals = ao_lisp_poly_frame_vals(frame->vals); - memset(vals->vals, '\0', vals->size * sizeof (struct ao_lisp_val)); - frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); - ao_lisp_frame_free_list[num] = frame; - } - } -} - -static struct ao_lisp_frame * -ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) -{ - struct ao_lisp_frame_vals *vals; - struct ao_lisp_frame_vals *new_vals; - int copy; - - if (new_num == frame->num) - return frame; - ao_lisp_frame_stash(0, frame); - new_vals = ao_lisp_frame_vals_new(new_num); - frame = ao_lisp_frame_fetch(0); - if (!new_vals) - return NULL; - vals = ao_lisp_poly_frame_vals(frame->vals); - copy = new_num; - if (copy > frame->num) - copy = frame->num; - memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_lisp_val)); - frame->vals = ao_lisp_frame_vals_poly(new_vals); - frame->num = new_num; - return frame; -} - -void -ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val) -{ - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int l = ao_lisp_frame_find(frame, num, atom); - - memmove(&vals->vals[l+1], - &vals->vals[l], - (num - l) * sizeof (struct ao_lisp_val)); - vals->vals[l].atom = atom; - vals->vals[l].val = val; -} - -ao_poly -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) -{ - ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; - - if (!ref) { - int f = frame->num; - ao_lisp_poly_stash(0, atom); - ao_lisp_poly_stash(1, val); - frame = ao_lisp_frame_realloc(frame, f + 1); - val = ao_lisp_poly_fetch(1); - atom = ao_lisp_poly_fetch(0); - if (!frame) - return AO_LISP_NIL; - ao_lisp_frame_bind(frame, frame->num - 1, atom, val); - } else - *ref = val; - return val; -} - -struct ao_lisp_frame *ao_lisp_frame_global; -struct ao_lisp_frame *ao_lisp_frame_current; - -void -ao_lisp_frame_init(void) -{ - if (!ao_lisp_frame_global) - ao_lisp_frame_global = ao_lisp_frame_new(0); -} diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c deleted file mode 100644 index 8e467755..00000000 --- a/src/lisp/ao_lisp_int.c +++ /dev/null @@ -1,79 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -void -ao_lisp_int_write(ao_poly p) -{ - int i = ao_lisp_poly_int(p); - printf("%d", i); -} - -int32_t -ao_lisp_poly_integer(ao_poly p) -{ - switch (ao_lisp_poly_base_type(p)) { - case AO_LISP_INT: - return ao_lisp_poly_int(p); - case AO_LISP_OTHER: - if (ao_lisp_other_type(ao_lisp_poly_other(p)) == AO_LISP_BIGINT) - return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); - } - return AO_LISP_NOT_INTEGER; -} - -ao_poly -ao_lisp_integer_poly(int32_t p) -{ - struct ao_lisp_bigint *bi; - - if (AO_LISP_MIN_INT <= p && p <= AO_LISP_MAX_INT) - return ao_lisp_int_poly(p); - bi = ao_lisp_alloc(sizeof (struct ao_lisp_bigint)); - bi->value = ao_lisp_int_bigint(p); - return ao_lisp_bigint_poly(bi); -} - -static void bigint_mark(void *addr) -{ - (void) addr; -} - -static int bigint_size(void *addr) -{ - if (!addr) - return 0; - return sizeof (struct ao_lisp_bigint); -} - -static void bigint_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_bigint_type = { - .mark = bigint_mark, - .size = bigint_size, - .move = bigint_move, - .name = "bigint", -}; - -void -ao_lisp_bigint_write(ao_poly p) -{ - struct ao_lisp_bigint *bi = ao_lisp_poly_bigint(p); - - printf("%d", ao_lisp_bigint_int(bi->value)); -} diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c deleted file mode 100644 index e72281db..00000000 --- a/src/lisp/ao_lisp_lambda.c +++ /dev/null @@ -1,208 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_lisp.h" - -int -lambda_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_lambda); -} - -void -lambda_mark(void *addr) -{ - struct ao_lisp_lambda *lambda = addr; - - ao_lisp_poly_mark(lambda->code, 0); - ao_lisp_poly_mark(lambda->frame, 0); -} - -void -lambda_move(void *addr) -{ - struct ao_lisp_lambda *lambda = addr; - - ao_lisp_poly_move(&lambda->code, 0); - ao_lisp_poly_move(&lambda->frame, 0); -} - -const struct ao_lisp_type ao_lisp_lambda_type = { - .size = lambda_size, - .mark = lambda_mark, - .move = lambda_move, - .name = "lambda", -}; - -void -ao_lisp_lambda_write(ao_poly poly) -{ - struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(poly); - struct ao_lisp_cons *cons = ao_lisp_poly_cons(lambda->code); - - printf("("); - printf("%s", ao_lisp_args_name(lambda->args)); - while (cons) { - printf(" "); - ao_lisp_poly_write(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - } - printf(")"); -} - -ao_poly -ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) -{ - struct ao_lisp_lambda *lambda; - ao_poly formal; - struct ao_lisp_cons *cons; - - formal = ao_lisp_arg(code, 0); - while (formal != AO_LISP_NIL) { - switch (ao_lisp_poly_type(formal)) { - case AO_LISP_CONS: - cons = ao_lisp_poly_cons(formal); - if (ao_lisp_poly_type(cons->car) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", cons->car); - formal = cons->cdr; - break; - case AO_LISP_ATOM: - formal = AO_LISP_NIL; - break; - default: - return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", formal); - } - } - - ao_lisp_cons_stash(0, code); - lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); - code = ao_lisp_cons_fetch(0); - if (!lambda) - return AO_LISP_NIL; - - lambda->type = AO_LISP_LAMBDA; - lambda->args = args; - lambda->code = ao_lisp_cons_poly(code); - lambda->frame = ao_lisp_frame_mark(ao_lisp_frame_current); - DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); - DBG_STACK(); - return ao_lisp_lambda_poly(lambda); -} - -ao_poly -ao_lisp_do_lambda(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); -} - -ao_poly -ao_lisp_do_nlambda(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); -} - -ao_poly -ao_lisp_do_macro(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO); -} - -ao_poly -ao_lisp_lambda_eval(void) -{ - struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(ao_lisp_v); - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - struct ao_lisp_cons *code = ao_lisp_poly_cons(lambda->code); - ao_poly formals; - struct ao_lisp_frame *next_frame; - int args_wanted; - ao_poly varargs = AO_LISP_NIL; - int args_provided; - int f; - struct ao_lisp_cons *vals; - - DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); - - args_wanted = 0; - for (formals = ao_lisp_arg(code, 0); - ao_lisp_is_pair(formals); - formals = ao_lisp_poly_cons(formals)->cdr) - ++args_wanted; - if (formals != AO_LISP_NIL) { - if (ao_lisp_poly_type(formals) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "bad lambda form"); - varargs = formals; - } - - /* Create a frame to hold the variables - */ - args_provided = ao_lisp_cons_length(cons) - 1; - if (varargs == AO_LISP_NIL) { - if (args_wanted != args_provided) - return ao_lisp_error(AO_LISP_INVALID, "need %d args, got %d", args_wanted, args_provided); - } else { - if (args_provided < args_wanted) - return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided); - } - - ao_lisp_poly_stash(1, varargs); - next_frame = ao_lisp_frame_new(args_wanted + (varargs != AO_LISP_NIL)); - varargs = ao_lisp_poly_fetch(1); - if (!next_frame) - return AO_LISP_NIL; - - /* Re-fetch all of the values in case something moved */ - lambda = ao_lisp_poly_lambda(ao_lisp_v); - cons = ao_lisp_poly_cons(ao_lisp_stack->values); - code = ao_lisp_poly_cons(lambda->code); - formals = ao_lisp_arg(code, 0); - vals = ao_lisp_poly_cons(cons->cdr); - - next_frame->prev = lambda->frame; - ao_lisp_frame_current = next_frame; - ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - - for (f = 0; f < args_wanted; f++) { - struct ao_lisp_cons *arg = ao_lisp_poly_cons(formals); - DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, arg->car, vals->car); - formals = arg->cdr; - vals = ao_lisp_poly_cons(vals->cdr); - } - if (varargs) { - DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); - /* - * Bind the rest of the arguments to the final parameter - */ - ao_lisp_frame_bind(next_frame, f, varargs, ao_lisp_cons_poly(vals)); - } else { - /* - * Mark the cons cells from the actuals as freed for immediate re-use, unless - * the actuals point into the source function (nlambdas and macros), or if the - * stack containing them was copied as a part of a continuation - */ - if (lambda->args == AO_LISP_FUNC_LAMBDA && !ao_lisp_stack_marked(ao_lisp_stack)) { - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_cons_free(cons); - } - } - DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); - DBG_STACK(); - DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); - return code->cdr; -} diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c deleted file mode 100644 index 6e4b411e..00000000 --- a/src/lisp/ao_lisp_make_const.c +++ /dev/null @@ -1,395 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include -#include -#include -#include - -static struct ao_lisp_builtin * -ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { - struct ao_lisp_builtin *b = ao_lisp_alloc(sizeof (struct ao_lisp_builtin)); - - b->type = AO_LISP_BUILTIN; - b->func = func; - b->args = args; - return b; -} - -struct builtin_func { - char *name; - int args; - enum ao_lisp_builtin_id func; -}; - -#define AO_LISP_BUILTIN_CONSTS -#include "ao_lisp_builtin.h" - -#define N_FUNC (sizeof funcs / sizeof funcs[0]) - -struct ao_lisp_frame *globals; - -static int -is_atom(int offset) -{ - struct ao_lisp_atom *a; - - for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) - if (((uint8_t *) a->name - ao_lisp_const) == offset) - return strlen(a->name); - return 0; -} - -#define AO_FEC_CRC_INIT 0xffff - -static inline uint16_t -ao_fec_crc_byte(uint8_t byte, uint16_t crc) -{ - uint8_t bit; - - for (bit = 0; bit < 8; bit++) { - if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) - crc = (crc << 1) ^ 0x8005; - else - crc = (crc << 1); - byte <<= 1; - } - return crc; -} - -uint16_t -ao_fec_crc(const uint8_t *bytes, uint8_t len) -{ - uint16_t crc = AO_FEC_CRC_INIT; - - while (len--) - crc = ao_fec_crc_byte(*bytes++, crc); - return crc; -} - -struct ao_lisp_macro_stack { - struct ao_lisp_macro_stack *next; - ao_poly p; -}; - -struct ao_lisp_macro_stack *macro_stack; - -int -ao_lisp_macro_push(ao_poly p) -{ - struct ao_lisp_macro_stack *m = macro_stack; - - while (m) { - if (m->p == p) - return 1; - m = m->next; - } - m = malloc (sizeof (struct ao_lisp_macro_stack)); - m->p = p; - m->next = macro_stack; - macro_stack = m; - return 0; -} - -void -ao_lisp_macro_pop(void) -{ - struct ao_lisp_macro_stack *m = macro_stack; - - macro_stack = m->next; - free(m); -} - -#define DBG_MACRO 0 -#if DBG_MACRO -int macro_scan_depth; - -void indent(void) -{ - int i; - for (i = 0; i < macro_scan_depth; i++) - printf(" "); -} -#define MACRO_DEBUG(a) a -#else -#define MACRO_DEBUG(a) -#endif - -ao_poly -ao_has_macro(ao_poly p); - -ao_poly -ao_macro_test_get(ao_poly atom) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - if (ref) - return *ref; - return AO_LISP_NIL; -} - -ao_poly -ao_is_macro(ao_poly p) -{ - struct ao_lisp_builtin *builtin; - struct ao_lisp_lambda *lambda; - ao_poly ret; - - MACRO_DEBUG(indent(); printf ("is macro "); ao_lisp_poly_write(p); printf("\n"); ++macro_scan_depth); - switch (ao_lisp_poly_type(p)) { - case AO_LISP_ATOM: - if (ao_lisp_macro_push(p)) - ret = AO_LISP_NIL; - else { - if (ao_is_macro(ao_macro_test_get(p))) - ret = p; - else - ret = AO_LISP_NIL; - ao_lisp_macro_pop(); - } - break; - case AO_LISP_CONS: - ret = ao_has_macro(p); - break; - case AO_LISP_BUILTIN: - builtin = ao_lisp_poly_builtin(p); - if ((builtin->args & AO_LISP_FUNC_MASK) == AO_LISP_FUNC_MACRO) - ret = p; - else - ret = 0; - break; - - case AO_LISP_LAMBDA: - lambda = ao_lisp_poly_lambda(p); - if (lambda->args == AO_LISP_FUNC_MACRO) - ret = p; - else - ret = ao_has_macro(lambda->code); - break; - default: - ret = AO_LISP_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_lisp_poly_write(ret); printf("\n")); - return ret; -} - -ao_poly -ao_has_macro(ao_poly p) -{ - struct ao_lisp_cons *cons; - struct ao_lisp_lambda *lambda; - ao_poly m; - ao_poly list; - - if (p == AO_LISP_NIL) - return AO_LISP_NIL; - - MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_write(p); printf("\n"); ++macro_scan_depth); - switch (ao_lisp_poly_type(p)) { - case AO_LISP_LAMBDA: - lambda = ao_lisp_poly_lambda(p); - p = ao_has_macro(lambda->code); - break; - case AO_LISP_CONS: - cons = ao_lisp_poly_cons(p); - if ((p = ao_is_macro(cons->car))) - break; - - list = cons->cdr; - p = AO_LISP_NIL; - while (list != AO_LISP_NIL && ao_lisp_poly_type(list) == AO_LISP_CONS) { - cons = ao_lisp_poly_cons(list); - m = ao_has_macro(cons->car); - if (m) { - p = m; - break; - } - list = cons->cdr; - } - break; - - default: - p = AO_LISP_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_lisp_poly_write(p); printf("\n")); - return p; -} - -int -ao_lisp_read_eval_abort(void) -{ - ao_poly in, out = AO_LISP_NIL; - for(;;) { - in = ao_lisp_read(); - if (in == _ao_lisp_atom_eof) - break; - out = ao_lisp_eval(in); - if (ao_lisp_exception) - return 0; - ao_lisp_poly_write(out); - putchar ('\n'); - } - return 1; -} - -static FILE *in; -static FILE *out; - -int -ao_lisp_getc(void) -{ - return getc(in); -} - -static const struct option options[] = { - { .name = "out", .has_arg = 1, .val = 'o' }, - { 0, 0, 0, 0 } -}; - -static void usage(char *program) -{ - fprintf(stderr, "usage: %s [--out=] [input]\n", program); - exit(1); -} - -int -main(int argc, char **argv) -{ - int f, o; - ao_poly val; - struct ao_lisp_atom *a; - struct ao_lisp_builtin *b; - int in_atom = 0; - char *out_name = NULL; - int c; - enum ao_lisp_builtin_id prev_func; - - in = stdin; - out = stdout; - - while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { - switch (c) { - case 'o': - out_name = optarg; - break; - default: - usage(argv[0]); - break; - } - } - - ao_lisp_frame_init(); - - /* Boolean values #f and #t */ - ao_lisp_bool_get(0); - ao_lisp_bool_get(1); - - prev_func = _builtin_last; - for (f = 0; f < (int) N_FUNC; f++) { - if (funcs[f].func != prev_func) - b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); - a = ao_lisp_atom_intern(funcs[f].name); - ao_lisp_atom_def(ao_lisp_atom_poly(a), - ao_lisp_builtin_poly(b)); - } - - /* end of file value */ - a = ao_lisp_atom_intern("eof"); - ao_lisp_atom_def(ao_lisp_atom_poly(a), - ao_lisp_atom_poly(a)); - - /* 'else' */ - a = ao_lisp_atom_intern("else"); - - if (argv[optind]){ - in = fopen(argv[optind], "r"); - if (!in) { - perror(argv[optind]); - exit(1); - } - } - if (!ao_lisp_read_eval_abort()) { - fprintf(stderr, "eval failed\n"); - exit(1); - } - - /* Reduce to referenced values */ - ao_lisp_collect(AO_LISP_COLLECT_FULL); - - for (f = 0; f < ao_lisp_frame_global->num; f++) { - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(ao_lisp_frame_global->vals); - val = ao_has_macro(vals->vals[f].val); - if (val != AO_LISP_NIL) { - printf("error: function %s contains unresolved macro: ", - ao_lisp_poly_atom(vals->vals[f].atom)->name); - ao_lisp_poly_write(val); - printf("\n"); - exit(1); - } - } - - if (out_name) { - out = fopen(out_name, "w"); - if (!out) { - perror(out_name); - exit(1); - } - } - - fprintf(out, "/* Generated file, do not edit */\n\n"); - - fprintf(out, "#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); - fprintf(out, "extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); - fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); - fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(ao_lisp_frame_global)); - fprintf(out, "#define ao_lisp_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_lisp_const, ao_lisp_top)); - - fprintf(out, "#define _ao_lisp_bool_false 0x%04x\n", ao_lisp_bool_poly(ao_lisp_false)); - fprintf(out, "#define _ao_lisp_bool_true 0x%04x\n", ao_lisp_bool_poly(ao_lisp_true)); - - for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { - char *n = a->name, c; - fprintf(out, "#define _ao_lisp_atom_"); - while ((c = *n++)) { - if (isalnum(c)) - fprintf(out, "%c", c); - else - fprintf(out, "%02x", c); - } - fprintf(out, " 0x%04x\n", ao_lisp_atom_poly(a)); - } - fprintf(out, "#ifdef AO_LISP_CONST_BITS\n"); - fprintf(out, "const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute((aligned(4))) = {"); - for (o = 0; o < ao_lisp_top; o++) { - uint8_t c; - if ((o & 0xf) == 0) - fprintf(out, "\n\t"); - else - fprintf(out, " "); - c = ao_lisp_const[o]; - if (!in_atom) - in_atom = is_atom(o); - if (in_atom) { - fprintf(out, " '%c',", c); - in_atom--; - } else { - fprintf(out, "0x%02x,", c); - } - } - fprintf(out, "\n};\n"); - fprintf(out, "#endif /* AO_LISP_CONST_BITS */\n"); - exit(0); -} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c deleted file mode 100644 index 5471b137..00000000 --- a/src/lisp/ao_lisp_mem.c +++ /dev/null @@ -1,968 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#define AO_LISP_CONST_BITS - -#include "ao_lisp.h" -#include -#include - -#ifdef AO_LISP_MAKE_CONST - -/* - * When building the constant table, it is the - * pool for allocations. - */ - -#include -uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); -#define ao_lisp_pool ao_lisp_const -#undef AO_LISP_POOL -#define AO_LISP_POOL AO_LISP_POOL_CONST - -#else - -uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); - -#endif - -#ifndef DBG_MEM_STATS -#define DBG_MEM_STATS DBG_MEM -#endif - -#if DBG_MEM -int dbg_move_depth; -int dbg_mem = DBG_MEM_START; -int dbg_validate = 0; - -struct ao_lisp_record { - struct ao_lisp_record *next; - const struct ao_lisp_type *type; - void *addr; - int size; -}; - -static struct ao_lisp_record *record_head, **record_tail; - -static void -ao_lisp_record_free(struct ao_lisp_record *record) -{ - while (record) { - struct ao_lisp_record *next = record->next; - free(record); - record = next; - } -} - -static void -ao_lisp_record_reset(void) -{ - ao_lisp_record_free(record_head); - record_head = NULL; - record_tail = &record_head; -} - -static void -ao_lisp_record(const struct ao_lisp_type *type, - void *addr, - int size) -{ - struct ao_lisp_record *r = malloc(sizeof (struct ao_lisp_record)); - - r->next = NULL; - r->type = type; - r->addr = addr; - r->size = size; - *record_tail = r; - record_tail = &r->next; -} - -static struct ao_lisp_record * -ao_lisp_record_save(void) -{ - struct ao_lisp_record *r = record_head; - - record_head = NULL; - record_tail = &record_head; - return r; -} - -static void -ao_lisp_record_compare(char *where, - struct ao_lisp_record *a, - struct ao_lisp_record *b) -{ - while (a && b) { - if (a->type != b->type || a->size != b->size) { - printf("%s record difers %d %s %d -> %d %s %d\n", - where, - MDBG_OFFSET(a->addr), - a->type->name, - a->size, - MDBG_OFFSET(b->addr), - b->type->name, - b->size); - ao_lisp_abort(); - } - a = a->next; - b = b->next; - } - if (a) { - printf("%s record differs %d %s %d -> NULL\n", - where, - MDBG_OFFSET(a->addr), - a->type->name, - a->size); - ao_lisp_abort(); - } - if (b) { - printf("%s record differs NULL -> %d %s %d\n", - where, - MDBG_OFFSET(b->addr), - b->type->name, - b->size); - ao_lisp_abort(); - } -} - -#else -#define ao_lisp_record_reset() -#endif - -uint8_t ao_lisp_exception; - -struct ao_lisp_root { - const struct ao_lisp_type *type; - void **addr; -}; - -static struct ao_lisp_cons *save_cons[2]; -static char *save_string[2]; -static struct ao_lisp_frame *save_frame[1]; -static ao_poly save_poly[3]; - -static const struct ao_lisp_root ao_lisp_root[] = { - { - .type = &ao_lisp_cons_type, - .addr = (void **) &save_cons[0], - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &save_cons[1], - }, - { - .type = &ao_lisp_string_type, - .addr = (void **) &save_string[0], - }, - { - .type = &ao_lisp_string_type, - .addr = (void **) &save_string[1], - }, - { - .type = &ao_lisp_frame_type, - .addr = (void **) &save_frame[0], - }, - { - .type = NULL, - .addr = (void **) (void *) &save_poly[0] - }, - { - .type = NULL, - .addr = (void **) (void *) &save_poly[1] - }, - { - .type = NULL, - .addr = (void **) (void *) &save_poly[2] - }, - { - .type = &ao_lisp_atom_type, - .addr = (void **) &ao_lisp_atoms - }, - { - .type = &ao_lisp_frame_type, - .addr = (void **) &ao_lisp_frame_global, - }, - { - .type = &ao_lisp_frame_type, - .addr = (void **) &ao_lisp_frame_current, - }, - { - .type = &ao_lisp_stack_type, - .addr = (void **) &ao_lisp_stack, - }, - { - .type = NULL, - .addr = (void **) (void *) &ao_lisp_v, - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &ao_lisp_read_cons, - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &ao_lisp_read_cons_tail, - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &ao_lisp_read_stack, - }, -#ifdef AO_LISP_MAKE_CONST - { - .type = &ao_lisp_bool_type, - .addr = (void **) &ao_lisp_false, - }, - { - .type = &ao_lisp_bool_type, - .addr = (void **) &ao_lisp_true, - }, -#endif -}; - -#define AO_LISP_ROOT (sizeof (ao_lisp_root) / sizeof (ao_lisp_root[0])) - -static const void ** const ao_lisp_cache[] = { - (const void **) &ao_lisp_cons_free_list, - (const void **) &ao_lisp_stack_free_list, - (const void **) &ao_lisp_frame_free_list[0], - (const void **) &ao_lisp_frame_free_list[1], - (const void **) &ao_lisp_frame_free_list[2], - (const void **) &ao_lisp_frame_free_list[3], - (const void **) &ao_lisp_frame_free_list[4], - (const void **) &ao_lisp_frame_free_list[5], -}; - -#if AO_LISP_FRAME_FREE != 6 -#error Unexpected AO_LISP_FRAME_FREE value -#endif - -#define AO_LISP_CACHE (sizeof (ao_lisp_cache) / sizeof (ao_lisp_cache[0])) - -#define AO_LISP_BUSY_SIZE ((AO_LISP_POOL + 31) / 32) - -static uint8_t ao_lisp_busy[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_cons_note[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_cons_last[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_cons_noted; - -uint16_t ao_lisp_top; - -struct ao_lisp_chunk { - uint16_t old_offset; - union { - uint16_t size; - uint16_t new_offset; - }; -}; - -#define AO_LISP_NCHUNK 64 - -static struct ao_lisp_chunk ao_lisp_chunk[AO_LISP_NCHUNK]; - -/* Offset of an address within the pool. */ -static inline uint16_t pool_offset(void *addr) { -#if DBG_MEM - if (!AO_LISP_IS_POOL(addr)) - ao_lisp_abort(); -#endif - return ((uint8_t *) addr) - ao_lisp_pool; -} - -static inline void mark(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - tag[byte] |= (1 << bit); -} - -static inline void clear(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - tag[byte] &= ~(1 << bit); -} - -static inline int busy(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - return (tag[byte] >> bit) & 1; -} - -static inline int min(int a, int b) { return a < b ? a : b; } -static inline int max(int a, int b) { return a > b ? a : b; } - -static inline int limit(int offset) { - return min(AO_LISP_POOL, max(offset, 0)); -} - -static void -note_cons(uint16_t offset) -{ - MDBG_MOVE("note cons %d\n", offset); - ao_lisp_cons_noted = 1; - mark(ao_lisp_cons_note, offset); -} - -static uint16_t chunk_low, chunk_high; -static uint16_t chunk_first, chunk_last; - -static int -find_chunk(uint16_t offset) -{ - int l, r; - /* Binary search for the location */ - l = chunk_first; - r = chunk_last - 1; - while (l <= r) { - int m = (l + r) >> 1; - if (ao_lisp_chunk[m].old_offset < offset) - l = m + 1; - else - r = m - 1; - } - return l; -} - -static void -note_chunk(uint16_t offset, uint16_t size) -{ - int l; - - if (offset < chunk_low || chunk_high <= offset) - return; - - l = find_chunk(offset); - - /* - * The correct location is always in 'l', with r = l-1 being - * the entry before the right one - */ - -#if DBG_MEM - /* Off the right side */ - if (l >= AO_LISP_NCHUNK) - ao_lisp_abort(); - - /* Off the left side */ - if (l == 0 && chunk_last && offset > ao_lisp_chunk[0].old_offset) - ao_lisp_abort(); -#endif - - /* Shuffle existing entries right */ - int end = min(AO_LISP_NCHUNK, chunk_last + 1); - - memmove(&ao_lisp_chunk[l+1], - &ao_lisp_chunk[l], - (end - (l+1)) * sizeof (struct ao_lisp_chunk)); - - /* Add new entry */ - ao_lisp_chunk[l].old_offset = offset; - ao_lisp_chunk[l].size = size; - - /* Increment the number of elements up to the size of the array */ - if (chunk_last < AO_LISP_NCHUNK) - chunk_last++; - - /* Set the top address if the array is full */ - if (chunk_last == AO_LISP_NCHUNK) - chunk_high = ao_lisp_chunk[AO_LISP_NCHUNK-1].old_offset + - ao_lisp_chunk[AO_LISP_NCHUNK-1].size; -} - -static void -reset_chunks(void) -{ - chunk_high = ao_lisp_top; - chunk_last = 0; - chunk_first = 0; -} - -/* - * Walk all referenced objects calling functions on each one - */ - -static void -walk(int (*visit_addr)(const struct ao_lisp_type *type, void **addr), - int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) -{ - int i; - - ao_lisp_record_reset(); - memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); - memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); - ao_lisp_cons_noted = 0; - for (i = 0; i < (int) AO_LISP_ROOT; i++) { - if (ao_lisp_root[i].type) { - void **a = ao_lisp_root[i].addr, *v; - if (a && (v = *a)) { - MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); - visit_addr(ao_lisp_root[i].type, a); - } - } else { - ao_poly *a = (ao_poly *) ao_lisp_root[i].addr, p; - if (a && (p = *a)) { - MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_lisp_ref(p))); - visit_poly(a, 0); - } - } - } - while (ao_lisp_cons_noted) { - memcpy(ao_lisp_cons_last, ao_lisp_cons_note, sizeof (ao_lisp_cons_note)); - memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); - ao_lisp_cons_noted = 0; - for (i = 0; i < AO_LISP_POOL; i += 4) { - if (busy(ao_lisp_cons_last, i)) { - void *v = ao_lisp_pool + i; - MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); - visit_addr(&ao_lisp_cons_type, &v); - } - } - } -} - -#if MDBG_DUMP -static void -dump_busy(void) -{ - int i; - MDBG_MOVE("busy:"); - for (i = 0; i < ao_lisp_top; i += 4) { - if ((i & 0xff) == 0) { - MDBG_MORE("\n"); - MDBG_MOVE("%s", ""); - } - else if ((i & 0x1f) == 0) - MDBG_MORE(" "); - if (busy(ao_lisp_busy, i)) - MDBG_MORE("*"); - else - MDBG_MORE("-"); - } - MDBG_MORE ("\n"); -} -#define DUMP_BUSY() dump_busy() -#else -#define DUMP_BUSY() -#endif - -static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { - [AO_LISP_CONS] = &ao_lisp_cons_type, - [AO_LISP_INT] = NULL, - [AO_LISP_STRING] = &ao_lisp_string_type, - [AO_LISP_OTHER] = (void *) 0x1, - [AO_LISP_ATOM] = &ao_lisp_atom_type, - [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, - [AO_LISP_FRAME] = &ao_lisp_frame_type, - [AO_LISP_FRAME_VALS] = &ao_lisp_frame_vals_type, - [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, - [AO_LISP_STACK] = &ao_lisp_stack_type, - [AO_LISP_BOOL] = &ao_lisp_bool_type, - [AO_LISP_BIGINT] = &ao_lisp_bigint_type, - [AO_LISP_FLOAT] = &ao_lisp_float_type, -}; - -static int -ao_lisp_mark_ref(const struct ao_lisp_type *type, void **ref) -{ - return ao_lisp_mark(type, *ref); -} - -static int -ao_lisp_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) -{ - return ao_lisp_poly_mark(*p, do_note_cons); -} - -#if DBG_MEM_STATS -int ao_lisp_collects[2]; -int ao_lisp_freed[2]; -int ao_lisp_loops[2]; -#endif - -int ao_lisp_last_top; - -int -ao_lisp_collect(uint8_t style) -{ - int i; - int top; -#if DBG_MEM_STATS - int loops = 0; -#endif -#if DBG_MEM - struct ao_lisp_record *mark_record = NULL, *move_record = NULL; - - MDBG_MOVE("collect %d\n", ao_lisp_collects[style]); -#endif - MDBG_DO(ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global))); - - /* The first time through, we're doing a full collect */ - if (ao_lisp_last_top == 0) - style = AO_LISP_COLLECT_FULL; - - /* Clear references to all caches */ - for (i = 0; i < (int) AO_LISP_CACHE; i++) - *ao_lisp_cache[i] = NULL; - if (style == AO_LISP_COLLECT_FULL) { - chunk_low = top = 0; - } else { - chunk_low = top = ao_lisp_last_top; - } - for (;;) { -#if DBG_MEM_STATS - loops++; -#endif - MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); - /* Find the sizes of the first chunk of objects to move */ - reset_chunks(); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); -#if DBG_MEM - - ao_lisp_record_free(mark_record); - mark_record = ao_lisp_record_save(); - if (mark_record && move_record) - ao_lisp_record_compare("mark", move_record, mark_record); -#endif - - DUMP_BUSY(); - - /* Find the first moving object */ - for (i = 0; i < chunk_last; i++) { - uint16_t size = ao_lisp_chunk[i].size; - -#if DBG_MEM - if (!size) - ao_lisp_abort(); -#endif - - if (ao_lisp_chunk[i].old_offset > top) - break; - - MDBG_MOVE("chunk %d %d not moving\n", - ao_lisp_chunk[i].old_offset, - ao_lisp_chunk[i].size); -#if DBG_MEM - if (ao_lisp_chunk[i].old_offset != top) - ao_lisp_abort(); -#endif - top += size; - } - - /* - * Limit amount of chunk array used in mapping moves - * to the active region - */ - chunk_first = i; - chunk_low = ao_lisp_chunk[i].old_offset; - - /* Copy all of the objects */ - for (; i < chunk_last; i++) { - uint16_t size = ao_lisp_chunk[i].size; - -#if DBG_MEM - if (!size) - ao_lisp_abort(); -#endif - - MDBG_MOVE("chunk %d %d -> %d\n", - ao_lisp_chunk[i].old_offset, - size, - top); - ao_lisp_chunk[i].new_offset = top; - - memmove(&ao_lisp_pool[top], - &ao_lisp_pool[ao_lisp_chunk[i].old_offset], - size); - - top += size; - } - - if (chunk_first < chunk_last) { - /* Relocate all references to the objects */ - walk(ao_lisp_move, ao_lisp_poly_move); - -#if DBG_MEM - ao_lisp_record_free(move_record); - move_record = ao_lisp_record_save(); - if (mark_record && move_record) - ao_lisp_record_compare("move", mark_record, move_record); -#endif - } - - /* If we ran into the end of the heap, then - * there's no need to keep walking - */ - if (chunk_last != AO_LISP_NCHUNK) - break; - - /* Next loop starts right above this loop */ - chunk_low = chunk_high; - } - -#if DBG_MEM_STATS - /* Collect stats */ - ++ao_lisp_collects[style]; - ao_lisp_freed[style] += ao_lisp_top - top; - ao_lisp_loops[style] += loops; -#endif - - ao_lisp_top = top; - if (style == AO_LISP_COLLECT_FULL) - ao_lisp_last_top = top; - - MDBG_DO(memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref)); - - return AO_LISP_POOL - ao_lisp_top; -} - -#if DBG_FREE_CONS -void -ao_lisp_cons_check(struct ao_lisp_cons *cons) -{ - ao_poly cdr; - int offset; - - chunk_low = 0; - reset_chunks(); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); - while (cons) { - if (!AO_LISP_IS_POOL(cons)) - break; - offset = pool_offset(cons); - if (busy(ao_lisp_busy, offset)) { - ao_lisp_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_lisp_cons_poly(cons), ao_lisp_cons_poly(cons)); - abort(); - } - cdr = cons->cdr; - if (!ao_lisp_is_pair(cdr)) - break; - cons = ao_lisp_poly_cons(cdr); - } -} -#endif - -/* - * Mark interfaces for objects - */ - - -/* - * Mark a block of memory with an explicit size - */ - -int -ao_lisp_mark_block(void *addr, int size) -{ - int offset; - if (!AO_LISP_IS_POOL(addr)) - return 1; - - offset = pool_offset(addr); - MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); - if (busy(ao_lisp_busy, offset)) { - MDBG_MOVE("already marked\n"); - return 1; - } - mark(ao_lisp_busy, offset); - note_chunk(offset, size); - return 0; -} - -/* - * Note a reference to memory and collect information about a few - * object sizes at a time - */ - -int -ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr) -{ - int offset; - if (!AO_LISP_IS_POOL(addr)) - return 1; - - offset = pool_offset(addr); - MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); - if (busy(ao_lisp_busy, offset)) { - MDBG_MOVE("already marked\n"); - return 1; - } - mark(ao_lisp_busy, offset); - note_chunk(offset, ao_lisp_size(type, addr)); - return 0; -} - -/* - * Mark an object and all that it refereces - */ -int -ao_lisp_mark(const struct ao_lisp_type *type, void *addr) -{ - int ret; - MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); - MDBG_MOVE_IN(); - ret = ao_lisp_mark_memory(type, addr); - if (!ret) { - MDBG_MOVE("mark recurse\n"); - type->mark(addr); - } - MDBG_MOVE_OUT(); - return ret; -} - -/* - * Mark an object, unless it is a cons cell and - * do_note_cons is set. In that case, just - * set a bit in the cons note array; those - * will be marked in a separate pass to avoid - * deep recursion in the collector - */ -int -ao_lisp_poly_mark(ao_poly p, uint8_t do_note_cons) -{ - uint8_t type; - void *addr; - - type = ao_lisp_poly_base_type(p); - - if (type == AO_LISP_INT) - return 1; - - addr = ao_lisp_ref(p); - if (!AO_LISP_IS_POOL(addr)) - return 1; - - if (type == AO_LISP_CONS && do_note_cons) { - note_cons(pool_offset(addr)); - return 1; - } else { - if (type == AO_LISP_OTHER) - type = ao_lisp_other_type(addr); - - const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_lisp_abort(); -#endif - - return ao_lisp_mark(lisp_type, addr); - } -} - -/* - * Find the current location of an object - * based on the original location. For unmoved - * objects, this is simple. For moved objects, - * go search for it - */ - -static uint16_t -move_map(uint16_t offset) -{ - int l; - - if (offset < chunk_low || chunk_high <= offset) - return offset; - - l = find_chunk(offset); - -#if DBG_MEM - if (ao_lisp_chunk[l].old_offset != offset) - ao_lisp_abort(); -#endif - return ao_lisp_chunk[l].new_offset; -} - -int -ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) -{ - void *addr = *ref; - uint16_t offset, orig_offset; - - if (!AO_LISP_IS_POOL(addr)) - return 1; - - (void) type; - - MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); - orig_offset = pool_offset(addr); - offset = move_map(orig_offset); - if (offset != orig_offset) { - MDBG_MOVE("update ref %d %d -> %d\n", - AO_LISP_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, - orig_offset, offset); - *ref = ao_lisp_pool + offset; - } - if (busy(ao_lisp_busy, offset)) { - MDBG_MOVE("already moved\n"); - return 1; - } - mark(ao_lisp_busy, offset); - MDBG_DO(ao_lisp_record(type, addr, ao_lisp_size(type, addr))); - return 0; -} - -int -ao_lisp_move(const struct ao_lisp_type *type, void **ref) -{ - int ret; - MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); - MDBG_MOVE_IN(); - ret = ao_lisp_move_memory(type, ref); - if (!ret) { - MDBG_MOVE("move recurse\n"); - type->move(*ref); - } - MDBG_MOVE_OUT(); - return ret; -} - -int -ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) -{ - uint8_t type; - ao_poly p = *ref; - int ret; - void *addr; - uint16_t offset, orig_offset; - uint8_t base_type; - - base_type = type = ao_lisp_poly_base_type(p); - - if (type == AO_LISP_INT) - return 1; - - addr = ao_lisp_ref(p); - if (!AO_LISP_IS_POOL(addr)) - return 1; - - orig_offset = pool_offset(addr); - offset = move_map(orig_offset); - - if (type == AO_LISP_CONS && do_note_cons) { - note_cons(orig_offset); - ret = 1; - } else { - if (type == AO_LISP_OTHER) - type = ao_lisp_other_type(ao_lisp_pool + offset); - - const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_lisp_abort(); -#endif - - ret = ao_lisp_move(lisp_type, &addr); - } - - /* Re-write the poly value */ - if (offset != orig_offset) { - ao_poly np = ao_lisp_poly(ao_lisp_pool + offset, base_type); - MDBG_MOVE("poly %d moved %d -> %d\n", - type, orig_offset, offset); - *ref = np; - } - return ret; -} - -#if DBG_MEM -void -ao_lisp_validate(void) -{ - chunk_low = 0; - memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); -} - -int dbg_allocs; - -#endif - -void * -ao_lisp_alloc(int size) -{ - void *addr; - - MDBG_DO(++dbg_allocs); - MDBG_DO(if (dbg_validate) ao_lisp_validate()); - size = ao_lisp_size_round(size); - if (AO_LISP_POOL - ao_lisp_top < size && - ao_lisp_collect(AO_LISP_COLLECT_INCREMENTAL) < size && - ao_lisp_collect(AO_LISP_COLLECT_FULL) < size) - { - ao_lisp_error(AO_LISP_OOM, "out of memory"); - return NULL; - } - addr = ao_lisp_pool + ao_lisp_top; - ao_lisp_top += size; - MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); - return addr; -} - -void -ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) -{ - assert(save_cons[id] == 0); - save_cons[id] = cons; -} - -struct ao_lisp_cons * -ao_lisp_cons_fetch(int id) -{ - struct ao_lisp_cons *cons = save_cons[id]; - save_cons[id] = NULL; - return cons; -} - -void -ao_lisp_poly_stash(int id, ao_poly poly) -{ - assert(save_poly[id] == AO_LISP_NIL); - save_poly[id] = poly; -} - -ao_poly -ao_lisp_poly_fetch(int id) -{ - ao_poly poly = save_poly[id]; - save_poly[id] = AO_LISP_NIL; - return poly; -} - -void -ao_lisp_string_stash(int id, char *string) -{ - assert(save_string[id] == NULL); - save_string[id] = string; -} - -char * -ao_lisp_string_fetch(int id) -{ - char *string = save_string[id]; - save_string[id] = NULL; - return string; -} - -void -ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame) -{ - assert(save_frame[id] == NULL); - save_frame[id] = frame; -} - -struct ao_lisp_frame * -ao_lisp_frame_fetch(int id) -{ - struct ao_lisp_frame *frame = save_frame[id]; - save_frame[id] = NULL; - return frame; -} diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c deleted file mode 100644 index d14f4151..00000000 --- a/src/lisp/ao_lisp_poly.c +++ /dev/null @@ -1,118 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -struct ao_lisp_funcs { - void (*write)(ao_poly); - void (*display)(ao_poly); -}; - -static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { - [AO_LISP_CONS] = { - .write = ao_lisp_cons_write, - .display = ao_lisp_cons_display, - }, - [AO_LISP_STRING] = { - .write = ao_lisp_string_write, - .display = ao_lisp_string_display, - }, - [AO_LISP_INT] = { - .write = ao_lisp_int_write, - .display = ao_lisp_int_write, - }, - [AO_LISP_ATOM] = { - .write = ao_lisp_atom_write, - .display = ao_lisp_atom_write, - }, - [AO_LISP_BUILTIN] = { - .write = ao_lisp_builtin_write, - .display = ao_lisp_builtin_write, - }, - [AO_LISP_FRAME] = { - .write = ao_lisp_frame_write, - .display = ao_lisp_frame_write, - }, - [AO_LISP_FRAME_VALS] = { - .write = NULL, - .display = NULL, - }, - [AO_LISP_LAMBDA] = { - .write = ao_lisp_lambda_write, - .display = ao_lisp_lambda_write, - }, - [AO_LISP_STACK] = { - .write = ao_lisp_stack_write, - .display = ao_lisp_stack_write, - }, - [AO_LISP_BOOL] = { - .write = ao_lisp_bool_write, - .display = ao_lisp_bool_write, - }, - [AO_LISP_BIGINT] = { - .write = ao_lisp_bigint_write, - .display = ao_lisp_bigint_write, - }, - [AO_LISP_FLOAT] = { - .write = ao_lisp_float_write, - .display = ao_lisp_float_write, - }, -}; - -static const struct ao_lisp_funcs * -funcs(ao_poly p) -{ - uint8_t type = ao_lisp_poly_type(p); - - if (type < AO_LISP_NUM_TYPE) - return &ao_lisp_funcs[type]; - return NULL; -} - -void -ao_lisp_poly_write(ao_poly p) -{ - const struct ao_lisp_funcs *f = funcs(p); - - if (f && f->write) - f->write(p); -} - -void -ao_lisp_poly_display(ao_poly p) -{ - const struct ao_lisp_funcs *f = funcs(p); - - if (f && f->display) - f->display(p); -} - -void * -ao_lisp_ref(ao_poly poly) { - if (poly == AO_LISP_NIL) - return NULL; - if (poly & AO_LISP_CONST) - return (void *) (ao_lisp_const + (poly & AO_LISP_REF_MASK) - 4); - return (void *) (ao_lisp_pool + (poly & AO_LISP_REF_MASK) - 4); -} - -ao_poly -ao_lisp_poly(const void *addr, ao_poly type) { - const uint8_t *a = addr; - if (a == NULL) - return AO_LISP_NIL; - if (AO_LISP_IS_CONST(a)) - return AO_LISP_CONST | (a - ao_lisp_const + 4) | type; - return (a - ao_lisp_pool + 4) | type; -} diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c deleted file mode 100644 index c990e9c6..00000000 --- a/src/lisp/ao_lisp_save.c +++ /dev/null @@ -1,77 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include - -ao_poly -ao_lisp_do_save(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) - return AO_LISP_NIL; - -#ifdef AO_LISP_SAVE - struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) (void *) &ao_lisp_pool[AO_LISP_POOL]; - - ao_lisp_collect(AO_LISP_COLLECT_FULL); - os->atoms = ao_lisp_atom_poly(ao_lisp_atoms); - os->globals = ao_lisp_frame_poly(ao_lisp_frame_global); - os->const_checksum = ao_lisp_const_checksum; - os->const_checksum_inv = (uint16_t) ~ao_lisp_const_checksum; - - if (ao_lisp_os_save()) - return _ao_lisp_bool_true; -#endif - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_restore(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) - return AO_LISP_NIL; - -#ifdef AO_LISP_SAVE - struct ao_lisp_os_save save; - struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) (void *) &ao_lisp_pool[AO_LISP_POOL]; - - if (!ao_lisp_os_restore_save(&save, AO_LISP_POOL)) - return ao_lisp_error(AO_LISP_INVALID, "header restore failed"); - - if (save.const_checksum != ao_lisp_const_checksum || - save.const_checksum_inv != (uint16_t) ~ao_lisp_const_checksum) - { - return ao_lisp_error(AO_LISP_INVALID, "image is corrupted or stale"); - } - - if (ao_lisp_os_restore()) { - - ao_lisp_atoms = ao_lisp_poly_atom(os->atoms); - ao_lisp_frame_global = ao_lisp_poly_frame(os->globals); - - /* Clear the eval global variabls */ - ao_lisp_eval_clear_globals(); - - /* Reset the allocator */ - ao_lisp_top = AO_LISP_POOL; - ao_lisp_collect(AO_LISP_COLLECT_FULL); - - /* Re-create the evaluator stack */ - if (!ao_lisp_eval_restart()) - return _ao_lisp_bool_false; - - return _ao_lisp_bool_true; - } -#endif - return _ao_lisp_bool_false; -} diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c deleted file mode 100644 index e7c89801..00000000 --- a/src/lisp/ao_lisp_stack.c +++ /dev/null @@ -1,280 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -const struct ao_lisp_type ao_lisp_stack_type; - -static int -stack_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_stack); -} - -static void -stack_mark(void *addr) -{ - struct ao_lisp_stack *stack = addr; - for (;;) { - ao_lisp_poly_mark(stack->sexprs, 0); - ao_lisp_poly_mark(stack->values, 0); - /* no need to mark values_tail */ - ao_lisp_poly_mark(stack->frame, 0); - ao_lisp_poly_mark(stack->list, 0); - stack = ao_lisp_poly_stack(stack->prev); - if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) - break; - } -} - -static void -stack_move(void *addr) -{ - struct ao_lisp_stack *stack = addr; - - while (stack) { - struct ao_lisp_stack *prev; - int ret; - (void) ao_lisp_poly_move(&stack->sexprs, 0); - (void) ao_lisp_poly_move(&stack->values, 0); - (void) ao_lisp_poly_move(&stack->values_tail, 0); - (void) ao_lisp_poly_move(&stack->frame, 0); - (void) ao_lisp_poly_move(&stack->list, 0); - prev = ao_lisp_poly_stack(stack->prev); - if (!prev) - break; - ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); - if (prev != ao_lisp_poly_stack(stack->prev)) - stack->prev = ao_lisp_stack_poly(prev); - if (ret) - break; - stack = prev; - } -} - -const struct ao_lisp_type ao_lisp_stack_type = { - .size = stack_size, - .mark = stack_mark, - .move = stack_move, - .name = "stack" -}; - -struct ao_lisp_stack *ao_lisp_stack_free_list; - -void -ao_lisp_stack_reset(struct ao_lisp_stack *stack) -{ - stack->state = eval_sexpr; - stack->sexprs = AO_LISP_NIL; - stack->values = AO_LISP_NIL; - stack->values_tail = AO_LISP_NIL; -} - -static struct ao_lisp_stack * -ao_lisp_stack_new(void) -{ - struct ao_lisp_stack *stack; - - if (ao_lisp_stack_free_list) { - stack = ao_lisp_stack_free_list; - ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); - } else { - stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); - if (!stack) - return 0; - stack->type = AO_LISP_STACK; - } - ao_lisp_stack_reset(stack); - return stack; -} - -int -ao_lisp_stack_push(void) -{ - struct ao_lisp_stack *stack; - - stack = ao_lisp_stack_new(); - - if (!stack) - return 0; - - stack->prev = ao_lisp_stack_poly(ao_lisp_stack); - stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - stack->list = AO_LISP_NIL; - - ao_lisp_stack = stack; - - DBGI("stack push\n"); - DBG_FRAMES(); - DBG_IN(); - return 1; -} - -void -ao_lisp_stack_pop(void) -{ - ao_poly prev; - struct ao_lisp_frame *prev_frame; - - if (!ao_lisp_stack) - return; - prev = ao_lisp_stack->prev; - if (!ao_lisp_stack_marked(ao_lisp_stack)) { - ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); - ao_lisp_stack_free_list = ao_lisp_stack; - } - - ao_lisp_stack = ao_lisp_poly_stack(prev); - prev_frame = ao_lisp_frame_current; - if (ao_lisp_stack) - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - else - ao_lisp_frame_current = NULL; - if (ao_lisp_frame_current != prev_frame) - ao_lisp_frame_free(prev_frame); - DBG_OUT(); - DBGI("stack pop\n"); - DBG_FRAMES(); -} - -void -ao_lisp_stack_clear(void) -{ - ao_lisp_stack = NULL; - ao_lisp_frame_current = NULL; - ao_lisp_v = AO_LISP_NIL; -} - -void -ao_lisp_stack_write(ao_poly poly) -{ - struct ao_lisp_stack *s = ao_lisp_poly_stack(poly); - - while (s) { - if (s->type & AO_LISP_STACK_PRINT) { - printf("[recurse...]"); - return; - } - s->type |= AO_LISP_STACK_PRINT; - printf("\t[\n"); - printf("\t\texpr: "); ao_lisp_poly_write(s->list); printf("\n"); - printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]); - ao_lisp_error_poly ("values: ", s->values, s->values_tail); - ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL); - ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); - printf("\t]\n"); - s->type &= ~AO_LISP_STACK_PRINT; - s = ao_lisp_poly_stack(s->prev); - } -} - -/* - * Copy a stack, being careful to keep everybody referenced - */ -static struct ao_lisp_stack * -ao_lisp_stack_copy(struct ao_lisp_stack *old) -{ - struct ao_lisp_stack *new = NULL; - struct ao_lisp_stack *n, *prev = NULL; - - while (old) { - ao_lisp_stack_stash(0, old); - ao_lisp_stack_stash(1, new); - ao_lisp_stack_stash(2, prev); - n = ao_lisp_stack_new(); - prev = ao_lisp_stack_fetch(2); - new = ao_lisp_stack_fetch(1); - old = ao_lisp_stack_fetch(0); - if (!n) - return NULL; - - ao_lisp_stack_mark(old); - ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame)); - *n = *old; - - if (prev) - prev->prev = ao_lisp_stack_poly(n); - else - new = n; - prev = n; - - old = ao_lisp_poly_stack(old->prev); - } - return new; -} - -/* - * Evaluate a continuation invocation - */ -ao_poly -ao_lisp_stack_eval(void) -{ - struct ao_lisp_stack *new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v)); - if (!new) - return AO_LISP_NIL; - - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - - if (!cons || !cons->cdr) - return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value"); - - new->state = eval_val; - - ao_lisp_stack = new; - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - - return ao_lisp_poly_cons(cons->cdr)->car; -} - -/* - * Call with current continuation. This calls a lambda, passing - * it a single argument which is the current continuation - */ -ao_poly -ao_lisp_do_call_cc(struct ao_lisp_cons *cons) -{ - struct ao_lisp_stack *new; - ao_poly v; - - /* Make sure the single parameter is a lambda */ - if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0)) - return AO_LISP_NIL; - - /* go get the lambda */ - ao_lisp_v = ao_lisp_arg(cons, 0); - - /* Note that the whole call chain now has - * a reference to it which may escape - */ - new = ao_lisp_stack_copy(ao_lisp_stack); - if (!new) - return AO_LISP_NIL; - - /* re-fetch cons after the allocation */ - cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr); - - /* Reset the arg list to the current stack, - * and call the lambda - */ - - cons->car = ao_lisp_stack_poly(new); - cons->cdr = AO_LISP_NIL; - v = ao_lisp_lambda_eval(); - ao_lisp_stack->sexprs = v; - ao_lisp_stack->state = eval_begin; - return AO_LISP_NIL; -} diff --git a/src/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/lisp/Makefile-lisp b/src/scheme/Makefile-scheme similarity index 54% rename from src/lisp/Makefile-lisp rename to src/scheme/Makefile-scheme index 998c7673..2427cffa 100644 --- a/src/lisp/Makefile-lisp +++ b/src/scheme/Makefile-scheme @@ -1,4 +1,4 @@ include ../lisp/Makefile-inc -ao_lisp_const.h: $(LISP_SRCS) $(LISP_HDRS) +ao_scheme_const.h: $(LISP_SRCS) $(LISP_HDRS) +cd ../lisp && make $@ diff --git a/src/lisp/README b/src/scheme/README similarity index 67% rename from src/lisp/README rename to src/scheme/README index c1e84475..98932b44 100644 --- a/src/lisp/README +++ b/src/scheme/README @@ -5,7 +5,6 @@ This follows the R7RS with the following known exceptions: * No dynamic-wind or exceptions * No environments * No ports -* No syntax-rules; we have macros instead -* define inside of lambda does not add name to lambda scope +* No syntax-rules; (have classic macros) * No record types * No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h new file mode 100644 index 00000000..4589f8a5 --- /dev/null +++ b/src/scheme/ao_scheme.h @@ -0,0 +1,928 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#ifndef _AO_SCHEME_H_ +#define _AO_SCHEME_H_ + +#define DBG_MEM 0 +#define DBG_EVAL 0 +#define DBG_READ 0 +#define DBG_FREE_CONS 0 +#define NDEBUG 1 + +#include +#include +#include +#ifndef __BYTE_ORDER +#include +#endif + +typedef uint16_t ao_poly; +typedef int16_t ao_signed_poly; + +#ifdef AO_SCHEME_SAVE + +struct ao_scheme_os_save { + ao_poly atoms; + ao_poly globals; + uint16_t const_checksum; + uint16_t const_checksum_inv; +}; + +#define AO_SCHEME_POOL_EXTRA (sizeof(struct ao_scheme_os_save)) +#define AO_SCHEME_POOL ((int) (AO_SCHEME_POOL_TOTAL - AO_SCHEME_POOL_EXTRA)) + +int +ao_scheme_os_save(void); + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset); + +int +ao_scheme_os_restore(void); + +#endif + +#ifdef AO_SCHEME_MAKE_CONST +#define AO_SCHEME_POOL_CONST 16384 +extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#define _atom(n) ao_scheme_atom_poly(ao_scheme_atom_intern(n)) +#define _bool(v) ao_scheme_bool_poly(ao_scheme_bool_get(v)) + +#define _ao_scheme_bool_true _bool(1) +#define _ao_scheme_bool_false _bool(0) + +#define _ao_scheme_atom_eof _atom("eof") +#define _ao_scheme_atom_else _atom("else") + +#define AO_SCHEME_BUILTIN_ATOMS +#include "ao_scheme_builtin.h" + +#else +#include "ao_scheme_const.h" +#ifndef AO_SCHEME_POOL +#define AO_SCHEME_POOL 3072 +#endif +extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); +#endif + +/* Primitive types */ +#define AO_SCHEME_CONS 0 +#define AO_SCHEME_INT 1 +#define AO_SCHEME_STRING 2 +#define AO_SCHEME_OTHER 3 + +#define AO_SCHEME_TYPE_MASK 0x0003 +#define AO_SCHEME_TYPE_SHIFT 2 +#define AO_SCHEME_REF_MASK 0x7ffc +#define AO_SCHEME_CONST 0x8000 + +/* These have a type value at the start of the struct */ +#define AO_SCHEME_ATOM 4 +#define AO_SCHEME_BUILTIN 5 +#define AO_SCHEME_FRAME 6 +#define AO_SCHEME_FRAME_VALS 7 +#define AO_SCHEME_LAMBDA 8 +#define AO_SCHEME_STACK 9 +#define AO_SCHEME_BOOL 10 +#define AO_SCHEME_BIGINT 11 +#define AO_SCHEME_FLOAT 12 +#define AO_SCHEME_NUM_TYPE 13 + +/* Leave two bits for types to use as they please */ +#define AO_SCHEME_OTHER_TYPE_MASK 0x3f + +#define AO_SCHEME_NIL 0 + +extern uint16_t ao_scheme_top; + +#define AO_SCHEME_OOM 0x01 +#define AO_SCHEME_DIVIDE_BY_ZERO 0x02 +#define AO_SCHEME_INVALID 0x04 +#define AO_SCHEME_UNDEFINED 0x08 +#define AO_SCHEME_REDEFINED 0x10 +#define AO_SCHEME_EOF 0x20 +#define AO_SCHEME_EXIT 0x40 + +extern uint8_t ao_scheme_exception; + +static inline int +ao_scheme_is_const(ao_poly poly) { + return poly & AO_SCHEME_CONST; +} + +#define AO_SCHEME_IS_CONST(a) (ao_scheme_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_const + AO_SCHEME_POOL_CONST) +#define AO_SCHEME_IS_POOL(a) (ao_scheme_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_pool + AO_SCHEME_POOL) +#define AO_SCHEME_IS_INT(p) (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) + +void * +ao_scheme_ref(ao_poly poly); + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type); + +struct ao_scheme_type { + int (*size)(void *addr); + void (*mark)(void *addr); + void (*move)(void *addr); + char name[]; +}; + +struct ao_scheme_cons { + ao_poly car; + ao_poly cdr; +}; + +struct ao_scheme_atom { + uint8_t type; + uint8_t pad[1]; + ao_poly next; + char name[]; +}; + +struct ao_scheme_val { + ao_poly atom; + ao_poly val; +}; + +struct ao_scheme_frame_vals { + uint8_t type; + uint8_t size; + struct ao_scheme_val vals[]; +}; + +struct ao_scheme_frame { + uint8_t type; + uint8_t num; + ao_poly prev; + ao_poly vals; +}; + +struct ao_scheme_bool { + uint8_t type; + uint8_t value; + uint16_t pad; +}; + +struct ao_scheme_bigint { + uint32_t value; +}; + +struct ao_scheme_float { + uint8_t type; + uint8_t pad1; + uint16_t pad2; + float value; +}; + +#if __BYTE_ORDER == __LITTLE_ENDIAN +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { + return AO_SCHEME_BIGINT | (i << 8); +} +static inline int32_t +ao_scheme_bigint_int(uint32_t bi) { + return (int32_t) bi >> 8; +} +#else +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { + return (uint32_t) (i & 0xffffff) | (AO_SCHEME_BIGINT << 24); +} +static inlint int32_t +ao_scheme_bigint_int(uint32_t bi) { + return (int32_t) (bi << 8) >> 8; +} +#endif + +#define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) +#define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) +#define AO_SCHEME_MIN_BIGINT (-(1 << 24)) +#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1) + +#define AO_SCHEME_NOT_INTEGER 0x7fffffff + +/* Set on type when the frame escapes the lambda */ +#define AO_SCHEME_FRAME_MARK 0x80 +#define AO_SCHEME_FRAME_PRINT 0x40 + +static inline int ao_scheme_frame_marked(struct ao_scheme_frame *f) { + return f->type & AO_SCHEME_FRAME_MARK; +} + +static inline struct ao_scheme_frame * +ao_scheme_poly_frame(ao_poly poly) { + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_poly(struct ao_scheme_frame *frame) { + return ao_scheme_poly(frame, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_frame_vals * +ao_scheme_poly_frame_vals(ao_poly poly) { + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_frame_vals_poly(struct ao_scheme_frame_vals *vals) { + return ao_scheme_poly(vals, AO_SCHEME_OTHER); +} + +enum eval_state { + eval_sexpr, /* Evaluate an sexpr */ + eval_val, /* Value computed */ + eval_formal, /* Formal computed */ + eval_exec, /* Start a lambda evaluation */ + eval_apply, /* Execute apply */ + eval_cond, /* Start next cond clause */ + eval_cond_test, /* Check cond condition */ + eval_begin, /* Start next begin entry */ + eval_while, /* Start while condition */ + eval_while_test, /* Check while condition */ + eval_macro, /* Finished with macro generation */ +}; + +struct ao_scheme_stack { + uint8_t type; /* AO_SCHEME_STACK */ + uint8_t state; /* enum eval_state */ + ao_poly prev; /* previous stack frame */ + ao_poly sexprs; /* expressions to evaluate */ + ao_poly values; /* values computed */ + ao_poly values_tail; /* end of the values list for easy appending */ + ao_poly frame; /* current lookup frame */ + ao_poly list; /* most recent function call */ +}; + +#define AO_SCHEME_STACK_MARK 0x80 /* set on type when a reference has been taken */ +#define AO_SCHEME_STACK_PRINT 0x40 /* stack is being printed */ + +static inline int ao_scheme_stack_marked(struct ao_scheme_stack *s) { + return s->type & AO_SCHEME_STACK_MARK; +} + +static inline void ao_scheme_stack_mark(struct ao_scheme_stack *s) { + s->type |= AO_SCHEME_STACK_MARK; +} + +static inline struct ao_scheme_stack * +ao_scheme_poly_stack(ao_poly p) +{ + return ao_scheme_ref(p); +} + +static inline ao_poly +ao_scheme_stack_poly(struct ao_scheme_stack *stack) +{ + return ao_scheme_poly(stack, AO_SCHEME_OTHER); +} + +extern ao_poly ao_scheme_v; + +#define AO_SCHEME_FUNC_LAMBDA 0 +#define AO_SCHEME_FUNC_NLAMBDA 1 +#define AO_SCHEME_FUNC_MACRO 2 + +#define AO_SCHEME_FUNC_FREE_ARGS 0x80 +#define AO_SCHEME_FUNC_MASK 0x7f + +#define AO_SCHEME_FUNC_F_LAMBDA (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_LAMBDA) +#define AO_SCHEME_FUNC_F_NLAMBDA (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_NLAMBDA) +#define AO_SCHEME_FUNC_F_MACRO (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_MACRO) + +struct ao_scheme_builtin { + uint8_t type; + uint8_t args; + uint16_t func; +}; + +#define AO_SCHEME_BUILTIN_ID +#include "ao_scheme_builtin.h" + +typedef ao_poly (*ao_scheme_func_t)(struct ao_scheme_cons *cons); + +extern const ao_scheme_func_t ao_scheme_builtins[]; + +static inline ao_scheme_func_t +ao_scheme_func(struct ao_scheme_builtin *b) +{ + return ao_scheme_builtins[b->func]; +} + +struct ao_scheme_lambda { + uint8_t type; + uint8_t args; + ao_poly code; + ao_poly frame; +}; + +static inline struct ao_scheme_lambda * +ao_scheme_poly_lambda(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_lambda_poly(struct ao_scheme_lambda *lambda) +{ + return ao_scheme_poly(lambda, AO_SCHEME_OTHER); +} + +static inline void * +ao_scheme_poly_other(ao_poly poly) { + return ao_scheme_ref(poly); +} + +static inline uint8_t +ao_scheme_other_type(void *other) { +#if DBG_MEM + if ((*((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK) >= AO_SCHEME_NUM_TYPE) + ao_scheme_abort(); +#endif + return *((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK; +} + +static inline ao_poly +ao_scheme_other_poly(const void *other) +{ + return ao_scheme_poly(other, AO_SCHEME_OTHER); +} + +static inline int +ao_scheme_size_round(int size) +{ + return (size + 3) & ~3; +} + +static inline int +ao_scheme_size(const struct ao_scheme_type *type, void *addr) +{ + return ao_scheme_size_round(type->size(addr)); +} + +#define AO_SCHEME_OTHER_POLY(other) ((ao_poly)(other) + AO_SCHEME_OTHER) + +static inline int ao_scheme_poly_base_type(ao_poly poly) { + return poly & AO_SCHEME_TYPE_MASK; +} + +static inline int ao_scheme_poly_type(ao_poly poly) { + int type = poly & AO_SCHEME_TYPE_MASK; + if (type == AO_SCHEME_OTHER) + return ao_scheme_other_type(ao_scheme_poly_other(poly)); + return type; +} + +static inline int +ao_scheme_is_cons(ao_poly poly) { + return (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline int +ao_scheme_is_pair(ao_poly poly) { + return poly != AO_SCHEME_NIL && (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); +} + +static inline struct ao_scheme_cons * +ao_scheme_poly_cons(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_cons_poly(struct ao_scheme_cons *cons) +{ + return ao_scheme_poly(cons, AO_SCHEME_CONS); +} + +static inline int32_t +ao_scheme_poly_int(ao_poly poly) +{ + return (int32_t) ((ao_signed_poly) poly >> AO_SCHEME_TYPE_SHIFT); +} + +static inline ao_poly +ao_scheme_int_poly(int32_t i) +{ + return ((ao_poly) i << 2) | AO_SCHEME_INT; +} + +static inline struct ao_scheme_bigint * +ao_scheme_poly_bigint(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) +{ + return ao_scheme_poly(bi, AO_SCHEME_OTHER); +} + +static inline char * +ao_scheme_poly_string(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_string_poly(char *s) +{ + return ao_scheme_poly(s, AO_SCHEME_STRING); +} + +static inline struct ao_scheme_atom * +ao_scheme_poly_atom(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_atom_poly(struct ao_scheme_atom *a) +{ + return ao_scheme_poly(a, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_builtin * +ao_scheme_poly_builtin(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_builtin_poly(struct ao_scheme_builtin *b) +{ + return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline ao_poly +ao_scheme_bool_poly(struct ao_scheme_bool *b) +{ + return ao_scheme_poly(b, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_bool * +ao_scheme_poly_bool(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_float_poly(struct ao_scheme_float *f) +{ + return ao_scheme_poly(f, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_float * +ao_scheme_poly_float(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* memory functions */ + +extern int ao_scheme_collects[2]; +extern int ao_scheme_freed[2]; +extern int ao_scheme_loops[2]; + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr); + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); + +void * +ao_scheme_move_map(void *addr); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); + +void * +ao_scheme_alloc(int size); + +#define AO_SCHEME_COLLECT_FULL 1 +#define AO_SCHEME_COLLECT_INCREMENTAL 0 + +int +ao_scheme_collect(uint8_t style); + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons); +#endif + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id); + +void +ao_scheme_poly_stash(int id, ao_poly poly); + +ao_poly +ao_scheme_poly_fetch(int id); + +void +ao_scheme_string_stash(int id, char *string); + +char * +ao_scheme_string_fetch(int id); + +static inline void +ao_scheme_stack_stash(int id, struct ao_scheme_stack *stack) { + ao_scheme_poly_stash(id, ao_scheme_stack_poly(stack)); +} + +static inline struct ao_scheme_stack * +ao_scheme_stack_fetch(int id) { + return ao_scheme_poly_stack(ao_scheme_poly_fetch(id)); +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame); + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id); + +/* bool */ + +extern const struct ao_scheme_type ao_scheme_bool_type; + +void +ao_scheme_bool_write(ao_poly v); + +#ifdef AO_SCHEME_MAKE_CONST +struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; + +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value); +#endif + +/* cons */ +extern const struct ao_scheme_type ao_scheme_cons_type; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr); + +/* Return a cons or NULL for a proper list, else error */ +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr); + +extern struct ao_scheme_cons *ao_scheme_cons_free_list; + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons); + +void +ao_scheme_cons_write(ao_poly); + +void +ao_scheme_cons_display(ao_poly); + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons); + +/* string */ +extern const struct ao_scheme_type ao_scheme_string_type; + +char * +ao_scheme_string_copy(char *a); + +char * +ao_scheme_string_cat(char *a, char *b); + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme_string_unpack(char *a); + +void +ao_scheme_string_write(ao_poly s); + +void +ao_scheme_string_display(ao_poly s); + +/* atom */ +extern const struct ao_scheme_type ao_scheme_atom_type; + +extern struct ao_scheme_atom *ao_scheme_atoms; +extern struct ao_scheme_frame *ao_scheme_frame_global; +extern struct ao_scheme_frame *ao_scheme_frame_current; + +void +ao_scheme_atom_write(ao_poly a); + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name); + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref); + +ao_poly +ao_scheme_atom_get(ao_poly atom); + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val); + +/* int */ +void +ao_scheme_int_write(ao_poly i); + +int32_t +ao_scheme_poly_integer(ao_poly p); + +ao_poly +ao_scheme_integer_poly(int32_t i); + +static inline int +ao_scheme_integer_typep(uint8_t t) +{ + return (t == AO_SCHEME_INT) || (t == AO_SCHEME_BIGINT); +} + +void +ao_scheme_bigint_write(ao_poly i); + +extern const struct ao_scheme_type ao_scheme_bigint_type; +/* prim */ +void +ao_scheme_poly_write(ao_poly p); + +void +ao_scheme_poly_display(ao_poly p); + +int +ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); + +/* returns 1 if the object has already been moved */ +int +ao_scheme_poly_move(ao_poly *p, uint8_t note_cons); + +/* eval */ + +void +ao_scheme_eval_clear_globals(void); + +int +ao_scheme_eval_restart(void); + +ao_poly +ao_scheme_eval(ao_poly p); + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *cons); + +/* float */ +extern const struct ao_scheme_type ao_scheme_float_type; + +void +ao_scheme_float_write(ao_poly p); + +ao_poly +ao_scheme_float_get(float value); + +static inline uint8_t +ao_scheme_number_typep(uint8_t t) +{ + return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* builtin */ +void +ao_scheme_builtin_write(ao_poly b); + +extern const struct ao_scheme_type ao_scheme_builtin_type; + +/* Check argument count */ +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max); + +/* Check argument type */ +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok); + +/* Fetch an arg (nil if off the end) */ +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc); + +char * +ao_scheme_args_name(uint8_t args); + +/* read */ +extern struct ao_scheme_cons *ao_scheme_read_cons; +extern struct ao_scheme_cons *ao_scheme_read_cons_tail; +extern struct ao_scheme_cons *ao_scheme_read_stack; + +ao_poly +ao_scheme_read(void); + +/* rep */ +ao_poly +ao_scheme_read_eval_print(void); + +/* frame */ +extern const struct ao_scheme_type ao_scheme_frame_type; +extern const struct ao_scheme_type ao_scheme_frame_vals_type; + +#define AO_SCHEME_FRAME_FREE 6 + +extern struct ao_scheme_frame *ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame); + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom); + +struct ao_scheme_frame * +ao_scheme_frame_new(int num); + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame); + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val); + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val); + +void +ao_scheme_frame_write(ao_poly p); + +void +ao_scheme_frame_init(void); + +/* lambda */ +extern const struct ao_scheme_type ao_scheme_lambda_type; + +extern const char * const ao_scheme_state_names[]; + +struct ao_scheme_lambda * +ao_scheme_lambda_new(ao_poly cons); + +void +ao_scheme_lambda_write(ao_poly lambda); + +ao_poly +ao_scheme_lambda_eval(void); + +/* stack */ + +extern const struct ao_scheme_type ao_scheme_stack_type; +extern struct ao_scheme_stack *ao_scheme_stack; +extern struct ao_scheme_stack *ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack); + +int +ao_scheme_stack_push(void); + +void +ao_scheme_stack_pop(void); + +void +ao_scheme_stack_clear(void); + +void +ao_scheme_stack_write(ao_poly stack); + +ao_poly +ao_scheme_stack_eval(void); + +/* error */ + +void +ao_scheme_vprintf(char *format, va_list args); + +void +ao_scheme_printf(char *format, ...); + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last); + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame); + +ao_poly +ao_scheme_error(int error, char *format, ...); + +/* builtins */ + +#define AO_SCHEME_BUILTIN_DECLS +#include "ao_scheme_builtin.h" + +/* debugging macros */ + +#if DBG_EVAL || DBG_READ || DBG_MEM +#define DBG_CODE 1 +int ao_scheme_stack_depth; +#define DBG_DO(a) a +#define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_scheme_stack_depth; _s++) printf(" "); } while(0) +#define DBG_IN() (++ao_scheme_stack_depth) +#define DBG_OUT() (--ao_scheme_stack_depth) +#define DBG_RESET() (ao_scheme_stack_depth = 0) +#define DBG(...) ao_scheme_printf(__VA_ARGS__) +#define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#define DBG_CONS(a) ao_scheme_cons_write(ao_scheme_cons_poly(a)) +#define DBG_POLY(a) ao_scheme_poly_write(a) +#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) +#define DBG_STACK() ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)) +static inline void +ao_scheme_frames_dump(void) +{ + struct ao_scheme_stack *s; + DBGI(".. current frame: "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + for (s = ao_scheme_stack; s; s = ao_scheme_poly_stack(s->prev)) { + DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); + } +} +#define DBG_FRAMES() ao_scheme_frames_dump() +#else +#define DBG_DO(a) +#define DBG_INDENT() +#define DBG_IN() +#define DBG_OUT() +#define DBG(...) +#define DBGI(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#define DBG_RESET() +#define DBG_STACK() +#define DBG_FRAMES() +#endif + +#if DBG_READ +#define RDBGI(...) DBGI(__VA_ARGS__) +#define RDBG_IN() DBG_IN() +#define RDBG_OUT() DBG_OUT() +#else +#define RDBGI(...) +#define RDBG_IN() +#define RDBG_OUT() +#endif + +#define DBG_MEM_START 1 + +#if DBG_MEM + +#include +extern int dbg_move_depth; +#define MDBG_DUMP 1 +#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_scheme_pool) : -1) + +extern int dbg_mem; + +#define MDBG_DO(a) DBG_DO(a) +#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) +#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) +#define MDBG_MOVE_IN() (dbg_move_depth++) +#define MDBG_MOVE_OUT() (assert(--dbg_move_depth >= 0)) + +#else + +#define MDBG_DO(a) +#define MDBG_MOVE(...) +#define MDBG_MORE(...) +#define MDBG_MOVE_IN() +#define MDBG_MOVE_OUT() + +#endif + +#endif /* _AO_SCHEME_H_ */ diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c new file mode 100644 index 00000000..cb32b7fe --- /dev/null +++ b/src/scheme/ao_scheme_atom.c @@ -0,0 +1,167 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_scheme.h" + +static int name_size(char *name) +{ + return sizeof(struct ao_scheme_atom) + strlen(name) + 1; +} + +static int atom_size(void *addr) +{ + struct ao_scheme_atom *atom = addr; + if (!atom) + return 0; + return name_size(atom->name); +} + +static void atom_mark(void *addr) +{ + struct ao_scheme_atom *atom = addr; + + for (;;) { + atom = ao_scheme_poly_atom(atom->next); + if (!atom) + break; + if (ao_scheme_mark_memory(&ao_scheme_atom_type, atom)) + break; + } +} + +static void atom_move(void *addr) +{ + struct ao_scheme_atom *atom = addr; + int ret; + + for (;;) { + struct ao_scheme_atom *next = ao_scheme_poly_atom(atom->next); + + if (!next) + break; + ret = ao_scheme_move_memory(&ao_scheme_atom_type, (void **) &next); + if (next != ao_scheme_poly_atom(atom->next)) + atom->next = ao_scheme_atom_poly(next); + if (ret) + break; + atom = next; + } +} + +const struct ao_scheme_type ao_scheme_atom_type = { + .mark = atom_mark, + .size = atom_size, + .move = atom_move, + .name = "atom" +}; + +struct ao_scheme_atom *ao_scheme_atoms; + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name) +{ + struct ao_scheme_atom *atom; + + for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { + if (!strcmp(atom->name, name)) + return atom; + } +#ifdef ao_builtin_atoms + for (atom = ao_scheme_poly_atom(ao_builtin_atoms); atom; atom = ao_scheme_poly_atom(atom->next)) { + if (!strcmp(atom->name, name)) + return atom; + } +#endif + ao_scheme_string_stash(0, name); + atom = ao_scheme_alloc(name_size(name)); + name = ao_scheme_string_fetch(0); + if (atom) { + atom->type = AO_SCHEME_ATOM; + atom->next = ao_scheme_atom_poly(ao_scheme_atoms); + ao_scheme_atoms = atom; + strcpy(atom->name, name); + } + return atom; +} + +ao_poly * +ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref) +{ + ao_poly *ref; + struct ao_scheme_frame *frame; + + for (frame = ao_scheme_frame_current; frame; frame = ao_scheme_poly_frame(frame->prev)) { + ref = ao_scheme_frame_ref(frame, atom); + if (ref) { + if (frame_ref) + *frame_ref = frame; + return ref; + } + } + ref = ao_scheme_frame_ref(ao_scheme_frame_global, atom); + if (ref) + if (frame_ref) + *frame_ref = ao_scheme_frame_global; + return ref; +} + +ao_poly +ao_scheme_atom_get(ao_poly atom) +{ + ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + +#ifdef ao_builtin_frame + if (!ref) + ref = ao_scheme_frame_ref(ao_scheme_poly_frame(ao_builtin_frame), atom); +#endif + if (ref) + return *ref; + return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); +} + +ao_poly +ao_scheme_atom_set(ao_poly atom, ao_poly val) +{ + ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + + if (!ref) + return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); + *ref = val; + return val; +} + +ao_poly +ao_scheme_atom_def(ao_poly atom, ao_poly val) +{ + struct ao_scheme_frame *frame; + ao_poly *ref = ao_scheme_atom_ref(atom, &frame); + + if (ref) { + if (frame == ao_scheme_frame_current) + return ao_scheme_error(AO_SCHEME_REDEFINED, "attempt to redefine atom %s", ao_scheme_poly_atom(atom)->name); + *ref = val; + return val; + } + return ao_scheme_frame_add(ao_scheme_frame_current ? ao_scheme_frame_current : ao_scheme_frame_global, atom, val); +} + +void +ao_scheme_atom_write(ao_poly a) +{ + struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); + printf("%s", atom->name); +} diff --git a/src/lisp/ao_lisp_bool.c b/src/scheme/ao_scheme_bool.c similarity index 65% rename from src/lisp/ao_lisp_bool.c rename to src/scheme/ao_scheme_bool.c index 391a7f78..c1e880ca 100644 --- a/src/lisp/ao_lisp_bool.c +++ b/src/scheme/ao_scheme_bool.c @@ -12,7 +12,7 @@ * General Public License for more details. */ -#include "ao_lisp.h" +#include "ao_scheme.h" static void bool_mark(void *addr) { @@ -22,7 +22,7 @@ static void bool_mark(void *addr) static int bool_size(void *addr) { (void) addr; - return sizeof (struct ao_lisp_bool); + return sizeof (struct ao_scheme_bool); } static void bool_move(void *addr) @@ -30,7 +30,7 @@ static void bool_move(void *addr) (void) addr; } -const struct ao_lisp_type ao_lisp_bool_type = { +const struct ao_scheme_type ao_scheme_bool_type = { .mark = bool_mark, .size = bool_size, .move = bool_move, @@ -38,9 +38,9 @@ const struct ao_lisp_type ao_lisp_bool_type = { }; void -ao_lisp_bool_write(ao_poly v) +ao_scheme_bool_write(ao_poly v) { - struct ao_lisp_bool *b = ao_lisp_poly_bool(v); + struct ao_scheme_bool *b = ao_scheme_poly_bool(v); if (b->value) printf("#t"); @@ -48,23 +48,23 @@ ao_lisp_bool_write(ao_poly v) printf("#f"); } -#ifdef AO_LISP_MAKE_CONST +#ifdef AO_SCHEME_MAKE_CONST -struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; +struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; -struct ao_lisp_bool * -ao_lisp_bool_get(uint8_t value) +struct ao_scheme_bool * +ao_scheme_bool_get(uint8_t value) { - struct ao_lisp_bool **b; + struct ao_scheme_bool **b; if (value) - b = &ao_lisp_true; + b = &ao_scheme_true; else - b = &ao_lisp_false; + b = &ao_scheme_false; if (!*b) { - *b = ao_lisp_alloc(sizeof (struct ao_lisp_bool)); - (*b)->type = AO_LISP_BOOL; + *b = ao_scheme_alloc(sizeof (struct ao_scheme_bool)); + (*b)->type = AO_SCHEME_BOOL; (*b)->value = value; } return *b; diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c new file mode 100644 index 00000000..49f218f6 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.c @@ -0,0 +1,868 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include +#include + +static int +builtin_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_builtin); +} + +static void +builtin_mark(void *addr) +{ + (void) addr; +} + +static void +builtin_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_builtin_type = { + .size = builtin_size, + .mark = builtin_mark, + .move = builtin_move +}; + +#ifdef AO_SCHEME_MAKE_CONST + +#define AO_SCHEME_BUILTIN_CASENAME +#include "ao_scheme_builtin.h" + +char *ao_scheme_args_name(uint8_t args) { + args &= AO_SCHEME_FUNC_MASK; + switch (args) { + case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name; + case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name; + case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name; + default: return "???"; + } +} +#else + +#define AO_SCHEME_BUILTIN_ARRAYNAME +#include "ao_scheme_builtin.h" + +static char * +ao_scheme_builtin_name(enum ao_scheme_builtin_id b) { + if (b < _builtin_last) + return ao_scheme_poly_atom(builtin_names[b])->name; + return "???"; +} + +static const ao_poly ao_scheme_args_atoms[] = { + [AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda, + [AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda, + [AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro, +}; + +char * +ao_scheme_args_name(uint8_t args) +{ + args &= AO_SCHEME_FUNC_MASK; + if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0]) + return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name; + return "(unknown)"; +} +#endif + +void +ao_scheme_builtin_write(ao_poly b) +{ + struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); + printf("%s", ao_scheme_builtin_name(builtin->func)); +} + +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max) +{ + int argc = 0; + + while (cons && argc <= max) { + argc++; + cons = ao_scheme_cons_cdr(cons); + } + if (argc < min || argc > max) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc) +{ + if (!cons) + return AO_SCHEME_NIL; + while (argc--) { + if (!cons) + return AO_SCHEME_NIL; + cons = ao_scheme_cons_cdr(cons); + } + return cons->car; +} + +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok) +{ + ao_poly car = ao_scheme_arg(cons, argc); + + if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: arg %d invalid type %v", ao_scheme_poly_atom(name)->name, argc, car); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_car(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(cons->car)->car; +} + +ao_poly +ao_scheme_do_cdr(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(cons->car)->cdr; +} + +ao_poly +ao_scheme_do_cons(struct ao_scheme_cons *cons) +{ + ao_poly car, cdr; + if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2)) + return AO_SCHEME_NIL; + car = ao_scheme_arg(cons, 0); + cdr = ao_scheme_arg(cons, 1); + return ao_scheme__cons(car, cdr); +} + +ao_poly +ao_scheme_do_last(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *list; + if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0)); + list; + list = ao_scheme_cons_cdr(list)) + { + if (!list->cdr) + return list->car; + } + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_length(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_quote(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1)) + return AO_SCHEME_NIL; + return ao_scheme_arg(cons, 0); +} + +ao_poly +ao_scheme_do_set(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_def(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_setq(struct ao_scheme_cons *cons) +{ + ao_poly name; + if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2)) + return AO_SCHEME_NIL; + name = cons->car; + if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name); + if (!ao_scheme_atom_ref(name, NULL)) + return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name); + return ao_scheme__cons(_ao_scheme_atom_set, + ao_scheme__cons(ao_scheme__cons(_ao_scheme_atom_quote, + ao_scheme__cons(name, AO_SCHEME_NIL)), + cons->cdr)); +} + +ao_poly +ao_scheme_do_cond(struct ao_scheme_cons *cons) +{ + ao_scheme_set_cond(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_begin(struct ao_scheme_cons *cons) +{ + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_while(struct ao_scheme_cons *cons) +{ + ao_scheme_stack->state = eval_while; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_write(struct ao_scheme_cons *cons) +{ + ao_poly val = AO_SCHEME_NIL; + while (cons) { + val = cons->car; + ao_scheme_poly_write(val); + cons = ao_scheme_cons_cdr(cons); + if (cons) + printf(" "); + } + printf("\n"); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_display(struct ao_scheme_cons *cons) +{ + ao_poly val = AO_SCHEME_NIL; + while (cons) { + val = cons->car; + ao_scheme_poly_display(val); + cons = ao_scheme_cons_cdr(cons); + } + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) +{ + struct ao_scheme_cons *cons = cons; + ao_poly ret = AO_SCHEME_NIL; + + for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) { + ao_poly car = cons->car; + uint8_t rt = ao_scheme_poly_type(ret); + uint8_t ct = ao_scheme_poly_type(car); + + if (cons == orig_cons) { + ret = car; + if (cons->cdr == AO_SCHEME_NIL) { + switch (op) { + case builtin_minus: + if (ao_scheme_integer_typep(ct)) + ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); + else if (ct == AO_SCHEME_FLOAT) + ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); + break; + case builtin_divide: + if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) + ; + else if (ao_scheme_number_typep(ct)) { + float v = ao_scheme_poly_number(ret); + ret = ao_scheme_float_get(1/v); + } + break; + default: + break; + } + } + } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { + int32_t r = ao_scheme_poly_integer(ret); + int32_t c = ao_scheme_poly_integer(car); + int64_t t; + + switch(op) { + case builtin_plus: + r += c; + check_overflow: + if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) + goto inexact; + break; + case builtin_minus: + r -= c; + goto check_overflow; + break; + case builtin_times: + t = (int64_t) r * (int64_t) c; + if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) + goto inexact; + r = (int32_t) t; + break; + case builtin_divide: + if (c != 0 && (r % c) == 0) + r /= c; + else + goto inexact; + break; + case builtin_quotient: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero"); + if (r % c != 0 && (c < 0) != (r < 0)) + r = r / c - 1; + else + r = r / c; + break; + case builtin_remainder: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero"); + r %= c; + break; + case builtin_modulo: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero"); + r %= c; + if ((r < 0) != (c < 0)) + r += c; + break; + default: + break; + } + ret = ao_scheme_integer_poly(r); + } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { + float r, c; + inexact: + r = ao_scheme_poly_number(ret); + c = ao_scheme_poly_number(car); + switch(op) { + case builtin_plus: + r += c; + break; + case builtin_minus: + r -= c; + break; + case builtin_times: + r *= c; + break; + case builtin_divide: + r /= c; + break; + case builtin_quotient: + case builtin_remainder: + case builtin_modulo: + return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); + default: + break; + } + ret = ao_scheme_float_get(r); + } + + else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) + ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), + ao_scheme_poly_string(car))); + else + return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); + } + return ret; +} + +ao_poly +ao_scheme_do_plus(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_plus); +} + +ao_poly +ao_scheme_do_minus(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_minus); +} + +ao_poly +ao_scheme_do_times(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_times); +} + +ao_poly +ao_scheme_do_divide(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_divide); +} + +ao_poly +ao_scheme_do_quotient(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_quotient); +} + +ao_poly +ao_scheme_do_modulo(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_modulo); +} + +ao_poly +ao_scheme_do_remainder(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_remainder); +} + +ao_poly +ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) +{ + ao_poly left; + + if (!cons) + return _ao_scheme_bool_true; + + left = cons->car; + for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { + ao_poly right = cons->car; + + if (op == builtin_equal) { + if (left != right) + return _ao_scheme_bool_false; + } else { + uint8_t lt = ao_scheme_poly_type(left); + uint8_t rt = ao_scheme_poly_type(right); + if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) { + int32_t l = ao_scheme_poly_integer(left); + int32_t r = ao_scheme_poly_integer(right); + + switch (op) { + case builtin_less: + if (!(l < r)) + return _ao_scheme_bool_false; + break; + case builtin_greater: + if (!(l > r)) + return _ao_scheme_bool_false; + break; + case builtin_less_equal: + if (!(l <= r)) + return _ao_scheme_bool_false; + break; + case builtin_greater_equal: + if (!(l >= r)) + return _ao_scheme_bool_false; + break; + default: + break; + } + } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { + int c = strcmp(ao_scheme_poly_string(left), + ao_scheme_poly_string(right)); + switch (op) { + case builtin_less: + if (!(c < 0)) + return _ao_scheme_bool_false; + break; + case builtin_greater: + if (!(c > 0)) + return _ao_scheme_bool_false; + break; + case builtin_less_equal: + if (!(c <= 0)) + return _ao_scheme_bool_false; + break; + case builtin_greater_equal: + if (!(c >= 0)) + return _ao_scheme_bool_false; + break; + default: + break; + } + } + } + left = right; + } + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_equal); +} + +ao_poly +ao_scheme_do_less(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_less); +} + +ao_poly +ao_scheme_do_greater(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_greater); +} + +ao_poly +ao_scheme_do_less_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_less_equal); +} + +ao_poly +ao_scheme_do_greater_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_greater_equal); +} + +ao_poly +ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_flush_output(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0)) + return AO_SCHEME_NIL; + ao_scheme_os_flush(); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_led(struct ao_scheme_cons *cons) +{ + ao_poly led; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + led = ao_scheme_arg(cons, 0); + ao_scheme_os_led(ao_scheme_poly_int(led)); + return led; +} + +ao_poly +ao_scheme_do_delay(struct ao_scheme_cons *cons) +{ + ao_poly delay; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + delay = ao_scheme_arg(cons, 0); + ao_scheme_os_delay(ao_scheme_poly_int(delay)); + return delay; +} + +ao_poly +ao_scheme_do_eval(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1)) + return AO_SCHEME_NIL; + ao_scheme_stack->state = eval_sexpr; + return cons->car; +} + +ao_poly +ao_scheme_do_apply(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX)) + return AO_SCHEME_NIL; + ao_scheme_stack->state = eval_apply; + return ao_scheme_cons_poly(cons); +} + +ao_poly +ao_scheme_do_read(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0)) + return AO_SCHEME_NIL; + return ao_scheme_read(); +} + +ao_poly +ao_scheme_do_collect(struct ao_scheme_cons *cons) +{ + int free; + (void) cons; + free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + return ao_scheme_int_poly(free); +} + +ao_poly +ao_scheme_do_nullp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL) + return _ao_scheme_bool_true; + else + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_not(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false) + return _ao_scheme_bool_true; + else + return _ao_scheme_bool_false; +} + +static ao_poly +ao_scheme_do_typep(int type, struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_pairp(struct ao_scheme_cons *cons) +{ + ao_poly v; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + v = ao_scheme_arg(cons, 0); + if (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_integerp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +ao_poly +ao_scheme_do_numberp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + case AO_SCHEME_FLOAT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +ao_poly +ao_scheme_do_stringp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_STRING, cons); +} + +ao_poly +ao_scheme_do_symbolp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_ATOM, cons); +} + +ao_poly +ao_scheme_do_booleanp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_BOOL, cons); +} + +ao_poly +ao_scheme_do_procedurep(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_BUILTIN: + case AO_SCHEME_LAMBDA: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +/* This one is special -- a list is either nil or + * a 'proper' list with only cons cells + */ +ao_poly +ao_scheme_do_listp(struct ao_scheme_cons *cons) +{ + ao_poly v; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + v = ao_scheme_arg(cons, 0); + for (;;) { + if (v == AO_SCHEME_NIL) + return _ao_scheme_bool_true; + if (ao_scheme_poly_type(v) != AO_SCHEME_CONS) + return _ao_scheme_bool_false; + v = ao_scheme_poly_cons(v)->cdr; + } +} + +ao_poly +ao_scheme_do_set_car(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name)); +} + +ao_poly +ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_read_char(struct ao_scheme_cons *cons) +{ + int c; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + c = getchar(); + return ao_scheme_int_poly(c); +} + +ao_poly +ao_scheme_do_write_char(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0))); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_exit(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + ao_scheme_exception |= AO_SCHEME_EXIT; + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) +{ + int jiffy; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + jiffy = ao_scheme_os_jiffy(); + return (ao_scheme_int_poly(jiffy)); +} + +ao_poly +ao_scheme_do_current_second(struct ao_scheme_cons *cons) +{ + int second; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND; + return (ao_scheme_int_poly(second)); +} + +ao_poly +ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); +} + +#define AO_SCHEME_BUILTIN_FUNCS +#include "ao_scheme_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/scheme/ao_scheme_builtin.txt similarity index 100% rename from src/lisp/ao_lisp_builtin.txt rename to src/scheme/ao_scheme_builtin.txt diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c new file mode 100644 index 00000000..03dad956 --- /dev/null +++ b/src/scheme/ao_scheme_cons.c @@ -0,0 +1,201 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static void cons_mark(void *addr) +{ + struct ao_scheme_cons *cons = addr; + + for (;;) { + ao_poly cdr = cons->cdr; + + ao_scheme_poly_mark(cons->car, 1); + if (!cdr) + break; + if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + ao_scheme_poly_mark(cdr, 1); + break; + } + cons = ao_scheme_poly_cons(cdr); + if (ao_scheme_mark_memory(&ao_scheme_cons_type, cons)) + break; + } +} + +static int cons_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_cons); +} + +static void cons_move(void *addr) +{ + struct ao_scheme_cons *cons = addr; + + if (!cons) + return; + + for (;;) { + ao_poly cdr; + struct ao_scheme_cons *c; + int ret; + + MDBG_MOVE("cons_move start %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); + (void) ao_scheme_poly_move(&cons->car, 1); + cdr = cons->cdr; + if (!cdr) + break; + if (ao_scheme_poly_base_type(cdr) != AO_SCHEME_CONS) { + (void) ao_scheme_poly_move(&cons->cdr, 0); + break; + } + c = ao_scheme_poly_cons(cdr); + ret = ao_scheme_move_memory(&ao_scheme_cons_type, (void **) &c); + if (c != ao_scheme_poly_cons(cons->cdr)) + cons->cdr = ao_scheme_cons_poly(c); + MDBG_MOVE("cons_move end %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); + if (ret) + break; + cons = c; + } +} + +const struct ao_scheme_type ao_scheme_cons_type = { + .mark = cons_mark, + .size = cons_size, + .move = cons_move, + .name = "cons", +}; + +struct ao_scheme_cons *ao_scheme_cons_free_list; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr) +{ + struct ao_scheme_cons *cons; + + if (ao_scheme_cons_free_list) { + cons = ao_scheme_cons_free_list; + ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr); + } else { + ao_scheme_poly_stash(0, car); + ao_scheme_poly_stash(1, cdr); + cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); + cdr = ao_scheme_poly_fetch(1); + car = ao_scheme_poly_fetch(0); + if (!cons) + return NULL; + } + cons->car = car; + cons->cdr = cdr; + return cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons) +{ + ao_poly cdr = cons->cdr; + if (cdr == AO_SCHEME_NIL) + return NULL; + if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + (void) ao_scheme_error(AO_SCHEME_INVALID, "improper list"); + return NULL; + } + return ao_scheme_poly_cons(cdr); +} + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr) +{ + return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); +} + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons) +{ +#if DBG_FREE_CONS + ao_scheme_cons_check(cons); +#endif + while (cons) { + ao_poly cdr = cons->cdr; + cons->cdr = ao_scheme_cons_poly(ao_scheme_cons_free_list); + ao_scheme_cons_free_list = cons; + cons = ao_scheme_poly_cons(cdr); + } +} + +void +ao_scheme_cons_write(ao_poly c) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + ao_poly cdr; + int first = 1; + + printf("("); + while (cons) { + if (!first) + printf(" "); + ao_scheme_poly_write(cons->car); + cdr = cons->cdr; + if (cdr == c) { + printf(" ..."); + break; + } + if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { + cons = ao_scheme_poly_cons(cdr); + first = 0; + } else { + printf(" . "); + ao_scheme_poly_write(cdr); + cons = NULL; + } + } + printf(")"); +} + +void +ao_scheme_cons_display(ao_poly c) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + ao_poly cdr; + + while (cons) { + ao_scheme_poly_display(cons->car); + cdr = cons->cdr; + if (cdr == c) { + printf("..."); + break; + } + if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) + cons = ao_scheme_poly_cons(cdr); + else { + ao_scheme_poly_display(cdr); + cons = NULL; + } + } +} + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_scheme_poly_cons(cons->cdr); + } + return len; +} diff --git a/src/lisp/ao_lisp_const.lisp b/src/scheme/ao_scheme_const.lisp similarity index 100% rename from src/lisp/ao_lisp_const.lisp rename to src/scheme/ao_scheme_const.lisp diff --git a/src/lisp/ao_lisp_error.c b/src/scheme/ao_scheme_error.c similarity index 58% rename from src/lisp/ao_lisp_error.c rename to src/scheme/ao_scheme_error.c index 7f909487..d580a2c0 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/scheme/ao_scheme_error.c @@ -12,23 +12,23 @@ * General Public License for more details. */ -#include "ao_lisp.h" +#include "ao_scheme.h" #include void -ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last) { int first = 1; printf("\t\t%s(", name); - if (ao_lisp_poly_type(poly) == AO_LISP_CONS) { + if (ao_scheme_poly_type(poly) == AO_SCHEME_CONS) { if (poly) { while (poly) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); + struct ao_scheme_cons *cons = ao_scheme_poly_cons(poly); if (!first) printf("\t\t "); else first = 0; - ao_lisp_poly_write(cons->car); + ao_scheme_poly_write(cons->car); printf("\n"); if (poly == last) break; @@ -38,7 +38,7 @@ ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) } else printf(")\n"); } else { - ao_lisp_poly_write(poly); + ao_scheme_poly_write(poly); printf("\n"); } } @@ -50,31 +50,31 @@ static void tabs(int indent) } void -ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame) { int f; tabs(indent); printf ("%s{", name); if (frame) { - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - if (frame->type & AO_LISP_FRAME_PRINT) + 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_LISP_FRAME_PRINT; + frame->type |= AO_SCHEME_FRAME_PRINT; for (f = 0; f < frame->num; f++) { if (f != 0) { tabs(indent); printf(" "); } - ao_lisp_poly_write(vals->vals[f].atom); + ao_scheme_poly_write(vals->vals[f].atom); printf(" = "); - ao_lisp_poly_write(vals->vals[f].val); + ao_scheme_poly_write(vals->vals[f].val); printf("\n"); } if (frame->prev) - ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); - frame->type &= ~AO_LISP_FRAME_PRINT; + ao_scheme_error_frame(indent + 1, "prev: ", ao_scheme_poly_frame(frame->prev)); + frame->type &= ~AO_SCHEME_FRAME_PRINT; } tabs(indent); printf(" }\n"); @@ -83,7 +83,7 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) } void -ao_lisp_vprintf(char *format, va_list args) +ao_scheme_vprintf(char *format, va_list args) { char c; @@ -91,7 +91,7 @@ ao_lisp_vprintf(char *format, va_list args) if (c == '%') { switch (c = *format++) { case 'v': - ao_lisp_poly_write((ao_poly) va_arg(args, unsigned int)); + ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int)); break; case 'p': printf("%p", va_arg(args, void *)); @@ -112,28 +112,28 @@ ao_lisp_vprintf(char *format, va_list args) } void -ao_lisp_printf(char *format, ...) +ao_scheme_printf(char *format, ...) { va_list args; va_start(args, format); - ao_lisp_vprintf(format, args); + ao_scheme_vprintf(format, args); va_end(args); } ao_poly -ao_lisp_error(int error, char *format, ...) +ao_scheme_error(int error, char *format, ...) { va_list args; - ao_lisp_exception |= error; + ao_scheme_exception |= error; va_start(args, format); - ao_lisp_vprintf(format, args); + ao_scheme_vprintf(format, args); putchar('\n'); va_end(args); - ao_lisp_printf("Value: %v\n", ao_lisp_v); - ao_lisp_printf("Frame: %v\n", ao_lisp_frame_poly(ao_lisp_frame_current)); + 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_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)); - ao_lisp_printf("Globals: %v\n", ao_lisp_frame_poly(ao_lisp_frame_global)); - return AO_LISP_NIL; + ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)); + ao_scheme_printf("Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global)); + return AO_SCHEME_NIL; } diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c new file mode 100644 index 00000000..9b3cf63e --- /dev/null +++ b/src/scheme/ao_scheme_eval.c @@ -0,0 +1,578 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +struct ao_scheme_stack *ao_scheme_stack; +ao_poly ao_scheme_v; +uint8_t ao_scheme_skip_cons_free; + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *c) +{ + ao_scheme_stack->state = eval_cond; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(c); + return AO_SCHEME_NIL; +} + +static int +func_type(ao_poly func) +{ + if (func == AO_SCHEME_NIL) + return ao_scheme_error(AO_SCHEME_INVALID, "func is nil"); + switch (ao_scheme_poly_type(func)) { + case AO_SCHEME_BUILTIN: + return ao_scheme_poly_builtin(func)->args & AO_SCHEME_FUNC_MASK; + case AO_SCHEME_LAMBDA: + return ao_scheme_poly_lambda(func)->args; + case AO_SCHEME_STACK: + return AO_SCHEME_FUNC_LAMBDA; + default: + ao_scheme_error(AO_SCHEME_INVALID, "not a func"); + return -1; + } +} + +/* + * Flattened eval to avoid stack issues + */ + +/* + * Evaluate an s-expression + * + * For a list, evaluate all of the elements and + * then execute the resulting function call. + * + * Each element of the list is evaluated in + * a clean stack context. + * + * The current stack state is set to 'formal' so that + * when the evaluation is complete, the value + * will get appended to the values list. + * + * For other types, compute the value directly. + */ + +static int +ao_scheme_eval_sexpr(void) +{ + DBGI("sexpr: %v\n", ao_scheme_v); + switch (ao_scheme_poly_type(ao_scheme_v)) { + case AO_SCHEME_CONS: + if (ao_scheme_v == AO_SCHEME_NIL) { + if (!ao_scheme_stack->values) { + /* + * empty list evaluates to empty list + */ + ao_scheme_v = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_val; + } else { + /* + * done with arguments, go execute it + */ + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; + ao_scheme_stack->state = eval_exec; + } + } else { + if (!ao_scheme_stack->values) + ao_scheme_stack->list = ao_scheme_v; + /* + * Evaluate another argument and then switch + * to 'formal' to add the value to the values + * list + */ + ao_scheme_stack->sexprs = ao_scheme_v; + ao_scheme_stack->state = eval_formal; + if (!ao_scheme_stack_push()) + return 0; + /* + * push will reset the state to 'sexpr', which + * will evaluate the expression + */ + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; + } + break; + case AO_SCHEME_ATOM: + DBGI("..frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + ao_scheme_v = ao_scheme_atom_get(ao_scheme_v); + /* fall through */ + case AO_SCHEME_BOOL: + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + case AO_SCHEME_FLOAT: + case AO_SCHEME_STRING: + case AO_SCHEME_BUILTIN: + case AO_SCHEME_LAMBDA: + ao_scheme_stack->state = eval_val; + break; + } + DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG("\n"); + return 1; +} + +/* + * A value has been computed. + * + * If the value was computed from a macro, + * then we want to reset the current context + * to evaluate the macro result again. + * + * If not a macro, then pop the stack. + * If the stack is empty, we're done. + * Otherwise, the stack will contain + * the next state. + */ + +static int +ao_scheme_eval_val(void) +{ + DBGI("val: "); DBG_POLY(ao_scheme_v); DBG("\n"); + /* + * Value computed, pop the stack + * to figure out what to do with the value + */ + ao_scheme_stack_pop(); + DBGI("..state %d\n", ao_scheme_stack ? ao_scheme_stack->state : -1); + return 1; +} + +/* + * A formal has been computed. + * + * If this is the first formal, then check to see if we've got a + * lamda, macro or nlambda. + * + * For lambda, go compute another formal. This will terminate + * when the sexpr state sees nil. + * + * For macro/nlambda, we're done, so move the sexprs into the values + * and go execute it. + * + * Macros have an additional step of saving a stack frame holding the + * macro value execution context, which then gets the result of the + * macro to run + */ + +static int +ao_scheme_eval_formal(void) +{ + ao_poly formal; + struct ao_scheme_stack *prev; + + DBGI("formal: "); DBG_POLY(ao_scheme_v); DBG("\n"); + + /* Check what kind of function we've got */ + if (!ao_scheme_stack->values) { + switch (func_type(ao_scheme_v)) { + case AO_SCHEME_FUNC_LAMBDA: + DBGI(".. lambda\n"); + break; + case AO_SCHEME_FUNC_MACRO: + /* Evaluate the result once more */ + ao_scheme_stack->state = eval_macro; + if (!ao_scheme_stack_push()) + return 0; + + /* After the function returns, take that + * value and re-evaluate it + */ + prev = ao_scheme_poly_stack(ao_scheme_stack->prev); + ao_scheme_stack->sexprs = prev->sexprs; + + DBGI(".. start macro\n"); + DBGI("\t.. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI("\t.. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); + DBG_FRAMES(); + + /* fall through ... */ + case AO_SCHEME_FUNC_NLAMBDA: + DBGI(".. nlambda or macro\n"); + + /* use the raw sexprs as values */ + ao_scheme_stack->values = ao_scheme_stack->sexprs; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_exec; + + /* ready to execute now */ + return 1; + case -1: + return 0; + } + } + + /* Append formal to list of values */ + formal = ao_scheme__cons(ao_scheme_v, AO_SCHEME_NIL); + if (!formal) + return 0; + + if (ao_scheme_stack->values_tail) + ao_scheme_poly_cons(ao_scheme_stack->values_tail)->cdr = formal; + else + ao_scheme_stack->values = formal; + ao_scheme_stack->values_tail = formal; + + DBGI(".. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); + + /* + * Step to the next argument, if this is last, then + * 'sexpr' will end up switching to 'exec' + */ + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + + ao_scheme_stack->state = eval_sexpr; + + DBGI(".. "); DBG_POLY(ao_scheme_v); DBG("\n"); + return 1; +} + +/* + * Start executing a function call + * + * Most builtins are easy, just call the function. + * 'cond' is magic; it sticks the list of clauses + * in 'sexprs' and switches to 'cond' state. That + * bit of magic is done in ao_scheme_set_cond. + * + * Lambdas build a new frame to hold the locals and + * then re-use the current stack context to evaluate + * the s-expression from the lambda. + */ + +static int +ao_scheme_eval_exec(void) +{ + ao_poly v; + struct ao_scheme_builtin *builtin; + + DBGI("exec: "); DBG_POLY(ao_scheme_v); DBG(" values "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); + ao_scheme_stack->sexprs = AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_v)) { + case AO_SCHEME_BUILTIN: + ao_scheme_stack->state = eval_val; + builtin = ao_scheme_poly_builtin(ao_scheme_v); + v = ao_scheme_func(builtin) ( + ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr)); + DBG_DO(if (!ao_scheme_exception && ao_scheme_poly_builtin(ao_scheme_v)->func == builtin_set) { + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + ao_poly atom = ao_scheme_arg(cons, 1); + ao_poly val = ao_scheme_arg(cons, 2); + DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); + }); + builtin = ao_scheme_poly_builtin(ao_scheme_v); + if (builtin && (builtin->args & AO_SCHEME_FUNC_FREE_ARGS) && !ao_scheme_stack_marked(ao_scheme_stack) && !ao_scheme_skip_cons_free) { + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_cons_free(cons); + } + + ao_scheme_v = v; + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG ("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + break; + case AO_SCHEME_LAMBDA: + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + ao_scheme_stack->state = eval_begin; + v = ao_scheme_lambda_eval(); + ao_scheme_stack->sexprs = v; + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_stack->values_tail = AO_SCHEME_NIL; + DBGI(".. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + break; + case AO_SCHEME_STACK: + DBGI(".. stack "); DBG_POLY(ao_scheme_v); DBG("\n"); + ao_scheme_v = ao_scheme_stack_eval(); + DBGI(".. value "); DBG_POLY(ao_scheme_v); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + break; + } + ao_scheme_skip_cons_free = 0; + return 1; +} + +/* + * Finish setting up the apply evaluation + * + * The value is the list to execute + */ +static int +ao_scheme_eval_apply(void) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_v); + struct ao_scheme_cons *cdr, *prev; + + /* Glue the arguments into the right shape. That's all but the last + * concatenated onto the last + */ + cdr = cons; + for (;;) { + prev = cdr; + cdr = ao_scheme_poly_cons(prev->cdr); + if (cdr->cdr == AO_SCHEME_NIL) + break; + } + DBGI("before mangling: "); DBG_POLY(ao_scheme_v); DBG("\n"); + prev->cdr = cdr->car; + ao_scheme_stack->values = ao_scheme_v; + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; + DBGI("apply: "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); + ao_scheme_stack->state = eval_exec; + ao_scheme_skip_cons_free = 1; + return 1; +} + +/* + * Start evaluating the next cond clause + * + * If the list of clauses is empty, then + * the result of the cond is nil. + * + * Otherwise, set the current stack state to 'cond_test' and create a + * new stack context to evaluate the test s-expression. Once that's + * complete, we'll land in 'cond_test' to finish the clause. + */ +static int +ao_scheme_eval_cond(void) +{ + DBGI("cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + if (!ao_scheme_stack->sexprs) { + ao_scheme_v = _ao_scheme_bool_false; + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; + if (!ao_scheme_v || ao_scheme_poly_type(ao_scheme_v) != AO_SCHEME_CONS) { + ao_scheme_error(AO_SCHEME_INVALID, "invalid cond clause"); + return 0; + } + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; + if (ao_scheme_v == _ao_scheme_atom_else) + ao_scheme_v = _ao_scheme_bool_true; + ao_scheme_stack->state = eval_cond_test; + if (!ao_scheme_stack_push()) + return 0; + } + return 1; +} + +/* + * Finish a cond clause. + * + * Check the value from the test expression, if + * non-nil, then set up to evaluate the value expression. + * + * Otherwise, step to the next clause and go back to the 'cond' + * state + */ +static int +ao_scheme_eval_cond_test(void) +{ + DBGI("cond_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + if (ao_scheme_v != _ao_scheme_bool_false) { + struct ao_scheme_cons *car = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car); + ao_poly c = car->cdr; + + if (c) { + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = c; + } else + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + DBGI("next cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + ao_scheme_stack->state = eval_cond; + } + return 1; +} + +/* + * Evaluate a list of sexprs, returning the value from the last one. + * + * ao_scheme_begin records the list in stack->sexprs, so we just need to + * walk that list. Set ao_scheme_v to the car of the list and jump to + * eval_sexpr. When that's done, it will land in eval_val. For all but + * the last, leave a stack frame with eval_begin set so that we come + * back here. For the last, don't add a stack frame so that we can + * just continue on. + */ +static int +ao_scheme_eval_begin(void) +{ + DBGI("begin: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + + if (!ao_scheme_stack->sexprs) { + ao_scheme_v = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; + ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + + /* If there are more sexprs to do, then come back here, otherwise + * return the value of the last one by just landing in eval_sexpr + */ + if (ao_scheme_stack->sexprs) { + ao_scheme_stack->state = eval_begin; + if (!ao_scheme_stack_push()) + return 0; + } + ao_scheme_stack->state = eval_sexpr; + } + return 1; +} + +/* + * Conditionally execute a list of sexprs while the first is true + */ +static int +ao_scheme_eval_while(void) +{ + DBGI("while: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + + ao_scheme_stack->values = ao_scheme_v; + if (!ao_scheme_stack->sexprs) { + ao_scheme_v = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_val; + } else { + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; + ao_scheme_stack->state = eval_while_test; + if (!ao_scheme_stack_push()) + return 0; + } + return 1; +} + +/* + * Check the while condition, terminate the loop if nil. Otherwise keep going + */ +static int +ao_scheme_eval_while_test(void) +{ + DBGI("while_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); + + if (ao_scheme_v != _ao_scheme_bool_false) { + ao_scheme_stack->values = ao_scheme_v; + ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; + ao_scheme_stack->state = eval_while; + if (!ao_scheme_stack_push()) + return 0; + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = ao_scheme_v; + } + else + { + ao_scheme_stack->state = eval_val; + ao_scheme_v = ao_scheme_stack->values; + } + return 1; +} + +/* + * Replace the original sexpr with the macro expansion, then + * execute that + */ +static int +ao_scheme_eval_macro(void) +{ + DBGI("macro: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); + + if (ao_scheme_v == AO_SCHEME_NIL) + ao_scheme_abort(); + if (ao_scheme_poly_type(ao_scheme_v) == AO_SCHEME_CONS) { + *ao_scheme_poly_cons(ao_scheme_stack->sexprs) = *ao_scheme_poly_cons(ao_scheme_v); + ao_scheme_v = ao_scheme_stack->sexprs; + DBGI("sexprs rewritten to: "); DBG_POLY(ao_scheme_v); DBG("\n"); + } + ao_scheme_stack->sexprs = AO_SCHEME_NIL; + ao_scheme_stack->state = eval_sexpr; + return 1; +} + +static int (*const evals[])(void) = { + [eval_sexpr] = ao_scheme_eval_sexpr, + [eval_val] = ao_scheme_eval_val, + [eval_formal] = ao_scheme_eval_formal, + [eval_exec] = ao_scheme_eval_exec, + [eval_apply] = ao_scheme_eval_apply, + [eval_cond] = ao_scheme_eval_cond, + [eval_cond_test] = ao_scheme_eval_cond_test, + [eval_begin] = ao_scheme_eval_begin, + [eval_while] = ao_scheme_eval_while, + [eval_while_test] = ao_scheme_eval_while_test, + [eval_macro] = ao_scheme_eval_macro, +}; + +const char * const ao_scheme_state_names[] = { + [eval_sexpr] = "sexpr", + [eval_val] = "val", + [eval_formal] = "formal", + [eval_exec] = "exec", + [eval_apply] = "apply", + [eval_cond] = "cond", + [eval_cond_test] = "cond_test", + [eval_begin] = "begin", + [eval_while] = "while", + [eval_while_test] = "while_test", + [eval_macro] = "macro", +}; + +/* + * Called at restore time to reset all execution state + */ + +void +ao_scheme_eval_clear_globals(void) +{ + ao_scheme_stack = NULL; + ao_scheme_frame_current = NULL; + ao_scheme_v = AO_SCHEME_NIL; +} + +int +ao_scheme_eval_restart(void) +{ + return ao_scheme_stack_push(); +} + +ao_poly +ao_scheme_eval(ao_poly _v) +{ + ao_scheme_v = _v; + + ao_scheme_frame_init(); + + if (!ao_scheme_stack_push()) + return AO_SCHEME_NIL; + + while (ao_scheme_stack) { + if (!(*evals[ao_scheme_stack->state])() || ao_scheme_exception) { + ao_scheme_stack_clear(); + return AO_SCHEME_NIL; + } + } + DBG_DO(if (ao_scheme_frame_current) {DBGI("frame left as "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n");}); + ao_scheme_frame_current = NULL; + return ao_scheme_v; +} diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c new file mode 100644 index 00000000..541f0264 --- /dev/null +++ b/src/scheme/ao_scheme_float.c @@ -0,0 +1,148 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +static void float_mark(void *addr) +{ + (void) addr; +} + +static int float_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_scheme_float); +} + +static void float_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_float_type = { + .mark = float_mark, + .size = float_size, + .move = float_move, + .name = "float", +}; + +void +ao_scheme_float_write(ao_poly p) +{ + struct ao_scheme_float *f = ao_scheme_poly_float(p); + float v = f->value; + + if (isnanf(v)) + printf("+nan.0"); + else if (isinff(v)) { + if (v < 0) + printf("-"); + else + printf("+"); + printf("inf.0"); + } else + printf ("%g", f->value); +} + +float +ao_scheme_poly_number(ao_poly p) +{ + switch (ao_scheme_poly_base_type(p)) { + case AO_SCHEME_INT: + return ao_scheme_poly_int(p); + case AO_SCHEME_OTHER: + switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { + case AO_SCHEME_BIGINT: + return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + case AO_SCHEME_FLOAT: + return ao_scheme_poly_float(p)->value; + } + } + return NAN; +} + +ao_poly +ao_scheme_float_get(float value) +{ + struct ao_scheme_float *f; + + f = ao_scheme_alloc(sizeof (struct ao_scheme_float)); + f->type = AO_SCHEME_FLOAT; + f->value = value; + return ao_scheme_float_poly(f); +} + +ao_poly +ao_scheme_do_inexactp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == AO_SCHEME_FLOAT) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_finitep(struct ao_scheme_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + value = ao_scheme_arg(cons, 0); + switch (ao_scheme_poly_type(value)) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + return _ao_scheme_bool_true; + case AO_SCHEME_FLOAT: + f = ao_scheme_poly_float(value)->value; + if (!isnan(f) && !isinf(f)) + return _ao_scheme_bool_true; + } + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_infinitep(struct ao_scheme_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + value = ao_scheme_arg(cons, 0); + switch (ao_scheme_poly_type(value)) { + case AO_SCHEME_FLOAT: + f = ao_scheme_poly_float(value)->value; + if (isinf(f)) + return _ao_scheme_bool_true; + } + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_sqrt(struct ao_scheme_cons *cons) +{ + ao_poly value; + + if (!ao_scheme_check_argc(_ao_scheme_atom_sqrt, cons, 1, 1)) + return AO_SCHEME_NIL; + value = ao_scheme_arg(cons, 0); + if (!ao_scheme_number_typep(ao_scheme_poly_type(value))) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: non-numeric", ao_scheme_poly_atom(_ao_scheme_atom_sqrt)->name); + return ao_scheme_float_get(sqrtf(ao_scheme_poly_number(value))); +} diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c new file mode 100644 index 00000000..e5d481e7 --- /dev/null +++ b/src/scheme/ao_scheme_frame.c @@ -0,0 +1,330 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +static inline int +frame_vals_num_size(int num) +{ + return sizeof (struct ao_scheme_frame_vals) + num * sizeof (struct ao_scheme_val); +} + +static int +frame_vals_size(void *addr) +{ + struct ao_scheme_frame_vals *vals = addr; + return frame_vals_num_size(vals->size); +} + +static void +frame_vals_mark(void *addr) +{ + struct ao_scheme_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_scheme_val *v = &vals->vals[f]; + + ao_scheme_poly_mark(v->val, 0); + MDBG_MOVE("frame mark atom %s %d val %d at %d ", + ao_scheme_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_scheme_ref(v->atom)), + MDBG_OFFSET(ao_scheme_ref(v->val)), f); + MDBG_DO(ao_scheme_poly_write(v->val)); + MDBG_DO(printf("\n")); + } +} + +static void +frame_vals_move(void *addr) +{ + struct ao_scheme_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_scheme_val *v = &vals->vals[f]; + + ao_scheme_poly_move(&v->atom, 0); + ao_scheme_poly_move(&v->val, 0); + MDBG_MOVE("frame move atom %s %d val %d at %d\n", + ao_scheme_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_scheme_ref(v->atom)), + MDBG_OFFSET(ao_scheme_ref(v->val)), f); + } +} + +const struct ao_scheme_type ao_scheme_frame_vals_type = { + .mark = frame_vals_mark, + .size = frame_vals_size, + .move = frame_vals_move, + .name = "frame_vals" +}; + +static int +frame_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_frame); +} + +static void +frame_mark(void *addr) +{ + struct ao_scheme_frame *frame = addr; + + for (;;) { + MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); + if (!AO_SCHEME_IS_POOL(frame)) + break; + ao_scheme_poly_mark(frame->vals, 0); + frame = ao_scheme_poly_frame(frame->prev); + MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); + if (!frame) + break; + if (ao_scheme_mark_memory(&ao_scheme_frame_type, frame)) + break; + } +} + +static void +frame_move(void *addr) +{ + struct ao_scheme_frame *frame = addr; + + for (;;) { + struct ao_scheme_frame *prev; + int ret; + + MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); + if (!AO_SCHEME_IS_POOL(frame)) + break; + ao_scheme_poly_move(&frame->vals, 0); + prev = ao_scheme_poly_frame(frame->prev); + if (!prev) + break; + ret = ao_scheme_move_memory(&ao_scheme_frame_type, (void **) &prev); + if (prev != ao_scheme_poly_frame(frame->prev)) { + MDBG_MOVE("frame prev moved from %d to %d\n", + MDBG_OFFSET(ao_scheme_poly_frame(frame->prev)), + MDBG_OFFSET(prev)); + frame->prev = ao_scheme_frame_poly(prev); + } + if (ret) + break; + frame = prev; + } +} + +const struct ao_scheme_type ao_scheme_frame_type = { + .mark = frame_mark, + .size = frame_size, + .move = frame_move, + .name = "frame", +}; + +void +ao_scheme_frame_write(ao_poly p) +{ + struct ao_scheme_frame *frame = ao_scheme_poly_frame(p); + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int f; + + printf ("{"); + if (frame) { + if (frame->type & AO_SCHEME_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_SCHEME_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) + printf(", "); + ao_scheme_poly_write(vals->vals[f].atom); + printf(" = "); + ao_scheme_poly_write(vals->vals[f].val); + } + if (frame->prev) + ao_scheme_poly_write(frame->prev); + frame->type &= ~AO_SCHEME_FRAME_PRINT; + } + } + printf("}"); +} + +static int +ao_scheme_frame_find(struct ao_scheme_frame *frame, int top, ao_poly atom) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = 0; + int r = top - 1; + + while (l <= r) { + int m = (l + r) >> 1; + if (vals->vals[m].atom < atom) + l = m + 1; + else + r = m - 1; + } + return l; +} + +ao_poly * +ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = ao_scheme_frame_find(frame, frame->num, atom); + + if (l >= frame->num) + return NULL; + + if (vals->vals[l].atom != atom) + return NULL; + return &vals->vals[l].val; +} + +struct ao_scheme_frame *ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; + +static struct ao_scheme_frame_vals * +ao_scheme_frame_vals_new(int num) +{ + struct ao_scheme_frame_vals *vals; + + vals = ao_scheme_alloc(frame_vals_num_size(num)); + if (!vals) + return NULL; + vals->type = AO_SCHEME_FRAME_VALS; + vals->size = num; + memset(vals->vals, '\0', num * sizeof (struct ao_scheme_val)); + return vals; +} + +struct ao_scheme_frame * +ao_scheme_frame_new(int num) +{ + struct ao_scheme_frame *frame; + struct ao_scheme_frame_vals *vals; + + if (num < AO_SCHEME_FRAME_FREE && (frame = ao_scheme_frame_free_list[num])) { + ao_scheme_frame_free_list[num] = ao_scheme_poly_frame(frame->prev); + vals = ao_scheme_poly_frame_vals(frame->vals); + } else { + frame = ao_scheme_alloc(sizeof (struct ao_scheme_frame)); + if (!frame) + return NULL; + frame->type = AO_SCHEME_FRAME; + frame->num = 0; + frame->prev = AO_SCHEME_NIL; + frame->vals = AO_SCHEME_NIL; + ao_scheme_frame_stash(0, frame); + vals = ao_scheme_frame_vals_new(num); + frame = ao_scheme_frame_fetch(0); + if (!vals) + return NULL; + frame->vals = ao_scheme_frame_vals_poly(vals); + frame->num = num; + } + frame->prev = AO_SCHEME_NIL; + return frame; +} + +ao_poly +ao_scheme_frame_mark(struct ao_scheme_frame *frame) +{ + if (!frame) + return AO_SCHEME_NIL; + frame->type |= AO_SCHEME_FRAME_MARK; + return ao_scheme_frame_poly(frame); +} + +void +ao_scheme_frame_free(struct ao_scheme_frame *frame) +{ + if (frame && !ao_scheme_frame_marked(frame)) { + int num = frame->num; + if (num < AO_SCHEME_FRAME_FREE) { + struct ao_scheme_frame_vals *vals; + + vals = ao_scheme_poly_frame_vals(frame->vals); + memset(vals->vals, '\0', vals->size * sizeof (struct ao_scheme_val)); + frame->prev = ao_scheme_frame_poly(ao_scheme_frame_free_list[num]); + ao_scheme_frame_free_list[num] = frame; + } + } +} + +static struct ao_scheme_frame * +ao_scheme_frame_realloc(struct ao_scheme_frame *frame, int new_num) +{ + struct ao_scheme_frame_vals *vals; + struct ao_scheme_frame_vals *new_vals; + int copy; + + if (new_num == frame->num) + return frame; + ao_scheme_frame_stash(0, frame); + new_vals = ao_scheme_frame_vals_new(new_num); + frame = ao_scheme_frame_fetch(0); + if (!new_vals) + return NULL; + vals = ao_scheme_poly_frame_vals(frame->vals); + copy = new_num; + if (copy > frame->num) + copy = frame->num; + memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_scheme_val)); + frame->vals = ao_scheme_frame_vals_poly(new_vals); + frame->num = new_num; + return frame; +} + +void +ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val) +{ + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int l = ao_scheme_frame_find(frame, num, atom); + + memmove(&vals->vals[l+1], + &vals->vals[l], + (num - l) * sizeof (struct ao_scheme_val)); + vals->vals[l].atom = atom; + vals->vals[l].val = val; +} + +ao_poly +ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val) +{ + ao_poly *ref = frame ? ao_scheme_frame_ref(frame, atom) : NULL; + + if (!ref) { + int f = frame->num; + ao_scheme_poly_stash(0, atom); + ao_scheme_poly_stash(1, val); + frame = ao_scheme_frame_realloc(frame, f + 1); + val = ao_scheme_poly_fetch(1); + atom = ao_scheme_poly_fetch(0); + if (!frame) + return AO_SCHEME_NIL; + ao_scheme_frame_bind(frame, frame->num - 1, atom, val); + } else + *ref = val; + return val; +} + +struct ao_scheme_frame *ao_scheme_frame_global; +struct ao_scheme_frame *ao_scheme_frame_current; + +void +ao_scheme_frame_init(void) +{ + if (!ao_scheme_frame_global) + ao_scheme_frame_global = ao_scheme_frame_new(0); +} diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c new file mode 100644 index 00000000..350a5d35 --- /dev/null +++ b/src/scheme/ao_scheme_int.c @@ -0,0 +1,79 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +void +ao_scheme_int_write(ao_poly p) +{ + int i = ao_scheme_poly_int(p); + printf("%d", i); +} + +int32_t +ao_scheme_poly_integer(ao_poly p) +{ + switch (ao_scheme_poly_base_type(p)) { + case AO_SCHEME_INT: + return ao_scheme_poly_int(p); + case AO_SCHEME_OTHER: + if (ao_scheme_other_type(ao_scheme_poly_other(p)) == AO_SCHEME_BIGINT) + return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + } + return AO_SCHEME_NOT_INTEGER; +} + +ao_poly +ao_scheme_integer_poly(int32_t p) +{ + struct ao_scheme_bigint *bi; + + if (AO_SCHEME_MIN_INT <= p && p <= AO_SCHEME_MAX_INT) + return ao_scheme_int_poly(p); + bi = ao_scheme_alloc(sizeof (struct ao_scheme_bigint)); + bi->value = ao_scheme_int_bigint(p); + return ao_scheme_bigint_poly(bi); +} + +static void bigint_mark(void *addr) +{ + (void) addr; +} + +static int bigint_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_scheme_bigint); +} + +static void bigint_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_bigint_type = { + .mark = bigint_mark, + .size = bigint_size, + .move = bigint_move, + .name = "bigint", +}; + +void +ao_scheme_bigint_write(ao_poly p) +{ + struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); + + printf("%d", ao_scheme_bigint_int(bi->value)); +} diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c new file mode 100644 index 00000000..ec6f858c --- /dev/null +++ b/src/scheme/ao_scheme_lambda.c @@ -0,0 +1,208 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_scheme.h" + +int +lambda_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_lambda); +} + +void +lambda_mark(void *addr) +{ + struct ao_scheme_lambda *lambda = addr; + + ao_scheme_poly_mark(lambda->code, 0); + ao_scheme_poly_mark(lambda->frame, 0); +} + +void +lambda_move(void *addr) +{ + struct ao_scheme_lambda *lambda = addr; + + ao_scheme_poly_move(&lambda->code, 0); + ao_scheme_poly_move(&lambda->frame, 0); +} + +const struct ao_scheme_type ao_scheme_lambda_type = { + .size = lambda_size, + .mark = lambda_mark, + .move = lambda_move, + .name = "lambda", +}; + +void +ao_scheme_lambda_write(ao_poly poly) +{ + struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(poly); + struct ao_scheme_cons *cons = ao_scheme_poly_cons(lambda->code); + + printf("("); + printf("%s", ao_scheme_args_name(lambda->args)); + while (cons) { + printf(" "); + ao_scheme_poly_write(cons->car); + cons = ao_scheme_poly_cons(cons->cdr); + } + printf(")"); +} + +ao_poly +ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args) +{ + struct ao_scheme_lambda *lambda; + ao_poly formal; + struct ao_scheme_cons *cons; + + formal = ao_scheme_arg(code, 0); + while (formal != AO_SCHEME_NIL) { + switch (ao_scheme_poly_type(formal)) { + case AO_SCHEME_CONS: + cons = ao_scheme_poly_cons(formal); + if (ao_scheme_poly_type(cons->car) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", cons->car); + formal = cons->cdr; + break; + case AO_SCHEME_ATOM: + formal = AO_SCHEME_NIL; + break; + default: + return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", formal); + } + } + + ao_scheme_cons_stash(0, code); + lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); + code = ao_scheme_cons_fetch(0); + if (!lambda) + return AO_SCHEME_NIL; + + lambda->type = AO_SCHEME_LAMBDA; + lambda->args = args; + lambda->code = ao_scheme_cons_poly(code); + lambda->frame = ao_scheme_frame_mark(ao_scheme_frame_current); + DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); + DBG_STACK(); + return ao_scheme_lambda_poly(lambda); +} + +ao_poly +ao_scheme_do_lambda(struct ao_scheme_cons *cons) +{ + return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_LAMBDA); +} + +ao_poly +ao_scheme_do_nlambda(struct ao_scheme_cons *cons) +{ + return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_NLAMBDA); +} + +ao_poly +ao_scheme_do_macro(struct ao_scheme_cons *cons) +{ + return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_MACRO); +} + +ao_poly +ao_scheme_lambda_eval(void) +{ + struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(ao_scheme_v); + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + struct ao_scheme_cons *code = ao_scheme_poly_cons(lambda->code); + ao_poly formals; + struct ao_scheme_frame *next_frame; + int args_wanted; + ao_poly varargs = AO_SCHEME_NIL; + int args_provided; + int f; + struct ao_scheme_cons *vals; + + DBGI("lambda "); DBG_POLY(ao_scheme_lambda_poly(lambda)); DBG("\n"); + + args_wanted = 0; + for (formals = ao_scheme_arg(code, 0); + ao_scheme_is_pair(formals); + formals = ao_scheme_poly_cons(formals)->cdr) + ++args_wanted; + if (formals != AO_SCHEME_NIL) { + if (ao_scheme_poly_type(formals) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "bad lambda form"); + varargs = formals; + } + + /* Create a frame to hold the variables + */ + args_provided = ao_scheme_cons_length(cons) - 1; + if (varargs == AO_SCHEME_NIL) { + if (args_wanted != args_provided) + return ao_scheme_error(AO_SCHEME_INVALID, "need %d args, got %d", args_wanted, args_provided); + } else { + if (args_provided < args_wanted) + return ao_scheme_error(AO_SCHEME_INVALID, "need at least %d args, got %d", args_wanted, args_provided); + } + + ao_scheme_poly_stash(1, varargs); + next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); + varargs = ao_scheme_poly_fetch(1); + if (!next_frame) + return AO_SCHEME_NIL; + + /* Re-fetch all of the values in case something moved */ + lambda = ao_scheme_poly_lambda(ao_scheme_v); + cons = ao_scheme_poly_cons(ao_scheme_stack->values); + code = ao_scheme_poly_cons(lambda->code); + formals = ao_scheme_arg(code, 0); + vals = ao_scheme_poly_cons(cons->cdr); + + next_frame->prev = lambda->frame; + ao_scheme_frame_current = next_frame; + ao_scheme_stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); + + for (f = 0; f < args_wanted; f++) { + struct ao_scheme_cons *arg = ao_scheme_poly_cons(formals); + DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + ao_scheme_frame_bind(next_frame, f, arg->car, vals->car); + formals = arg->cdr; + vals = ao_scheme_poly_cons(vals->cdr); + } + if (varargs) { + DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_scheme_cons_poly(vals)); DBG("\n"); + /* + * Bind the rest of the arguments to the final parameter + */ + ao_scheme_frame_bind(next_frame, f, varargs, ao_scheme_cons_poly(vals)); + } else { + /* + * Mark the cons cells from the actuals as freed for immediate re-use, unless + * the actuals point into the source function (nlambdas and macros), or if the + * stack containing them was copied as a part of a continuation + */ + if (lambda->args == AO_SCHEME_FUNC_LAMBDA && !ao_scheme_stack_marked(ao_scheme_stack)) { + ao_scheme_stack->values = AO_SCHEME_NIL; + ao_scheme_cons_free(cons); + } + } + DBGI("eval frame: "); DBG_POLY(ao_scheme_frame_poly(next_frame)); DBG("\n"); + DBG_STACK(); + DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); + return code->cdr; +} diff --git a/src/lisp/ao_lisp_lex.c b/src/scheme/ao_scheme_lex.c similarity index 96% rename from src/lisp/ao_lisp_lex.c rename to src/scheme/ao_scheme_lex.c index fe7c47f4..266b1fc0 100644 --- a/src/lisp/ao_lisp_lex.c +++ b/src/scheme/ao_scheme_lex.c @@ -12,5 +12,5 @@ * General Public License for more details. */ -#include "ao_lisp.h" +#include "ao_scheme.h" diff --git a/src/lisp/ao_lisp_make_builtin b/src/scheme/ao_scheme_make_builtin similarity index 68% rename from src/lisp/ao_lisp_make_builtin rename to src/scheme/ao_scheme_make_builtin index 783ab378..8e9c2c0b 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/scheme/ao_scheme_make_builtin @@ -53,31 +53,31 @@ bool is_atom(builtin_t b) = b.type == "atom"; void dump_ids(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_ID\n"); - printf("#undef AO_LISP_BUILTIN_ID\n"); - printf("enum ao_lisp_builtin_id {\n"); + 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_LISP_BUILTIN_ID */\n"); + printf("#endif /* AO_SCHEME_BUILTIN_ID */\n"); } void dump_casename(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_CASENAME\n"); - printf("#undef AO_LISP_BUILTIN_CASENAME\n"); - printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n"); + printf("#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_lisp_poly_atom(_atom(\"%s\"))->name;\n", + 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_LISP_BUILTIN_CASENAME */\n"); + printf("#endif /* AO_SCHEME_BUILTIN_CASENAME */\n"); } void @@ -93,59 +93,59 @@ cify_lisp(string l) { void dump_arrayname(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_ARRAYNAME\n"); - printf("#undef AO_LISP_BUILTIN_ARRAYNAME\n"); + 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_lisp_atom_", + 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_LISP_BUILTIN_ARRAYNAME */\n"); + printf("#endif /* AO_SCHEME_BUILTIN_ARRAYNAME */\n"); } void dump_funcs(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_FUNCS\n"); - printf("#undef AO_LISP_BUILTIN_FUNCS\n"); - printf("const ao_lisp_func_t ao_lisp_builtins[] = {\n"); + 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_lisp_do_%s,\n", + printf("\t[builtin_%s] = ao_scheme_do_%s,\n", builtins[i].c_name, builtins[i].c_name); } printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_FUNCS */\n"); + printf("#endif /* AO_SCHEME_BUILTIN_FUNCS */\n"); } void dump_decls(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_DECLS\n"); - printf("#undef AO_LISP_BUILTIN_DECLS\n"); + 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_lisp_do_%s(struct ao_lisp_cons *cons);\n", + printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n", builtins[i].c_name); } } - printf("#endif /* AO_LISP_BUILTIN_DECLS */\n"); + printf("#endif /* AO_SCHEME_BUILTIN_DECLS */\n"); } void dump_consts(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_CONSTS\n"); - printf("#undef AO_LISP_BUILTIN_CONSTS\n"); + 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_LISP_FUNC_%s, .func = builtin_%s },\n", + 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); @@ -153,21 +153,21 @@ dump_consts(builtin_t[*] builtins) { } } printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); + printf("#endif /* AO_SCHEME_BUILTIN_CONSTS */\n"); } void dump_atoms(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_ATOMS\n"); - printf("#undef AO_LISP_BUILTIN_ATOMS\n"); + 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_lisp_atom_"); + printf("#define _ao_scheme_atom_"); cify_lisp(builtins[i].lisp_names[j]); printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); } } - printf("#endif /* AO_LISP_BUILTIN_ATOMS */\n"); + printf("#endif /* AO_SCHEME_BUILTIN_ATOMS */\n"); } void main() { diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c new file mode 100644 index 00000000..cf42ec52 --- /dev/null +++ b/src/scheme/ao_scheme_make_const.c @@ -0,0 +1,395 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include +#include +#include +#include + +static struct ao_scheme_builtin * +ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { + struct ao_scheme_builtin *b = ao_scheme_alloc(sizeof (struct ao_scheme_builtin)); + + b->type = AO_SCHEME_BUILTIN; + b->func = func; + b->args = args; + return b; +} + +struct builtin_func { + char *name; + int args; + enum ao_scheme_builtin_id func; +}; + +#define AO_SCHEME_BUILTIN_CONSTS +#include "ao_scheme_builtin.h" + +#define N_FUNC (sizeof funcs / sizeof funcs[0]) + +struct ao_scheme_frame *globals; + +static int +is_atom(int offset) +{ + struct ao_scheme_atom *a; + + for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) + if (((uint8_t *) a->name - ao_scheme_const) == offset) + return strlen(a->name); + return 0; +} + +#define AO_FEC_CRC_INIT 0xffff + +static inline uint16_t +ao_fec_crc_byte(uint8_t byte, uint16_t crc) +{ + uint8_t bit; + + for (bit = 0; bit < 8; bit++) { + if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) + crc = (crc << 1) ^ 0x8005; + else + crc = (crc << 1); + byte <<= 1; + } + return crc; +} + +uint16_t +ao_fec_crc(const uint8_t *bytes, uint8_t len) +{ + uint16_t crc = AO_FEC_CRC_INIT; + + while (len--) + crc = ao_fec_crc_byte(*bytes++, crc); + return crc; +} + +struct ao_scheme_macro_stack { + struct ao_scheme_macro_stack *next; + ao_poly p; +}; + +struct ao_scheme_macro_stack *macro_stack; + +int +ao_scheme_macro_push(ao_poly p) +{ + struct ao_scheme_macro_stack *m = macro_stack; + + while (m) { + if (m->p == p) + return 1; + m = m->next; + } + m = malloc (sizeof (struct ao_scheme_macro_stack)); + m->p = p; + m->next = macro_stack; + macro_stack = m; + return 0; +} + +void +ao_scheme_macro_pop(void) +{ + struct ao_scheme_macro_stack *m = macro_stack; + + macro_stack = m->next; + free(m); +} + +#define DBG_MACRO 0 +#if DBG_MACRO +int macro_scan_depth; + +void indent(void) +{ + int i; + for (i = 0; i < macro_scan_depth; i++) + printf(" "); +} +#define MACRO_DEBUG(a) a +#else +#define MACRO_DEBUG(a) +#endif + +ao_poly +ao_has_macro(ao_poly p); + +ao_poly +ao_macro_test_get(ao_poly atom) +{ + ao_poly *ref = ao_scheme_atom_ref(atom, NULL); + if (ref) + return *ref; + return AO_SCHEME_NIL; +} + +ao_poly +ao_is_macro(ao_poly p) +{ + struct ao_scheme_builtin *builtin; + struct ao_scheme_lambda *lambda; + ao_poly ret; + + MACRO_DEBUG(indent(); printf ("is macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); + switch (ao_scheme_poly_type(p)) { + case AO_SCHEME_ATOM: + if (ao_scheme_macro_push(p)) + ret = AO_SCHEME_NIL; + else { + if (ao_is_macro(ao_macro_test_get(p))) + ret = p; + else + ret = AO_SCHEME_NIL; + ao_scheme_macro_pop(); + } + break; + case AO_SCHEME_CONS: + ret = ao_has_macro(p); + break; + case AO_SCHEME_BUILTIN: + builtin = ao_scheme_poly_builtin(p); + if ((builtin->args & AO_SCHEME_FUNC_MASK) == AO_SCHEME_FUNC_MACRO) + ret = p; + else + ret = 0; + break; + + case AO_SCHEME_LAMBDA: + lambda = ao_scheme_poly_lambda(p); + if (lambda->args == AO_SCHEME_FUNC_MACRO) + ret = p; + else + ret = ao_has_macro(lambda->code); + break; + default: + ret = AO_SCHEME_NIL; + break; + } + MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_scheme_poly_write(ret); printf("\n")); + return ret; +} + +ao_poly +ao_has_macro(ao_poly p) +{ + struct ao_scheme_cons *cons; + struct ao_scheme_lambda *lambda; + ao_poly m; + ao_poly list; + + if (p == AO_SCHEME_NIL) + return AO_SCHEME_NIL; + + MACRO_DEBUG(indent(); printf("has macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); + switch (ao_scheme_poly_type(p)) { + case AO_SCHEME_LAMBDA: + lambda = ao_scheme_poly_lambda(p); + p = ao_has_macro(lambda->code); + break; + case AO_SCHEME_CONS: + cons = ao_scheme_poly_cons(p); + if ((p = ao_is_macro(cons->car))) + break; + + list = cons->cdr; + p = AO_SCHEME_NIL; + while (list != AO_SCHEME_NIL && ao_scheme_poly_type(list) == AO_SCHEME_CONS) { + cons = ao_scheme_poly_cons(list); + m = ao_has_macro(cons->car); + if (m) { + p = m; + break; + } + list = cons->cdr; + } + break; + + default: + p = AO_SCHEME_NIL; + break; + } + MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_scheme_poly_write(p); printf("\n")); + return p; +} + +int +ao_scheme_read_eval_abort(void) +{ + ao_poly in, out = AO_SCHEME_NIL; + for(;;) { + in = ao_scheme_read(); + if (in == _ao_scheme_atom_eof) + break; + out = ao_scheme_eval(in); + if (ao_scheme_exception) + return 0; + ao_scheme_poly_write(out); + putchar ('\n'); + } + return 1; +} + +static FILE *in; +static FILE *out; + +int +ao_scheme_getc(void) +{ + return getc(in); +} + +static const struct option options[] = { + { .name = "out", .has_arg = 1, .val = 'o' }, + { 0, 0, 0, 0 } +}; + +static void usage(char *program) +{ + fprintf(stderr, "usage: %s [--out=] [input]\n", program); + exit(1); +} + +int +main(int argc, char **argv) +{ + int f, o; + ao_poly val; + struct ao_scheme_atom *a; + struct ao_scheme_builtin *b; + int in_atom = 0; + char *out_name = NULL; + int c; + enum ao_scheme_builtin_id prev_func; + + in = stdin; + out = stdout; + + while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { + switch (c) { + case 'o': + out_name = optarg; + break; + default: + usage(argv[0]); + break; + } + } + + ao_scheme_frame_init(); + + /* Boolean values #f and #t */ + ao_scheme_bool_get(0); + ao_scheme_bool_get(1); + + prev_func = _builtin_last; + for (f = 0; f < (int) N_FUNC; f++) { + if (funcs[f].func != prev_func) + b = ao_scheme_make_builtin(funcs[f].func, funcs[f].args); + a = ao_scheme_atom_intern(funcs[f].name); + ao_scheme_atom_def(ao_scheme_atom_poly(a), + ao_scheme_builtin_poly(b)); + } + + /* end of file value */ + a = ao_scheme_atom_intern("eof"); + ao_scheme_atom_def(ao_scheme_atom_poly(a), + ao_scheme_atom_poly(a)); + + /* 'else' */ + a = ao_scheme_atom_intern("else"); + + if (argv[optind]){ + in = fopen(argv[optind], "r"); + if (!in) { + perror(argv[optind]); + exit(1); + } + } + if (!ao_scheme_read_eval_abort()) { + fprintf(stderr, "eval failed\n"); + exit(1); + } + + /* Reduce to referenced values */ + ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + + for (f = 0; f < ao_scheme_frame_global->num; f++) { + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(ao_scheme_frame_global->vals); + val = ao_has_macro(vals->vals[f].val); + if (val != AO_SCHEME_NIL) { + printf("error: function %s contains unresolved macro: ", + ao_scheme_poly_atom(vals->vals[f].atom)->name); + ao_scheme_poly_write(val); + printf("\n"); + exit(1); + } + } + + if (out_name) { + out = fopen(out_name, "w"); + if (!out) { + perror(out_name); + exit(1); + } + } + + fprintf(out, "/* Generated file, do not edit */\n\n"); + + fprintf(out, "#define AO_SCHEME_POOL_CONST %d\n", ao_scheme_top); + fprintf(out, "extern const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4)));\n"); + fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_scheme_atom_poly(ao_scheme_atoms)); + fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_scheme_frame_poly(ao_scheme_frame_global)); + fprintf(out, "#define ao_scheme_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_scheme_const, ao_scheme_top)); + + fprintf(out, "#define _ao_scheme_bool_false 0x%04x\n", ao_scheme_bool_poly(ao_scheme_false)); + fprintf(out, "#define _ao_scheme_bool_true 0x%04x\n", ao_scheme_bool_poly(ao_scheme_true)); + + for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) { + char *n = a->name, c; + fprintf(out, "#define _ao_scheme_atom_"); + while ((c = *n++)) { + if (isalnum(c)) + fprintf(out, "%c", c); + else + fprintf(out, "%02x", c); + } + fprintf(out, " 0x%04x\n", ao_scheme_atom_poly(a)); + } + fprintf(out, "#ifdef AO_SCHEME_CONST_BITS\n"); + fprintf(out, "const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute((aligned(4))) = {"); + for (o = 0; o < ao_scheme_top; o++) { + uint8_t c; + if ((o & 0xf) == 0) + fprintf(out, "\n\t"); + else + fprintf(out, " "); + c = ao_scheme_const[o]; + if (!in_atom) + in_atom = is_atom(o); + if (in_atom) { + fprintf(out, " '%c',", c); + in_atom--; + } else { + fprintf(out, "0x%02x,", c); + } + } + fprintf(out, "\n};\n"); + fprintf(out, "#endif /* AO_SCHEME_CONST_BITS */\n"); + exit(0); +} diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c new file mode 100644 index 00000000..acc726c8 --- /dev/null +++ b/src/scheme/ao_scheme_mem.c @@ -0,0 +1,968 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#define AO_SCHEME_CONST_BITS + +#include "ao_scheme.h" +#include +#include + +#ifdef AO_SCHEME_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + +#include +uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); +#define ao_scheme_pool ao_scheme_const +#undef AO_SCHEME_POOL +#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST + +#else + +uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); + +#endif + +#ifndef DBG_MEM_STATS +#define DBG_MEM_STATS DBG_MEM +#endif + +#if DBG_MEM +int dbg_move_depth; +int dbg_mem = DBG_MEM_START; +int dbg_validate = 0; + +struct ao_scheme_record { + struct ao_scheme_record *next; + const struct ao_scheme_type *type; + void *addr; + int size; +}; + +static struct ao_scheme_record *record_head, **record_tail; + +static void +ao_scheme_record_free(struct ao_scheme_record *record) +{ + while (record) { + struct ao_scheme_record *next = record->next; + free(record); + record = next; + } +} + +static void +ao_scheme_record_reset(void) +{ + ao_scheme_record_free(record_head); + record_head = NULL; + record_tail = &record_head; +} + +static void +ao_scheme_record(const struct ao_scheme_type *type, + void *addr, + int size) +{ + struct ao_scheme_record *r = malloc(sizeof (struct ao_scheme_record)); + + r->next = NULL; + r->type = type; + r->addr = addr; + r->size = size; + *record_tail = r; + record_tail = &r->next; +} + +static struct ao_scheme_record * +ao_scheme_record_save(void) +{ + struct ao_scheme_record *r = record_head; + + record_head = NULL; + record_tail = &record_head; + return r; +} + +static void +ao_scheme_record_compare(char *where, + struct ao_scheme_record *a, + struct ao_scheme_record *b) +{ + while (a && b) { + if (a->type != b->type || a->size != b->size) { + printf("%s record difers %d %s %d -> %d %s %d\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_scheme_abort(); + } + a = a->next; + b = b->next; + } + if (a) { + printf("%s record differs %d %s %d -> NULL\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size); + ao_scheme_abort(); + } + if (b) { + printf("%s record differs NULL -> %d %s %d\n", + where, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_scheme_abort(); + } +} + +#else +#define ao_scheme_record_reset() +#endif + +uint8_t ao_scheme_exception; + +struct ao_scheme_root { + const struct ao_scheme_type *type; + void **addr; +}; + +static struct ao_scheme_cons *save_cons[2]; +static char *save_string[2]; +static struct ao_scheme_frame *save_frame[1]; +static ao_poly save_poly[3]; + +static const struct ao_scheme_root ao_scheme_root[] = { + { + .type = &ao_scheme_cons_type, + .addr = (void **) &save_cons[0], + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &save_cons[1], + }, + { + .type = &ao_scheme_string_type, + .addr = (void **) &save_string[0], + }, + { + .type = &ao_scheme_string_type, + .addr = (void **) &save_string[1], + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &save_frame[0], + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[0] + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[1] + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[2] + }, + { + .type = &ao_scheme_atom_type, + .addr = (void **) &ao_scheme_atoms + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &ao_scheme_frame_global, + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &ao_scheme_frame_current, + }, + { + .type = &ao_scheme_stack_type, + .addr = (void **) &ao_scheme_stack, + }, + { + .type = NULL, + .addr = (void **) (void *) &ao_scheme_v, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_cons, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_cons_tail, + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &ao_scheme_read_stack, + }, +#ifdef AO_SCHEME_MAKE_CONST + { + .type = &ao_scheme_bool_type, + .addr = (void **) &ao_scheme_false, + }, + { + .type = &ao_scheme_bool_type, + .addr = (void **) &ao_scheme_true, + }, +#endif +}; + +#define AO_SCHEME_ROOT (sizeof (ao_scheme_root) / sizeof (ao_scheme_root[0])) + +static const void ** const ao_scheme_cache[] = { + (const void **) &ao_scheme_cons_free_list, + (const void **) &ao_scheme_stack_free_list, + (const void **) &ao_scheme_frame_free_list[0], + (const void **) &ao_scheme_frame_free_list[1], + (const void **) &ao_scheme_frame_free_list[2], + (const void **) &ao_scheme_frame_free_list[3], + (const void **) &ao_scheme_frame_free_list[4], + (const void **) &ao_scheme_frame_free_list[5], +}; + +#if AO_SCHEME_FRAME_FREE != 6 +#error Unexpected AO_SCHEME_FRAME_FREE value +#endif + +#define AO_SCHEME_CACHE (sizeof (ao_scheme_cache) / sizeof (ao_scheme_cache[0])) + +#define AO_SCHEME_BUSY_SIZE ((AO_SCHEME_POOL + 31) / 32) + +static uint8_t ao_scheme_busy[AO_SCHEME_BUSY_SIZE]; +static uint8_t ao_scheme_cons_note[AO_SCHEME_BUSY_SIZE]; +static uint8_t ao_scheme_cons_last[AO_SCHEME_BUSY_SIZE]; +static uint8_t ao_scheme_cons_noted; + +uint16_t ao_scheme_top; + +struct ao_scheme_chunk { + uint16_t old_offset; + union { + uint16_t size; + uint16_t new_offset; + }; +}; + +#define AO_SCHEME_NCHUNK 64 + +static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK]; + +/* Offset of an address within the pool. */ +static inline uint16_t pool_offset(void *addr) { +#if DBG_MEM + if (!AO_SCHEME_IS_POOL(addr)) + ao_scheme_abort(); +#endif + return ((uint8_t *) addr) - ao_scheme_pool; +} + +static inline void mark(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + tag[byte] |= (1 << bit); +} + +static inline void clear(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + tag[byte] &= ~(1 << bit); +} + +static inline int busy(uint8_t *tag, int offset) { + int byte = offset >> 5; + int bit = (offset >> 2) & 7; + return (tag[byte] >> bit) & 1; +} + +static inline int min(int a, int b) { return a < b ? a : b; } +static inline int max(int a, int b) { return a > b ? a : b; } + +static inline int limit(int offset) { + return min(AO_SCHEME_POOL, max(offset, 0)); +} + +static void +note_cons(uint16_t offset) +{ + MDBG_MOVE("note cons %d\n", offset); + ao_scheme_cons_noted = 1; + mark(ao_scheme_cons_note, offset); +} + +static uint16_t chunk_low, chunk_high; +static uint16_t chunk_first, chunk_last; + +static int +find_chunk(uint16_t offset) +{ + int l, r; + /* Binary search for the location */ + l = chunk_first; + r = chunk_last - 1; + while (l <= r) { + int m = (l + r) >> 1; + if (ao_scheme_chunk[m].old_offset < offset) + l = m + 1; + else + r = m - 1; + } + return l; +} + +static void +note_chunk(uint16_t offset, uint16_t size) +{ + int l; + + if (offset < chunk_low || chunk_high <= offset) + return; + + l = find_chunk(offset); + + /* + * The correct location is always in 'l', with r = l-1 being + * the entry before the right one + */ + +#if DBG_MEM + /* Off the right side */ + if (l >= AO_SCHEME_NCHUNK) + ao_scheme_abort(); + + /* Off the left side */ + if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset) + ao_scheme_abort(); +#endif + + /* Shuffle existing entries right */ + int end = min(AO_SCHEME_NCHUNK, chunk_last + 1); + + memmove(&ao_scheme_chunk[l+1], + &ao_scheme_chunk[l], + (end - (l+1)) * sizeof (struct ao_scheme_chunk)); + + /* Add new entry */ + ao_scheme_chunk[l].old_offset = offset; + ao_scheme_chunk[l].size = size; + + /* Increment the number of elements up to the size of the array */ + if (chunk_last < AO_SCHEME_NCHUNK) + chunk_last++; + + /* Set the top address if the array is full */ + if (chunk_last == AO_SCHEME_NCHUNK) + chunk_high = ao_scheme_chunk[AO_SCHEME_NCHUNK-1].old_offset + + ao_scheme_chunk[AO_SCHEME_NCHUNK-1].size; +} + +static void +reset_chunks(void) +{ + chunk_high = ao_scheme_top; + chunk_last = 0; + chunk_first = 0; +} + +/* + * Walk all referenced objects calling functions on each one + */ + +static void +walk(int (*visit_addr)(const struct ao_scheme_type *type, void **addr), + int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) +{ + int i; + + ao_scheme_record_reset(); + memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); + memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); + ao_scheme_cons_noted = 0; + for (i = 0; i < (int) AO_SCHEME_ROOT; i++) { + if (ao_scheme_root[i].type) { + void **a = ao_scheme_root[i].addr, *v; + if (a && (v = *a)) { + MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); + visit_addr(ao_scheme_root[i].type, a); + } + } else { + ao_poly *a = (ao_poly *) ao_scheme_root[i].addr, p; + if (a && (p = *a)) { + MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_scheme_ref(p))); + visit_poly(a, 0); + } + } + } + while (ao_scheme_cons_noted) { + memcpy(ao_scheme_cons_last, ao_scheme_cons_note, sizeof (ao_scheme_cons_note)); + memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); + ao_scheme_cons_noted = 0; + for (i = 0; i < AO_SCHEME_POOL; i += 4) { + if (busy(ao_scheme_cons_last, i)) { + void *v = ao_scheme_pool + i; + MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); + visit_addr(&ao_scheme_cons_type, &v); + } + } + } +} + +#if MDBG_DUMP +static void +dump_busy(void) +{ + int i; + MDBG_MOVE("busy:"); + for (i = 0; i < ao_scheme_top; i += 4) { + if ((i & 0xff) == 0) { + MDBG_MORE("\n"); + MDBG_MOVE("%s", ""); + } + else if ((i & 0x1f) == 0) + MDBG_MORE(" "); + if (busy(ao_scheme_busy, i)) + MDBG_MORE("*"); + else + MDBG_MORE("-"); + } + MDBG_MORE ("\n"); +} +#define DUMP_BUSY() dump_busy() +#else +#define DUMP_BUSY() +#endif + +static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = { + [AO_SCHEME_CONS] = &ao_scheme_cons_type, + [AO_SCHEME_INT] = NULL, + [AO_SCHEME_STRING] = &ao_scheme_string_type, + [AO_SCHEME_OTHER] = (void *) 0x1, + [AO_SCHEME_ATOM] = &ao_scheme_atom_type, + [AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type, + [AO_SCHEME_FRAME] = &ao_scheme_frame_type, + [AO_SCHEME_FRAME_VALS] = &ao_scheme_frame_vals_type, + [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, + [AO_SCHEME_STACK] = &ao_scheme_stack_type, + [AO_SCHEME_BOOL] = &ao_scheme_bool_type, + [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, + [AO_SCHEME_FLOAT] = &ao_scheme_float_type, +}; + +static int +ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref) +{ + return ao_scheme_mark(type, *ref); +} + +static int +ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) +{ + return ao_scheme_poly_mark(*p, do_note_cons); +} + +#if DBG_MEM_STATS +int ao_scheme_collects[2]; +int ao_scheme_freed[2]; +int ao_scheme_loops[2]; +#endif + +int ao_scheme_last_top; + +int +ao_scheme_collect(uint8_t style) +{ + int i; + int top; +#if DBG_MEM_STATS + int loops = 0; +#endif +#if DBG_MEM + struct ao_scheme_record *mark_record = NULL, *move_record = NULL; + + MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); +#endif + MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + + /* The first time through, we're doing a full collect */ + if (ao_scheme_last_top == 0) + style = AO_SCHEME_COLLECT_FULL; + + /* Clear references to all caches */ + for (i = 0; i < (int) AO_SCHEME_CACHE; i++) + *ao_scheme_cache[i] = NULL; + if (style == AO_SCHEME_COLLECT_FULL) { + chunk_low = top = 0; + } else { + chunk_low = top = ao_scheme_last_top; + } + for (;;) { +#if DBG_MEM_STATS + loops++; +#endif + MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); + /* Find the sizes of the first chunk of objects to move */ + reset_chunks(); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +#if DBG_MEM + + ao_scheme_record_free(mark_record); + mark_record = ao_scheme_record_save(); + if (mark_record && move_record) + ao_scheme_record_compare("mark", move_record, mark_record); +#endif + + DUMP_BUSY(); + + /* Find the first moving object */ + for (i = 0; i < chunk_last; i++) { + uint16_t size = ao_scheme_chunk[i].size; + +#if DBG_MEM + if (!size) + ao_scheme_abort(); +#endif + + if (ao_scheme_chunk[i].old_offset > top) + break; + + MDBG_MOVE("chunk %d %d not moving\n", + ao_scheme_chunk[i].old_offset, + ao_scheme_chunk[i].size); +#if DBG_MEM + if (ao_scheme_chunk[i].old_offset != top) + ao_scheme_abort(); +#endif + top += size; + } + + /* + * Limit amount of chunk array used in mapping moves + * to the active region + */ + chunk_first = i; + chunk_low = ao_scheme_chunk[i].old_offset; + + /* Copy all of the objects */ + for (; i < chunk_last; i++) { + uint16_t size = ao_scheme_chunk[i].size; + +#if DBG_MEM + if (!size) + ao_scheme_abort(); +#endif + + MDBG_MOVE("chunk %d %d -> %d\n", + ao_scheme_chunk[i].old_offset, + size, + top); + ao_scheme_chunk[i].new_offset = top; + + memmove(&ao_scheme_pool[top], + &ao_scheme_pool[ao_scheme_chunk[i].old_offset], + size); + + top += size; + } + + if (chunk_first < chunk_last) { + /* Relocate all references to the objects */ + walk(ao_scheme_move, ao_scheme_poly_move); + +#if DBG_MEM + ao_scheme_record_free(move_record); + move_record = ao_scheme_record_save(); + if (mark_record && move_record) + ao_scheme_record_compare("move", mark_record, move_record); +#endif + } + + /* If we ran into the end of the heap, then + * there's no need to keep walking + */ + if (chunk_last != AO_SCHEME_NCHUNK) + break; + + /* Next loop starts right above this loop */ + chunk_low = chunk_high; + } + +#if DBG_MEM_STATS + /* Collect stats */ + ++ao_scheme_collects[style]; + ao_scheme_freed[style] += ao_scheme_top - top; + ao_scheme_loops[style] += loops; +#endif + + ao_scheme_top = top; + if (style == AO_SCHEME_COLLECT_FULL) + ao_scheme_last_top = top; + + MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref)); + + return AO_SCHEME_POOL - ao_scheme_top; +} + +#if DBG_FREE_CONS +void +ao_scheme_cons_check(struct ao_scheme_cons *cons) +{ + ao_poly cdr; + int offset; + + chunk_low = 0; + reset_chunks(); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); + while (cons) { + if (!AO_SCHEME_IS_POOL(cons)) + break; + offset = pool_offset(cons); + if (busy(ao_scheme_busy, offset)) { + ao_scheme_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_scheme_cons_poly(cons), ao_scheme_cons_poly(cons)); + abort(); + } + cdr = cons->cdr; + if (!ao_scheme_is_pair(cdr)) + break; + cons = ao_scheme_poly_cons(cdr); + } +} +#endif + +/* + * Mark interfaces for objects + */ + + +/* + * Mark a block of memory with an explicit size + */ + +int +ao_scheme_mark_block(void *addr, int size) +{ + int offset; + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + offset = pool_offset(addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; + } + mark(ao_scheme_busy, offset); + note_chunk(offset, size); + return 0; +} + +/* + * Note a reference to memory and collect information about a few + * object sizes at a time + */ + +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) +{ + int offset; + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + offset = pool_offset(addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; + } + mark(ao_scheme_busy, offset); + note_chunk(offset, ao_scheme_size(type, addr)); + return 0; +} + +/* + * Mark an object and all that it refereces + */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr) +{ + int ret; + MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE_IN(); + ret = ao_scheme_mark_memory(type, addr); + if (!ret) { + MDBG_MOVE("mark recurse\n"); + type->mark(addr); + } + MDBG_MOVE_OUT(); + return ret; +} + +/* + * Mark an object, unless it is a cons cell and + * do_note_cons is set. In that case, just + * set a bit in the cons note array; those + * will be marked in a separate pass to avoid + * deep recursion in the collector + */ +int +ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) +{ + uint8_t type; + void *addr; + + type = ao_scheme_poly_base_type(p); + + if (type == AO_SCHEME_INT) + return 1; + + addr = ao_scheme_ref(p); + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + if (type == AO_SCHEME_CONS && do_note_cons) { + note_cons(pool_offset(addr)); + return 1; + } else { + if (type == AO_SCHEME_OTHER) + type = ao_scheme_other_type(addr); + + const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM + if (!lisp_type) + ao_scheme_abort(); +#endif + + return ao_scheme_mark(lisp_type, addr); + } +} + +/* + * Find the current location of an object + * based on the original location. For unmoved + * objects, this is simple. For moved objects, + * go search for it + */ + +static uint16_t +move_map(uint16_t offset) +{ + int l; + + if (offset < chunk_low || chunk_high <= offset) + return offset; + + l = find_chunk(offset); + +#if DBG_MEM + if (ao_scheme_chunk[l].old_offset != offset) + ao_scheme_abort(); +#endif + return ao_scheme_chunk[l].new_offset; +} + +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) +{ + void *addr = *ref; + uint16_t offset, orig_offset; + + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + (void) type; + + MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); + orig_offset = pool_offset(addr); + offset = move_map(orig_offset); + if (offset != orig_offset) { + MDBG_MOVE("update ref %d %d -> %d\n", + AO_SCHEME_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, + orig_offset, offset); + *ref = ao_scheme_pool + offset; + } + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already moved\n"); + return 1; + } + mark(ao_scheme_busy, offset); + MDBG_DO(ao_scheme_record(type, addr, ao_scheme_size(type, addr))); + return 0; +} + +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref) +{ + int ret; + MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); + MDBG_MOVE_IN(); + ret = ao_scheme_move_memory(type, ref); + if (!ret) { + MDBG_MOVE("move recurse\n"); + type->move(*ref); + } + MDBG_MOVE_OUT(); + return ret; +} + +int +ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) +{ + uint8_t type; + ao_poly p = *ref; + int ret; + void *addr; + uint16_t offset, orig_offset; + uint8_t base_type; + + base_type = type = ao_scheme_poly_base_type(p); + + if (type == AO_SCHEME_INT) + return 1; + + addr = ao_scheme_ref(p); + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + orig_offset = pool_offset(addr); + offset = move_map(orig_offset); + + if (type == AO_SCHEME_CONS && do_note_cons) { + note_cons(orig_offset); + ret = 1; + } else { + if (type == AO_SCHEME_OTHER) + type = ao_scheme_other_type(ao_scheme_pool + offset); + + const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM + if (!lisp_type) + ao_scheme_abort(); +#endif + + ret = ao_scheme_move(lisp_type, &addr); + } + + /* Re-write the poly value */ + if (offset != orig_offset) { + ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, base_type); + MDBG_MOVE("poly %d moved %d -> %d\n", + type, orig_offset, offset); + *ref = np; + } + return ret; +} + +#if DBG_MEM +void +ao_scheme_validate(void) +{ + chunk_low = 0; + memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +} + +int dbg_allocs; + +#endif + +void * +ao_scheme_alloc(int size) +{ + void *addr; + + MDBG_DO(++dbg_allocs); + MDBG_DO(if (dbg_validate) ao_scheme_validate()); + size = ao_scheme_size_round(size); + if (AO_SCHEME_POOL - ao_scheme_top < size && + ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size && + ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size) + { + ao_scheme_error(AO_SCHEME_OOM, "out of memory"); + return NULL; + } + addr = ao_scheme_pool + ao_scheme_top; + ao_scheme_top += size; + MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); + return addr; +} + +void +ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons) +{ + assert(save_cons[id] == 0); + save_cons[id] = cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id) +{ + struct ao_scheme_cons *cons = save_cons[id]; + save_cons[id] = NULL; + return cons; +} + +void +ao_scheme_poly_stash(int id, ao_poly poly) +{ + assert(save_poly[id] == AO_SCHEME_NIL); + save_poly[id] = poly; +} + +ao_poly +ao_scheme_poly_fetch(int id) +{ + ao_poly poly = save_poly[id]; + save_poly[id] = AO_SCHEME_NIL; + return poly; +} + +void +ao_scheme_string_stash(int id, char *string) +{ + assert(save_string[id] == NULL); + save_string[id] = string; +} + +char * +ao_scheme_string_fetch(int id) +{ + char *string = save_string[id]; + save_string[id] = NULL; + return string; +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame) +{ + assert(save_frame[id] == NULL); + save_frame[id] = frame; +} + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id) +{ + struct ao_scheme_frame *frame = save_frame[id]; + save_frame[id] = NULL; + return frame; +} diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c new file mode 100644 index 00000000..d726321c --- /dev/null +++ b/src/scheme/ao_scheme_poly.c @@ -0,0 +1,118 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +struct ao_scheme_funcs { + void (*write)(ao_poly); + void (*display)(ao_poly); +}; + +static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { + [AO_SCHEME_CONS] = { + .write = ao_scheme_cons_write, + .display = ao_scheme_cons_display, + }, + [AO_SCHEME_STRING] = { + .write = ao_scheme_string_write, + .display = ao_scheme_string_display, + }, + [AO_SCHEME_INT] = { + .write = ao_scheme_int_write, + .display = ao_scheme_int_write, + }, + [AO_SCHEME_ATOM] = { + .write = ao_scheme_atom_write, + .display = ao_scheme_atom_write, + }, + [AO_SCHEME_BUILTIN] = { + .write = ao_scheme_builtin_write, + .display = ao_scheme_builtin_write, + }, + [AO_SCHEME_FRAME] = { + .write = ao_scheme_frame_write, + .display = ao_scheme_frame_write, + }, + [AO_SCHEME_FRAME_VALS] = { + .write = NULL, + .display = NULL, + }, + [AO_SCHEME_LAMBDA] = { + .write = ao_scheme_lambda_write, + .display = ao_scheme_lambda_write, + }, + [AO_SCHEME_STACK] = { + .write = ao_scheme_stack_write, + .display = ao_scheme_stack_write, + }, + [AO_SCHEME_BOOL] = { + .write = ao_scheme_bool_write, + .display = ao_scheme_bool_write, + }, + [AO_SCHEME_BIGINT] = { + .write = ao_scheme_bigint_write, + .display = ao_scheme_bigint_write, + }, + [AO_SCHEME_FLOAT] = { + .write = ao_scheme_float_write, + .display = ao_scheme_float_write, + }, +}; + +static const struct ao_scheme_funcs * +funcs(ao_poly p) +{ + uint8_t type = ao_scheme_poly_type(p); + + if (type < AO_SCHEME_NUM_TYPE) + return &ao_scheme_funcs[type]; + return NULL; +} + +void +ao_scheme_poly_write(ao_poly p) +{ + const struct ao_scheme_funcs *f = funcs(p); + + if (f && f->write) + f->write(p); +} + +void +ao_scheme_poly_display(ao_poly p) +{ + const struct ao_scheme_funcs *f = funcs(p); + + if (f && f->display) + f->display(p); +} + +void * +ao_scheme_ref(ao_poly poly) { + if (poly == AO_SCHEME_NIL) + return NULL; + if (poly & AO_SCHEME_CONST) + return (void *) (ao_scheme_const + (poly & AO_SCHEME_REF_MASK) - 4); + return (void *) (ao_scheme_pool + (poly & AO_SCHEME_REF_MASK) - 4); +} + +ao_poly +ao_scheme_poly(const void *addr, ao_poly type) { + const uint8_t *a = addr; + if (a == NULL) + return AO_SCHEME_NIL; + if (AO_SCHEME_IS_CONST(a)) + return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; + return (a - ao_scheme_pool + 4) | type; +} diff --git a/src/lisp/ao_lisp_read.c b/src/scheme/ao_scheme_read.c similarity index 77% rename from src/lisp/ao_lisp_read.c rename to src/scheme/ao_scheme_read.c index 0ca12a81..6b1e9d66 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/scheme/ao_scheme_read.c @@ -12,8 +12,8 @@ * General Public License for more details. */ -#include "ao_lisp.h" -#include "ao_lisp_read.h" +#include "ao_scheme.h" +#include "ao_scheme_read.h" #include #include @@ -158,7 +158,7 @@ lex_get() c = lex_unget_c; lex_unget_c = 0; } else { - c = ao_lisp_getc(); + c = ao_scheme_getc(); } return c; } @@ -244,15 +244,15 @@ lex_quoted(void) } } -#define AO_LISP_TOKEN_MAX 32 +#define AO_SCHEME_TOKEN_MAX 32 -static char token_string[AO_LISP_TOKEN_MAX]; +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_LISP_TOKEN_MAX - 1) + if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) token_string[token_len++] = c; } @@ -372,7 +372,7 @@ _lex(void) else if (!strcmp(token_string, "formfeed")) token_int = '\f'; else { - ao_lisp_error(AO_LISP_INVALID, "invalid character token #\\%s", token_string); + ao_scheme_error(AO_SCHEME_INVALID, "invalid character token #\\%s", token_string); continue; } return NUM; @@ -470,9 +470,9 @@ static inline int lex(void) static int parse_token; -struct ao_lisp_cons *ao_lisp_read_cons; -struct ao_lisp_cons *ao_lisp_read_cons_tail; -struct ao_lisp_cons *ao_lisp_read_stack; +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 @@ -481,17 +481,17 @@ struct ao_lisp_cons *ao_lisp_read_stack; static int push_read_stack(int cons, int read_state) { - RDBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); + RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); RDBG_IN(); if (cons) { - ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), - ao_lisp__cons(ao_lisp_int_poly(read_state), - ao_lisp_cons_poly(ao_lisp_read_stack))); - if (!ao_lisp_read_stack) + 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_lisp_read_cons = NULL; - ao_lisp_read_cons_tail = NULL; + ao_scheme_read_cons = NULL; + ao_scheme_read_cons_tail = NULL; return 1; } @@ -500,41 +500,41 @@ pop_read_stack(int cons) { int read_state = 0; if (cons) { - ao_lisp_read_cons = ao_lisp_poly_cons(ao_lisp_read_stack->car); - ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); - read_state = ao_lisp_poly_int(ao_lisp_read_stack->car); - ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); - for (ao_lisp_read_cons_tail = ao_lisp_read_cons; - ao_lisp_read_cons_tail && ao_lisp_read_cons_tail->cdr; - ao_lisp_read_cons_tail = ao_lisp_poly_cons(ao_lisp_read_cons_tail->cdr)) + 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_lisp_read_cons = 0; - ao_lisp_read_cons_tail = 0; - ao_lisp_read_stack = 0; + 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_lisp_read_cons, read_state); + RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); return read_state; } ao_poly -ao_lisp_read(void) +ao_scheme_read(void) { - struct ao_lisp_atom *atom; + struct ao_scheme_atom *atom; char *string; int cons; int read_state; - ao_poly v = AO_LISP_NIL; + ao_poly v = AO_SCHEME_NIL; cons = 0; read_state = 0; - ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 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_LISP_NIL; + return AO_SCHEME_NIL; cons++; read_state = 0; parse_token = lex(); @@ -544,75 +544,75 @@ ao_lisp_read(void) case END: default: if (cons) - ao_lisp_error(AO_LISP_EOF, "unexpected end of file"); - return _ao_lisp_atom_eof; + ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); + return _ao_scheme_atom_eof; break; case NAME: - atom = ao_lisp_atom_intern(token_string); + atom = ao_scheme_atom_intern(token_string); if (atom) - v = ao_lisp_atom_poly(atom); + v = ao_scheme_atom_poly(atom); else - v = AO_LISP_NIL; + v = AO_SCHEME_NIL; break; case NUM: - v = ao_lisp_integer_poly(token_int); + v = ao_scheme_integer_poly(token_int); break; case FLOAT: - v = ao_lisp_float_get(token_float); + v = ao_scheme_float_get(token_float); break; case BOOL: if (token_string[0] == 't') - v = _ao_lisp_bool_true; + v = _ao_scheme_bool_true; else - v = _ao_lisp_bool_false; + v = _ao_scheme_bool_false; break; case STRING: - string = ao_lisp_string_copy(token_string); + string = ao_scheme_string_copy(token_string); if (string) - v = ao_lisp_string_poly(string); + v = ao_scheme_string_poly(string); else - v = AO_LISP_NIL; + v = AO_SCHEME_NIL; break; case QUOTE: case QUASIQUOTE: case UNQUOTE: case UNQUOTE_SPLICING: if (!push_read_stack(cons, read_state)) - return AO_LISP_NIL; + return AO_SCHEME_NIL; cons++; read_state = READ_IN_QUOTE; switch (parse_token) { case QUOTE: - v = _ao_lisp_atom_quote; + v = _ao_scheme_atom_quote; break; case QUASIQUOTE: - v = _ao_lisp_atom_quasiquote; + v = _ao_scheme_atom_quasiquote; break; case UNQUOTE: - v = _ao_lisp_atom_unquote; + v = _ao_scheme_atom_unquote; break; case UNQUOTE_SPLICING: - v = _ao_lisp_atom_unquote2dsplicing; + v = _ao_scheme_atom_unquote2dsplicing; break; } break; case CLOSE: if (!cons) { - v = AO_LISP_NIL; + v = AO_SCHEME_NIL; break; } - v = ao_lisp_cons_poly(ao_lisp_read_cons); + v = ao_scheme_cons_poly(ao_scheme_read_cons); --cons; read_state = pop_read_stack(cons); break; case DOT: if (!cons) { - ao_lisp_error(AO_LISP_INVALID, ". outside of cons"); - return AO_LISP_NIL; + ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); + return AO_SCHEME_NIL; } - if (!ao_lisp_read_cons) { - ao_lisp_error(AO_LISP_INVALID, ". first in cons"); - return AO_LISP_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; @@ -624,29 +624,29 @@ ao_lisp_read(void) return v; if (read_state & READ_DONE_DOT) { - ao_lisp_error(AO_LISP_INVALID, ". not last in cons"); - return AO_LISP_NIL; + 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_lisp_read_cons_tail->cdr = v; + ao_scheme_read_cons_tail->cdr = v; } else { - struct ao_lisp_cons *read = ao_lisp_cons_cons(v, AO_LISP_NIL); + struct ao_scheme_cons *read = ao_scheme_cons_cons(v, AO_SCHEME_NIL); if (!read) - return AO_LISP_NIL; + return AO_SCHEME_NIL; - if (ao_lisp_read_cons_tail) - ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); + if (ao_scheme_read_cons_tail) + ao_scheme_read_cons_tail->cdr = ao_scheme_cons_poly(read); else - ao_lisp_read_cons = read; - ao_lisp_read_cons_tail = read; + ao_scheme_read_cons = read; + ao_scheme_read_cons_tail = read; } - if (!(read_state & READ_IN_QUOTE) || !ao_lisp_read_cons->cdr) + if (!(read_state & READ_IN_QUOTE) || !ao_scheme_read_cons->cdr) break; - v = ao_lisp_cons_poly(ao_lisp_read_cons); + v = ao_scheme_cons_poly(ao_scheme_read_cons); --cons; read_state = pop_read_stack(cons); } diff --git a/src/lisp/ao_lisp_read.h b/src/scheme/ao_scheme_read.h similarity index 94% rename from src/lisp/ao_lisp_read.h rename to src/scheme/ao_scheme_read.h index 8f6bf130..e9508835 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/scheme/ao_scheme_read.h @@ -12,8 +12,8 @@ * General Public License for more details. */ -#ifndef _AO_LISP_READ_H_ -#define _AO_LISP_READ_H_ +#ifndef _AO_SCHEME_READ_H_ +#define _AO_SCHEME_READ_H_ /* * token classes @@ -55,4 +55,4 @@ # define INTEGER (DIGIT|SIGN) # define NUMBER (INTEGER|FLOATC) -#endif /* _AO_LISP_READ_H_ */ +#endif /* _AO_SCHEME_READ_H_ */ diff --git a/src/lisp/ao_lisp_rep.c b/src/scheme/ao_scheme_rep.c similarity index 68% rename from src/lisp/ao_lisp_rep.c rename to src/scheme/ao_scheme_rep.c index 43cc387f..9dbce5f2 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/scheme/ao_scheme_rep.c @@ -12,23 +12,23 @@ * General Public License for more details. */ -#include "ao_lisp.h" +#include "ao_scheme.h" ao_poly -ao_lisp_read_eval_print(void) +ao_scheme_read_eval_print(void) { - ao_poly in, out = AO_LISP_NIL; + ao_poly in, out = AO_SCHEME_NIL; for(;;) { - in = ao_lisp_read(); - if (in == _ao_lisp_atom_eof) + in = ao_scheme_read(); + if (in == _ao_scheme_atom_eof) break; - out = ao_lisp_eval(in); - if (ao_lisp_exception) { - if (ao_lisp_exception & AO_LISP_EXIT) + out = ao_scheme_eval(in); + if (ao_scheme_exception) { + if (ao_scheme_exception & AO_SCHEME_EXIT) break; - ao_lisp_exception = 0; + ao_scheme_exception = 0; } else { - ao_lisp_poly_write(out); + ao_scheme_poly_write(out); putchar ('\n'); } } diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c new file mode 100644 index 00000000..af9345b8 --- /dev/null +++ b/src/scheme/ao_scheme_save.c @@ -0,0 +1,77 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +ao_poly +ao_scheme_do_save(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) + return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE + struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + + ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + os->atoms = ao_scheme_atom_poly(ao_scheme_atoms); + os->globals = ao_scheme_frame_poly(ao_scheme_frame_global); + os->const_checksum = ao_scheme_const_checksum; + os->const_checksum_inv = (uint16_t) ~ao_scheme_const_checksum; + + if (ao_scheme_os_save()) + return _ao_scheme_bool_true; +#endif + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_restore(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) + return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE + struct ao_scheme_os_save save; + struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + + if (!ao_scheme_os_restore_save(&save, AO_SCHEME_POOL)) + return ao_scheme_error(AO_SCHEME_INVALID, "header restore failed"); + + if (save.const_checksum != ao_scheme_const_checksum || + save.const_checksum_inv != (uint16_t) ~ao_scheme_const_checksum) + { + return ao_scheme_error(AO_SCHEME_INVALID, "image is corrupted or stale"); + } + + if (ao_scheme_os_restore()) { + + ao_scheme_atoms = ao_scheme_poly_atom(os->atoms); + ao_scheme_frame_global = ao_scheme_poly_frame(os->globals); + + /* Clear the eval global variabls */ + ao_scheme_eval_clear_globals(); + + /* Reset the allocator */ + ao_scheme_top = AO_SCHEME_POOL; + ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + + /* Re-create the evaluator stack */ + if (!ao_scheme_eval_restart()) + return _ao_scheme_bool_false; + + return _ao_scheme_bool_true; + } +#endif + return _ao_scheme_bool_false; +} diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c new file mode 100644 index 00000000..d19dd6d6 --- /dev/null +++ b/src/scheme/ao_scheme_stack.c @@ -0,0 +1,280 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +const struct ao_scheme_type ao_scheme_stack_type; + +static int +stack_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_stack); +} + +static void +stack_mark(void *addr) +{ + struct ao_scheme_stack *stack = addr; + for (;;) { + ao_scheme_poly_mark(stack->sexprs, 0); + ao_scheme_poly_mark(stack->values, 0); + /* no need to mark values_tail */ + ao_scheme_poly_mark(stack->frame, 0); + ao_scheme_poly_mark(stack->list, 0); + stack = ao_scheme_poly_stack(stack->prev); + if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack)) + break; + } +} + +static void +stack_move(void *addr) +{ + struct ao_scheme_stack *stack = addr; + + while (stack) { + struct ao_scheme_stack *prev; + int ret; + (void) ao_scheme_poly_move(&stack->sexprs, 0); + (void) ao_scheme_poly_move(&stack->values, 0); + (void) ao_scheme_poly_move(&stack->values_tail, 0); + (void) ao_scheme_poly_move(&stack->frame, 0); + (void) ao_scheme_poly_move(&stack->list, 0); + prev = ao_scheme_poly_stack(stack->prev); + if (!prev) + break; + ret = ao_scheme_move_memory(&ao_scheme_stack_type, (void **) &prev); + if (prev != ao_scheme_poly_stack(stack->prev)) + stack->prev = ao_scheme_stack_poly(prev); + if (ret) + break; + stack = prev; + } +} + +const struct ao_scheme_type ao_scheme_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move, + .name = "stack" +}; + +struct ao_scheme_stack *ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack) +{ + stack->state = eval_sexpr; + stack->sexprs = AO_SCHEME_NIL; + stack->values = AO_SCHEME_NIL; + stack->values_tail = AO_SCHEME_NIL; +} + +static struct ao_scheme_stack * +ao_scheme_stack_new(void) +{ + struct ao_scheme_stack *stack; + + if (ao_scheme_stack_free_list) { + stack = ao_scheme_stack_free_list; + ao_scheme_stack_free_list = ao_scheme_poly_stack(stack->prev); + } else { + stack = ao_scheme_alloc(sizeof (struct ao_scheme_stack)); + if (!stack) + return 0; + stack->type = AO_SCHEME_STACK; + } + ao_scheme_stack_reset(stack); + return stack; +} + +int +ao_scheme_stack_push(void) +{ + struct ao_scheme_stack *stack; + + stack = ao_scheme_stack_new(); + + if (!stack) + return 0; + + stack->prev = ao_scheme_stack_poly(ao_scheme_stack); + stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); + stack->list = AO_SCHEME_NIL; + + ao_scheme_stack = stack; + + DBGI("stack push\n"); + DBG_FRAMES(); + DBG_IN(); + return 1; +} + +void +ao_scheme_stack_pop(void) +{ + ao_poly prev; + struct ao_scheme_frame *prev_frame; + + if (!ao_scheme_stack) + return; + prev = ao_scheme_stack->prev; + if (!ao_scheme_stack_marked(ao_scheme_stack)) { + ao_scheme_stack->prev = ao_scheme_stack_poly(ao_scheme_stack_free_list); + ao_scheme_stack_free_list = ao_scheme_stack; + } + + ao_scheme_stack = ao_scheme_poly_stack(prev); + prev_frame = ao_scheme_frame_current; + if (ao_scheme_stack) + ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + else + ao_scheme_frame_current = NULL; + if (ao_scheme_frame_current != prev_frame) + ao_scheme_frame_free(prev_frame); + DBG_OUT(); + DBGI("stack pop\n"); + DBG_FRAMES(); +} + +void +ao_scheme_stack_clear(void) +{ + ao_scheme_stack = NULL; + ao_scheme_frame_current = NULL; + ao_scheme_v = AO_SCHEME_NIL; +} + +void +ao_scheme_stack_write(ao_poly poly) +{ + struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + + while (s) { + if (s->type & AO_SCHEME_STACK_PRINT) { + printf("[recurse...]"); + return; + } + s->type |= AO_SCHEME_STACK_PRINT; + printf("\t[\n"); + printf("\t\texpr: "); ao_scheme_poly_write(s->list); printf("\n"); + printf("\t\tstate: %s\n", ao_scheme_state_names[s->state]); + ao_scheme_error_poly ("values: ", s->values, s->values_tail); + ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL); + ao_scheme_error_frame(2, "frame: ", ao_scheme_poly_frame(s->frame)); + printf("\t]\n"); + s->type &= ~AO_SCHEME_STACK_PRINT; + s = ao_scheme_poly_stack(s->prev); + } +} + +/* + * Copy a stack, being careful to keep everybody referenced + */ +static struct ao_scheme_stack * +ao_scheme_stack_copy(struct ao_scheme_stack *old) +{ + struct ao_scheme_stack *new = NULL; + struct ao_scheme_stack *n, *prev = NULL; + + while (old) { + ao_scheme_stack_stash(0, old); + ao_scheme_stack_stash(1, new); + ao_scheme_stack_stash(2, prev); + n = ao_scheme_stack_new(); + prev = ao_scheme_stack_fetch(2); + new = ao_scheme_stack_fetch(1); + old = ao_scheme_stack_fetch(0); + if (!n) + return NULL; + + ao_scheme_stack_mark(old); + ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame)); + *n = *old; + + if (prev) + prev->prev = ao_scheme_stack_poly(n); + else + new = n; + prev = n; + + old = ao_scheme_poly_stack(old->prev); + } + return new; +} + +/* + * Evaluate a continuation invocation + */ +ao_poly +ao_scheme_stack_eval(void) +{ + struct ao_scheme_stack *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); + if (!new) + return AO_SCHEME_NIL; + + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + + if (!cons || !cons->cdr) + return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value"); + + new->state = eval_val; + + ao_scheme_stack = new; + ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + + return ao_scheme_poly_cons(cons->cdr)->car; +} + +/* + * Call with current continuation. This calls a lambda, passing + * it a single argument which is the current continuation + */ +ao_poly +ao_scheme_do_call_cc(struct ao_scheme_cons *cons) +{ + struct ao_scheme_stack *new; + ao_poly v; + + /* Make sure the single parameter is a lambda */ + if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0)) + return AO_SCHEME_NIL; + + /* go get the lambda */ + ao_scheme_v = ao_scheme_arg(cons, 0); + + /* Note that the whole call chain now has + * a reference to it which may escape + */ + new = ao_scheme_stack_copy(ao_scheme_stack); + if (!new) + return AO_SCHEME_NIL; + + /* re-fetch cons after the allocation */ + cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr); + + /* Reset the arg list to the current stack, + * and call the lambda + */ + + cons->car = ao_scheme_stack_poly(new); + cons->cdr = AO_SCHEME_NIL; + v = ao_scheme_lambda_eval(); + ao_scheme_stack->sexprs = v; + ao_scheme_stack->state = eval_begin; + return AO_SCHEME_NIL; +} diff --git a/src/lisp/ao_lisp_string.c b/src/scheme/ao_scheme_string.c similarity index 55% rename from src/lisp/ao_lisp_string.c rename to src/scheme/ao_scheme_string.c index 1daa50ea..e25306cb 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/scheme/ao_scheme_string.c @@ -15,7 +15,7 @@ * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. */ -#include "ao_lisp.h" +#include "ao_scheme.h" static void string_mark(void *addr) { @@ -34,7 +34,7 @@ static void string_move(void *addr) (void) addr; } -const struct ao_lisp_type ao_lisp_string_type = { +const struct ao_scheme_type ao_scheme_string_type = { .mark = string_mark, .size = string_size, .move = string_move, @@ -42,13 +42,13 @@ const struct ao_lisp_type ao_lisp_string_type = { }; char * -ao_lisp_string_copy(char *a) +ao_scheme_string_copy(char *a) { int alen = strlen(a); - ao_lisp_string_stash(0, a); - char *r = ao_lisp_alloc(alen + 1); - a = ao_lisp_string_fetch(0); + 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); @@ -56,16 +56,16 @@ ao_lisp_string_copy(char *a) } char * -ao_lisp_string_cat(char *a, char *b) +ao_scheme_string_cat(char *a, char *b) { int alen = strlen(a); int blen = strlen(b); - ao_lisp_string_stash(0, a); - ao_lisp_string_stash(1, b); - char *r = ao_lisp_alloc(alen + blen + 1); - a = ao_lisp_string_fetch(0); - b = ao_lisp_string_fetch(1); + 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); @@ -74,57 +74,57 @@ ao_lisp_string_cat(char *a, char *b) } ao_poly -ao_lisp_string_pack(struct ao_lisp_cons *cons) +ao_scheme_string_pack(struct ao_scheme_cons *cons) { - int len = ao_lisp_cons_length(cons); - ao_lisp_cons_stash(0, cons); - char *r = ao_lisp_alloc(len + 1); - cons = ao_lisp_cons_fetch(0); + 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_lisp_integer_typep(ao_lisp_poly_type(cons->car))) - return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); - *s++ = ao_lisp_poly_integer(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); + 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_lisp_string_poly(r); + return ao_scheme_string_poly(r); } ao_poly -ao_lisp_string_unpack(char *a) +ao_scheme_string_unpack(char *a) { - struct ao_lisp_cons *cons = NULL, *tail = NULL; + struct ao_scheme_cons *cons = NULL, *tail = NULL; int c; int i; for (i = 0; (c = a[i]); i++) { - ao_lisp_cons_stash(0, cons); - ao_lisp_cons_stash(1, tail); - ao_lisp_string_stash(0, a); - struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), AO_LISP_NIL); - a = ao_lisp_string_fetch(0); - cons = ao_lisp_cons_fetch(0); - tail = ao_lisp_cons_fetch(1); + 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_lisp_cons_poly(n); + tail->cdr = ao_scheme_cons_poly(n); else cons = n; tail = n; } - return ao_lisp_cons_poly(cons); + return ao_scheme_cons_poly(cons); } void -ao_lisp_string_write(ao_poly p) +ao_scheme_string_write(ao_poly p) { - char *s = ao_lisp_poly_string(p); + char *s = ao_scheme_poly_string(p); char c; putchar('"'); @@ -151,9 +151,9 @@ ao_lisp_string_write(ao_poly p) } void -ao_lisp_string_display(ao_poly p) +ao_scheme_string_display(ao_poly p) { - char *s = ao_lisp_poly_string(p); + char *s = ao_scheme_poly_string(p); char c; while ((c = *s++)) 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/lisp/ao_lisp_os.h b/src/scheme/make-const/ao_scheme_os.h similarity index 67% rename from src/lisp/ao_lisp_os.h rename to src/scheme/make-const/ao_scheme_os.h index 4285cb8c..f06bbbb1 100644 --- a/src/lisp/ao_lisp_os.h +++ b/src/scheme/make-const/ao_scheme_os.h @@ -15,49 +15,49 @@ * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. */ -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ #include #include #include -extern int ao_lisp_getc(void); +extern int ao_scheme_getc(void); static inline void -ao_lisp_os_flush(void) { +ao_scheme_os_flush(void) { fflush(stdout); } static inline void -ao_lisp_abort(void) +ao_scheme_abort(void) { abort(); } static inline void -ao_lisp_os_led(int led) +ao_scheme_os_led(int led) { printf("leds set to 0x%x\n", led); } -#define AO_LISP_JIFFIES_PER_SECOND 100 +#define AO_SCHEME_JIFFIES_PER_SECOND 100 static inline void -ao_lisp_os_delay(int jiffies) +ao_scheme_os_delay(int jiffies) { struct timespec ts = { - .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) + .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_lisp_os_jiffy(void) +ao_scheme_os_jiffy(void) { struct timespec tp; clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); + return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); } #endif diff --git a/src/test/ao_lisp_os.h b/src/test/ao_scheme_os.h similarity index 100% rename from src/test/ao_lisp_os.h rename to src/test/ao_scheme_os.h diff --git a/src/test/ao_lisp_test.c b/src/test/ao_scheme_test.c similarity index 100% rename from src/test/ao_lisp_test.c rename to src/test/ao_scheme_test.c -- 2.30.2