From f26cc1a677f577da533425a15485fcaa24626b23 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 10 Jan 2018 23:11:40 -0800 Subject: [PATCH] altos/scheme: Move ao-scheme to a separate repository This way it can be incorporated into multiple operating systems more easily. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/Makefile | 12 +- src/scheme/.gitignore | 2 - src/scheme/Makefile | 25 - src/scheme/Makefile-inc | 35 - src/scheme/Makefile-scheme | 4 - src/scheme/README | 10 - src/scheme/ao_scheme.h | 1207 ----------------- src/scheme/ao_scheme_advanced_syntax.scheme | 388 ------ src/scheme/ao_scheme_atom.c | 298 ---- src/scheme/ao_scheme_basic_syntax.scheme | 414 ------ src/scheme/ao_scheme_bool.c | 80 -- src/scheme/ao_scheme_builtin.c | 1008 -------------- src/scheme/ao_scheme_builtin.txt | 100 -- src/scheme/ao_scheme_char.scheme | 80 -- src/scheme/ao_scheme_cons.c | 402 ------ src/scheme/ao_scheme_const.scheme | 916 ------------- src/scheme/ao_scheme_do.scheme | 34 - src/scheme/ao_scheme_error.c | 78 -- src/scheme/ao_scheme_eval.c | 573 -------- src/scheme/ao_scheme_finish.scheme | 17 - src/scheme/ao_scheme_float.c | 161 --- src/scheme/ao_scheme_frame.c | 391 ------ src/scheme/ao_scheme_int.c | 132 -- src/scheme/ao_scheme_lambda.c | 208 --- src/scheme/ao_scheme_lex.c | 16 - src/scheme/ao_scheme_make_builtin | 318 ----- src/scheme/ao_scheme_make_const.c | 543 -------- src/scheme/ao_scheme_mem.c | 1117 --------------- src/scheme/ao_scheme_poly.c | 74 - src/scheme/ao_scheme_port.c | 193 --- src/scheme/ao_scheme_port.scheme | 43 - src/scheme/ao_scheme_read.c | 727 ---------- src/scheme/ao_scheme_read.h | 76 -- src/scheme/ao_scheme_rep.c | 42 - src/scheme/ao_scheme_save.c | 89 -- src/scheme/ao_scheme_stack.c | 279 ---- src/scheme/ao_scheme_string.c | 349 ----- src/scheme/ao_scheme_string.scheme | 156 --- src/scheme/ao_scheme_vector.c | 284 ---- src/scheme/ao_scheme_vector.scheme | 192 --- src/scheme/make-const/.gitignore | 1 - src/scheme/make-const/Makefile | 26 - src/scheme/make-const/ao_scheme_os.h | 63 - src/scheme/test/.gitignore | 1 - src/scheme/test/Makefile | 33 - src/scheme/test/ao_scheme_os.h | 53 - src/scheme/test/ao_scheme_test.c | 188 --- src/scheme/test/ao_scheme_test.scheme | 175 --- src/scheme/test/hanoi.scheme | 177 --- src/scheme/tiny-test/.gitignore | 1 - src/scheme/tiny-test/Makefile | 32 - src/scheme/tiny-test/ao_scheme_os.h | 53 - .../tiny-test/ao_scheme_tiny_const.scheme | 389 ------ .../tiny-test/ao_scheme_tiny_test.scheme | 56 - src/stmf0/Makefile-stmf0.defs | 2 +- 55 files changed, 8 insertions(+), 12315 deletions(-) delete mode 100644 src/scheme/.gitignore delete mode 100644 src/scheme/Makefile delete mode 100644 src/scheme/Makefile-inc delete mode 100644 src/scheme/Makefile-scheme delete mode 100644 src/scheme/README delete mode 100644 src/scheme/ao_scheme.h delete mode 100644 src/scheme/ao_scheme_advanced_syntax.scheme delete mode 100644 src/scheme/ao_scheme_atom.c delete mode 100644 src/scheme/ao_scheme_basic_syntax.scheme delete mode 100644 src/scheme/ao_scheme_bool.c delete mode 100644 src/scheme/ao_scheme_builtin.c delete mode 100644 src/scheme/ao_scheme_builtin.txt delete mode 100644 src/scheme/ao_scheme_char.scheme delete mode 100644 src/scheme/ao_scheme_cons.c delete mode 100644 src/scheme/ao_scheme_const.scheme delete mode 100644 src/scheme/ao_scheme_do.scheme delete mode 100644 src/scheme/ao_scheme_error.c delete mode 100644 src/scheme/ao_scheme_eval.c delete mode 100644 src/scheme/ao_scheme_finish.scheme delete mode 100644 src/scheme/ao_scheme_float.c delete mode 100644 src/scheme/ao_scheme_frame.c delete mode 100644 src/scheme/ao_scheme_int.c delete mode 100644 src/scheme/ao_scheme_lambda.c delete mode 100644 src/scheme/ao_scheme_lex.c delete mode 100644 src/scheme/ao_scheme_make_builtin delete mode 100644 src/scheme/ao_scheme_make_const.c delete mode 100644 src/scheme/ao_scheme_mem.c delete mode 100644 src/scheme/ao_scheme_poly.c delete mode 100644 src/scheme/ao_scheme_port.c delete mode 100644 src/scheme/ao_scheme_port.scheme delete mode 100644 src/scheme/ao_scheme_read.c delete mode 100644 src/scheme/ao_scheme_read.h delete mode 100644 src/scheme/ao_scheme_rep.c delete mode 100644 src/scheme/ao_scheme_save.c delete mode 100644 src/scheme/ao_scheme_stack.c delete mode 100644 src/scheme/ao_scheme_string.c delete mode 100644 src/scheme/ao_scheme_string.scheme delete mode 100644 src/scheme/ao_scheme_vector.c delete mode 100644 src/scheme/ao_scheme_vector.scheme delete mode 100644 src/scheme/make-const/.gitignore delete mode 100644 src/scheme/make-const/Makefile delete mode 100644 src/scheme/make-const/ao_scheme_os.h delete mode 100644 src/scheme/test/.gitignore delete mode 100644 src/scheme/test/Makefile delete mode 100644 src/scheme/test/ao_scheme_os.h delete mode 100644 src/scheme/test/ao_scheme_test.c delete mode 100644 src/scheme/test/ao_scheme_test.scheme delete mode 100755 src/scheme/test/hanoi.scheme delete mode 100644 src/scheme/tiny-test/.gitignore delete mode 100644 src/scheme/tiny-test/Makefile delete mode 100644 src/scheme/tiny-test/ao_scheme_os.h delete mode 100644 src/scheme/tiny-test/ao_scheme_tiny_const.scheme delete mode 100644 src/scheme/tiny-test/ao_scheme_tiny_test.scheme diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index 9d30c521..33c68cf5 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -5,10 +5,9 @@ include ../stmf0/Makefile.defs -include ../scheme/Makefile-inc +aoschemelib=$(shell pkg-config --variable=aoschemelib ao-scheme) -vpath %.scheme ../scheme -vpath ao_scheme_make_const ../scheme/make-const +include $(aoschemelib)/Makefile-scheme NEWLIB_FULL=-lm -lc -lgcc @@ -54,7 +53,7 @@ MAP=$(PROG).map NEWLIB=/local/newlib-mini MAPFILE=-Wl,-Map=$(MAP) LDFLAGS=-L../stmf0 -L$(NEWLIB)/arm-none-eabi/lib/thumb/v6-m/ -Wl,-Tlambda.ld $(MAPFILE) -nostartfiles -AO_CFLAGS=-I. -I../stmf0 -I../kernel -I../drivers -I.. -I../scheme -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB +AO_CFLAGS=-I. -I../stmf0 -I../kernel -I../drivers -I.. -I$(aoschemelib) -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB PROGNAME=lambdakey-v1.0 PROG=$(PROGNAME)-$(VERSION).elf @@ -63,6 +62,9 @@ HEX=$(PROGNAME)-$(VERSION).ihx SRC=$(ALTOS_SRC) ao_lambdakey.c OBJ=$(SRC:.c=.o) +bletch: + echo lib is $(aoschemelib) + all: $(PROG) $(HEX) $(PROG): Makefile $(OBJ) lambda.ld @@ -73,7 +75,7 @@ $(OBJ): $(INC) ao_product.h: ao-make-product.5c ../Version $(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@ -ao_scheme_const.h: ao_scheme_make_const ao_scheme_basic_syntax.scheme +ao_scheme_const.h: ao-scheme-make-const ao_scheme_basic_syntax.scheme $^ -o $@ -d FLOAT,VECTOR,QUASI,BIGINT,POSIX,PORT,SAVE,UNDEF load: $(PROG) diff --git a/src/scheme/.gitignore b/src/scheme/.gitignore deleted file mode 100644 index ee72cb9d..00000000 --- a/src/scheme/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -ao_scheme_const.h -ao_scheme_builtin.h diff --git a/src/scheme/Makefile b/src/scheme/Makefile deleted file mode 100644 index be312754..00000000 --- a/src/scheme/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -all: ao_scheme_builtin.h make-const/ao_scheme_make_const test/ao-scheme tiny-test/ao-scheme-tiny - -clean: - +cd make-const && make clean - +cd test && make clean - +cd tiny-test && make clean - rm -f ao_scheme_builtin.h - -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 ao_scheme_builtin.h - +cd make-const && make ao_scheme_make_const - -test/ao-scheme: FRC ao_scheme_builtin.h make-const/ao_scheme_make_const - +cd test && make - -tiny-test/ao-scheme-tiny: FRC ao_scheme_builtin.h make-const/ao_scheme_make_const - +cd tiny-test && make - -install: all - +cd test && make install - +cd tiny-test && make install - -FRC: diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc deleted file mode 100644 index ed3f7f5f..00000000 --- a/src/scheme/Makefile-inc +++ /dev/null @@ -1,35 +0,0 @@ -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 \ - ao_scheme_vector.c \ - ao_scheme_port.c - -SCHEME_HDRS=\ - ao_scheme.h \ - ao_scheme_os.h \ - ao_scheme_read.h \ - ao_scheme_builtin.h - -SCHEME_SCHEME=\ - ao_scheme_basic_syntax.scheme \ - ao_scheme_advanced_syntax.scheme \ - ao_scheme_vector.scheme \ - ao_scheme_string.scheme \ - ao_scheme_char.scheme \ - ao_scheme_port.scheme \ - ao_scheme_finish.scheme diff --git a/src/scheme/Makefile-scheme b/src/scheme/Makefile-scheme deleted file mode 100644 index b9018e19..00000000 --- a/src/scheme/Makefile-scheme +++ /dev/null @@ -1,4 +0,0 @@ -include ../scheme/Makefile-inc - -ao_scheme_const.h: $(SCHEME_SRCS) $(SCHEME_HDRS) - +cd ../scheme && make $@ diff --git a/src/scheme/README b/src/scheme/README deleted file mode 100644 index a18457fd..00000000 --- a/src/scheme/README +++ /dev/null @@ -1,10 +0,0 @@ -This follows the R7RS with the following known exceptions: - -* No vectors or bytevectors -* Characters are just numbers -* No dynamic-wind or exceptions -* No environments -* No ports -* No syntax-rules -* No record types -* No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h deleted file mode 100644 index 9ce239a6..00000000 --- a/src/scheme/ao_scheme.h +++ /dev/null @@ -1,1207 +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_SCHEME_H_ -#define _AO_SCHEME_H_ - -#ifndef DBG_MEM -#define DBG_MEM 0 -#endif -#ifndef DBG_EVAL -#define DBG_EVAL 0 -#endif -#ifndef DBG_READ -#define DBG_READ 0 -#endif -#ifndef DBG_FREE_CONS -#define DBG_FREE_CONS 0 -#endif -#define NDEBUG 1 - -#include -#include -#include -#include -#define AO_SCHEME_BUILTIN_FEATURES -#include "ao_scheme_builtin.h" -#undef AO_SCHEME_BUILTIN_FEATURES -#ifndef __BYTE_ORDER -#include -#endif - -typedef uint16_t ao_poly; -typedef int16_t ao_signed_poly; - -#ifdef AO_SCHEME_MAKE_CONST -#define AO_SCHEME_POOL_CONST 32764 -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((char *) 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" - -#ifdef AO_SCHEME_FEATURE_SAVE - -struct ao_scheme_os_save { - ao_poly atoms; - ao_poly globals; - uint16_t const_checksum; - uint16_t const_checksum_inv; -}; - -#ifndef AO_SCHEME_POOL_TOTAL -#error Must define AO_SCHEME_POOL_TOTAL for AO_SCHEME_FEATURE_SAVE -#endif - -#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 /* AO_SCHEME_FEATURE_SAVE */ - -#ifndef AO_SCHEME_POOL -#error Must define AO_SCHEME_POOL -#endif -#ifndef AO_SCHEME_POOL_EXTRA -#define AO_SCHEME_POOL_EXTRA 0 -#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_BIGINT 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_STRING 11 -#ifdef AO_SCHEME_FEATURE_FLOAT -#define AO_SCHEME_FLOAT 12 -#define _AO_SCHEME_FLOAT AO_SCHEME_FLOAT -#else -#define _AO_SCHEME_FLOAT 12 -#endif -#ifdef AO_SCHEME_FEATURE_VECTOR -#define AO_SCHEME_VECTOR 13 -#define _AO_SCHEME_VECTOR AO_SCHEME_VECTOR -#else -#define _AO_SCHEME_VECTOR _AO_SCHEME_FLOAT -#endif -#ifdef AO_SCHEME_FEATURE_PORT -#define AO_SCHEME_PORT 14 -#define _AO_SCHEME_PORT AO_SCHEME_PORT -#else -#define _AO_SCHEME_PORT _AO_SCHEME_VECTOR -#endif -#define AO_SCHEME_NUM_TYPE (_AO_SCHEME_PORT+1) - -/* 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_FILEERROR 0x40 -#define AO_SCHEME_EXIT 0x80 - -extern uint8_t ao_scheme_exception; - -static inline int -ao_scheme_is_const(ao_poly poly) { - return poly & AO_SCHEME_CONST; -} - -static inline int -ao_scheme_is_const_addr(const void *addr) { - const uint8_t *a = addr; - return (ao_scheme_const <= a) && (a < ao_scheme_const + AO_SCHEME_POOL_CONST); -} - -static inline int -ao_scheme_is_pool_addr(const void *addr) { - const uint8_t *a = addr; - return (ao_scheme_pool <= a) && (a < ao_scheme_pool + AO_SCHEME_POOL); -} - -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_string { - uint8_t type; - char val[]; -}; - -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; -}; - - -#ifdef AO_SCHEME_FEATURE_FLOAT -struct ao_scheme_float { - uint8_t type; - uint8_t pad1; - uint16_t pad2; - float value; -}; -#endif - -#ifdef AO_SCHEME_FEATURE_VECTOR -struct ao_scheme_vector { - uint8_t type; - uint8_t pad1; - uint16_t length; - ao_poly vals[]; -}; -#endif - -#ifdef AO_SCHEME_FEATURE_PORT -struct ao_scheme_port { - uint8_t type; - uint8_t stayopen; - ao_poly next; - FILE *file; -}; -#endif - -#define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) -#define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) - -#ifdef AO_SCHEME_FEATURE_BIGINT - -struct ao_scheme_bigint { - uint32_t value; -}; - -#define AO_SCHEME_MIN_BIGINT INT32_MIN -#define AO_SCHEME_MAX_BIGINT INT32_MAX - -#endif /* AO_SCHEME_FEATURE_BIGINT */ - -/* Set on type when the frame escapes the lambda */ -#define AO_SCHEME_FRAME_MARK 0x80 - -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 */ - -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; -} - -#ifdef AO_SCHEME_FEATURE_BIGINT -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_BIGINT); -} -#endif /* AO_SCHEME_FEATURE_BIGINT */ - -static inline struct ao_scheme_string * -ao_scheme_poly_string(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_string_poly(struct ao_scheme_string *s) -{ - return ao_scheme_poly(s, AO_SCHEME_OTHER); -} - -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); -} - -#ifdef AO_SCHEME_FEATURE_FLOAT -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); -#endif - -#ifdef AO_SCHEME_FEATURE_VECTOR -static inline ao_poly -ao_scheme_vector_poly(struct ao_scheme_vector *v) -{ - return ao_scheme_poly(v, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_vector * -ao_scheme_poly_vector(ao_poly poly) -{ - return ao_scheme_ref(poly); -} -#endif - -#ifdef AO_SCHEME_FEATURE_PORT -static inline ao_poly -ao_scheme_port_poly(struct ao_scheme_port *v) -{ - return ao_scheme_poly(v, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_port * -ao_scheme_poly_port(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -extern ao_poly ao_scheme_stdin, ao_scheme_stdout, ao_scheme_stderr; - -#endif - -/* memory functions */ - -extern uint64_t ao_scheme_collects[2]; -extern uint64_t ao_scheme_freed[2]; -extern uint64_t ao_scheme_loops[2]; - -/* returns 1 if the object was already marked */ -int -ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); - -/* returns 1 if the object is marked */ -int -ao_scheme_marked(void *addr); - -/* 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); - -/* Marks an object as being printed, returns 1 if it was already marked */ -int -ao_scheme_print_mark_addr(void *addr); - -void -ao_scheme_print_clear_addr(void *addr); - -/* Notes that printing has started */ -void -ao_scheme_print_start(void); - -/* Notes that printing has ended, returns 1 if printing is still happening */ -int -ao_scheme_print_stop(void); - -#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_poly_stash(ao_poly poly); - -ao_poly -ao_scheme_poly_fetch(void); - -static inline void -ao_scheme_cons_stash(struct ao_scheme_cons *cons) { - ao_scheme_poly_stash(ao_scheme_cons_poly(cons)); -} - -static inline struct ao_scheme_cons * -ao_scheme_cons_fetch(void) { - return ao_scheme_poly_cons(ao_scheme_poly_fetch()); -} - -static inline void -ao_scheme_atom_stash(struct ao_scheme_atom *atom) { - ao_scheme_poly_stash(ao_scheme_atom_poly(atom)); -} - -static inline struct ao_scheme_atom * -ao_scheme_atom_fetch(void) { - return ao_scheme_poly_atom(ao_scheme_poly_fetch()); -} - -static inline void -ao_scheme_string_stash(struct ao_scheme_string *string) { - ao_scheme_poly_stash(ao_scheme_string_poly(string)); -} - -static inline struct ao_scheme_string * -ao_scheme_string_fetch(void) { - return ao_scheme_poly_string(ao_scheme_poly_fetch()); -} - -#ifdef AO_SCHEME_FEATURE_VECTOR -static inline void -ao_scheme_vector_stash(struct ao_scheme_vector *vector) { - ao_scheme_poly_stash(ao_scheme_vector_poly(vector)); -} - -static inline struct ao_scheme_vector * -ao_scheme_vector_fetch(void) { - return ao_scheme_poly_vector(ao_scheme_poly_fetch()); -} -#endif - -#ifdef AO_SCHEME_FEATURE_PORT -static inline void -ao_scheme_port_stash(struct ao_scheme_port *port) { - ao_scheme_poly_stash(ao_scheme_port_poly(port)); -} - -static inline struct ao_scheme_port * -ao_scheme_port_fetch(void) { - return ao_scheme_poly_port(ao_scheme_poly_fetch()); -} -#endif - -static inline void -ao_scheme_stack_stash(struct ao_scheme_stack *stack) { - ao_scheme_poly_stash(ao_scheme_stack_poly(stack)); -} - -static inline struct ao_scheme_stack * -ao_scheme_stack_fetch(void) { - return ao_scheme_poly_stack(ao_scheme_poly_fetch()); -} - -static inline void -ao_scheme_frame_stash(struct ao_scheme_frame *frame) { - ao_scheme_poly_stash(ao_scheme_frame_poly(frame)); -} - -static inline struct ao_scheme_frame * -ao_scheme_frame_fetch(void) { - return ao_scheme_poly_frame(ao_scheme_poly_fetch()); -} - -/* bool */ - -extern const struct ao_scheme_type ao_scheme_bool_type; - -void -ao_scheme_bool_write(FILE *out, ao_poly v, bool write); - -#ifdef AO_SCHEME_MAKE_CONST -extern 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(FILE *out, ao_poly, bool write); - -int -ao_scheme_cons_length(struct ao_scheme_cons *cons); - -/* string */ -extern const struct ao_scheme_type ao_scheme_string_type; - -struct ao_scheme_string * -ao_scheme_string_new(char *a); - -struct ao_scheme_string * -ao_scheme_atom_to_string(struct ao_scheme_atom *a); - -struct ao_scheme_string * -ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b); - -void -ao_scheme_string_write(FILE *out, ao_poly s, bool write); - -/* 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(FILE *out, ao_poly a, bool write); - -struct ao_scheme_atom * -ao_scheme_string_to_atom(struct ao_scheme_string *string); - -struct ao_scheme_atom * -ao_scheme_atom_intern(char *name); - -void -ao_scheme_atom_check_references(void); - -void -ao_scheme_atom_move(void); - -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_def(ao_poly atom, ao_poly val); - -/* int */ -void -ao_scheme_int_write(FILE *out, ao_poly i, bool write); - -#ifdef AO_SCHEME_FEATURE_BIGINT -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(FILE *out, ao_poly i, bool write); - -extern const struct ao_scheme_type ao_scheme_bigint_type; - -#else - -static inline int32_t ao_scheme_poly_integer(ao_poly poly) { - return ao_scheme_poly_int(poly); -} - -static inline ao_poly ao_scheme_integer_poly(int32_t i) { - return ao_scheme_int_poly(i); -} - -static inline int -ao_scheme_integer_typep(uint8_t t) -{ - return (t == AO_SCHEME_INT); -} - -#endif /* AO_SCHEME_FEATURE_BIGINT */ - -/* vector */ - -#ifdef AO_SCHEME_FEATURE_VECTOR - -void -ao_scheme_vector_write(FILE *OUT, ao_poly v, bool write); - -struct ao_scheme_vector * -ao_scheme_vector_alloc(uint16_t length, ao_poly fill); - -struct ao_scheme_vector * -ao_scheme_list_to_vector(struct ao_scheme_cons *cons); - -struct ao_scheme_cons * -ao_scheme_vector_to_list(struct ao_scheme_vector *vector, int start, int end); - -extern const struct ao_scheme_type ao_scheme_vector_type; - -#endif /* AO_SCHEME_FEATURE_VECTOR */ - -/* port */ - -#ifdef AO_SCHEME_FEATURE_PORT - -void -ao_scheme_port_write(FILE *out, ao_poly v, bool write); - -struct ao_scheme_port * -ao_scheme_port_alloc(FILE *file, bool stayopen); - -void -ao_scheme_port_close(struct ao_scheme_port *port); - -void -ao_scheme_port_check_references(void); - -extern ao_poly ao_scheme_open_ports; - -static inline int -ao_scheme_port_getc(struct ao_scheme_port *port) -{ - if (port->file) - return getc(port->file); - return EOF; -} - -static inline int -ao_scheme_port_putc(struct ao_scheme_port *port, char c) -{ - if (port->file) - return putc(c, port->file); - return EOF; -} - -static inline int -ao_scheme_port_ungetc(struct ao_scheme_port *port, char c) -{ - if (port->file) - return ungetc(c, port->file); - return EOF; -} - -extern const struct ao_scheme_type ao_scheme_port_type; - -#endif /* AO_SCHEME_FEATURE_PORT */ - -#ifdef AO_SCHEME_FEATURE_POSIX - -void -ao_scheme_set_argv(char **argv); - -#endif - -/* prim */ -void (*ao_scheme_poly_write_func(ao_poly p))(FILE *out, ao_poly p, bool write); - -static inline void -ao_scheme_poly_write(FILE *out, ao_poly p, bool write) { (*ao_scheme_poly_write_func(p))(out, p, write); } - -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 */ - -#ifdef AO_SCHEME_FEATURE_SAVE -void -ao_scheme_eval_clear_globals(void); - -int -ao_scheme_eval_restart(void); -#endif - -ao_poly -ao_scheme_eval(ao_poly p); - -ao_poly -ao_scheme_set_cond(struct ao_scheme_cons *cons); - -/* float */ -#ifdef AO_SCHEME_FEATURE_FLOAT -extern const struct ao_scheme_type ao_scheme_float_type; - -void -ao_scheme_float_write(FILE *out, ao_poly p, bool write); - -ao_poly -ao_scheme_float_get(float value); -#endif - -#ifdef AO_SCHEME_FEATURE_FLOAT -static inline bool -ao_scheme_number_typep(uint8_t t) -{ - return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); -} -#else -#define ao_scheme_number_typep ao_scheme_integer_typep -#endif - -static inline bool -ao_scheme_is_integer(ao_poly poly) { - return ao_scheme_integer_typep(ao_scheme_poly_base_type(poly)); -} - -static inline bool -ao_scheme_is_number(ao_poly poly) { - return ao_scheme_number_typep(ao_scheme_poly_type(poly)); -} - -/* builtin */ -void -ao_scheme_builtin_write(FILE *out, ao_poly b, bool write); - -ao_poly -ao_scheme_do_typep(ao_poly proc, int type, struct ao_scheme_cons *cons); - -extern const struct ao_scheme_type ao_scheme_builtin_type; - -#define AO_SCHEME_ARG_OPTIONAL 0x100 -#define AO_SCHEME_ARG_NIL_OK 0x200 -#define AO_SCHEME_ARG_RET_POLY 0x400 -#define AO_SCHEME_ARG_END -1 -#define AO_SCHEME_POLY 0xff -#define AO_SCHEME_ARG_MASK 0xff - -int -ao_scheme_parse_args(ao_poly name, struct ao_scheme_cons *cons, ...); - -/* 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 int ao_scheme_read_list; -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(FILE *in); - -/* rep */ -ao_poly -ao_scheme_read_eval_print(FILE *read_file, FILE *write_file, bool interactive); - -/* 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); - -#ifdef AO_SCHEME_FEATURE_UNDEF -ao_poly -ao_scheme_frame_del(struct ao_scheme_frame *frame, ao_poly atom); -#endif - -void -ao_scheme_frame_write(FILE *out, ao_poly p, bool write); - -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(FILE *out, ao_poly lambda, bool write); - -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; - -extern int ao_scheme_frame_print_indent; - -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_write(FILE *out, ao_poly stack, bool write); - -ao_poly -ao_scheme_stack_eval(void); - -/* error */ - -void -ao_scheme_vfprintf(FILE *out, const char *format, va_list args); - -void -ao_scheme_fprintf(FILE *out, const char *format, ...); - -ao_poly -ao_scheme_error(int error, const char *format, ...); - -/* builtins */ - -#define AO_SCHEME_BUILTIN_DECLS -#include "ao_scheme_builtin.h" - -/* debugging macros */ - -#if DBG_EVAL || DBG_READ -int ao_scheme_stack_depth; -#endif - -#if DBG_EVAL -#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_fprintf(stdout, __VA_ARGS__) -#define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_scheme_cons_write(stdout, ao_scheme_cons_poly(a), true) -#define DBG_POLY(a) ao_scheme_poly_write(stdout, a, true) -#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) -#define DBG_STACK() ao_scheme_stack_write(stdout, ao_scheme_stack_poly(ao_scheme_stack), true) -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(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); ao_scheme_printf(__VA_ARGS__); } while (0) -#define RDBG_IN() (++ao_scheme_stack_depth) -#define RDBG_OUT() (--ao_scheme_stack_depth) -#else -#define RDBGI(...) -#define RDBG_IN() -#define RDBG_OUT() -#endif - -static inline int -ao_scheme_mdbg_offset(void *a) -{ - uint8_t *u = a; - - if (u == 0) - return -1; - - if (ao_scheme_pool <= u && u < ao_scheme_pool + AO_SCHEME_POOL) - return u - ao_scheme_pool; - -#ifndef AO_SCHEME_MAKE_CONST - if (ao_scheme_const <= u && u < ao_scheme_const + AO_SCHEME_POOL_CONST) - return - (int) (u - ao_scheme_const); -#endif - return -2; -} - -#define MDBG_OFFSET(a) ao_scheme_mdbg_offset(a) - -#if DBG_MEM - -#define DBG_MEM_START 1 - -#include -extern int dbg_move_depth; -#define MDBG_DUMP 1 - -extern int dbg_mem; - -#define MDBG_DO(a) a -#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) -#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) -#define MDBG_MOVE_IN() (dbg_move_depth++) -#define MDBG_MOVE_OUT() (--dbg_move_depth) - -#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_advanced_syntax.scheme b/src/scheme/ao_scheme_advanced_syntax.scheme deleted file mode 100644 index 4cddc803..00000000 --- a/src/scheme/ao_scheme_advanced_syntax.scheme +++ /dev/null @@ -1,388 +0,0 @@ -; -; Copyright © 2018 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. -; -; Advanced syntax, including vectors and floats - -(begin - (def! equal? - (lambda (a b) - (cond ((eq? a b) #t) - ((and (pair? a) (pair? b)) - (and (equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b))) - ((lambda (i l) - (while (and (< i l) - (equal? (vector-ref a i) - (vector-ref b i))) - (set! i (+ i 1))) - (eq? i l) - ) - 0 - (vector-length a) - ) - ) - (else #f) - ) - ) - ) - 'equal? - ) - -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) -(equal? #(1 2 3) #(1 2 3)) -(equal? #(1 2 3) #(4 5 6)) - -(define quasiquote - (macro (x) - (define (constant? exp) - ; A constant value is either a pair starting with quote, - ; or anything which is neither a pair nor a symbol - - (cond ((pair? exp) - (eq? (car exp) 'quote) - ) - (else - (not (symbol? exp)) - ) - ) - ) - - (define (combine-skeletons left right exp) - (cond - ((and (constant? left) (constant? right)) - (cond ((and (eqv? (eval left) (car exp)) - (eqv? (eval right) (cdr exp))) - (list 'quote exp) - ) - (else - (list 'quote (cons (eval left) (eval right))) - ) - ) - ) - ((null? right) - (list 'list left) - ) - ((and (pair? right) (eq? (car right) 'list)) - (cons 'list (cons left (cdr right))) - ) - (else - (list 'cons left right) - ) - ) - ) - - (define (expand-quasiquote exp nesting) - (cond - - ; non cons -- constants - ; themselves, others are - ; quoted - - ((not (pair? exp)) - (cond ((constant? exp) - exp - ) - (else - (list 'quote exp) - ) - ) - ) - - ; check for an unquote exp and - ; add the param unquoted - - ((and (eq? (car exp) 'unquote) (= (length exp) 2)) - (cond ((= nesting 0) - (car (cdr exp)) - ) - (else - (combine-skeletons ''unquote - (expand-quasiquote (cdr exp) (- nesting 1)) - exp)) - ) - ) - - ; nested quasi-quote -- - ; construct the right - ; expression - - ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) - (combine-skeletons ''quasiquote - (expand-quasiquote (cdr exp) (+ nesting 1)) - exp)) - - ; check for an - ; unquote-splicing member, - ; compute the expansion of the - ; value and append the rest of - ; the quasiquote result to it - - ((and (pair? (car exp)) - (eq? (car (car exp)) 'unquote-splicing) - (= (length (car exp)) 2)) - (cond ((= nesting 0) - (list 'append (car (cdr (car exp))) - (expand-quasiquote (cdr exp) nesting)) - ) - (else - (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) - (expand-quasiquote (cdr exp) nesting) - exp)) - ) - ) - - ; for other lists, just glue - ; the expansion of the first - ; element to the expansion of - ; the rest of the list - - (else (combine-skeletons (expand-quasiquote (car exp) nesting) - (expand-quasiquote (cdr exp) nesting) - exp) - ) - ) - ) - (expand-quasiquote x 0) - ) - ) - - ; `q -> (quote q) - ; `(q) -> (append (quote (q))) - ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) - ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) - - -`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) - - ; define a set of local - ; variables all at once and - ; then evaluate a list of - ; sexprs - ; - ; (let (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let ((x 1) (y)) (set! y (+ x 1)) y) - -(define let - (macro (vars . exprs) - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-vals vars) - (cond ((not (null? vars)) - (cons (cond ((null? (cdr (car vars))) ()) - (else - (car (cdr (car vars)))) - ) - (make-vals (cdr vars)))) - (else ()) - ) - ) - ; prepend the set operations - ; to the expressions - - ; build the lambda. - - `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) - ) - ) - - -(let ((x 1) (y)) (set! y 2) (+ x y)) - -(define assv assq) - -(assv 'b '((a 1) (b 2) (c 3))) - -(define when (macro (test . l) `(cond (,test ,@l)))) - -(when #t (+ 1 2)) -(when #f (+ 1 2)) - -(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) - -(unless #f (+ 2 3)) -(unless #t (+ 2 3)) - -(define (cdar l) (cdr (car l))) - -(cdar '((1 2) (3 4))) - -(define (cddr l) (cdr (cdr l))) - -(cddr '(1 2 3)) - -(define (caddr l) (car (cdr (cdr l)))) - -(caddr '(1 2 3 4)) - -(define (reverse list) - (define (_r old new) - (if (null? old) - new - (_r (cdr old) (cons (car old) new)) - ) - ) - (_r list ()) - ) - -(reverse '(1 2 3)) - -(define make-list - (lambda (a . b) - (define (_m a x) - (if (zero? a) - x - (_m (- a 1) (cons b x)) - ) - ) - (if (null? b) - (set! b #f) - (set! b (car b)) - ) - (_m a '()) - ) - ) - -(make-list 10 'a) - -(make-list 10) - -(define for-each - (lambda (proc . lists) - (define (_f lists) - (cond ((null? (car lists)) #t) - (else - (apply proc (map car lists)) - (_f (map cdr lists)) - ) - ) - ) - (_f lists) - ) - ) - -(let ((a 0)) - (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) - a - ) - -(call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - #t)) - -(define case - (macro (test . l) - ; construct the body of the - ; case, dealing with the - ; lambda version ( => lambda) - - (define (_unarrow l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)) - ) - - ; Build the case elements, which is - ; simply a list of cond clauses - - (define (_case l) - - (cond ((null? l) ()) - - ; else case - - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) - - ; regular case - - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - ) - ) - - ; now construct the overall - ; expression, using a lambda - ; to hold the computed value - ; of the test expression - - `((lambda (__key__) - (cond ,@(_case l))) ,test) - ) - ) - -(case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) -(case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) -(case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else")) -(case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) -(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) - -(define do - (macro (vars test . cmds) - (define (_step v) - (if (null? v) - '() - (if (null? (cddr (car v))) - (_step (cdr v)) - (cons `(set! ,(caar v) ,(caddr (car v))) - (_step (cdr v)) - ) - ) - ) - ) - `(let ,(map (lambda (v) (list (car v) (cadr v))) vars) - (while (not ,(car test)) - ,@cmds - ,@(_step vars) - ) - ,@(cdr test) - ) - ) - ) - -(do ((x 1 (+ x 1)) - (y 0) - ) - ((= x 10) y) - (set! y (+ y x)) - ) diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c deleted file mode 100644 index 2a568ed9..00000000 --- a/src/scheme/ao_scheme_atom.c +++ /dev/null @@ -1,298 +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_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) -{ - MDBG_MOVE("mark atom %s\n", ((struct ao_scheme_atom *) addr)->name); - (void) addr; -} - -static void atom_move(void *addr) -{ - (void) addr; -} - -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; - -static struct ao_scheme_atom * -ao_scheme_atom_find(const char *name) -{ - struct ao_scheme_atom *atom; - -#ifdef ao_builtin_atoms - if (!ao_scheme_atoms) - ao_scheme_atoms = ao_scheme_poly_atom(ao_builtin_atoms); -#endif - for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { - if (!strcmp(atom->name, name)) - return atom; - } - return NULL; -} - -#ifdef AO_SCHEME_MAKE_CONST - -#define AO_SCHEME_BUILTIN_SYNTAX_ATOMS -#include "ao_scheme_builtin.h" -#undef AO_SCHEME_BUILTIN_SYNTAX_ATOMS - -static void -ao_scheme_atom_mark_syntax(void) -{ - unsigned a; - for (a = 0; a < sizeof(syntax_atoms)/sizeof(syntax_atoms[0]); a++) { - struct ao_scheme_atom *atom = ao_scheme_atom_find(syntax_atoms[a]); - if (atom) - ao_scheme_mark_memory(&ao_scheme_atom_type, atom); - } -} - -#else -#define ao_scheme_atom_mark_syntax() -#endif - -void -ao_scheme_atom_move(void) -{ - struct ao_scheme_atom *atom; - ao_scheme_move_memory(&ao_scheme_atom_type, (void **) (void *) &ao_scheme_atoms); - for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { - if (!ao_scheme_is_pool_addr(atom)) { - MDBG_DO(printf("atom out of pool %s\n", atom->name)); - break; - } - MDBG_DO(printf("move atom %s\n", atom->name)); - ao_scheme_poly_move(&atom->next, 0); - } -} - -void -ao_scheme_atom_check_references(void) -{ - struct ao_scheme_atom *atom; - ao_poly *prev = NULL; - - ao_scheme_atom_mark_syntax(); - for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { - if (!ao_scheme_marked(atom)) { - MDBG_DO(printf("unreferenced atom %s\n", atom->name)); - if (prev) - *prev = atom->next; - else - ao_scheme_atoms = ao_scheme_poly_atom(atom->next); - } else - prev = &atom->next; - } -} - -static void -ao_scheme_atom_init(struct ao_scheme_atom *atom, char *name) -{ - if (atom) { - atom->type = AO_SCHEME_ATOM; - strcpy(atom->name, name); - atom->next = ao_scheme_atom_poly(ao_scheme_atoms); - ao_scheme_atoms = atom; - } -} - -struct ao_scheme_atom * -ao_scheme_string_to_atom(struct ao_scheme_string *string) -{ - struct ao_scheme_atom *atom = ao_scheme_atom_find(string->val); - - if (atom) - return atom; - ao_scheme_string_stash(string); - atom = ao_scheme_alloc(name_size(string->val)); - string = ao_scheme_string_fetch(); - ao_scheme_atom_init(atom, string->val); - return atom; -} - -struct ao_scheme_atom * -ao_scheme_atom_intern(char *name) -{ - struct ao_scheme_atom *atom = ao_scheme_atom_find(name); - if (atom) - return atom; - - atom = ao_scheme_alloc(name_size(name)); - ao_scheme_atom_init(atom, 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_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(FILE *out, ao_poly a, bool write) -{ - struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); - (void) write; - fprintf(out, "%s", atom->name); -} - -ao_poly -ao_scheme_do_symbolp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(_ao_scheme_atom_symbol3f, AO_SCHEME_ATOM, cons); -} - -ao_poly -ao_scheme_do_set(struct ao_scheme_cons *cons) -{ - ao_poly atom; - ao_poly val; - ao_poly *ref; - - if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons, - AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - ref = ao_scheme_atom_ref(atom, NULL); - - if (!ref) - return ao_scheme_error(AO_SCHEME_UNDEFINED, "%v: undefined atom %v", - _ao_scheme_atom_set, atom); - *ref = val; - return val; -} - -ao_poly -ao_scheme_do_def(struct ao_scheme_cons *cons) -{ - ao_poly atom; - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons, - AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_atom_def(atom, val); -} - -ao_poly -ao_scheme_do_setq(struct ao_scheme_cons *cons) -{ - ao_poly atom; - ao_poly val; - ao_poly p; - - if (!ao_scheme_parse_args(_ao_scheme_atom_set21, cons, - AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!ao_scheme_atom_ref(atom, NULL)) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: symbol %v not defined", - _ao_scheme_atom_set21, atom); - /* - * Build the macro return -- `(set (quote ,atom) ,val) - */ - ao_scheme_poly_stash(cons->cdr); - p = ao_scheme_cons(atom, AO_SCHEME_NIL); - p = ao_scheme_cons(_ao_scheme_atom_quote, p); - p = ao_scheme_cons(p, ao_scheme_poly_fetch()); - return ao_scheme_cons(_ao_scheme_atom_set, p); -} - -#ifdef AO_SCHEME_FEATURE_UNDEF -ao_poly -ao_scheme_do_undef(struct ao_scheme_cons *cons) -{ - ao_poly atom; - - if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons, - AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_frame_del(ao_scheme_frame_global, atom); -} -#endif diff --git a/src/scheme/ao_scheme_basic_syntax.scheme b/src/scheme/ao_scheme_basic_syntax.scheme deleted file mode 100644 index 4cd3e167..00000000 --- a/src/scheme/ao_scheme_basic_syntax.scheme +++ /dev/null @@ -1,414 +0,0 @@ -; -; Copyright © 2018 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. -; -; Basic syntax placed in ROM - -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (a b) - (list - def - (list quote a) - b) - ) - ) - -(begin - (def! append - (lambda a - (def! _a - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (_a (cdr a) b))) - ) - ) - ) - - (def! _b - (lambda (l) - (cond ((null? l) l) - ((null? (cdr l)) (car l)) - (else (_a (car l) (_b (cdr l)))) - ) - ) - ) - (_b a) - ) - ) - 'append) - -(append '(a) '(b)) - - - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated. - ; - ; Also accepts the alternate - ; form for defining lambdas of - ; (define (name x y z) sexprs ...) - ; - -(begin - (def! define - (macro (a . b) - ; check for alternate lambda definition form - - (cond ((pair? a) - (set! b - (cons - lambda - (cons (cdr a) b))) - (set! a (car a)) - ) - (else - (set! b (car b)) - ) - ) - (cons begin - (cons - (cons def - (cons (cons quote (cons a '())) - (cons b '()) - ) - ) - (cons - (cons quote (cons a '())) - '()) - ) - ) - ) - ) - 'define - ) - ; boolean operators - -(define or - (macro a - (def! b - (lambda (a) - (cond ((null? a) #f) - ((null? (cdr a)) - (car a)) - (else - (list - cond - (list - (car a)) - (list - 'else - (b (cdr a)) - ) - ) - ) - ) - ) - ) - (b a))) - - ; execute to resolve macros - -(or #f #t) - -(define and - (macro a - (def! b - (lambda (a) - (cond ((null? a) #t) - ((null? (cdr a)) - (car a)) - (else - (list - cond - (list - (car a) - (b (cdr a)) - ) - ) - ) - ) - ) - ) - (b a) - ) - ) - - ; execute to resolve macros - -(and #t #f) - - ; (if ) - ; (if 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) - -(define letrec - (macro (a . b) - - ; - ; make the list of names in the let - ; - - (define (_a a) - (cond ((not (null? a)) - (cons (car (car a)) - (_a (cdr a)))) - (else ()) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (define (_b a b) - (cond ((null? a) b) - (else - (cons - (list set - (list quote - (car (car a)) - ) - (cond ((null? (cdr (car a))) - () - ) - (else - (car (cdr (car a))) - ) - ) - ) - (_b (cdr a) b) - ) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (_c a) - (cond ((null? a) ()) - (else (cons () (_c (cdr a)))) - ) - ) - ; build the lambda. - - (cons (cons lambda (cons (_a a) (_b a b))) (_c a)) - ) - ) - -(letrec ((a 1) (b a)) (+ a b)) - - ; letrec is sufficient for let* - -(define let* letrec) - - ; use letrec for let in basic - ; syntax - -(define let letrec) - - ; Basic recursive - ; equality. Replaced with - ; vector-capable version in - ; advanced syntax - -(define (equal? a b) - (cond ((eq? a b) #t) - ((pair? a) - (cond ((pair? b) - (cond ((equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - ) - ) - ) - ) - ) - -(equal? '(a b c) '(a b c)) - - ; basic list accessors - -(define (caar a) (car (car a))) - -(define (cadr a) (car (cdr a))) - -(define (list-ref a b) - (car (list-tail a b)) - ) - -(list-ref '(1 2 3) 2) - -(define (member a b . t?) - (cond ((null? b) - #f - ) - (else - (if (null? t?) (set! t? equal?) (set! t? (car t?))) - (if (t? a (car b)) - b - (member a (cdr b) t?)) - ) - ) - ) - -(member '(2) '((1) (2) (3))) -(member '(4) '((1) (2) (3))) - -(define (memq a b) (member a b eq?)) - -(memq 2 '(1 2 3)) -(memq 4 '(1 2 3)) -(memq '(2) '((1) (2) (3))) - -(define (assoc a b . t?) - (if (null? t?) - (set! t? equal?) - (set! t? (car t?)) - ) - (if (null? b) - #f - (if (t? a (caar b)) - (car b) - (assoc a (cdr b) t?) - ) - ) - ) - -(assoc '(c) '((a 1) (b 2) ((c) 3))) - -(define (assq a b) (assoc a b eq?)) - -(assq 'a '((a 1) (b 2) (c 3))) - -(define map - (lambda (proc . lists) - (define (_a lists) - (cond ((null? lists) ()) - (else - (cons (caar lists) (_a (cdr lists))) - ) - ) - ) - (define (_n lists) - (cond ((null? lists) ()) - (else - (cons (cdr (car lists)) (_n (cdr lists))) - ) - ) - ) - (define (_m lists) - (cond ((null? (car lists)) ()) - (else - (cons (apply proc (_a lists)) (_m (_n lists))) - ) - ) - ) - (_m lists) - ) - ) - -(map cadr '((a b) (d e) (g h))) - - ; use map as for-each in basic - ; mode - -(define for-each map) - ; simple math operators - -(define zero? (macro (value) (list eq? value 0))) - -(zero? 1) -(zero? 0) -(zero? "hello") - -(define positive? (macro (value) (list > value 0))) - -(positive? 12) -(positive? -12) - -(define negative? (macro (value) (list < value 0))) - -(negative? 12) -(negative? -12) - -(define (abs a) (if (>= a 0) a (- a))) - -(abs 12) -(abs -12) - -(define max (lambda (a . b) - (while (not (null? b)) - (cond ((< a (car b)) - (set! a (car b))) - ) - (set! b (cdr b)) - ) - a) - ) - -(max 1 2 3) -(max 3 2 1) - -(define min (lambda (a . b) - (while (not (null? b)) - (cond ((> a (car b)) - (set! a (car b))) - ) - (set! b (cdr b)) - ) - a) - ) - -(min 1 2 3) -(min 3 2 1) - -(define (even? a) (zero? (% a 2))) - -(even? 2) -(even? -2) -(even? 3) -(even? -1) - -(define (odd? a) (not (even? a))) - -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - -(define (newline) (write-char #\newline)) - -(newline) diff --git a/src/scheme/ao_scheme_bool.c b/src/scheme/ao_scheme_bool.c deleted file mode 100644 index 05109fb9..00000000 --- a/src/scheme/ao_scheme_bool.c +++ /dev/null @@ -1,80 +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_scheme.h" - -static void bool_mark(void *addr) -{ - (void) addr; -} - -static int bool_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_bool); -} - -static void bool_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_bool_type = { - .mark = bool_mark, - .size = bool_size, - .move = bool_move, - .name = "bool" -}; - -void -ao_scheme_bool_write(FILE *out, ao_poly v, bool write) -{ - struct ao_scheme_bool *b = ao_scheme_poly_bool(v); - - (void) write; - if (b->value) - fprintf(out, "#t"); - else - fprintf(out, "#f"); -} - -ao_poly -ao_scheme_do_booleanp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(_ao_scheme_atom_boolean3f, AO_SCHEME_BOOL, cons); -} - -#ifdef AO_SCHEME_MAKE_CONST - -struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; - -struct ao_scheme_bool * -ao_scheme_bool_get(uint8_t value) -{ - struct ao_scheme_bool **b; - - if (value) - b = &ao_scheme_true; - else - b = &ao_scheme_false; - - if (!*b) { - *b = ao_scheme_alloc(sizeof (struct ao_scheme_bool)); - (*b)->type = AO_SCHEME_BOOL; - (*b)->value = value; - } - return *b; -} - -#endif diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c deleted file mode 100644 index 2b0c394b..00000000 --- a/src/scheme/ao_scheme_builtin.c +++ /dev/null @@ -1,1008 +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 _GNU_SOURCE -#include "ao_scheme.h" -#include -#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 (char *) "???"; - } -} -#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 (char *) "???"; -} - -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 (char *) "(unknown)"; -} -#endif - -void -ao_scheme_builtin_write(FILE *out, ao_poly b, bool write) -{ - struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); - (void) write; - fputs(ao_scheme_builtin_name(builtin->func), out); -} - -static bool -ao_scheme_typecheck(ao_poly actual, int formal_type) { - int actual_type; - - if ((formal_type & AO_SCHEME_ARG_MASK) == AO_SCHEME_POLY) - return true; - - /* allow nil? */ - if (actual == AO_SCHEME_NIL) - return (formal_type & AO_SCHEME_ARG_NIL_OK) != 0; - - actual_type = ao_scheme_poly_type(actual); - formal_type &= AO_SCHEME_ARG_MASK; - - if (actual_type == formal_type) - return true; - if (actual_type == AO_SCHEME_BUILTIN && formal_type == AO_SCHEME_LAMBDA) - return true; - -#ifdef AO_SCHEME_FEATURE_BIGINT - if (ao_scheme_integer_typep(actual_type) && formal_type == AO_SCHEME_INT) - return true; -#endif -#ifdef AO_SCHEME_FEATURE_FLOAT - if (ao_scheme_number_typep(actual_type) && formal_type == AO_SCHEME_FLOAT) - return true; -#endif - return false; -} - -int -ao_scheme_parse_args(ao_poly name, struct ao_scheme_cons *cons, ...) -{ - va_list ap; - int formal; - int argc = 0; - ao_poly car; - - va_start(ap, cons); - while ((formal = va_arg(ap, int)) != AO_SCHEME_ARG_END) { - if (formal & AO_SCHEME_ARG_OPTIONAL) - car = (ao_poly) va_arg(ap, int); - if (cons) { - car = cons->car; - cons = ao_scheme_cons_cdr(cons); - if (!ao_scheme_typecheck(car, formal)) { - ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car); - return 0; - } - } else if (!(formal & AO_SCHEME_ARG_OPTIONAL)) { - goto bad_args; - } - if (formal & AO_SCHEME_ARG_RET_POLY) - formal = AO_SCHEME_POLY; - - switch (formal & AO_SCHEME_ARG_MASK) { - case AO_SCHEME_INT: -#ifdef AO_SCHEME_FEATURE_BIGINT - case AO_SCHEME_BIGINT: -#endif - *(va_arg(ap, int32_t *)) = ao_scheme_poly_integer(car); - break; -#ifdef AO_SCHEME_FEATURE_FLOAT - case AO_SCHEME_FLOAT: - *(va_arg(ap, float *)) = ao_scheme_poly_number(car); - break; -#endif - case AO_SCHEME_POLY: - *(va_arg(ap, ao_poly *)) = car; - break; - default: - *(va_arg(ap, void **)) = ao_scheme_ref(car); - break; - } - argc++; - } - if (cons) { - bad_args: - ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid arg count", name); - return 0; - } - return 1; -} - -ao_poly -ao_scheme_arg(struct ao_scheme_cons *cons, int argc) -{ - for (;;) { - if (!cons) - return AO_SCHEME_NIL; - if (argc == 0) - return cons->car; - cons = ao_scheme_cons_cdr(cons); - argc--; - } -} - -ao_poly -ao_scheme_do_quote(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_quote, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return val; -} - -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; -} - -static ao_poly -ao_scheme_do_display_or_write(ao_poly proc, struct ao_scheme_cons *cons, bool write) -{ -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly val; - ao_poly port; - - if (!ao_scheme_parse_args(proc, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_POLY | AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_poly_write(stdout, val, write); -#else - ao_poly val; - struct ao_scheme_port *port; - FILE *file = stdout; - - if (!ao_scheme_parse_args(proc, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_PORT | AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (port) { - file = port->file; - if (!file) - return _ao_scheme_bool_true; - } - ao_scheme_poly_write(file, val, write); -#endif - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_write(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_display_or_write(_ao_scheme_atom_write, cons, true); -} - -ao_poly -ao_scheme_do_display(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_display_or_write(_ao_scheme_atom_display, cons, false); -} - -static ao_poly -ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) -{ - struct ao_scheme_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; - ao_scheme_cons_stash(cons); - 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)); -#ifdef AO_SCHEME_FEATURE_FLOAT - else if (ct == AO_SCHEME_FLOAT) - ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); -#endif - break; - case builtin_divide: - if (ao_scheme_poly_integer(ret) == 1) { - } else { -#ifdef AO_SCHEME_FEATURE_FLOAT - if (ao_scheme_number_typep(ct)) { - float v = ao_scheme_poly_number(ret); - ret = ao_scheme_float_get(1/v); - } -#else - ret = ao_scheme_integer_poly(0); -#endif - } - break; - default: - break; - } - } - cons = ao_scheme_cons_fetch(); - } 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); -#ifdef AO_SCHEME_FEATURE_FLOAT - int64_t t; -#endif - - switch(op) { - case builtin_plus: - r += c; - check_overflow: -#ifdef AO_SCHEME_FEATURE_FLOAT - if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) - goto inexact; -#endif - break; - case builtin_minus: - r -= c; - goto check_overflow; - break; - case builtin_times: -#ifdef AO_SCHEME_FEATURE_FLOAT - t = (int64_t) r * (int64_t) c; - if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) - goto inexact; - r = (int32_t) t; -#else - r = r * c; -#endif - break; - case builtin_divide: -#ifdef AO_SCHEME_FEATURE_FLOAT - if (c != 0 && (r % c) == 0) - r /= c; - else - goto inexact; -#else - r /= c; -#endif - break; - case builtin_quotient: - if (c == 0) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero"); - r = r / c; - break; - case builtin_floor_quotient: - if (c == 0) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "floor-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; - } - ao_scheme_cons_stash(cons); - ret = ao_scheme_integer_poly(r); - cons = ao_scheme_cons_fetch(); -#ifdef AO_SCHEME_FEATURE_FLOAT - } 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_floor_quotient: - case builtin_remainder: - case builtin_modulo: - return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); - default: - break; - } - ao_scheme_cons_stash(cons); - ret = ao_scheme_float_get(r); - cons = ao_scheme_cons_fetch(); -#endif - } - else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { - ao_scheme_cons_stash(cons); - ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), - ao_scheme_poly_string(car))); - cons = ao_scheme_cons_fetch(); - if (!ret) - return ret; - } - 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_floor_quotient(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_floor_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); -} - -static 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 && left == right) { - ; - } 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; - case builtin_equal: - if (!(l == r)) - return _ao_scheme_bool_false; - default: - break; - } -#ifdef AO_SCHEME_FEATURE_FLOAT - } else if (ao_scheme_number_typep(lt) && ao_scheme_number_typep(rt)) { - float l, r; - - l = ao_scheme_poly_number(left); - r = ao_scheme_poly_number(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; - case builtin_equal: - if (!(l == r)) - return _ao_scheme_bool_false; - default: - break; - } -#endif /* AO_SCHEME_FEATURE_FLOAT */ - } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { - int c = strcmp(ao_scheme_poly_string(left)->val, - ao_scheme_poly_string(right)->val); - 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; - case builtin_equal: - if (!(c == 0)) - return _ao_scheme_bool_false; - break; - default: - break; - } - } else - return _ao_scheme_bool_false; - } - 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_flush_output(struct ao_scheme_cons *cons) -{ -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly port; - if (!ao_scheme_parse_args(_ao_scheme_atom_flush2doutput, cons, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - fflush(stdout); -#else - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_flush2doutput, cons, - AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - fflush(stdout); - if (port) { - if (port->file) - fflush(port->file); - } else - fflush(stdout); -#endif - return _ao_scheme_bool_true; -} - -#ifdef AO_SCHEME_FEATURE_GPIO - -ao_poly -ao_scheme_do_led(struct ao_scheme_cons *cons) -{ - int32_t led; - if (!ao_scheme_parse_args(_ao_scheme_atom_led, cons, - AO_SCHEME_INT, &led, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_os_led(led); - return _ao_scheme_bool_true; -} - -#endif - -ao_poly -ao_scheme_do_eval(struct ao_scheme_cons *cons) -{ - ao_poly expr; - ao_poly env; - - if (!ao_scheme_parse_args(_ao_scheme_atom_eval, cons, - AO_SCHEME_POLY, &expr, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &env, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_stack->state = eval_sexpr; - ao_scheme_stack->frame = AO_SCHEME_NIL; - ao_scheme_frame_current = NULL; - return expr; -} - -ao_poly -ao_scheme_do_apply(struct ao_scheme_cons *cons) -{ - ao_scheme_stack->state = eval_apply; - return ao_scheme_cons_poly(cons); -} - -ao_poly -ao_scheme_do_read(struct ao_scheme_cons *cons) -{ - FILE *file = stdin; -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly port; - if (!ao_scheme_parse_args(_ao_scheme_atom_read, cons, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; -#else - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_read, cons, - AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (port) { - file = port->file; - if (!file) - return _ao_scheme_atom_eof; - } -#endif - return ao_scheme_read(file); -} - -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_integer_poly(free); -} - -ao_poly -ao_scheme_do_nullp(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_not, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (val == 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) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_not, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (val == _ao_scheme_bool_false) - return _ao_scheme_bool_true; - else - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_typep(ao_poly proc, int type, struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(proc, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (ao_scheme_poly_type(val) == type) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_procedurep(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(val)) { - case AO_SCHEME_BUILTIN: - case AO_SCHEME_LAMBDA: - return _ao_scheme_bool_true; - default: - return _ao_scheme_bool_false; - } -} - -ao_poly -ao_scheme_do_read_char(struct ao_scheme_cons *cons) -{ - int c; -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly port; - if (!ao_scheme_parse_args(_ao_scheme_atom_read2dchar, cons, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - c = getchar(); -#else - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_read2dchar, cons, - AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (port) - c = ao_scheme_port_getc(port); - else - c = getchar(); -#endif - if (c == EOF) - return _ao_scheme_atom_eof; - return ao_scheme_integer_poly(c); -} - -ao_poly -ao_scheme_do_write_char(struct ao_scheme_cons *cons) -{ - int32_t c; -#ifndef AO_SCHEME_FEATURE_PORT - ao_poly port; - if (!ao_scheme_parse_args(_ao_scheme_atom_write2dchar, cons, - AO_SCHEME_INT, &c, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - putchar(c); -#else - struct ao_scheme_port *port; - if (!ao_scheme_parse_args(_ao_scheme_atom_write2dchar, cons, - AO_SCHEME_INT, &c, - AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (port) - ao_scheme_port_putc(port, c); - else - putchar(c); -#endif - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_exit(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_exit, cons, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, _ao_scheme_bool_true, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_exception |= AO_SCHEME_EXIT; - return val; -} - -#ifdef AO_SCHEME_FEATURE_TIME - -ao_poly -ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_parse_args(_ao_scheme_atom_current2djiffy, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(ao_scheme_os_jiffy()); -} - -ao_poly -ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_parse_args(_ao_scheme_atom_jiffies2dper2dsecond, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(AO_SCHEME_JIFFIES_PER_SECOND); -} - -ao_poly -ao_scheme_do_delay(struct ao_scheme_cons *cons) -{ - int32_t delay; - - if (!ao_scheme_parse_args(_ao_scheme_atom_delay, cons, - AO_SCHEME_INT, &delay, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_os_delay(delay); - return cons->car; -} -#endif - -#ifdef AO_SCHEME_FEATURE_POSIX - -#include - -static char **ao_scheme_argv; - -void -ao_scheme_set_argv(char **argv) -{ - ao_scheme_argv = argv; -} - -ao_poly -ao_scheme_do_command_line(struct ao_scheme_cons *cons) -{ - ao_poly args = AO_SCHEME_NIL; - ao_poly arg; - int i; - - if (!ao_scheme_parse_args(_ao_scheme_atom_command2dline, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - for (i = 0; ao_scheme_argv[i]; i++); - - while (--i >= 0) { - ao_scheme_poly_stash(args); - arg = ao_scheme_string_poly(ao_scheme_string_new(ao_scheme_argv[i])); - args = ao_scheme_poly_fetch(); - if (!arg) - return AO_SCHEME_NIL; - args = ao_scheme_cons(arg, args); - if (!args) - return AO_SCHEME_NIL; - } - return args; -} - -ao_poly -ao_scheme_do_get_environment_variables(struct ao_scheme_cons *cons) -{ - ao_poly envs = AO_SCHEME_NIL; - ao_poly env; - int i; - - if (!ao_scheme_parse_args(_ao_scheme_atom_get2denvironment2dvariables, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - for (i = 0; environ[i]; i++); - - while (--i >= 0) { - ao_scheme_poly_stash(envs); - env = ao_scheme_string_poly(ao_scheme_string_new(environ[i])); - envs = ao_scheme_poly_fetch(); - if (!env) - return AO_SCHEME_NIL; - envs = ao_scheme_cons(env, envs); - if (!envs) - return AO_SCHEME_NIL; - } - return envs; -} - -ao_poly -ao_scheme_do_get_environment_variable(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *name; - char *val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_get2denvironment2dvariable, cons, - AO_SCHEME_STRING, &name, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - val = secure_getenv(name->val); - if (!val) - return _ao_scheme_bool_false; - return ao_scheme_string_poly(ao_scheme_string_new(val)); -} - -ao_poly -ao_scheme_do_file_existsp(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *name; - - if (!ao_scheme_parse_args(_ao_scheme_atom_file2dexists3f, cons, - AO_SCHEME_STRING, &name, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (access(name->val, F_OK) == 0) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_delete_file(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *name; - - if (!ao_scheme_parse_args(_ao_scheme_atom_delete2dfile, cons, - AO_SCHEME_STRING, &name, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (unlink(name->val) == 0) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_current_second(struct ao_scheme_cons *cons) -{ - int32_t second; - - if (!ao_scheme_parse_args(_ao_scheme_atom_current2dsecond, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - second = (int32_t) time(NULL); - return ao_scheme_integer_poly(second); -} - -#endif /* AO_SCHEME_FEATURE_POSIX */ - -#define AO_SCHEME_BUILTIN_FUNCS -#include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt deleted file mode 100644 index fd29d607..00000000 --- a/src/scheme/ao_scheme_builtin.txt +++ /dev/null @@ -1,100 +0,0 @@ -BIGINT feature bigint -all atom eof -all atom else -all f_lambda eval -all f_lambda read -all nlambda lambda -all nlambda nlambda -all nlambda macro -all f_lambda car -all f_lambda cdr -all f_lambda cons -all f_lambda last -all f_lambda length -all f_lambda list_copy list-copy -all f_lambda list_tail list-tail -all nlambda quote -QUASI atom quasiquote -QUASI atom unquote -QUASI atom unquote_splicing unquote-splicing -all f_lambda set -all macro setq set! -all f_lambda def -all nlambda cond -all nlambda begin -all nlambda while -all f_lambda write -all f_lambda display -all f_lambda plus + string-append -all f_lambda minus - -all f_lambda times * -all f_lambda divide / -all f_lambda modulo modulo % -all f_lambda remainder -all f_lambda quotient -all f_lambda floor_quotient floor-quotient -all f_lambda equal = eq? eqv? -all f_lambda less < string string>? -all f_lambda less_equal <= string<=? -all f_lambda greater_equal >= string>=? -all f_lambda flush_output flush-output -TIME f_lambda delay -GPIO f_lambda led -SAVE f_lambda save -SAVE f_lambda restore -all f_lambda call_cc call-with-current-continuation call/cc -all f_lambda collect -all f_lambda nullp null? -all f_lambda not -all f_lambda listp list? -all f_lambda pairp pair? -all f_lambda integerp integer? exact?@BIGINT exact-integer?@BIGINT -all f_lambda numberp number? real?@FLOAT -all f_lambda booleanp boolean? -all f_lambda set_car set-car! -all f_lambda set_cdr set-cdr! -all f_lambda symbolp symbol? -all f_lambda list_to_string list->string -all f_lambda string_to_list string->list -all f_lambda symbol_to_string symbol->string -all f_lambda string_to_symbol string->symbol -all f_lambda stringp string? -all f_lambda string_ref string-ref -all f_lambda string_set string-set! -all f_lambda string_length string-length -all f_lambda make_string make-string -all f_lambda procedurep procedure? -all lambda apply -all f_lambda read_char read-char -all f_lambda write_char write-char -all f_lambda exit -TIME f_lambda current_jiffy current-jiffy -TIME f_lambda jiffies_per_second jiffies-per-second -FLOAT f_lambda finitep finite? -FLOAT f_lambda infinitep infinite? -FLOAT f_lambda inexactp inexact? -FLOAT f_lambda sqrt -VECTOR f_lambda vector_ref vector-ref -VECTOR f_lambda vector_set vector-set! -VECTOR f_lambda vector -VECTOR f_lambda make_vector make-vector -VECTOR f_lambda list_to_vector list->vector -VECTOR f_lambda vector_to_list vector->list -VECTOR f_lambda vector_length vector-length -VECTOR f_lambda vectorp vector? -PORT f_lambda portp port? -PORT f_lambda port_openp port-open? -PORT f_lambda open_input_file open-input-file -PORT f_lambda open_output_file open-output-file -PORT f_lambda close_port close-port -PORT f_lambda current_input_port current-input-port -PORT f_lambda current_output_port current-output-port -PORT f_lambda current_error_port current-error-port -POSIX f_lambda command_line command-line -POSIX f_lambda get_environment_variables get-environment-variables -POSIX f_lambda get_environment_variable get-environment-variable -POSIX f_lambda file_existsp file-exists? -POSIX f_lambda delete_file delete-file -POSIX f_lambda current_second current-second -UNDEF f_lambda undef diff --git a/src/scheme/ao_scheme_char.scheme b/src/scheme/ao_scheme_char.scheme deleted file mode 100644 index fdb7fa64..00000000 --- a/src/scheme/ao_scheme_char.scheme +++ /dev/null @@ -1,80 +0,0 @@ -; -; Copyright © 2018 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. -; -; Char primitives placed in ROM - -(define char? integer?) - -(char? #\q) -(char? "h") - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(char-upper-case? #\a) -(char-upper-case? #\B) -(char-upper-case? #\0) -(char-upper-case? #\space) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(char-lower-case? #\a) -(char-lower-case? #\B) -(char-lower-case? #\0) -(char-lower-case? #\space) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(char-alphabetic? #\a) -(char-alphabetic? #\B) -(char-alphabetic? #\0) -(char-alphabetic? #\space) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(char-numeric? #\a) -(char-numeric? #\B) -(char-numeric? #\0) -(char-numeric? #\space) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(char-whitespace? #\a) -(char-whitespace? #\B) -(char-whitespace? #\0) -(char-whitespace? #\space) - -(define char->integer (macro (v) v)) -(define integer->char char->integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(char-upcase #\a) -(char-upcase #\B) -(char-upcase #\0) -(char-upcase #\space) - -(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) - -(char-downcase #\a) -(char-downcase #\B) -(char-downcase #\0) -(char-downcase #\space) - -(define (digit-value c) - (if (char-numeric? c) - (- c #\0) - #f) - ) - -(digit-value #\1) -(digit-value #\a) diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c deleted file mode 100644 index a6e697b2..00000000 --- a/src/scheme/ao_scheme_cons.c +++ /dev/null @@ -1,402 +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_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_is_cons(cdr)) { - ao_scheme_poly_mark(cdr, 0); - 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_is_cons(cdr)) { - (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(car); - ao_scheme_poly_stash(cdr); - cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); - cdr = ao_scheme_poly_fetch(); - car = ao_scheme_poly_fetch(); - 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_is_cons(cdr)) { - (void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr); - 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)); -} - -static struct ao_scheme_cons * -ao_scheme_cons_copy(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *head = NULL; - struct ao_scheme_cons *tail = NULL; - - while (cons) { - struct ao_scheme_cons *new; - ao_poly cdr; - - ao_scheme_cons_stash(cons); - ao_scheme_cons_stash(head); - ao_scheme_cons_stash(tail); - new = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); - tail = ao_scheme_cons_fetch(); - head = ao_scheme_cons_fetch(); - cons = ao_scheme_cons_fetch(); - if (!new) - return AO_SCHEME_NIL; - new->car = cons->car; - new->cdr = AO_SCHEME_NIL; - if (!head) - head = new; - else - tail->cdr = ao_scheme_cons_poly(new); - tail = new; - cdr = cons->cdr; - if (!ao_scheme_is_cons(cdr)) { - tail->cdr = cdr; - break; - } - cons = ao_scheme_poly_cons(cdr); - } - return head; -} - -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(FILE *out, ao_poly c, bool write) -{ - struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); - struct ao_scheme_cons *clear = cons; - ao_poly cdr; - int written = 0; - - ao_scheme_print_start(); - fprintf(out, "("); - while (cons) { - if (written != 0) - fprintf(out, " "); - - /* Note if there's recursion in printing. Not - * as good as actual references, but at least - * we don't infinite loop... - */ - if (ao_scheme_print_mark_addr(cons)) { - fprintf(out, "..."); - break; - } - - ao_scheme_poly_write(out, cons->car, write); - - /* keep track of how many pairs have been printed */ - written++; - - cdr = cons->cdr; - if (!ao_scheme_is_cons(cdr)) { - fprintf(out, " . "); - ao_scheme_poly_write(out, cdr, write); - break; - } - cons = ao_scheme_poly_cons(cdr); - } - fprintf(out, ")"); - - if (ao_scheme_print_stop()) { - - /* If we're still printing, clear the print marks on - * all printed pairs - */ - while (written--) { - ao_scheme_print_clear_addr(clear); - clear = ao_scheme_poly_cons(clear->cdr); - } - } -} - -int -ao_scheme_cons_length(struct ao_scheme_cons *cons) -{ - int len = 0; - while (cons) { - len++; - cons = ao_scheme_cons_cdr(cons); - } - return len; -} - -ao_poly -ao_scheme_do_car(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - - if (!ao_scheme_parse_args(_ao_scheme_atom_car, cons, - AO_SCHEME_CONS, &pair, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return pair->car; -} - -ao_poly -ao_scheme_do_cdr(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - - if (!ao_scheme_parse_args(_ao_scheme_atom_cdr, cons, - AO_SCHEME_CONS, &pair, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return pair->cdr; -} - -ao_poly -ao_scheme_do_cons(struct ao_scheme_cons *cons) -{ - ao_poly car, cdr; - - if (!ao_scheme_parse_args(_ao_scheme_atom_cons, cons, - AO_SCHEME_POLY, &car, - AO_SCHEME_POLY, &cdr, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_cons(car, cdr); -} - -ao_poly -ao_scheme_do_last(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - - if (!ao_scheme_parse_args(_ao_scheme_atom_last, cons, - AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - while (pair) { - if (!pair->cdr) - return pair->car; - pair = ao_scheme_cons_cdr(pair); - } - return AO_SCHEME_NIL; -} - -ao_poly -ao_scheme_do_length(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - if (!ao_scheme_parse_args(_ao_scheme_atom_length, cons, - AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(ao_scheme_cons_length(pair)); -} - -ao_poly -ao_scheme_do_list_copy(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - - if (!ao_scheme_parse_args(_ao_scheme_atom_list2dcopy, cons, - AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_cons_poly(ao_scheme_cons_copy(pair)); -} - -ao_poly -ao_scheme_do_list_tail(struct ao_scheme_cons *cons) -{ - ao_poly list; - int32_t v; - - if (!ao_scheme_parse_args(_ao_scheme_atom_list2dtail, cons, - AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK | AO_SCHEME_ARG_RET_POLY, &list, - AO_SCHEME_INT, &v, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - while (v > 0) { - if (!list) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: ran off end", _ao_scheme_atom_list2dtail); - if (!ao_scheme_is_cons(list)) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid list", _ao_scheme_atom_list2dtail); - list = ao_scheme_poly_cons(list)->cdr; - v--; - } - return list; -} - -ao_poly -ao_scheme_do_pairp(struct ao_scheme_cons *cons) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (ao_scheme_is_pair(val)) - return _ao_scheme_bool_true; - 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 val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - for (;;) { - if (val == AO_SCHEME_NIL) - return _ao_scheme_bool_true; - if (!ao_scheme_is_cons(val)) - return _ao_scheme_bool_false; - val = ao_scheme_poly_cons(val)->cdr; - } -} - -ao_poly -ao_scheme_do_set_car(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_set2dcar21, cons, - AO_SCHEME_CONS, &pair, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - pair->car = val; - return val; -} - -ao_poly -ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_set2dcar21, cons, - AO_SCHEME_CONS, &pair, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - pair->cdr = val; - return val; -} - diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme deleted file mode 100644 index 17dc51a9..00000000 --- a/src/scheme/ao_scheme_const.scheme +++ /dev/null @@ -1,916 +0,0 @@ -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Lisp code placed in ROM - -(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit 1))))) - - ; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (name value) - (list - def - (list quote name) - value) - ) - ) - -(begin - (def! append - (lambda args - (def! append-list - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - - (def! append-lists - (lambda (lists) - (cond ((null? lists) lists) - ((null? (cdr lists)) (car lists)) - (else (append-list (car lists) (append-lists (cdr lists)))) - ) - ) - ) - (append-lists args) - ) - ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - - ; boolean operators - -(begin - (def! or - (macro l - (def! _or - (lambda (l) - (cond ((null? l) #f) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l)) - (list - 'else - (_or (cdr l)) - ) - ) - ) - ) - ) - ) - (_or l))) - 'or) - - ; execute to resolve macros - -(_?_ (or #f #t) #t) - -(begin - (def! and - (macro l - (def! _and - (lambda (l) - (cond ((null? l) #t) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l) - (_and (cdr l)) - ) - ) - ) - ) - ) - ) - (_and l) - ) - ) - 'and) - - ; execute to resolve macros - -(_?_ (and #t #f) #f) - - ; recursive equality - -(begin - (def! equal? - (lambda (a b) - (cond ((eq? a b) #t) - ((and (pair? a) (pair? b)) - (and (equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b))) - ((lambda (i l) - (while (and (< i l) - (equal? (vector-ref a i) - (vector-ref b i))) - (set! i (+ i 1))) - (eq? i l) - ) - 0 - (vector-length a) - ) - ) - (else #f) - ) - ) - ) - 'equal? - ) - -(_?_ (equal? '(a b c) '(a b c)) #t) -(_?_ (equal? '(a b c) '(a b b)) #f) -(_?_ (equal? #(1 2 3) #(1 2 3)) #t) -(_?_ (equal? #(1 2 3) #(4 5 6)) #f) - -(def (quote _??_) (lambda (a b) (cond ((equal? a b) a) (else (exit))))) - -(begin - (def! quasiquote - (macro (x) - (def! constant? - ; A constant value is either a pair starting with quote, - ; or anything which is neither a pair nor a symbol - - (lambda (exp) - (cond ((pair? exp) - (eq? (car exp) 'quote) - ) - (else - (not (symbol? exp)) - ) - ) - ) - ) - (def! combine-skeletons - (lambda (left right exp) - (cond - ((and (constant? left) (constant? right)) - (cond ((and (eqv? (eval left) (car exp)) - (eqv? (eval right) (cdr exp))) - (list 'quote exp) - ) - (else - (list 'quote (cons (eval left) (eval right))) - ) - ) - ) - ((null? right) - (list 'list left) - ) - ((and (pair? right) (eq? (car right) 'list)) - (cons 'list (cons left (cdr right))) - ) - (else - (list 'cons left right) - ) - ) - ) - ) - - (def! expand-quasiquote - (lambda (exp nesting) - (cond - - ; non cons -- constants - ; themselves, others are - ; quoted - - ((not (pair? exp)) - (cond ((constant? exp) - exp - ) - (else - (list 'quote exp) - ) - ) - ) - - ; check for an unquote exp and - ; add the param unquoted - - ((and (eq? (car exp) 'unquote) (= (length exp) 2)) - (cond ((= nesting 0) - (car (cdr exp)) - ) - (else - (combine-skeletons ''unquote - (expand-quasiquote (cdr exp) (- nesting 1)) - exp)) - ) - ) - - ; nested quasi-quote -- - ; construct the right - ; expression - - ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) - (combine-skeletons ''quasiquote - (expand-quasiquote (cdr exp) (+ nesting 1)) - exp)) - - ; check for an - ; unquote-splicing member, - ; compute the expansion of the - ; value and append the rest of - ; the quasiquote result to it - - ((and (pair? (car exp)) - (eq? (car (car exp)) 'unquote-splicing) - (= (length (car exp)) 2)) - (cond ((= nesting 0) - (list 'append (car (cdr (car exp))) - (expand-quasiquote (cdr exp) nesting)) - ) - (else - (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) - (expand-quasiquote (cdr exp) nesting) - exp)) - ) - ) - - ; for other lists, just glue - ; the expansion of the first - ; element to the expansion of - ; the rest of the list - - (else (combine-skeletons (expand-quasiquote (car exp) nesting) - (expand-quasiquote (cdr exp) nesting) - exp) - ) - ) - ) - ) - (def! result (expand-quasiquote x 0)) - result - ) - ) - 'quasiquote) - - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated. - ; - ; Also accepts the alternate - ; form for defining lambdas of - ; (define (name x y z) sexprs ...) - ; - -(begin - (def! define - (macro (first . rest) - ; check for alternate lambda definition form - - (cond ((pair? first) - (set! rest - (append - (list - 'lambda - (cdr first)) - rest)) - (set! first (car first)) - ) - (else - (set! rest (car rest)) - ) - ) - (def! result `(,begin - (,def (,quote ,first) ,rest) - (,quote ,first)) - ) - result - ) - ) - 'define - ) - - ; basic list accessors - -(define (caar l) (car (car l))) - -(_??_ (caar '((1 2 3) (4 5 6))) 1) - -(define (cadr l) (car (cdr l))) - -(_??_ (cadr '(1 2 3 4 5 6)) 2) - -(define (cdar l) (cdr (car l))) - -(_??_ (cdar '((1 2) (3 4))) '(2)) - -(define (cddr l) (cdr (cdr l))) - -(_??_ (cddr '(1 2 3)) '(3)) - -(define (caddr l) (car (cdr (cdr l)))) - -(_??_ (caddr '(1 2 3 4)) 3) - - ; (if ) - ; (if 3 2) 'yes) 'yes) -(_??_ (if (> 3 2) 'yes 'no) 'yes) -(_??_ (if (> 2 3) 'no 'yes) 'yes) -(_??_ (if (> 2 3) 'no) #f) - - ; simple math operators - -(define zero? (macro (value) `(eq? ,value 0))) - -(_??_ (zero? 1) #f) -(_??_ (zero? 0) #t) -(_??_ (zero? "hello") #f) - -(define positive? (macro (value) `(> ,value 0))) - -(_??_ (positive? 12) #t) -(_??_ (positive? -12) #f) - -(define negative? (macro (value) `(< ,value 0))) - -(_??_ (negative? 12) #f) -(_??_ (negative? -12) #t) - -(define (abs x) (if (>= x 0) x (- x))) - -(_??_ (abs 12) 12) -(_??_ (abs -12) 12) - -(define max (lambda (first . rest) - (while (not (null? rest)) - (cond ((< first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(_??_ (max 1 2 3) 3) -(_??_ (max 3 2 1) 3) - -(define min (lambda (first . rest) - (while (not (null? rest)) - (cond ((> first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(_??_ (min 1 2 3) 1) -(_??_ (min 3 2 1) 1) - -(define (even? x) (zero? (% x 2))) - -(_??_ (even? 2) #t) -(_??_ (even? -2) #t) -(_??_ (even? 3) #f) -(_??_ (even? -1) #f) - -(define (odd? x) (not (even? x))) - -(_??_ (odd? 2) #f) -(_??_ (odd? -2) #f) -(_??_ (odd? 3) #t) -(_??_ (odd? -1) #t) - -(_??_ (list-tail '(1 2 3 . 4) 3) 4) - -(define (list-ref x k) - (car (list-tail x k)) - ) - -(_??_ (list-ref '(1 2 3 4) 3) 4) - -(define (list-set! x k v) - (set-car! (list-tail x k) v) - x) - -(list-set! (list 1 2 3) 1 4) - - ; define a set of local - ; variables all at once and - ; then evaluate a list of - ; sexprs - ; - ; (let (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let ((x 1) (y)) (set! y (+ x 1)) y) - -(define let - (macro (vars . exprs) - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-vals vars) - (cond ((not (null? vars)) - (cons (cond ((null? (cdr (car vars))) ()) - (else - (car (cdr (car vars)))) - ) - (make-vals (cdr vars)))) - (else ()) - ) - ) - ; prepend the set operations - ; to the expressions - - ; build the lambda. - - `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) - ) - ) - - -(_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3) - - ; define a set of local - ; variables one at a time and - ; then evaluate a list of - ; sexprs - ; - ; (let* (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let* ((x 1) (y)) (set! y (+ x 1)) y) - -(define letrec - (macro (vars . exprs) - - ; - ; make the list of names in the let - ; - - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (define (make-exprs vars exprs) - (cond ((null? vars) exprs) - (else - (cons - (list set - (list quote - (car (car vars)) - ) - (cond ((null? (cdr (car vars))) ()) - (else (cadr (car vars)))) - ) - (make-exprs (cdr vars) exprs) - ) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-nils vars) - (cond ((null? vars) ()) - (else (cons () (make-nils (cdr vars)))) - ) - ) - ; build the lambda. - - `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) - ) - ) - -(_??_ (letrec ((x 1) (y x)) (+ x y)) 2) - - ; letrec is sufficient for let* - -(define let* letrec) - -(define when (macro (test . l) `(cond (,test ,@l)))) - -(_??_ (when #t (+ 1 2)) 3) -(_??_ (when #f (+ 1 2)) #f) - -(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) - -(_??_ (unless #f (+ 2 3)) 5) -(_??_ (unless #t (+ 2 3)) #f) - -(define (reverse list) - (define (_r old new) - (if (null? old) - new - (_r (cdr old) (cons (car old) new)) - ) - ) - (_r list ()) - ) - -(_??_ (reverse '(1 2 3)) '(3 2 1)) - -(define make-list - (lambda (a . b) - (define (_m a x) - (if (zero? a) - x - (_m (- a 1) (cons b x)) - ) - ) - (if (null? b) - (set! b #f) - (set! b (car b)) - ) - (_m a '()) - ) - ) - -(_??_ (make-list 10 'a) '(a a a a a a a a a a)) - -(_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f)) - -(define member (lambda (obj list . test?) - (cond ((null? list) - #f - ) - (else - (if (null? test?) (set! test? equal?) (set! test? (car test?))) - (if (test? obj (car list)) - list - (member obj (cdr list) test?)) - ) - ) - ) - ) - -(_??_ (member '(2) '((1) (2) (3))) '((2) (3))) - -(_??_ (member '(4) '((1) (2) (3))) #f) - -(define (memq obj list) (member obj list eq?)) - -(_??_ (memq 2 '(1 2 3)) '(2 3)) - -(_??_ (memq 4 '(1 2 3)) #f) - -(_??_ (memq '(2) '((1) (2) (3))) #f) - -(define (memv obj list) (member obj list eqv?)) - -(_??_ (memv 2 '(1 2 3)) '(2 3)) - -(_??_ (memv 4 '(1 2 3)) #f) - -(_??_ (memv '(2) '((1) (2) (3))) #f) - -(define (assoc obj list . compare) - (if (null? compare) - (set! compare equal?) - (set! compare (car compare)) - ) - (if (null? list) - #f - (if (compare obj (caar list)) - (car list) - (assoc obj (cdr list) compare) - ) - ) - ) - -(define (assq obj list) (assoc obj list eq?)) -(define (assv obj list) (assoc obj list eqv?)) - -(_??_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1)) -(_??_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2)) -(_??_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3)) - -(define char? integer?) - -(_??_ (char? #\q) #t) -(_??_ (char? "h") #f) - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(_??_ (char-upper-case? #\a) #f) -(_??_ (char-upper-case? #\B) #t) -(_??_ (char-upper-case? #\0) #f) -(_??_ (char-upper-case? #\space) #f) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(_??_ (char-lower-case? #\a) #t) -(_??_ (char-lower-case? #\B) #f) -(_??_ (char-lower-case? #\0) #f) -(_??_ (char-lower-case? #\space) #f) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(_??_ (char-alphabetic? #\a) #t) -(_??_ (char-alphabetic? #\B) #t) -(_??_ (char-alphabetic? #\0) #f) -(_??_ (char-alphabetic? #\space) #f) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(_??_ (char-numeric? #\a) #f) -(_??_ (char-numeric? #\B) #f) -(_??_ (char-numeric? #\0) #t) -(_??_ (char-numeric? #\space) #f) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(_??_ (char-whitespace? #\a) #f) -(_??_ (char-whitespace? #\B) #f) -(_??_ (char-whitespace? #\0) #f) -(_??_ (char-whitespace? #\space) #t) - -(define char->integer (macro (v) v)) -(define integer->char char->integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(_??_ (char-upcase #\a) #\A) -(_??_ (char-upcase #\B) #\B) -(_??_ (char-upcase #\0) #\0) -(_??_ (char-upcase #\space) #\space) - -(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) - -(_??_ (char-downcase #\a) #\a) -(_??_ (char-downcase #\B) #\b) -(_??_ (char-downcase #\0) #\0) -(_??_ (char-downcase #\space) #\space) - -(define (digit-value c) - (if (char-numeric? c) - (- c #\0) - #f) - ) - -(_??_ (digit-value #\1) 1) -(_??_ (digit-value #\a) #f) - -(define string (lambda chars (list->string chars))) - -(_??_ (string #\a #\b #\c) "abc") - -(_??_ (apply cons '(a b)) '(a . b)) - -(define map - (lambda (proc . lists) - (define (_a lists) - (cond ((null? lists) ()) - (else - (cons (caar lists) (_a (cdr lists))) - ) - ) - ) - (define (_n lists) - (cond ((null? lists) ()) - (else - (cons (cdr (car lists)) (_n (cdr lists))) - ) - ) - ) - (define (_m lists) - (cond ((null? (car lists)) ()) - (else - (cons (apply proc (_a lists)) (_m (_n lists))) - ) - ) - ) - (_m lists) - ) - ) - -(_??_ (map cadr '((a b) (d e) (g h))) '(b e h)) - -(define for-each - (lambda (proc . lists) - (define (_f lists) - (cond ((null? (car lists)) #t) - (else - (apply proc (map car lists)) - (_f (map cdr lists)) - ) - ) - ) - (_f lists) - ) - ) - -(_??_ (let ((a 0)) - (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) - a - ) - 6) - - -(define (newline) (write-char #\newline)) - -(newline) - -(_??_ (call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - #t)) - -3) - - - ; `q -> (quote q) - ; `(q) -> (append (quote (q))) - ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) - ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) - - - -(_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) - - -(define repeat - (macro (count . rest) - (define counter '__count__) - (cond ((pair? count) - (set! counter (car count)) - (set! count (cadr count)) - ) - ) - `(let ((,counter 0) - (__max__ ,count) - ) - (while (< ,counter __max__) - ,@rest - (set! ,counter (+ ,counter 1)) - ) - ) - ) - ) - -(repeat 2 (write 'hello)) -(repeat (x 3) (write (list 'goodbye x))) - -(define case - (macro (test . l) - ; construct the body of the - ; case, dealing with the - ; lambda version ( => lambda) - - (define (_unarrow l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)) - ) - - ; Build the case elements, which is - ; simply a list of cond clauses - - (define (_case l) - - (cond ((null? l) ()) - - ; else case - - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) - - ; regular case - - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - ) - ) - - ; now construct the overall - ; expression, using a lambda - ; to hold the computed value - ; of the test expression - - `((lambda (__key__) - (cond ,@(_case l))) ,test) - ) - ) - -(_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "one") -(_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "two") -(_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else")) "three") -(_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "else") -(_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "twelve") - -(define do - (macro (vars test . cmds) - (define (_step v) - (if (null? v) - '() - (if (null? (cddr (car v))) - (_step (cdr v)) - (cons `(set! ,(caar v) ,(caddr (car v))) - (_step (cdr v)) - ) - ) - ) - ) - `(let ,(map (lambda (v) (list (car v) (cadr v))) vars) - (while (not ,(car test)) - ,@cmds - ,@(_step vars) - ) - ,@(cdr test) - ) - ) - ) - -(define (eof-object? a) - (equal? a 'eof) - ) - -(_??_ (do ((x 1 (+ x 1)) - (y 0) - ) - ((= x 10) y) - (set! y (+ y x)) - ) - 45) - -(_??_ (do ((vec (make-vector 5)) - (i 0 (+ i 1))) - ((= i 5) vec) - (vector-set! vec i i)) #(0 1 2 3 4)) diff --git a/src/scheme/ao_scheme_do.scheme b/src/scheme/ao_scheme_do.scheme deleted file mode 100644 index 063e4a38..00000000 --- a/src/scheme/ao_scheme_do.scheme +++ /dev/null @@ -1,34 +0,0 @@ -(define do - (macro (vars test . cmds) - (define (_step v) - (if (null? v) - '() - (if (null? (cddr (car v))) - (_step (cdr v)) - (cons `(set! ,(caar v) ,(caddr (car v))) - (_step (cdr v)) - ) - ) - ) - ) - `(let ,(map (lambda (v) (list (car v) (cadr v))) vars) - (while (not ,(car test)) - ,@cmds - ,@(_step vars) - ) - ,@(cdr test) - ) - ) - ) - -(do ((x 1 (+ x 1))) - ((= x 10) "done") - (display "x: ") - (write x) - (newline) - ) - -(do ((vec (make-vector 5)) - (i 0 (+ i 1))) - ((= i 5) vec) - (vector-set! vec i i)) diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c deleted file mode 100644 index f97eb003..00000000 --- a/src/scheme/ao_scheme_error.c +++ /dev/null @@ -1,78 +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_scheme.h" -#include - -void -ao_scheme_vfprintf(FILE *out, const char *format, va_list args) -{ - char c; - - while ((c = *format++) != '\0') { - if (c == '%') { - switch (c = *format++) { - case 'v': - ao_scheme_poly_write(out, (ao_poly) va_arg(args, unsigned int), true); - break; - case 'V': - ao_scheme_poly_write(out, (ao_poly) va_arg(args, unsigned int), false); - break; - case 'p': - fprintf(out, "%p", va_arg(args, void *)); - break; - case 'd': - fprintf(out, "%d", va_arg(args, int)); - break; - case 'x': - fprintf(out, "%x", va_arg(args, int)); - break; - case 's': - fprintf(out, "%s", va_arg(args, char *)); - break; - default: - putc(c, out); - break; - } - } else - putc(c, out); - } -} - -void -ao_scheme_fprintf(FILE *out, const char *format, ...) -{ - va_list args; - va_start(args, format); - ao_scheme_vfprintf(out, format, args); - va_end(args); -} - -ao_poly -ao_scheme_error(int error, const char *format, ...) -{ - va_list args; - - ao_scheme_exception |= error; - va_start(args, format); - ao_scheme_vfprintf(stdout, format, args); - putchar('\n'); - va_end(args); - ao_scheme_fprintf(stdout, "Value: %v\n", ao_scheme_v); - ao_scheme_fprintf(stdout, "Frame: %v\n", ao_scheme_frame_poly(ao_scheme_frame_current)); - printf("Stack:\n"); - ao_scheme_stack_write(stdout, ao_scheme_stack_poly(ao_scheme_stack), true); - ao_scheme_fprintf(stdout, "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 deleted file mode 100644 index 9536cb91..00000000 --- a/src/scheme/ao_scheme_eval.c +++ /dev/null @@ -1,573 +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_scheme.h" -#include - -struct ao_scheme_stack *ao_scheme_stack; -ao_poly ao_scheme_v; - -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 */ - default: - 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)) { - 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; - if (ao_scheme_stack->state != eval_exec) { - 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; - } - 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_stack_mark(ao_scheme_stack); - 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_is_pair(ao_scheme_v)) { - 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_is_cons(ao_scheme_v)) { - *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", -}; - -#ifdef AO_SCHEME_FEATURE_SAVE -/* - * 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(); -} -#endif /* AO_SCHEME_FEATURE_SAVE */ - -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) - break; - } - 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_stack = NULL; - ao_scheme_frame_current = NULL; - return ao_scheme_v; -} diff --git a/src/scheme/ao_scheme_finish.scheme b/src/scheme/ao_scheme_finish.scheme deleted file mode 100644 index fde04fb3..00000000 --- a/src/scheme/ao_scheme_finish.scheme +++ /dev/null @@ -1,17 +0,0 @@ -; -; Copyright © 2018 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. -; -; Finish setting up ROM lisp code - -(undef '_?_) -(undef '_??_) diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c deleted file mode 100644 index 483035f9..00000000 --- a/src/scheme/ao_scheme_float.c +++ /dev/null @@ -1,161 +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_scheme.h" -#include - -#ifdef AO_SCHEME_FEATURE_FLOAT - -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", -}; - -#ifndef FLOAT_FORMAT -#define FLOAT_FORMAT "%g" -#endif - -void -ao_scheme_float_write(FILE *out, ao_poly p, bool write) -{ - struct ao_scheme_float *f = ao_scheme_poly_float(p); - float v = f->value; - - (void) write; - if (isnanf(v)) - fputs("+nan.0", out); - else if (isinff(v)) { - if (v < 0) - putc('-', out); - else - putc('+', out); - fputs("inf.0", out); - } else - fprintf(out, FLOAT_FORMAT, v); -} - -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_BIGINT: - return ao_scheme_poly_bigint(p)->value; - case AO_SCHEME_OTHER: - switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { - 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) -{ - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (ao_scheme_poly_type(val) == 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 val; - float f; - - if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(val)) { - case AO_SCHEME_INT: - case AO_SCHEME_BIGINT: - return _ao_scheme_bool_true; - case AO_SCHEME_FLOAT: - f = ao_scheme_poly_float(val)->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 val; - float f; - - if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(val)) { - case AO_SCHEME_FLOAT: - f = ao_scheme_poly_float(val)->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) -{ - float f; - - if (!ao_scheme_parse_args(_ao_scheme_atom_sqrt, cons, - AO_SCHEME_FLOAT, &f, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_float_get(sqrtf(f)); -} -#endif diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c deleted file mode 100644 index e4da279b..00000000 --- a/src/scheme/ao_scheme_frame.c +++ /dev/null @@ -1,391 +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_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->atom, 0); - ao_scheme_poly_mark(v->val, 0); - MDBG_MOVE("frame mark 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); - } -} - -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 (;;) { - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - - MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); - if (!ao_scheme_mark_memory(&ao_scheme_frame_vals_type, vals)) - frame_vals_mark(vals); - 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; - struct ao_scheme_frame_vals *vals; - int ret; - - MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); - vals = ao_scheme_poly_frame_vals(frame->vals); - if (!ao_scheme_move_memory(&ao_scheme_frame_vals_type, (void **) &vals)) - frame_vals_move(vals); - if (vals != ao_scheme_poly_frame_vals(frame->vals)) - frame->vals = ao_scheme_frame_vals_poly(vals); - - 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", -}; - -int ao_scheme_frame_print_indent; - -static void -ao_scheme_frame_indent(FILE *out, int extra) -{ - int i; - putc('\n', out); - for (i = 0; i < ao_scheme_frame_print_indent+extra; i++) - putc('\t', out); -} - -void -ao_scheme_frame_write(FILE *out, ao_poly p, bool write) -{ - struct ao_scheme_frame *frame = ao_scheme_poly_frame(p); - struct ao_scheme_frame *clear = frame; - int f; - int written = 0; - - ao_scheme_print_start(); - while (frame) { - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - - if (written != 0) - fputs(", ", out); - if (ao_scheme_print_mark_addr(frame)) { - fputs("recurse...", out); - break; - } - - putc('{', out); - written++; - for (f = 0; f < frame->num; f++) { - ao_scheme_frame_indent(out, 1); - ao_scheme_poly_write(out, vals->vals[f].atom, write); - fputs(" = ", out); - ao_scheme_poly_write(out, vals->vals[f].val, write); - } - frame = ao_scheme_poly_frame(frame->prev); - ao_scheme_frame_indent(out, 0); - putc('}', out); - } - if (ao_scheme_print_stop()) { - while (written--) { - ao_scheme_print_clear_addr(clear); - clear = ao_scheme_poly_frame(clear->prev); - } - } -} - -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(frame); - vals = ao_scheme_frame_vals_new(num); - frame = ao_scheme_frame_fetch(); - 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(frame); - new_vals = ao_scheme_frame_vals_new(new_num); - frame = ao_scheme_frame_fetch(); - 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(atom); - ao_scheme_poly_stash(val); - frame = ao_scheme_frame_realloc(frame, f + 1); - val = ao_scheme_poly_fetch(); - atom = ao_scheme_poly_fetch(); - if (!frame) - return AO_SCHEME_NIL; - ao_scheme_frame_bind(frame, frame->num - 1, atom, val); - } else - *ref = val; - return val; -} - -#ifdef AO_SCHEME_FEATURE_UNDEF -ao_poly -ao_scheme_frame_del(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); - int f = frame->num; - struct ao_scheme_frame *moved_frame; - - if (l >= frame->num) - return _ao_scheme_bool_false; - - if (vals->vals[l].atom != atom) - return _ao_scheme_bool_false; - - /* squash the deleted entry */ - memmove(&vals->vals[l], - &vals->vals[l+1], - (f - l) * sizeof (struct ao_scheme_val)); - - /* allocate a smaller vals array */ - ao_scheme_frame_stash(frame); - moved_frame = ao_scheme_frame_realloc(frame, f - 1); - frame = ao_scheme_frame_fetch(); - - /* - * We couldn't allocate a smaller frame, so just - * ignore the last value in the array - */ - if (!moved_frame) - frame->num = f - 1; - return _ao_scheme_bool_true; -} -#endif - -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 deleted file mode 100644 index 2c9e45a0..00000000 --- a/src/scheme/ao_scheme_int.c +++ /dev/null @@ -1,132 +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_scheme.h" - -void -ao_scheme_int_write(FILE *out, ao_poly p, bool write) -{ - int i = ao_scheme_poly_int(p); - (void) write; - fprintf(out, "%d", i); -} - -ao_poly -ao_scheme_do_integerp(struct ao_scheme_cons *cons) -{ -#ifdef AO_SCHEME_FEATURE_BIGINT - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(val)) { - case AO_SCHEME_INT: - case AO_SCHEME_BIGINT: - return _ao_scheme_bool_true; - default: - return _ao_scheme_bool_false; - } -#else - return ao_scheme_do_typep(_ao_scheme_atom_integer3f, AO_SCHEME_INT, cons); -#endif -} - -ao_poly -ao_scheme_do_numberp(struct ao_scheme_cons *cons) -{ -#if defined(AO_SCHEME_FEATURE_BIGINT) || defined(AO_SCHEME_FEATURE_FLOAT) - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - switch (ao_scheme_poly_type(val)) { - case AO_SCHEME_INT: -#ifdef AO_SCHEME_FEATURE_BIGINT - case AO_SCHEME_BIGINT: -#endif -#ifdef AO_SCHEME_FEATURE_FLOAT - case AO_SCHEME_FLOAT: -#endif - return _ao_scheme_bool_true; - default: - return _ao_scheme_bool_false; - } -#else - return ao_scheme_do_integerp(cons); -#endif -} - -#ifdef AO_SCHEME_FEATURE_BIGINT - -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_BIGINT: - return ao_scheme_poly_bigint(p)->value; - } - return 0; -} - -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 = 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(FILE *out, ao_poly p, bool write) -{ - struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); - - (void) write; - fprintf(out, "%d", bi->value); -} -#endif /* AO_SCHEME_FEATURE_BIGINT */ diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c deleted file mode 100644 index 18470efe..00000000 --- a/src/scheme/ao_scheme_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_scheme.h" - -static int -lambda_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_lambda); -} - -static 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); -} - -static 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(FILE *out, ao_poly poly, bool write) -{ - struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(poly); - struct ao_scheme_cons *cons = ao_scheme_poly_cons(lambda->code); - - putc('(', out); - fputs(ao_scheme_args_name(lambda->args), out); - while (cons) { - putc(' ', out); - ao_scheme_poly_write(out, cons->car, write); - cons = ao_scheme_poly_cons(cons->cdr); - } - putc(')', out); -} - -static 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(code); - lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); - code = ao_scheme_cons_fetch(); - 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(varargs); - next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); - varargs = ao_scheme_poly_fetch(); - if (!next_frame) - return AO_SCHEME_NIL; - - /* Re-fetch all of the values in case something moved */ - lambda = ao_scheme_poly_lambda(ao_scheme_v); - cons = ao_scheme_poly_cons(ao_scheme_stack->values); - code = ao_scheme_poly_cons(lambda->code); - formals = ao_scheme_arg(code, 0); - vals = ao_scheme_poly_cons(cons->cdr); - - next_frame->prev = lambda->frame; - ao_scheme_frame_current = next_frame; - ao_scheme_stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); - - for (f = 0; f < args_wanted; f++) { - struct ao_scheme_cons *arg = ao_scheme_poly_cons(formals); - DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_scheme_frame_bind(next_frame, f, arg->car, vals->car); - formals = arg->cdr; - vals = ao_scheme_poly_cons(vals->cdr); - } - if (varargs) { - DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_scheme_cons_poly(vals)); DBG("\n"); - /* - * Bind the rest of the arguments to the final parameter - */ - ao_scheme_frame_bind(next_frame, f, varargs, ao_scheme_cons_poly(vals)); - } else { - /* - * Mark the cons cells from the actuals as freed for immediate re-use, unless - * the actuals point into the source function (nlambdas and macros), or if the - * stack containing them was copied as a part of a continuation - */ - if (lambda->args == AO_SCHEME_FUNC_LAMBDA && !ao_scheme_stack_marked(ao_scheme_stack)) { - ao_scheme_stack->values = AO_SCHEME_NIL; - ao_scheme_cons_free(cons); - } - } - DBGI("eval frame: "); DBG_POLY(ao_scheme_frame_poly(next_frame)); DBG("\n"); - DBG_STACK(); - DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); - return code->cdr; -} diff --git a/src/scheme/ao_scheme_lex.c b/src/scheme/ao_scheme_lex.c deleted file mode 100644 index 266b1fc0..00000000 --- a/src/scheme/ao_scheme_lex.c +++ /dev/null @@ -1,16 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" - diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin deleted file mode 100644 index a34affce..00000000 --- a/src/scheme/ao_scheme_make_builtin +++ /dev/null @@ -1,318 +0,0 @@ -#!/usr/bin/nickle - -typedef struct { - string name; - string feature; -} lisp_name_t; - -typedef struct { - string feature; - string type; - string c_name; - lisp_name_t[*] lisp_names; -} builtin_t; - -string[string] type_map = { - "lambda" => "LAMBDA", - "nlambda" => "NLAMBDA", - "macro" => "MACRO", - "f_lambda" => "F_LAMBDA", - "atom" => "atom", - "feature" => "feature", -}; - -lisp_name_t -make_one_lisp(string token) -{ - string[*] bits = String::split(token, "@"); - string name = bits[0]; - string feature = "all"; - - if (dim(bits) > 1) - feature = bits[1]; - return (lisp_name_t) {.name = name, .feature = feature }; -} - -lisp_name_t[*] -make_lisp(string[*] tokens) -{ - lisp_name_t[...] lisp = {}; - - if (dim(tokens) < 4) - return (lisp_name_t[1]) { make_one_lisp(tokens[dim(tokens) - 1]) }; - return (lisp_name_t[dim(tokens)-3]) { [i] = make_one_lisp(tokens[i+3]) }; -} - -builtin_t -read_builtin(file f) { - string line = File::fgets(f); - string[*] tokens = String::wordsplit(line, " \t"); - - return (builtin_t) { - .feature = dim(tokens) > 0 ? tokens[0] : "#", - .type = dim(tokens) > 1 ? type_map[tokens[1]] : "#", - .c_name = dim(tokens) > 2 ? tokens[2] : "#", - .lisp_names = make_lisp(tokens), - }; -} - -builtin_t[*] -read_builtins(file f) { - builtin_t[...] builtins = {}; - - while (!File::end(f)) { - builtin_t b = read_builtin(f); - - if (b.type[0] != '#') - builtins[dim(builtins)] = b; - } - return builtins; -} - -void -dump_ifdef(builtin_t builtin) -{ - if (builtin.feature != "all") - printf("#ifdef AO_SCHEME_FEATURE_%s\n", builtin.feature); -} - -void -dump_endif(builtin_t builtin) -{ - if (builtin.feature != "all") - printf("#endif /* AO_SCHEME_FEATURE_%s */\n", builtin.feature); -} - -bool is_atom(builtin_t b) = b.type == "atom"; - -bool is_func(builtin_t b) = b.type != "atom" && b.type != "feature"; - -bool is_feature(builtin_t b) = b.type == "feature"; - -void -dump_ids(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_ID\n"); - printf("#undef AO_SCHEME_BUILTIN_ID\n"); - printf("enum ao_scheme_builtin_id {\n"); - for (int i = 0; i < dim(builtins); i++) - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - printf("\tbuiltin_%s,\n", builtins[i].c_name); - dump_endif(builtins[i]); - } - printf("\t_builtin_last\n"); - printf("};\n"); - printf("#endif /* AO_SCHEME_BUILTIN_ID */\n"); -} - -void -dump_casename(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_CASENAME\n"); - printf("#undef AO_SCHEME_BUILTIN_CASENAME\n"); - printf("static char *ao_scheme_builtin_name(enum ao_scheme_builtin_id b) {\n"); - printf("\tswitch(b) {\n"); - for (int i = 0; i < dim(builtins); i++) - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - printf("\tcase builtin_%s: return ao_scheme_poly_atom(_atom(\"%s\"))->name;\n", - builtins[i].c_name, builtins[i].lisp_names[0].name); - dump_endif(builtins[i]); - } - printf("\tdefault: return (char *) \"???\";\n"); - printf("\t}\n"); - printf("}\n"); - printf("#endif /* AO_SCHEME_BUILTIN_CASENAME */\n"); -} - -void -cify_lisp(string l) { - for (int j = 0; j < String::length(l); j++) { - int c= l[j]; - if (Ctype::isalnum(c) || c == '_') - printf("%c", c); - else - printf("%02x", c); - } -} - -void -dump_arrayname(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_ARRAYNAME\n"); - printf("#undef AO_SCHEME_BUILTIN_ARRAYNAME\n"); - printf("static const ao_poly builtin_names[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - printf("\t[builtin_%s] = _ao_scheme_atom_", - builtins[i].c_name); - cify_lisp(builtins[i].lisp_names[0].name); - printf(",\n"); - dump_endif(builtins[i]); - } - } - printf("};\n"); - printf("#endif /* AO_SCHEME_BUILTIN_ARRAYNAME */\n"); -} - -void -dump_funcs(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_FUNCS\n"); - printf("#undef AO_SCHEME_BUILTIN_FUNCS\n"); - printf("const ao_scheme_func_t ao_scheme_builtins[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - printf("\t[builtin_%s] = ao_scheme_do_%s,\n", - builtins[i].c_name, - builtins[i].c_name); - dump_endif(builtins[i]); - } - } - printf("};\n"); - printf("#endif /* AO_SCHEME_BUILTIN_FUNCS */\n"); -} - -void -dump_decls(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_DECLS\n"); - printf("#undef AO_SCHEME_BUILTIN_DECLS\n"); - for (int i = 0; i < dim(builtins); i++) { - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - printf("ao_poly\n"); - printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n", - builtins[i].c_name); - dump_endif(builtins[i]); - } - } - printf("#endif /* AO_SCHEME_BUILTIN_DECLS */\n"); -} - -void -dump_consts(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_CONSTS\n"); - printf("#undef AO_SCHEME_BUILTIN_CONSTS\n"); - printf("struct builtin_func funcs[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - string feature = builtins[i].feature; - if (builtins[i].lisp_names[j].feature != "all") - feature = builtins[i].lisp_names[j].feature; - printf ("\t{ .feature = \"%s\", .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", - feature, - builtins[i].lisp_names[j].name, - builtins[i].type, - builtins[i].c_name); - } - dump_endif(builtins[i]); - } - } - printf("};\n"); - printf("#endif /* AO_SCHEME_BUILTIN_CONSTS */\n"); -} - -void -dump_atoms(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_ATOMS\n"); - printf("#undef AO_SCHEME_BUILTIN_ATOMS\n"); - for (int i = 0; i < dim(builtins); i++) { - if (!is_feature(builtins[i])) { - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - printf("#define _ao_scheme_atom_"); - cify_lisp(builtins[i].lisp_names[j].name); - printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j].name); - } - } - } - printf("#endif /* AO_SCHEME_BUILTIN_ATOMS */\n"); -} - -void -dump_atom_names(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_ATOM_NAMES\n"); - printf("#undef AO_SCHEME_BUILTIN_ATOM_NAMES\n"); - printf("static struct builtin_atom atoms[] = {\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++) { - string feature = builtins[i].feature; - if (builtins[i].lisp_names[j].feature != "all") - feature = builtins[i].lisp_names[j].feature; - printf("\t{ .feature = \"%s\", .name = \"%s\" },\n", - feature, - builtins[i].lisp_names[j].name); - } - } - } - printf("};\n"); - printf("#endif /* AO_SCHEME_BUILTIN_ATOM_NAMES */\n"); -} - -void -dump_syntax_atoms(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_SYNTAX_ATOMS\n"); - printf("#undef AO_SCHEME_BUILTIN_SYNTAX_ATOMS\n"); - printf("static const char *syntax_atoms[] = {\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\"%s\",\n", builtins[i].lisp_names[j].name); - } - } - } - printf("};\n"); - printf("#endif /* AO_SCHEME_BUILTIN_SYNTAX_ATOMS */\n"); -} - -bool -has_feature(string[*] features, string feature) -{ - for (int i = 0; i < dim(features); i++) - if (features[i] == feature) - return true; - return false; -} - -void -dump_features(builtin_t[*] builtins) { - string[...] features = {}; - printf("#ifdef AO_SCHEME_BUILTIN_FEATURES\n"); - for (int i = 0; i < dim(builtins); i++) { - if (builtins[i].feature != "all") { - string feature = builtins[i].feature; - if (!has_feature(features, feature)) { - features[dim(features)] = feature; - printf("#ifndef AO_SCHEME_NO_FEATURE_%s\n", feature); - printf("#define AO_SCHEME_FEATURE_%s\n", feature); - printf("#endif /* AO_SCHEME_NO_FEATURE_%s */\n", feature); - } - } - } - printf("#endif /* AO_SCHEME_BUILTIN_FEATURES */\n"); -} - -void main() { - if (dim(argv) < 2) { - File::fprintf(stderr, "usage: %s \n", argv[0]); - exit(1); - } - twixt(file f = File::open(argv[1], "r"); File::close(f)) { - builtin_t[*] builtins = read_builtins(f); - - printf("/* %d builtins */\n", dim(builtins)); - dump_ids(builtins); - dump_casename(builtins); - dump_arrayname(builtins); - dump_funcs(builtins); - dump_decls(builtins); - dump_consts(builtins); - dump_atoms(builtins); - dump_atom_names(builtins); - dump_syntax_atoms(builtins); - dump_features(builtins); - } -} - -main(); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c deleted file mode 100644 index 8561bf0b..00000000 --- a/src/scheme/ao_scheme_make_const.c +++ /dev/null @@ -1,543 +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_scheme.h" -#include -#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 { - const char *feature; - const char *name; - int args; - enum ao_scheme_builtin_id func; -}; - -struct builtin_atom { - const char *feature; - const char *name; -}; - -#define AO_SCHEME_BUILTIN_CONSTS -#define AO_SCHEME_BUILTIN_ATOM_NAMES - -#include "ao_scheme_builtin.h" - -#define N_FUNC (sizeof funcs / sizeof funcs[0]) - -#define N_ATOM (sizeof atoms / sizeof atoms[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; -} - -static 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; - -static 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; -} - -static 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 -static int macro_scan_depth; - -static 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); - -static 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; -} - -static ao_poly -ao_is_macro(ao_poly p) -{ - struct ao_scheme_builtin *builtin; - struct ao_scheme_lambda *lambda; - ao_poly ret; - - MACRO_DEBUG(indent(); ao_scheme_printf ("is macro %v\n", p); ++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(); ao_scheme_printf ("... %v\n", ret);); - 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(); ao_scheme_printf("has macro %v\n", p); ++macro_scan_depth); - switch (ao_scheme_poly_type(p)) { - case AO_SCHEME_LAMBDA: - lambda = ao_scheme_poly_lambda(p); - p = ao_has_macro(ao_scheme_poly_cons(lambda->code)->cdr); - 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 (ao_scheme_is_pair(list)) { - 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(); ao_scheme_printf("... %v\n", p)); - return p; -} - -static struct ao_scheme_builtin * -ao_scheme_get_builtin(ao_poly p) -{ - if (ao_scheme_poly_type(p) == AO_SCHEME_BUILTIN) - return ao_scheme_poly_builtin(p); - return NULL; -} - -struct seen_builtin { - struct seen_builtin *next; - struct ao_scheme_builtin *builtin; -}; - -static struct seen_builtin *seen_builtins; - -static int -ao_scheme_seen_builtin(struct ao_scheme_builtin *b) -{ - struct seen_builtin *s; - - for (s = seen_builtins; s; s = s->next) - if (s->builtin == b) - return 1; - s = malloc (sizeof (struct seen_builtin)); - s->builtin = b; - s->next = seen_builtins; - seen_builtins = s; - return 0; -} - -static int -ao_scheme_read_eval_abort(FILE *read_file) -{ - ao_poly in; - - for(;;) { - in = ao_scheme_read(read_file); - if (in == _ao_scheme_atom_eof) - break; - (void) ao_scheme_eval(in); - if (ao_scheme_exception) { - ao_scheme_fprintf(stderr, "make_const failed on %v\n", in); - return 0; - } - } - return 1; -} - -static FILE *in; -static FILE *out; - -struct feature { - struct feature *next; - char name[]; -}; - -static struct feature *enable; -static struct feature *disable; - -static void -ao_scheme_add_feature(struct feature **list, char *name) -{ - struct feature *feature = malloc (sizeof (struct feature) + strlen(name) + 1); - strcpy(feature->name, name); - feature->next = *list; - *list = feature; -} - -static bool -_ao_scheme_has_feature(struct feature *list, const char *name, bool skip_undef) -{ - if (skip_undef && !strcmp(name, "UNDEF")) - return false; - - while (list) { - if (!strcmp(list->name, name)) - return true; - list = list->next; - } - return false; -} - -static bool -ao_scheme_has_undef(struct feature *list) -{ - return _ao_scheme_has_feature(list, "UNDEF", false); -} - -static bool -ao_scheme_has_feature(struct feature *list, const char *name) -{ - return _ao_scheme_has_feature(list, name, true); -} - -static void -ao_scheme_add_features(struct feature **list, const char *names) -{ - char *saveptr = NULL; - char *name; - char *copy = strdup(names); - char *save = copy; - - while ((name = strtok_r(copy, ",", &saveptr)) != NULL) { - copy = NULL; - if (!ao_scheme_has_feature(*list, name)) - ao_scheme_add_feature(list, name); - } - free(save); -} - -int -ao_scheme_getc(void) -{ - return getc(in); -} - -static const struct option options[] = { - { .name = "out", .has_arg = 1, .val = 'o' }, - { .name = "disable", .has_arg = 1, .val = 'd' }, - { .name = "enable", .has_arg = 1, .val = 'e' }, - { 0, 0, 0, 0 } -}; - -static void usage(char *program) -{ - fprintf(stderr, "usage: %s [--out=] [--disable={feature,...}] [--enable={feature,...} [input]\n", program); - exit(1); -} - -int -main(int argc, char **argv) -{ - int f, o, an; - ao_poly val; - struct ao_scheme_atom *a; - struct ao_scheme_builtin *b; - struct feature *d; - int in_atom = 0; - char *out_name = NULL; - int c; - enum ao_scheme_builtin_id prev_func; - enum ao_scheme_builtin_id target_func; - enum ao_scheme_builtin_id func_map[_builtin_last]; - - in = stdin; - out = stdout; - - while ((c = getopt_long(argc, argv, "o:d:e:", options, NULL)) != -1) { - switch (c) { - case 'o': - out_name = optarg; - break; - case 'd': - ao_scheme_add_features(&disable, optarg); - break; - case 'e': - ao_scheme_add_features(&enable, 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; - target_func = 0; - b = NULL; - for (f = 0; f < (int) N_FUNC; f++) { - if (ao_scheme_has_feature(enable, funcs[f].feature) || !ao_scheme_has_feature(disable, funcs[f].feature)) { - if (funcs[f].func != prev_func) { - prev_func = funcs[f].func; - b = ao_scheme_make_builtin(prev_func, funcs[f].args); - - /* Target may have only a subset of - * the enum values; record what those - * values will be here. This obviously - * depends on the functions in the - * array being in the same order as - * the enumeration; which - * ao_scheme_make_builtin ensures. - */ - func_map[prev_func] = target_func++; - } - a = ao_scheme_atom_intern((char *) funcs[f].name); - ao_scheme_atom_def(ao_scheme_atom_poly(a), - ao_scheme_builtin_poly(b)); - } - } - - /* atoms */ - for (an = 0; an < (int) N_ATOM; an++) { - if (ao_scheme_has_feature(enable, atoms[an].feature) || !ao_scheme_has_feature(disable, atoms[an].feature)) - a = ao_scheme_atom_intern((char *) atoms[an].name); - } - - while (argv[optind]) { - in = fopen(argv[optind], "r"); - if (!in) { - perror(argv[optind]); - exit(1); - } - if (!ao_scheme_read_eval_abort(in)) { - fprintf(stderr, "eval failed\n"); - exit(1); - } - fclose(in); - optind++; - } - - if (!ao_scheme_has_undef(enable) && ao_scheme_has_undef(disable)) { - struct ao_scheme_cons cons; - - cons.car = _ao_scheme_atom_undef; - cons.cdr = AO_SCHEME_NIL; - ao_scheme_do_undef(&cons); - } - - /* 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) { - fprintf(stderr, "error: function %s contains unresolved macro: ", - ao_scheme_poly_atom(vals->vals[f].atom)->name); - ao_scheme_poly_write(stderr, val, true); - fprintf(stderr, "\n"); - exit(1); - } - - /* Remap builtin enum values to match target set */ - b = ao_scheme_get_builtin(vals->vals[f].val); - if (b != NULL) { - if (!ao_scheme_seen_builtin(b)) - b->func = func_map[b->func]; - } - } - - if (out_name) { - out = fopen(out_name, "w"); - if (!out) { - perror(out_name); - exit(1); - } - } - - fprintf(out, "/* Generated file, do not edit */\n\n"); - - for (d = disable; d; d = d->next) - fprintf(out, "#undef AO_SCHEME_FEATURE_%s\n", d->name); - - 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)) { - const char *n = a->name; - char ch; - fprintf(out, "#define _ao_scheme_atom_"); - while ((ch = *n++)) { - if (isalnum(ch)) - fprintf(out, "%c", ch); - else - fprintf(out, "%02x", ch); - } - 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 ch; - if ((o & 0xf) == 0) - fprintf(out, "\n\t"); - else - fprintf(out, " "); - ch = ao_scheme_const[o]; - if (!in_atom) - in_atom = is_atom(o); - if (in_atom) { - fprintf(out, " '%c',", ch); - in_atom--; - } else { - fprintf(out, "0x%02x,", ch); - } - } - 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 deleted file mode 100644 index 94cbdfc1..00000000 --- a/src/scheme/ao_scheme_mem.c +++ /dev/null @@ -1,1117 +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_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 - -#define DBG_MEM_STACK 0 -#if DBG_MEM_STACK -char *mem_collect_stack; -int64_t mem_collect_max_depth; - -static void -ao_scheme_check_stack(void) -{ - char x; - int64_t depth; - - depth = mem_collect_stack - &x; - if (depth > mem_collect_max_depth) - mem_collect_max_depth = depth; -} - -static void -_ao_scheme_reset_stack(char *x) -{ - mem_collect_stack = x; -// mem_collect_max_depth = 0; -} -#define ao_scheme_declare_stack char x; -#define ao_scheme_reset_stack() _ao_scheme_reset_stack(&x) -#else -#define ao_scheme_check_stack() -#define ao_scheme_declare_stack -#define ao_scheme_reset_stack() -#endif - -#if DBG_MEM -#define DBG_MEM_RECORD 1 -#endif - -#if DBG_MEM -int dbg_move_depth; -int dbg_mem = DBG_MEM_START; -int dbg_validate = 0; -#endif - -#if DBG_MEM_RECORD -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(const 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() -#define ao_scheme_record(t,a,s) -#endif - -uint8_t ao_scheme_exception; - -struct ao_scheme_root { - const struct ao_scheme_type *type; - void **addr; -}; - -#define AO_SCHEME_NUM_STASH 6 -static ao_poly stash_poly[AO_SCHEME_NUM_STASH]; -static int stash_poly_ptr; - -static const struct ao_scheme_root ao_scheme_root[] = { - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[0] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[1] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[2] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[3] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[4] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[5] - }, - { - .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_FEATURE_PORT - { - .type = NULL, - .addr = (void **) (void *) &ao_scheme_stdin, - }, - { - .type = NULL, - .addr = (void **) (void *) &ao_scheme_stdout, - }, - { - .type = NULL, - .addr = (void **) (void *) &ao_scheme_stderr, - }, -#endif -#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 int ao_scheme_printing, ao_scheme_print_cleared; -#if DBG_MEM -static int ao_scheme_collecting; -#endif -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 (AO_SCHEME_POOL / 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(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; - ao_scheme_check_stack(); - 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 inline 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; - int end; - - 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(); - - if (l < chunk_last && ao_scheme_chunk[l].old_offset == offset) - ao_scheme_abort(); -#endif - - /* Shuffle existing entries right */ - 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; - printf("busy:"); - for (i = 0; i < ao_scheme_top; i += 4) { - if ((i & 0xff) == 0) { - printf("\n\t"); - } - else if ((i & 0x1f) == 0) - printf(" "); - if (busy(ao_scheme_busy, i)) - printf("*"); - else - printf("-"); - } - printf ("\n"); -} -#define DUMP_BUSY() dump_busy() -#else -#define DUMP_BUSY() -#endif - -#if MDBG_DUMP -static void -dump_atoms(int show_marked) -{ - struct ao_scheme_atom *atom; - - printf("atoms {\n"); - for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { - printf("\t%d: %s", MDBG_OFFSET(atom), atom->name); - if (show_marked) - printf(" %s", ao_scheme_marked(atom) ? "referenced" : "unreferenced"); - printf("\n"); - } - printf("}\n"); - -} -#define DUMP_ATOMS(a) dump_atoms(a) -#else -#define DUMP_ATOMS(a) -#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, -#ifdef AO_SCHEME_FEATURE_BIGINT - [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, -#endif - [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_STRING] = &ao_scheme_string_type, -#ifdef AO_SCHEME_FEATURE_FLOAT - [AO_SCHEME_FLOAT] = &ao_scheme_float_type, -#endif -#ifdef AO_SCHEME_FEATURE_VECTOR - [AO_SCHEME_VECTOR] = &ao_scheme_vector_type, -#endif -#ifdef AO_SCHEME_FEATURE_PORT - [AO_SCHEME_PORT] = &ao_scheme_port_type, -#endif -}; - -static int -ao_scheme_mark(const struct ao_scheme_type *type, void *addr); - -static int -ao_scheme_move(const struct ao_scheme_type *type, void **ref); - -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 -uint64_t ao_scheme_collects[2]; -uint64_t ao_scheme_freed[2]; -uint64_t ao_scheme_loops[2]; -#endif - -int ao_scheme_last_top; -int ao_scheme_collect_counts; - -int -ao_scheme_collect(uint8_t style) -{ - ao_scheme_declare_stack - int i; - int top; -#if DBG_MEM_STATS - int loops = 0; -#endif -#if DBG_MEM_RECORD - struct ao_scheme_record *mark_record = NULL, *move_record = NULL; -#endif - MDBG_MOVE("collect %lu\n", ao_scheme_collects[style]); - - MDBG_DO(ao_scheme_frame_write(stdout, ao_scheme_frame_poly(ao_scheme_frame_global), true)); - MDBG_DO(++ao_scheme_collecting); - - ao_scheme_reset_stack(); - - /* The first time through, we're doing a full collect */ - if (ao_scheme_last_top == 0) - style = AO_SCHEME_COLLECT_FULL; - - /* One in a while, just do a full collect */ - - if (ao_scheme_collect_counts >= 128) - style = AO_SCHEME_COLLECT_FULL; - - if (style == AO_SCHEME_COLLECT_FULL) - ao_scheme_collect_counts = 0; - - /* 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 (;;) { - 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); - -#ifdef AO_SCHEME_FEATURE_PORT - ao_scheme_port_check_references(); -#endif - ao_scheme_atom_check_references(); - -#if DBG_MEM_RECORD - 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_ATOMS(1); - 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; - } - - /* Short-circuit the rest of the loop when all of the - * found objects aren't moving. This isn't strictly - * necessary as the rest of the loop is structured to - * work in this case, but GCC 7.2.0 with optimization - * greater than 2 generates incorrect code for this... - */ - if (i == AO_SCHEME_NCHUNK) { - chunk_low = chunk_high; -#if DBG_MEM_STATS - loops++; -#endif - continue; - } - - /* - * 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); - ao_scheme_atom_move(); -#ifdef AO_SCHEME_FEATURE_PORT - /* the set of open ports gets relocated but not marked, so - * just deal with it separately - */ - ao_scheme_poly_move(&ao_scheme_open_ports, 0); -#endif - -#if DBG_MEM_RECORD - 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 - DUMP_ATOMS(0); - } - -#if DBG_MEM_STATS - loops++; -#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)); - -#if DBG_MEM_STACK - fprintf(stderr, "max collect stack depth %lu\n", mem_collect_max_depth); -#endif - MDBG_DO(--ao_scheme_collecting); - 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_addr(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 - */ - - -/* - * 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(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 - */ -static int -ao_scheme_mark(const struct ao_scheme_type *type, void *addr) -{ - int ret; - MDBG_MOVE("mark offset %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; - int ret; - - 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(addr)) - return 1; - - if (type == AO_SCHEME_CONS && do_note_cons) { - note_cons(pool_offset(addr)); - return 1; - } else { - const struct ao_scheme_type *lisp_type; - - if (type == AO_SCHEME_OTHER) - type = ao_scheme_other_type(addr); - - lisp_type = ao_scheme_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_scheme_abort(); -#endif - - MDBG_MOVE("poly_mark offset %d\n", MDBG_OFFSET(addr)); - MDBG_MOVE_IN(); - ret = ao_scheme_mark_memory(lisp_type, addr); - if (!ret) { - MDBG_MOVE("mark recurse\n"); - lisp_type->mark(addr); - } - MDBG_MOVE_OUT(); - return ret; - } -} - -/* - * 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(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_addr(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); - ao_scheme_record(type, addr, ao_scheme_size(type, addr)); - return 0; -} - -static 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) -{ - ao_poly p = *ref; - int ret; - void *addr; - uint16_t offset, orig_offset; - - if (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) - return 1; - - addr = ao_scheme_ref(p); - if (!ao_scheme_is_pool_addr(addr)) - return 1; - - orig_offset = pool_offset(addr); - offset = move_map(orig_offset); - - if (ao_scheme_poly_base_type(p) == AO_SCHEME_CONS && do_note_cons) { - note_cons(orig_offset); - ret = 1; - } else { - uint8_t type = ao_scheme_poly_base_type(p); - const struct ao_scheme_type *lisp_type; - - if (type == AO_SCHEME_OTHER) - type = ao_scheme_other_type(ao_scheme_pool + offset); - - lisp_type = ao_scheme_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_scheme_abort(); -#endif - /* inline ao_scheme_move to save stack space */ - MDBG_MOVE("move object %d\n", MDBG_OFFSET(addr)); - MDBG_MOVE_IN(); - ret = ao_scheme_move_memory(lisp_type, &addr); - if (!ret) { - MDBG_MOVE("move recurse\n"); - lisp_type->move(addr); - } - MDBG_MOVE_OUT(); - } - - /* Re-write the poly value */ - if (offset != orig_offset) { - ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, ao_scheme_poly_base_type(p)); - MDBG_MOVE("poly %d moved %d -> %d\n", - ao_scheme_poly_type(np), orig_offset, offset); - *ref = np; - } - return ret; -} - -int -ao_scheme_marked(void *addr) -{ - if (!ao_scheme_is_pool_addr(addr)) - return 1; - return busy(ao_scheme_busy, pool_offset(addr)); -} - -#if DBG_MEM -static 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_poly_stash(ao_poly p) -{ - assert(stash_poly_ptr < AO_SCHEME_NUM_STASH); - stash_poly[stash_poly_ptr++] = p; -} - -ao_poly -ao_scheme_poly_fetch(void) -{ - ao_poly p; - - assert (stash_poly_ptr > 0); - p = stash_poly[--stash_poly_ptr]; - stash_poly[stash_poly_ptr] = AO_SCHEME_NIL; - return p; -} - -int -ao_scheme_print_mark_addr(void *addr) -{ - int offset; - -#if DBG_MEM - if (ao_scheme_collecting) - ao_scheme_abort(); -#endif - - if (!ao_scheme_is_pool_addr(addr)) - return 0; - - if (!ao_scheme_print_cleared) { - ao_scheme_print_cleared = 1; - memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); - } - offset = pool_offset(addr); - if (busy(ao_scheme_busy, offset)) - return 1; - mark(ao_scheme_busy, offset); - return 0; -} - -void -ao_scheme_print_clear_addr(void *addr) -{ - int offset; - -#if DBG_MEM - if (ao_scheme_collecting) - ao_scheme_abort(); -#endif - - if (!ao_scheme_is_pool_addr(addr)) - return; - - if (!ao_scheme_print_cleared) - return; - offset = pool_offset(addr); - clear(ao_scheme_busy, offset); -} - -/* Notes that printing has started */ -void -ao_scheme_print_start(void) -{ - ao_scheme_printing++; -} - -/* Notes that printing has ended. Returns 1 if printing is still going on */ -int -ao_scheme_print_stop(void) -{ - ao_scheme_printing--; - if (ao_scheme_printing != 0) - return 1; - ao_scheme_print_cleared = 0; - return 0; -} diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c deleted file mode 100644 index 8a92c9f2..00000000 --- a/src/scheme/ao_scheme_poly.c +++ /dev/null @@ -1,74 +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_scheme.h" - -static void ao_scheme_invalid_write(FILE *out, ao_poly p, bool write) { - fprintf(out, "??? type %d poly 0x%04x ???", ao_scheme_poly_type (p), p); - (void) write; - ao_scheme_abort(); -} - -static void (*const ao_scheme_write_funcs[AO_SCHEME_NUM_TYPE]) (FILE *out, ao_poly p, bool write) = { - [AO_SCHEME_CONS] = ao_scheme_cons_write, -#ifdef AO_SCHEME_FEATURE_BIGINT - [AO_SCHEME_BIGINT] = ao_scheme_bigint_write, -#endif - [AO_SCHEME_INT] = ao_scheme_int_write, - [AO_SCHEME_ATOM] = ao_scheme_atom_write, - [AO_SCHEME_BUILTIN] = ao_scheme_builtin_write, - [AO_SCHEME_FRAME] = ao_scheme_frame_write, - [AO_SCHEME_FRAME_VALS] = ao_scheme_invalid_write, - [AO_SCHEME_LAMBDA] = ao_scheme_lambda_write, - [AO_SCHEME_STACK] = ao_scheme_stack_write, - [AO_SCHEME_BOOL] = ao_scheme_bool_write, - [AO_SCHEME_STRING] = ao_scheme_string_write, -#ifdef AO_SCHEME_FEATURE_FLOAT - [AO_SCHEME_FLOAT] = ao_scheme_float_write, -#endif -#ifdef AO_SCHEME_FEATURE_VECTOR - [AO_SCHEME_VECTOR] = ao_scheme_vector_write, -#endif -#ifdef AO_SCHEME_FEATURE_PORT - [AO_SCHEME_PORT] = ao_scheme_port_write, -#endif -}; - -void (*ao_scheme_poly_write_func(ao_poly p))(FILE *out, ao_poly p, bool write) -{ - uint8_t type = ao_scheme_poly_type(p); - - if (type < AO_SCHEME_NUM_TYPE) - return ao_scheme_write_funcs[type]; - return ao_scheme_invalid_write; -} - -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_addr(a)) - return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; - return (a - ao_scheme_pool + 4) | type; -} diff --git a/src/scheme/ao_scheme_port.c b/src/scheme/ao_scheme_port.c deleted file mode 100644 index b5e5d8dc..00000000 --- a/src/scheme/ao_scheme_port.c +++ /dev/null @@ -1,193 +0,0 @@ -/* - * Copyright © 2018 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" - -#ifdef AO_SCHEME_FEATURE_PORT - -static void port_mark(void *addr) -{ - (void) addr; -} - -static int port_size(void *addr) -{ - (void) addr; - return sizeof(struct ao_scheme_port); -} - -static void port_move(void *addr) -{ - struct ao_scheme_port *port = addr; - - (void) ao_scheme_poly_move(&port->next, 0); -} - -const struct ao_scheme_type ao_scheme_port_type = { - .mark = port_mark, - .size = port_size, - .move = port_move, - .name = "port", -}; - -void -ao_scheme_port_write(FILE *out, ao_poly v, bool write) -{ - (void) write; - ao_scheme_fprintf(out, "#port<%d>", fileno(ao_scheme_poly_port(v)->file)); -} - -ao_poly ao_scheme_stdin, ao_scheme_stdout, ao_scheme_stderr; - -ao_poly ao_scheme_open_ports; - -void -ao_scheme_port_check_references(void) -{ - struct ao_scheme_port *p; - - for (p = ao_scheme_poly_port(ao_scheme_open_ports); p; p = ao_scheme_poly_port(p->next)) { - if (!ao_scheme_marked(p)) - ao_scheme_port_close(p); - } -} - -struct ao_scheme_port * -ao_scheme_port_alloc(FILE *file, bool stayopen) -{ - struct ao_scheme_port *p; - - p = ao_scheme_alloc(sizeof (struct ao_scheme_port)); - if (!p) - return NULL; - p->type = AO_SCHEME_PORT; - p->stayopen = stayopen; - p->file = file; - p->next = ao_scheme_open_ports; - ao_scheme_open_ports = ao_scheme_port_poly(p); - return p; -} - -void -ao_scheme_port_close(struct ao_scheme_port *port) -{ - ao_poly *prev; - struct ao_scheme_port *ref; - - if (port->file && !port->stayopen) { - fclose(port->file); - port->file = NULL; - for (prev = &ao_scheme_open_ports; (ref = ao_scheme_poly_port(*prev)); prev = &ref->next) - if (ref == port) { - *prev = port->next; - break; - } - } -} - -ao_poly -ao_scheme_do_portp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(_ao_scheme_atom_port3f, AO_SCHEME_PORT, cons); -} - -ao_poly -ao_scheme_do_port_openp(struct ao_scheme_cons *cons) -{ - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_port2dopen3f, cons, - AO_SCHEME_PORT, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return port->file ? _ao_scheme_bool_true : _ao_scheme_bool_false; -} - -static ao_poly -ao_scheme_do_open_file(ao_poly proc, struct ao_scheme_cons *cons, const char *mode) -{ - FILE *file; - struct ao_scheme_string *name; - - if (!ao_scheme_parse_args(proc, cons, - AO_SCHEME_STRING, &name, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - file = fopen(name->val, mode); - if (!file) - return ao_scheme_error(AO_SCHEME_FILEERROR, - "%v: no such file \"%v\"", - proc, name); - return ao_scheme_port_poly(ao_scheme_port_alloc(file, false)); -} - -ao_poly -ao_scheme_do_open_input_file(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_open_file(_ao_scheme_atom_open2dinput2dfile, cons, "r"); -} - -ao_poly -ao_scheme_do_open_output_file(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_open_file(_ao_scheme_atom_open2doutput2dfile, cons, "w"); -} - -ao_poly -ao_scheme_do_close_port(struct ao_scheme_cons *cons) -{ - struct ao_scheme_port *port; - - if (!ao_scheme_parse_args(_ao_scheme_atom_port2dopen3f, cons, - AO_SCHEME_PORT, &port, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - ao_scheme_port_close(port); - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_current_input_port(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_parse_args(_ao_scheme_atom_current2dinput2dport, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!ao_scheme_stdin) - ao_scheme_stdin = ao_scheme_port_poly(ao_scheme_port_alloc(stdin, true)); - return ao_scheme_stdin; -} - -ao_poly -ao_scheme_do_current_output_port(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_parse_args(_ao_scheme_atom_current2doutput2dport, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!ao_scheme_stdout) - ao_scheme_stdout = ao_scheme_port_poly(ao_scheme_port_alloc(stdout, true)); - return ao_scheme_stdout; -} - -ao_poly -ao_scheme_do_current_error_port(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_parse_args(_ao_scheme_atom_current2derror2dport, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!ao_scheme_stderr) - ao_scheme_stderr = ao_scheme_port_poly(ao_scheme_port_alloc(stderr, true)); - return ao_scheme_stderr; -} - -#endif /* AO_SCHEME_FEATURE_PORT */ diff --git a/src/scheme/ao_scheme_port.scheme b/src/scheme/ao_scheme_port.scheme deleted file mode 100644 index 886aed25..00000000 --- a/src/scheme/ao_scheme_port.scheme +++ /dev/null @@ -1,43 +0,0 @@ -; -; Copyright © 2018 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. -; -; port functions placed in ROM - - -(define newline - (lambda args - (if (null? args) - (write-char #\newline) - (write-char #\newline (car args)) - ) - ) - ) - -(newline) -(newline (open-output-file "/dev/null")) - -(define (eof-object? a) - (equal? a 'eof) - ) - -(define (load name) - (let ((p (open-input-file name)) - (e)) - (while (not (eof-object? (set! e (read p)))) - (write (eval e)) (newline) - ) - (close-port p) - ) - ) - -(load "/dev/null") diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c deleted file mode 100644 index 3575ff3f..00000000 --- a/src/scheme/ao_scheme_read.c +++ /dev/null @@ -1,727 +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_scheme.h" -#include "ao_scheme_read.h" -#include -#include - -static const uint16_t lex_classes[128] = { - IGNORE, /* ^@ */ - IGNORE, /* ^A */ - IGNORE, /* ^B */ - IGNORE, /* ^C */ - IGNORE, /* ^D */ - IGNORE, /* ^E */ - IGNORE, /* ^F */ - IGNORE, /* ^G */ - IGNORE, /* ^H */ - WHITE, /* ^I */ - WHITE, /* ^J */ - WHITE, /* ^K */ - WHITE, /* ^L */ - WHITE, /* ^M */ - IGNORE, /* ^N */ - IGNORE, /* ^O */ - IGNORE, /* ^P */ - IGNORE, /* ^Q */ - IGNORE, /* ^R */ - IGNORE, /* ^S */ - IGNORE, /* ^T */ - IGNORE, /* ^U */ - IGNORE, /* ^V */ - IGNORE, /* ^W */ - IGNORE, /* ^X */ - IGNORE, /* ^Y */ - IGNORE, /* ^Z */ - IGNORE, /* ^[ */ - IGNORE, /* ^\ */ - IGNORE, /* ^] */ - IGNORE, /* ^^ */ - IGNORE, /* ^_ */ - PRINTABLE|WHITE, /* */ - PRINTABLE, /* ! */ - PRINTABLE|STRINGC, /* " */ - PRINTABLE, /* # */ - PRINTABLE, /* $ */ - PRINTABLE, /* % */ - PRINTABLE, /* & */ - PRINTABLE|SPECIAL, /* ' */ - PRINTABLE|SPECIAL, /* ( */ - PRINTABLE|SPECIAL, /* ) */ - PRINTABLE, /* * */ - PRINTABLE|SIGN, /* + */ - PRINTABLE|SPECIAL_QUASI, /* , */ - PRINTABLE|SIGN, /* - */ - PRINTABLE|SPECIAL|FLOATC, /* . */ - PRINTABLE, /* / */ - PRINTABLE|DIGIT, /* 0 */ - PRINTABLE|DIGIT, /* 1 */ - PRINTABLE|DIGIT, /* 2 */ - PRINTABLE|DIGIT, /* 3 */ - PRINTABLE|DIGIT, /* 4 */ - PRINTABLE|DIGIT, /* 5 */ - PRINTABLE|DIGIT, /* 6 */ - PRINTABLE|DIGIT, /* 7 */ - PRINTABLE|DIGIT, /* 8 */ - PRINTABLE|DIGIT, /* 9 */ - PRINTABLE, /* : */ - PRINTABLE|COMMENT, /* ; */ - PRINTABLE, /* < */ - PRINTABLE, /* = */ - PRINTABLE, /* > */ - PRINTABLE, /* ? */ - PRINTABLE, /* @ */ - PRINTABLE|ALPHA|HEX_LETTER, /* A */ - PRINTABLE|ALPHA|HEX_LETTER, /* B */ - PRINTABLE|ALPHA|HEX_LETTER, /* C */ - PRINTABLE|ALPHA|HEX_LETTER, /* D */ - PRINTABLE|ALPHA|FLOATC|HEX_LETTER,/* E */ - PRINTABLE|ALPHA|HEX_LETTER, /* F */ - PRINTABLE|ALPHA, /* G */ - PRINTABLE|ALPHA, /* H */ - PRINTABLE|ALPHA, /* I */ - PRINTABLE|ALPHA, /* J */ - PRINTABLE|ALPHA, /* K */ - PRINTABLE|ALPHA, /* L */ - PRINTABLE|ALPHA, /* M */ - PRINTABLE|ALPHA, /* N */ - PRINTABLE|ALPHA, /* O */ - PRINTABLE|ALPHA, /* P */ - PRINTABLE|ALPHA, /* Q */ - PRINTABLE|ALPHA, /* R */ - PRINTABLE|ALPHA, /* S */ - PRINTABLE|ALPHA, /* T */ - PRINTABLE|ALPHA, /* U */ - PRINTABLE|ALPHA, /* V */ - PRINTABLE|ALPHA, /* W */ - PRINTABLE|ALPHA, /* X */ - PRINTABLE|ALPHA, /* Y */ - PRINTABLE|ALPHA, /* Z */ - PRINTABLE, /* [ */ - PRINTABLE, /* \ */ - PRINTABLE, /* ] */ - PRINTABLE, /* ^ */ - PRINTABLE, /* _ */ - PRINTABLE|SPECIAL_QUASI, /* ` */ - PRINTABLE|ALPHA|HEX_LETTER, /* a */ - PRINTABLE|ALPHA|HEX_LETTER, /* b */ - PRINTABLE|ALPHA|HEX_LETTER, /* c */ - PRINTABLE|ALPHA|HEX_LETTER, /* d */ - PRINTABLE|ALPHA|FLOATC|HEX_LETTER,/* e */ - PRINTABLE|ALPHA|HEX_LETTER, /* f */ - PRINTABLE|ALPHA, /* g */ - PRINTABLE|ALPHA, /* h */ - PRINTABLE|ALPHA, /* i */ - PRINTABLE|ALPHA, /* j */ - PRINTABLE|ALPHA, /* k */ - PRINTABLE|ALPHA, /* l */ - PRINTABLE|ALPHA, /* m */ - PRINTABLE|ALPHA, /* n */ - PRINTABLE|ALPHA, /* o */ - PRINTABLE|ALPHA, /* p */ - PRINTABLE|ALPHA, /* q */ - PRINTABLE|ALPHA, /* r */ - PRINTABLE|ALPHA, /* s */ - PRINTABLE|ALPHA, /* t */ - PRINTABLE|ALPHA, /* u */ - PRINTABLE|ALPHA, /* v */ - PRINTABLE|ALPHA, /* w */ - PRINTABLE|ALPHA, /* x */ - PRINTABLE|ALPHA, /* y */ - PRINTABLE|ALPHA, /* z */ - PRINTABLE, /* { */ - PRINTABLE, /* | */ - PRINTABLE, /* } */ - PRINTABLE, /* ~ */ - IGNORE, /* ^? */ -}; - -static int lex_unget_c; - -#ifndef ao_scheme_getc -#define ao_scheme_getc(f) getc(f) -#endif - -static inline int -lex_get(FILE *in) -{ - int c; - if (lex_unget_c) { - c = lex_unget_c; - lex_unget_c = 0; - } else { - c = ao_scheme_getc(in); - } - return c; -} - -static inline void -lex_unget(int c) -{ - if (c != EOF) - lex_unget_c = c; -} - -static uint16_t lex_class; - -static int -lexc(FILE *in) -{ - int c; - do { - c = lex_get(in); - if (c == EOF) { - c = 0; - lex_class = ENDOFFILE; - } else { - lex_class = PRINTABLE; - if (c <= 0x7f) - lex_class = lex_classes[c]; - } - } while (lex_class & IGNORE); - return c; -} - -static int -lex_quoted(FILE *in) -{ - int c; - int v; - int count; - - c = lex_get(in); - if (c == EOF) { - eof: - lex_class = ENDOFFILE; - return 0; - } - lex_class = 0; - c &= 0x7f; - switch (c) { - case 'a': - return '\a'; - case 'b': - return '\b'; - case 't': - return '\t'; - case 'n': - return '\n'; - case 'r': - return '\r'; - case 'f': - return '\f'; - case 'v': - return '\v'; - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - v = c - '0'; - count = 1; - while (count <= 3) { - c = lex_get(in); - if (c == EOF) - goto eof; - c &= 0x7f; - if (c < '0' || '7' < c) { - lex_unget(c); - break; - } - v = (v << 3) + c - '0'; - ++count; - } - return v; - default: - return c; - } -} - -#ifndef AO_SCHEME_TOKEN_MAX -#define AO_SCHEME_TOKEN_MAX 128 -#endif - -static char token_string[AO_SCHEME_TOKEN_MAX]; -static int32_t token_int; -static int token_len; - -static void start_token(void) { - token_len = 0; -} - -static void add_token(int c) { - if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) - token_string[token_len++] = c; -} - -static void end_token(void) { - token_string[token_len] = '\0'; -} - -#ifdef AO_SCHEME_FEATURE_FLOAT -static float token_float; - -struct namedfloat { - const char *name; - float value; -}; - -static const struct namedfloat namedfloats[] = { - { .name = "+inf.0", .value = INFINITY }, - { .name = "-inf.0", .value = -INFINITY }, - { .name = "+nan.0", .value = NAN }, - { .name = "-nan.0", .value = NAN }, -}; - -#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) -#endif - -static int -parse_int(FILE *in, int base) -{ - int cval; - int c; - - token_int = 0; - for (;;) { - c = lexc(in); - if ((lex_class & HEX_DIGIT) == 0) { - lex_unget(c); - return NUM; - } - if ('0' <= c && c <= '9') - cval = c - '0'; - else - cval = (c | ('a' - 'A')) - 'a' + 10; - token_int = token_int * base + cval; - } - return NUM; -} - -static int -_lex(FILE *in) -{ - int c; - - start_token(); - for (;;) { - c = lexc(in); - if (lex_class & ENDOFFILE) - return END; - - if (lex_class & WHITE) - continue; - - if (lex_class & COMMENT) { - while ((c = lexc(in)) != '\n') { - if (lex_class & ENDOFFILE) - return END; - } - continue; - } - - if (lex_class & SPECIAL) { - switch (c) { - case '(': - case '[': - return OPEN; - case ')': - case ']': - return CLOSE; - case '\'': - return QUOTE; - case '.': - return DOT; -#ifdef AO_SCHEME_FEATURE_QUASI - case '`': - return QUASIQUOTE; - case ',': - c = lexc(in); - if (c == '@') { - return UNQUOTE_SPLICING; - } else { - lex_unget(c); - return UNQUOTE; - } -#endif - } - } - if (c == '#') { - c = lexc(in); - switch (c) { - case 't': - return TRUE_TOKEN; - case 'f': - return FALSE_TOKEN; -#ifdef AO_SCHEME_FEATURE_VECTOR - case '(': - return OPEN_VECTOR; -#endif - case '\\': - for (;;) { - c = lexc(in); - if (token_len == 0) { - add_token(c); - if (!(lex_class & ALPHA)) - break; - } else { - if (lex_class & ALPHA) - add_token(c); - else { - lex_unget(c); - break; - } - } - } - end_token(); - if (token_len == 1) - token_int = token_string[0]; - else if (!strcmp(token_string, "space")) - token_int = ' '; - else if (!strcmp(token_string, "newline")) - token_int = '\n'; - else if (!strcmp(token_string, "tab")) - token_int = '\t'; - else if (!strcmp(token_string, "return")) - token_int = '\r'; - else if (!strcmp(token_string, "formfeed")) - token_int = '\f'; - else { - ao_scheme_error(AO_SCHEME_INVALID, "invalid character token #\\%s", token_string); - continue; - } - return NUM; - case 'x': - return parse_int(in, 16); - case 'o': - return parse_int(in, 8); - case 'b': - return parse_int(in, 2); - } - } - if (lex_class & STRINGC) { - for (;;) { - c = lexc(in); - if (c == '\\') - c = lex_quoted(in); - if (lex_class & (STRINGC|ENDOFFILE)) { - end_token(); - return STRING; - } - add_token(c); - } - } - if (lex_class & PRINTABLE) { -#ifdef AO_SCHEME_FEATURE_FLOAT - int isfloat = 1; - int epos = 0; -#endif - int hasdigit = 0; - int isneg = 0; - int isint = 1; - - token_int = 0; - for (;;) { - if (!(lex_class & NUMBER)) { - isint = 0; -#ifdef AO_SCHEME_FEATURE_FLOAT - isfloat = 0; -#endif - } else { -#ifdef AO_SCHEME_FEATURE_FLOAT - if (!(lex_class & INTEGER)) - isint = 0; - if (token_len != epos && - (lex_class & SIGN)) - { - isint = 0; - isfloat = 0; - } -#endif - if (c == '-') - isneg = 1; -#ifdef AO_SCHEME_FEATURE_FLOAT - if (c == '.' && epos != 0) - isfloat = 0; - if (c == 'e' || c == 'E') { - if (token_len == 0) - isfloat = 0; - else - epos = token_len + 1; - } -#endif - if (lex_class & DIGIT) { - hasdigit = 1; - if (isint) - token_int = token_int * 10 + c - '0'; - } - } - add_token (c); - c = lexc (in); - if ((lex_class & (NOTNAME)) -#ifdef AO_SCHEME_FEATURE_FLOAT - && (c != '.' || !isfloat) -#endif - ) { -#ifdef AO_SCHEME_FEATURE_FLOAT - unsigned int u; -#endif - lex_unget(c); - end_token (); - if (isint && hasdigit) { - if (isneg) - token_int = -token_int; - return NUM; - } -#ifdef AO_SCHEME_FEATURE_FLOAT - if (isfloat && hasdigit) { - token_float = strtof(token_string, NULL); - return FLOAT; - } - for (u = 0; u < NUM_NAMED_FLOATS; u++) - if (!strcmp(namedfloats[u].name, token_string)) { - token_float = namedfloats[u].value; - return FLOAT; - } -#endif - return NAME; - } - } - } - } -} - -static inline int lex(FILE *in) -{ - int parse_token = _lex(in); - RDBGI("token %d \"%s\"\n", parse_token, token_string); - return parse_token; -} - -static int parse_token; - -int ao_scheme_read_list; -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; -static int ao_scheme_read_state; - -#define READ_IN_QUOTE 0x01 -#define READ_SAW_DOT 0x02 -#define READ_DONE_DOT 0x04 -#define READ_SAW_VECTOR 0x08 - -static int -push_read_stack(int read_state) -{ - RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); - RDBG_IN(); - if (ao_scheme_read_list) { - 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; - } else - ao_scheme_read_state = read_state; - ao_scheme_read_cons = NULL; - ao_scheme_read_cons_tail = NULL; - return 1; -} - -static int -pop_read_stack(void) -{ - int read_state = 0; - if (ao_scheme_read_list) { - 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 { - read_state = ao_scheme_read_state; - ao_scheme_read_cons = NULL; - ao_scheme_read_cons_tail = NULL; - ao_scheme_read_stack = NULL; - ao_scheme_read_state = 0; - } - RDBG_OUT(); - RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); - return read_state; -} - -#ifdef AO_SCHEME_FEATURE_VECTOR -#define is_open(t) ((t) == OPEN || (t) == OPEN_VECTOR) -#else -#define is_open(t) ((t) == OPEN) -#endif - -ao_poly -ao_scheme_read(FILE *in) -{ - struct ao_scheme_atom *atom; - struct ao_scheme_string *string; - int read_state; - ao_poly v = AO_SCHEME_NIL; - - ao_scheme_read_list = 0; - read_state = 0; - ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = NULL; - for (;;) { - parse_token = lex(in); - while (is_open(parse_token)) { -#ifdef AO_SCHEME_FEATURE_VECTOR - if (parse_token == OPEN_VECTOR) - read_state |= READ_SAW_VECTOR; -#endif - if (!push_read_stack(read_state)) - return AO_SCHEME_NIL; - ao_scheme_read_list++; - read_state = 0; - parse_token = lex(in); - } - - switch (parse_token) { - case END: - default: - if (ao_scheme_read_list) - ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); - return _ao_scheme_atom_eof; - break; - case NAME: - atom = ao_scheme_atom_intern(token_string); - if (atom) - v = ao_scheme_atom_poly(atom); - else - v = AO_SCHEME_NIL; - break; - case NUM: - v = ao_scheme_integer_poly(token_int); - break; -#ifdef AO_SCHEME_FEATURE_FLOAT - case FLOAT: - v = ao_scheme_float_get(token_float); - break; -#endif - case TRUE_TOKEN: - v = _ao_scheme_bool_true; - break; - case FALSE_TOKEN: - v = _ao_scheme_bool_false; - break; - case STRING: - string = ao_scheme_string_new(token_string); - if (string) - v = ao_scheme_string_poly(string); - else - v = AO_SCHEME_NIL; - break; - case QUOTE: -#ifdef AO_SCHEME_FEATURE_QUASI - case QUASIQUOTE: - case UNQUOTE: - case UNQUOTE_SPLICING: -#endif - if (!push_read_stack(read_state)) - return AO_SCHEME_NIL; - ao_scheme_read_list++; - read_state = READ_IN_QUOTE; - switch (parse_token) { - case QUOTE: - v = _ao_scheme_atom_quote; - break; -#ifdef AO_SCHEME_FEATURE_QUASI - case QUASIQUOTE: - v = _ao_scheme_atom_quasiquote; - break; - case UNQUOTE: - v = _ao_scheme_atom_unquote; - break; - case UNQUOTE_SPLICING: - v = _ao_scheme_atom_unquote2dsplicing; - break; -#endif - } - break; - case CLOSE: - if (!ao_scheme_read_list) { - v = AO_SCHEME_NIL; - break; - } - v = ao_scheme_cons_poly(ao_scheme_read_cons); - --ao_scheme_read_list; - read_state = pop_read_stack(); -#ifdef AO_SCHEME_FEATURE_VECTOR - if (read_state & READ_SAW_VECTOR) { - v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v))); - read_state &= ~READ_SAW_VECTOR; - } -#endif - break; - case DOT: - if (!ao_scheme_read_list) { - ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); - return AO_SCHEME_NIL; - } - if (!ao_scheme_read_cons) { - ao_scheme_error(AO_SCHEME_INVALID, ". first in cons"); - return AO_SCHEME_NIL; - } - read_state |= READ_SAW_DOT; - continue; - } - - /* loop over QUOTE ends */ - for (;;) { - if (!ao_scheme_read_list) - return v; - - if (read_state & READ_DONE_DOT) { - ao_scheme_error(AO_SCHEME_INVALID, ". not last in cons"); - return AO_SCHEME_NIL; - } - - if (read_state & READ_SAW_DOT) { - read_state |= READ_DONE_DOT; - ao_scheme_read_cons_tail->cdr = v; - } else { - struct ao_scheme_cons *read = ao_scheme_cons_cons(v, AO_SCHEME_NIL); - if (!read) - return AO_SCHEME_NIL; - - if (ao_scheme_read_cons_tail) - ao_scheme_read_cons_tail->cdr = ao_scheme_cons_poly(read); - else - ao_scheme_read_cons = read; - ao_scheme_read_cons_tail = read; - } - - if (!(read_state & READ_IN_QUOTE) || !ao_scheme_read_cons->cdr) - break; - - v = ao_scheme_cons_poly(ao_scheme_read_cons); - --ao_scheme_read_list; - read_state = pop_read_stack(); - } - } - return v; -} diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h deleted file mode 100644 index 34739c9e..00000000 --- a/src/scheme/ao_scheme_read.h +++ /dev/null @@ -1,76 +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_SCHEME_READ_H_ -#define _AO_SCHEME_READ_H_ - -/* - * token classes - */ - -# define END 0 -# define NAME 1 -# define OPEN 2 -# define CLOSE 3 -# define QUOTE 4 -#ifdef AO_SCHEME_FEATURE_QUASI -# define QUASIQUOTE 5 -# define UNQUOTE 6 -# define UNQUOTE_SPLICING 7 -#endif -# define STRING 8 -# define NUM 9 -#ifdef AO_SCHEME_FEATURE_FLOAT -# define FLOAT 10 -#endif -# define DOT 11 -# define TRUE_TOKEN 12 -# define FALSE_TOKEN 13 -#ifdef AO_SCHEME_FEATURE_VECTOR -# define OPEN_VECTOR 14 -#endif - -/* - * character classes - */ - -# define PRINTABLE 0x0001 /* \t \n ' ' - ~ */ -# define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */ -#ifdef AO_SCHEME_FEATURE_QUASI -# define SPECIAL_QUASI SPECIAL -#else -# define SPECIAL_QUASI 0 -#endif -# -# define ALPHA 0x0004 /* A-Z a-z */ -# define WHITE 0x0008 /* ' ' \t \n */ -# define DIGIT 0x0010 /* [0-9] */ -# define SIGN 0x0020 /* +- */ -#ifdef AO_SCHEME_FEATURE_FLOAT -# define FLOATC 0x0040 /* . e E */ -#else -# define FLOATC 0 -#endif -# define ENDOFFILE 0x0080 /* end of file */ -# define COMMENT 0x0100 /* ; */ -# define IGNORE 0x0200 /* \0 - ' ' */ -# define STRINGC 0x0400 /* " */ -# define HEX_LETTER 0x0800 /* a-f A-F */ - -# define NOTNAME (STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) -# define INTEGER (DIGIT|SIGN) -# define NUMBER (INTEGER|FLOATC) -# define HEX_DIGIT (DIGIT|HEX_LETTER) - -#endif /* _AO_SCHEME_READ_H_ */ diff --git a/src/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c deleted file mode 100644 index 49ab0559..00000000 --- a/src/scheme/ao_scheme_rep.c +++ /dev/null @@ -1,42 +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_scheme.h" - -ao_poly -ao_scheme_read_eval_print(FILE *read_file, FILE *write_file, bool interactive) -{ - ao_poly in, out = AO_SCHEME_NIL; - - ao_scheme_exception = 0; - for(;;) { - if (interactive) - fputs("> ", write_file); - in = ao_scheme_read(read_file); - if (in == _ao_scheme_atom_eof) - break; - out = ao_scheme_eval(in); - if (ao_scheme_exception) { - if (ao_scheme_exception & AO_SCHEME_EXIT) - break; - ao_scheme_exception = 0; - } else { - if (write_file) { - ao_scheme_poly_write(write_file, out, true); - putc('\n', write_file); - } - } - } - return out; -} diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c deleted file mode 100644 index 0ef547d8..00000000 --- a/src/scheme/ao_scheme_save.c +++ /dev/null @@ -1,89 +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_scheme.h" - -#ifdef AO_SCHEME_FEATURE_SAVE -ao_poly -ao_scheme_do_save(struct ao_scheme_cons *cons) -{ -#ifndef AO_SCHEME_MAKE_CONST - struct ao_scheme_os_save *os; - - if (!ao_scheme_parse_args(_ao_scheme_atom_save, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - 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; -#else - (void) cons; -#endif - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_restore(struct ao_scheme_cons *cons) -{ -#ifndef AO_SCHEME_MAKE_CONST - 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_parse_args(_ao_scheme_atom_restore, cons, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - 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; - } -#else - (void) cons; -#endif - return _ao_scheme_bool_false; -} - -#endif /* AO_SCHEME_FEATURE_SAVE */ diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c deleted file mode 100644 index d3b5d4b7..00000000 --- a/src/scheme/ao_scheme_stack.c +++ /dev/null @@ -1,279 +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_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, 1); - ao_scheme_poly_mark(stack->values, 1); - /* no need to mark values_tail */ - ao_scheme_poly_mark(stack->frame, 0); - ao_scheme_poly_mark(stack->list, 1); - 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, 1); - (void) ao_scheme_poly_move(&stack->values, 1); - (void) ao_scheme_poly_move(&stack->values_tail, 0); - (void) ao_scheme_poly_move(&stack->frame, 0); - (void) ao_scheme_poly_move(&stack->list, 1); - 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_write(FILE *out, ao_poly poly, bool write) -{ - struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); - struct ao_scheme_stack *clear = s; - int written = 0; - - (void) write; - ao_scheme_print_start(); - ao_scheme_frame_print_indent += 2; - while (s) { - if (ao_scheme_print_mark_addr(s)) { - fputs("[recurse...]", out); - break; - } - written++; - fputs("\t[\n", out); - ao_scheme_fprintf(out, "\t\texpr: %v\n", s->list); - ao_scheme_fprintf(out, "\t\tvalues: %v\n", s->values); - ao_scheme_fprintf(out, "\t\tframe: %v\n", s->frame); - fputs("\t]\n", out); - s = ao_scheme_poly_stack(s->prev); - } - ao_scheme_frame_print_indent -= 2; - if (ao_scheme_print_stop()) { - while (written--) { - ao_scheme_print_clear_addr(clear); - clear = ao_scheme_poly_stack(clear->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(old); - ao_scheme_stack_stash(new); - ao_scheme_stack_stash(prev); - n = ao_scheme_stack_new(); - prev = ao_scheme_stack_fetch(); - new = ao_scheme_stack_fetch(); - old = ao_scheme_stack_fetch(); - 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_cons *cons; - struct ao_scheme_stack *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); - if (!new) - return AO_SCHEME_NIL; - - 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; - - if (!ao_scheme_parse_args(_ao_scheme_atom_call2fcc, cons, - AO_SCHEME_LAMBDA|AO_SCHEME_ARG_RET_POLY, &v, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - ao_scheme_poly_stash(v); - /* 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; - v = ao_scheme_poly_fetch(); - - /* 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; - - ao_scheme_stack->state = eval_exec; - return v; -} diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c deleted file mode 100644 index 2c6d0960..00000000 --- a/src/scheme/ao_scheme_string.c +++ /dev/null @@ -1,349 +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_scheme.h" - -static void string_mark(void *addr) -{ - (void) addr; -} - -static int string_size(void *addr) -{ - struct ao_scheme_string *string = addr; - if (!addr) - return 0; - return strlen(string->val) + 2; -} - -static void string_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_string_type = { - .mark = string_mark, - .size = string_size, - .move = string_move, - .name = "string", -}; - -static struct ao_scheme_string * -ao_scheme_string_alloc(int len) -{ - struct ao_scheme_string *s; - - if (len < 0) - return NULL; - s = ao_scheme_alloc(len + 2); - if (!s) - return NULL; - s->type = AO_SCHEME_STRING; - s->val[len] = '\0'; - return s; -} - -struct ao_scheme_string * -ao_scheme_string_new(char *a) -{ - struct ao_scheme_string *r; - - r = ao_scheme_string_alloc(strlen(a)); - if (!r) - return NULL; - strcpy(r->val, a); - return r; -} - -struct ao_scheme_string * -ao_scheme_atom_to_string(struct ao_scheme_atom *a) -{ - int alen = strlen(a->name); - struct ao_scheme_string *r; - - ao_scheme_atom_stash(a); - r = ao_scheme_string_alloc(alen); - a = ao_scheme_atom_fetch(); - if (!r) - return NULL; - strcpy(r->val, a->name); - return r; -} - -struct ao_scheme_string * -ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b) -{ - int alen = strlen(a->val); - int blen = strlen(b->val); - struct ao_scheme_string *r; - - ao_scheme_string_stash(a); - ao_scheme_string_stash(b); - r = ao_scheme_string_alloc(alen + blen); - b = ao_scheme_string_fetch(); - a = ao_scheme_string_fetch(); - if (!r) - return NULL; - strcpy(r->val, a->val); - strcpy(r->val+alen, b->val); - return r; -} - -static ao_poly -ao_scheme_string_pack(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - char *s; - int len; - - len = ao_scheme_cons_length(cons); - ao_scheme_cons_stash(cons); - string = ao_scheme_string_alloc(len); - cons = ao_scheme_cons_fetch(); - if (!string) - return AO_SCHEME_NIL; - s = string->val; - - while (cons) { - ao_poly car = cons->car; - int32_t c; - if (!ao_scheme_is_integer(car) || (c = ao_scheme_poly_integer(car)) == 0) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: Invalid %v", _ao_scheme_atom_list2d3estring, car); - *s++ = c; - cons = ao_scheme_cons_cdr(cons); - } - return ao_scheme_string_poly(string); -} - -static ao_poly -ao_scheme_string_unpack(struct ao_scheme_string *a) -{ - ao_poly cons = AO_SCHEME_NIL; - int i; - - for (i = strlen(a->val); --i >= 0;) { - ao_scheme_string_stash(a); - cons = ao_scheme_cons(ao_scheme_int_poly(a->val[i]), cons); - a = ao_scheme_string_fetch(); - if (!cons) - break; - } - return cons; -} - -void -ao_scheme_string_write(FILE *out, ao_poly p, bool write) -{ - struct ao_scheme_string *s = ao_scheme_poly_string(p); - char *sval = s->val; - char c; - - if (write) { - putc('"', out); - while ((c = *sval++)) { - switch (c) { - case '\a': - fputs("\\a", out); - break; - case '\b': - fputs("\\b", out); - break; - case '\t': - fputs("\\t", out); - break; - case '\n': - fputs("\\n", out); - break; - case '\r': - fputs("\\r", out); - break; - case '\f': - fputs("\\f", out); - break; - case '\v': - fputs("\\v", out); - break; - case '\"': - fputs("\\\"", out); - break; - case '\\': - fputs("\\\\", out); - break; - default: - if ((uint8_t) c < ' ') - fprintf(out, "\\%03o", (uint8_t) c); - else - putc(c, out); - break; - } - } - putc('"', out); - } else { - while ((c = *sval++)) - putc(c, out); - } -} - -ao_poly -ao_scheme_do_stringp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(_ao_scheme_atom_string3f, AO_SCHEME_STRING, cons); -} - -ao_poly -ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *list; - - if (!ao_scheme_parse_args(_ao_scheme_atom_list2d3estring, cons, - AO_SCHEME_CONS, &list, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_string_pack(list); -} - -ao_poly -ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - - if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3elist, cons, - AO_SCHEME_STRING, &string, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_string_unpack(string); -} - -static char * -ao_scheme_string_ref(struct ao_scheme_string *string, int32_t r) -{ - char *s = string->val; - while (*s && r) { - ++s; - --r; - } - return s; -} - -ao_poly -ao_scheme_do_string_ref(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - int32_t ref; - char *s; - - if (!ao_scheme_parse_args(_ao_scheme_atom_string2dref, cons, - AO_SCHEME_STRING, &string, - AO_SCHEME_INT, &ref, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - - s = ao_scheme_string_ref(string, ref); - if (!*s) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", - _ao_scheme_atom_string2dref, - cons->car, - ao_scheme_arg(cons, 1)); - return ao_scheme_integer_poly(*s); -} - -ao_poly -ao_scheme_do_string_length(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - - if (!ao_scheme_parse_args(_ao_scheme_atom_string2dlength, cons, - AO_SCHEME_STRING, &string, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(strlen(string->val)); -} - -ao_poly -ao_scheme_do_string_set(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - int32_t ref; - int32_t val; - char *s; - - if (!ao_scheme_parse_args(_ao_scheme_atom_string2dset21, cons, - AO_SCHEME_STRING, &string, - AO_SCHEME_INT, &ref, - AO_SCHEME_INT, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!val) - goto fail; - s = ao_scheme_string_ref(string, ref); - if (!*s) - goto fail; - *s = val; - return ao_scheme_integer_poly(val); -fail: - return ao_scheme_error(AO_SCHEME_INVALID, "%v: %v[%v] = %v invalid", - _ao_scheme_atom_string2dset21, - ao_scheme_arg(cons, 0), - ao_scheme_arg(cons, 1), - ao_scheme_arg(cons, 2)); -} - -ao_poly -ao_scheme_do_make_string(struct ao_scheme_cons *cons) -{ - int32_t len; - int32_t fill; - struct ao_scheme_string *string; - - if (!ao_scheme_parse_args(_ao_scheme_atom_make2dstring, cons, - AO_SCHEME_INT, &len, - AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(' '), &fill, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!fill) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: fill 0 invalid", - _ao_scheme_atom_make2dstring); - string = ao_scheme_string_alloc(len); - if (!string) - return AO_SCHEME_NIL; - memset(string->val, fill, len); - return ao_scheme_string_poly(string); -} - -ao_poly -ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) -{ - struct ao_scheme_atom *atom; - - if (!ao_scheme_parse_args(_ao_scheme_atom_symbol2d3estring, cons, - AO_SCHEME_ATOM, &atom, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_string_poly(ao_scheme_atom_to_string(atom)); -} - -ao_poly -ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - - if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3esymbol, cons, - AO_SCHEME_STRING, &string, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_atom_poly(ao_scheme_string_to_atom(string)); -} diff --git a/src/scheme/ao_scheme_string.scheme b/src/scheme/ao_scheme_string.scheme deleted file mode 100644 index 99f16fab..00000000 --- a/src/scheme/ao_scheme_string.scheme +++ /dev/null @@ -1,156 +0,0 @@ -; -; Copyright © 2018 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. -; -; string functions placed in ROM - -(define string (lambda chars (list->string chars))) - -(string #\a #\b #\c) - -(define string-map - (lambda (proc . strings) - ; result length is min of arg lengths - (let* ((l (apply min (map string-length strings))) - ; create the result - (s (make-string l))) - ; walk the strings, doing evaluation - (define (_m p) - (if (equal? p l) - s - (begin - (string-set! s p (apply proc (map (lambda (s) (string-ref s p)) strings))) - (_m (+ p 1)) - ) - ) - ) - (_m 0) - ) - ) - ) - -(string-map (lambda (x) (+ 1 x)) "HAL") - -(define string-copy! - (lambda (t a f . args) - (let ((l 0) - (h (string-length f)) - (o a) - (d 1)) - ; handle optional start/end args - - (if (not (null? args)) - (begin - (set! l (car args)) - (if (not (null? (cdr args))) - (set! h (cadr args))) - (set! o (- a l)) - ) - ) - ; flip copy order if dst is - ; after src - (if (< l a) - (begin - (set! d h) - (set! h (- l 1)) - (set! l (- d 1)) - (set! d -1) - ) - ) - ; loop copying one at a time - (do ((p l (+ p d)) - ) - ((= p h) t) - (string-set! t (+ p o) (string-ref f p)) - ) - ) - ) - ) - -(string-copy! (make-string 10) 0 "hello" 0 5) -(string-copy! (make-string 10) 1 "hello" 0 5) -(string-copy! (make-string 10) 0 "hello" 0 5) - -(define (string-upcase s) (string-map char-upcase s)) -(define (string-downcase s) (string-map char-downcase s)) -(define string-foldcase string-downcase) - -(define string-copy - (lambda (s . args) - (let ((l 0) - (h (string-length s))) - (if (not (null? args)) - (begin - (set! l (car args)) - (if (not (null? (cdr args))) - (set! h (cadr args))) - ) - ) - (string-copy! (make-string (- h l)) 0 s l h) - ) - ) - ) - -(string-copy "hello" 0 1) -(string-copy "hello" 1) -(string-copy "hello") - -(define substring string-copy) - -(define string-fill! - (lambda (s a . args) - (let ((l 0) - (h (string-length s))) - (cond ((not (null? args)) - (set! l (car args)) - (cond ((not (null? (cdr args))) - (set! h (cadr args))) - ) - ) - ) - (define (_f b) - (cond ((< b h) - (string-set! s b a) - (_f (+ b 1)) - ) - (else s) - ) - ) - (_f l) - ) - ) - ) - -(string-fill! (make-string 10) #\a) -(string-fill! (make-string 10) #\a 1 2) - -(define string-for-each - (lambda (proc . strings) - ; result length is min of arg lengths - (let* ((l (apply min (map string-length strings))) - ) - ; walk the strings, doing evaluation - (define (_m p) - (if (equal? p l) - #t - (begin - (apply proc (map (lambda (s) (string-ref s p)) strings)) - (_m (+ p 1)) - ) - ) - ) - (_m 0) - ) - ) - ) - -(string-for-each write-char "IBM\n") diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c deleted file mode 100644 index e7328e32..00000000 --- a/src/scheme/ao_scheme_vector.c +++ /dev/null @@ -1,284 +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_scheme.h" - -#ifdef AO_SCHEME_FEATURE_VECTOR - -static void vector_mark(void *addr) -{ - struct ao_scheme_vector *vector = addr; - unsigned int i; - - for (i = 0; i < vector->length; i++) { - ao_poly v = vector->vals[i]; - - ao_scheme_poly_mark(v, 1); - } -} - -static int vector_len_size(uint16_t length) -{ - return sizeof (struct ao_scheme_vector) + length * sizeof (ao_poly); -} - -static int vector_size(void *addr) -{ - struct ao_scheme_vector *vector = addr; - - return vector_len_size(vector->length); -} - -static void vector_move(void *addr) -{ - struct ao_scheme_vector *vector = addr; - unsigned int i; - - for (i = 0; i < vector->length; i++) - (void) ao_scheme_poly_move(&vector->vals[i], 1); -} - -const struct ao_scheme_type ao_scheme_vector_type = { - .mark = vector_mark, - .size = vector_size, - .move = vector_move, - .name = "vector", -}; - -struct ao_scheme_vector * -ao_scheme_vector_alloc(uint16_t length, ao_poly fill) -{ - struct ao_scheme_vector *vector; - unsigned int i; - - vector = ao_scheme_alloc(vector_len_size(length)); - if (!vector) - return NULL; - vector->type = AO_SCHEME_VECTOR; - vector->length = length; - for (i = 0; i < length; i++) - vector->vals[i] = fill; - return vector; -} - -struct vl { - struct ao_scheme_vector *vector; - struct vl *prev; -}; - -static struct vl *vl; -static unsigned int vd; - -void -ao_scheme_vector_write(FILE *out, ao_poly v, bool write) -{ - struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); - unsigned int i; - int was_marked = 0; - struct vl *ve; - - ++vd; - for (ve = vl; ve; ve = ve->prev) - if (ve->vector == vector) - abort(); - - ve = malloc(sizeof (struct vl)); - ve->prev = vl; - ve->vector = vector; - vl = ve; - - ao_scheme_print_start(); - was_marked = ao_scheme_print_mark_addr(vector); - if (was_marked) { - fputs("...", out); - } else { - fputs("#(", out); - for (i = 0; i < vector->length; i++) { - if (i != 0) - putc(' ', out); - ao_scheme_poly_write(out, vector->vals[i], write); - } - printf(")"); - } - if (ao_scheme_print_stop() && !was_marked) - ao_scheme_print_clear_addr(vector); - if (vl != ve) - abort(); - vl = ve->prev; - free(ve); - --vd; -} - -struct ao_scheme_vector * -ao_scheme_list_to_vector(struct ao_scheme_cons *cons) -{ - uint16_t length; - uint16_t i; - struct ao_scheme_vector *vector; - - length = (uint16_t) ao_scheme_cons_length (cons); - if (ao_scheme_exception) - return NULL; - - ao_scheme_cons_stash(cons); - vector = ao_scheme_vector_alloc(length, AO_SCHEME_NIL); - cons = ao_scheme_cons_fetch(); - if (!vector) - return NULL; - i = 0; - while (cons) { - vector->vals[i++] = cons->car; - cons = ao_scheme_cons_cdr(cons); - } - return vector; -} - -struct ao_scheme_cons * -ao_scheme_vector_to_list(struct ao_scheme_vector *vector, int start, int end) -{ - int i; - uint16_t length = vector->length; - struct ao_scheme_cons *cons = NULL; - - if (end == -1) - end = length; - if (start < 0) - start = 0; - if (end > length) - end = length; - for (i = end; i-- > start;) { - ao_scheme_vector_stash(vector); - cons = ao_scheme_cons_cons(vector->vals[i], ao_scheme_cons_poly(cons)); - vector = ao_scheme_vector_fetch(); - if (!cons) - return NULL; - } - return cons; -} - -ao_poly -ao_scheme_do_vector(struct ao_scheme_cons *cons) -{ - return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons)); -} - -ao_poly -ao_scheme_do_make_vector(struct ao_scheme_cons *cons) -{ - int32_t len; - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_make2dvector, cons, - AO_SCHEME_INT, &len, - AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, _ao_scheme_bool_false, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_vector_poly(ao_scheme_vector_alloc(len, val)); -} - -static bool -ao_scheme_check_vector(ao_poly proc, struct ao_scheme_vector *vector, int32_t offset) -{ - if (offset < 0 || vector->length <= offset) { - (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: vector index %d out of range (max %d)", - proc, - offset, vector->length); - return false; - } - return true; -} - -ao_poly -ao_scheme_do_vector_ref(struct ao_scheme_cons *cons) -{ - struct ao_scheme_vector *vector; - int32_t offset; - - if (!ao_scheme_parse_args(_ao_scheme_atom_vector2dref, cons, - AO_SCHEME_VECTOR, &vector, - AO_SCHEME_INT, &offset, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_vector(_ao_scheme_atom_vector2dref, vector, offset)) - return AO_SCHEME_NIL; - return vector->vals[offset]; -} - -ao_poly -ao_scheme_do_vector_set(struct ao_scheme_cons *cons) -{ - struct ao_scheme_vector *vector; - int32_t offset; - ao_poly val; - - if (!ao_scheme_parse_args(_ao_scheme_atom_vector2dset21, cons, - AO_SCHEME_VECTOR, &vector, - AO_SCHEME_INT, &offset, - AO_SCHEME_POLY, &val, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_vector(_ao_scheme_atom_vector2dset21, vector, offset)) - return AO_SCHEME_NIL; - vector->vals[offset] = val; - return val; -} - -ao_poly -ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *pair; - - if (!ao_scheme_parse_args(_ao_scheme_atom_list2d3evector, cons, - AO_SCHEME_CONS|AO_SCHEME_ARG_NIL_OK, &pair, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_vector_poly(ao_scheme_list_to_vector(pair)); -} - -ao_poly -ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons) -{ - struct ao_scheme_vector *vector; - int32_t start, end; - - if (!ao_scheme_parse_args(_ao_scheme_atom_vector2d3elist, cons, - AO_SCHEME_VECTOR, &vector, - AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(0), &start, - AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(-1), &end, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - if (end == -1) - end = vector->length; - return ao_scheme_cons_poly(ao_scheme_vector_to_list(vector, start, end)); -} - -ao_poly -ao_scheme_do_vector_length(struct ao_scheme_cons *cons) -{ - struct ao_scheme_vector *vector; - - if (!ao_scheme_parse_args(_ao_scheme_atom_vector2d3elist, cons, - AO_SCHEME_VECTOR, &vector, - AO_SCHEME_ARG_END)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(vector->length); -} - -ao_poly -ao_scheme_do_vectorp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(_ao_scheme_atom_vector3f, AO_SCHEME_VECTOR, cons); -} - -#endif /* AO_SCHEME_FEATURE_VECTOR */ diff --git a/src/scheme/ao_scheme_vector.scheme b/src/scheme/ao_scheme_vector.scheme deleted file mode 100644 index 6c25aae5..00000000 --- a/src/scheme/ao_scheme_vector.scheme +++ /dev/null @@ -1,192 +0,0 @@ -; -; Copyright © 2018 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. -; -; vector functions placed in ROM - - -(define vector->string - (lambda (v . args) - (let ((l 0) - (h (vector-length v))) - (if (not (null? args)) - (begin - (set! l (car args)) - (if (not (null? (cdr args))) - (set! h (cadr args))) - ) - ) - (do ((s (make-string (- h l))) - (p l (+ p 1)) - ) - ((= p h) s) - (string-set! s (- p l) (vector-ref v p)) - ) - ) - ) - ) - -(vector->string #(#\a #\b #\c) 0 2) - -(define string->vector - (lambda (s . args) - (let ((l 0) - (h (string-length s))) - (if (not (null? args)) - (begin - (set! l (car args)) - (if (not (null? (cdr args))) - (set! h (cadr args))) - ) - ) - (do ((v (make-vector (- h l))) - (p l (+ p 1)) - ) - ((= p h) v) - (vector-set! v (- p l) (string-ref s p)) - ) - ) - ) - ) - -(string->vector "hello" 0 2) - -(define vector-copy! - (lambda (t a f . args) - (let ((l 0) - (h (vector-length f)) - (o a) - (d 1)) - ; handle optional start/end args - - (if (not (null? args)) - (begin - (set! l (car args)) - (if (not (null? (cdr args))) - (set! h (cadr args))) - (set! o (- a l)) - ) - ) - ; flip copy order if dst is - ; after src - (if (< l a) - (begin - (set! d h) - (set! h (- l 1)) - (set! l (- d 1)) - (set! d -1) - ) - ) - ; loop copying one at a time - (do ((p l (+ p d)) - ) - ((= p h) t) - (vector-set! t (+ p o) (vector-ref f p)) - ) - ) - ) - ) - - ; simple vector-copy test - -(vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5) - -(let ((v (vector 1 2 3 4 5 6 7 8 9 0))) - (vector-copy! v 1 v 0 2) - (display "v ") (write v) (newline) - ) - -(define vector-copy - (lambda (v . args) - (let ((l 0) - (h (vector-length v))) - (if (not (null? args)) - (begin - (set! l (car args)) - (if (not (null? (cdr args))) - (set! h (cadr args))) - ) - ) - (vector-copy! (make-vector (- h l)) 0 v) - ) - ) - ) - -(vector-copy #(1 2 3) 0 3) - -(define vector-append - (lambda a - (define (_f v a p) - (if (null? a) - v - (begin - (vector-copy! v p (car a)) - (_f v (cdr a) (+ p (vector-length (car a)))) - ) - ) - ) - (_f (make-vector (apply + (map vector-length a))) a 0) - ) - ) - -(vector-append #(1 2 3) #(4 5 6) #(7 8 9)) - -(define vector-fill! - (lambda (v a . args) - (let ((l 0) - (h (vector-length v))) - (cond ((not (null? args)) - (set! l (car args)) - (cond ((not (null? (cdr args))) - (set! h (cadr args))) - ) - ) - ) - (define (_f b) - (cond ((< b h) - (vector-set! v b a) - (_f (+ b 1)) - ) - (else v) - ) - ) - (_f l) - ) - ) - ) - -(vector-fill! (make-vector 3) #t 1 2) - - ; like 'map', but for vectors - -(define vector-map - (lambda (proc . vectors) - ; result length is min of arg lengths - (let* ((l (apply min (map vector-length vectors))) - ; create the result - (v (make-vector l))) - ; walk the vectors, doing evaluation - (define (_m p) - (if (equal? p l) - v - (begin - (vector-set! v p (apply proc (map (lambda (v) (vector-ref v p)) vectors))) - (_m (+ p 1)) - ) - ) - ) - (_m 0) - ) - ) - ) - -(vector-map + #(1 2 3) #(4 5 6)) diff --git a/src/scheme/make-const/.gitignore b/src/scheme/make-const/.gitignore deleted file mode 100644 index bcd57242..00000000 --- a/src/scheme/make-const/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao_scheme_make_const diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile deleted file mode 100644 index a8e3a7f5..00000000 --- a/src/scheme/make-const/Makefile +++ /dev/null @@ -1,26 +0,0 @@ -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 -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast - -.c.o: - $(CC) -c $(CFLAGS) $< -o $@ - -all: ao_scheme_make_const - -ao_scheme_make_const: $(OBJS) - $(CC) $(CFLAGS) -o $@ $^ -lm - -clean: - rm -f $(OBJS) ao_scheme_make_const - -$(OBJS): $(SCHEME_HDRS) diff --git a/src/scheme/make-const/ao_scheme_os.h b/src/scheme/make-const/ao_scheme_os.h deleted file mode 100644 index f06bbbb1..00000000 --- a/src/scheme/make-const/ao_scheme_os.h +++ /dev/null @@ -1,63 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_SCHEME_OS_H_ -#define _AO_SCHEME_OS_H_ - -#include -#include -#include - -extern int ao_scheme_getc(void); - -static inline void -ao_scheme_os_flush(void) { - fflush(stdout); -} - -static inline void -ao_scheme_abort(void) -{ - abort(); -} - -static inline void -ao_scheme_os_led(int led) -{ - printf("leds set to 0x%x\n", led); -} - -#define AO_SCHEME_JIFFIES_PER_SECOND 100 - -static inline void -ao_scheme_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_scheme_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); -} -#endif diff --git a/src/scheme/test/.gitignore b/src/scheme/test/.gitignore deleted file mode 100644 index 3622bc1d..00000000 --- a/src/scheme/test/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao-scheme diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile deleted file mode 100644 index a8129217..00000000 --- a/src/scheme/test/Makefile +++ /dev/null @@ -1,33 +0,0 @@ -include ../Makefile-inc - -vpath %.o . -vpath %.c .. -vpath %.h .. -vpath %.scheme .. -vpath ao_scheme_make_const ../make-const - -SRCS=$(SCHEME_SRCS) ao_scheme_test.c -HDRS=$(SCHEME_HDRS) ao_scheme_const.h - -OBJS=$(SRCS:.c=.o) - -#PGFLAGS=-pg -no-pie -OFLAGS=-O3 -#DFLAGS=-O0 - -CFLAGS=$(DFLAGS) $(OFLAGS) $(PGFLAGS) -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast - -ao-scheme: $(OBJS) - cc $(CFLAGS) -o $@ $(OBJS) -lm - ./ao-scheme ao_scheme_test.scheme - -$(OBJS): $(HDRS) - -ao_scheme_const.h: ao_scheme_make_const $(SCHEME_SCHEME) - $^ -o $@ -d GPIO - -clean:: - rm -f $(OBJS) ao-scheme ao_scheme_const.h - -install: ao-scheme - install -t $$HOME/bin $^ diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h deleted file mode 100644 index 9836d534..00000000 --- a/src/scheme/test/ao_scheme_os.h +++ /dev/null @@ -1,53 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_SCHEME_OS_H_ -#define _AO_SCHEME_OS_H_ - -#include -#include -#include - -#define AO_SCHEME_POOL_TOTAL 32768 - -static inline void -ao_scheme_abort(void) -{ - abort(); -} - -#define AO_SCHEME_JIFFIES_PER_SECOND 100 - -static inline void -ao_scheme_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_scheme_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); -} - -#endif diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c deleted file mode 100644 index 195b8b46..00000000 --- a/src/scheme/test/ao_scheme_test.c +++ /dev/null @@ -1,188 +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_scheme.h" -#include -#include -#include - -static char save_file[] = "scheme.image"; - -int -ao_scheme_os_save(void) -{ - FILE *save = fopen(save_file, "w"); - - if (!save) { - perror(save_file); - return 0; - } - fwrite(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, save); - fclose(save); - return 1; -} - -int -ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - fseek(restore, offset, SEEK_SET); - ret = fread(save, sizeof (struct ao_scheme_os_save), 1, restore); - fclose(restore); - if (ret != 1) - return 0; - return 1; -} - -int -ao_scheme_os_restore(void) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - ret = fread(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, restore); - fclose(restore); - if (ret != AO_SCHEME_POOL_TOTAL) - return 0; - return 1; -} - -static const struct option options[] = { - { .name = "load", .has_arg = 1, .val = 'l' }, - { 0, 0, 0, 0 }, -}; - -static void usage(char *program) -{ - fprintf(stderr, "usage: %s [--load= ...] \n", program); -} - -static void -check_exit(ao_poly v) -{ - if (ao_scheme_exception & AO_SCHEME_EXIT) { - int ret; - - if (v == _ao_scheme_bool_true) - ret = 0; - else { - ret = 1; - if (ao_scheme_is_integer(v)) - ret = ao_scheme_poly_integer(v); - } - exit(ret); - } -} - -static void -run_file(char *name) -{ - FILE *in; - int c; - ao_poly v; - - in = fopen(name, "r"); - if (!in) { - perror(name); - exit(1); - } - c = getc(in); - if (c == '#') { - do { - c = getc(in); - } while (c != EOF && c != '\n'); - } else { - ungetc(c, in); - } - v = ao_scheme_read_eval_print(in, NULL, false); - fclose(in); - check_exit(v); -} - -int -main (int argc, char **argv) -{ - int o; - - while ((o = getopt_long(argc, argv, "?l:", options, NULL)) != -1) { - switch (o) { - case '?': - usage(argv[0]); - exit(0); - case 'l': -#ifdef AO_SCHEME_FEATURE_POSIX - ao_scheme_set_argv(&argv[argc]); -#endif - run_file(optarg); - break; - default: - usage(argv[0]); - exit(1); - } - } -#ifdef AO_SCHEME_FEATURE_POSIX - ao_scheme_set_argv(argv + optind); -#endif - if (argv[optind]) { - run_file(argv[optind]); - } else { - ao_poly v; - v = ao_scheme_read_eval_print(stdin, stdout, true); - check_exit(v); - putchar('\n'); - } - -#ifdef DBG_MEM_STATS - printf ("collects: full: %lu incremental %lu\n", - ao_scheme_collects[AO_SCHEME_COLLECT_FULL], - ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf ("freed: full %lu incremental %lu\n", - ao_scheme_freed[AO_SCHEME_COLLECT_FULL], - ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf("loops: full %lu incremental %lu\n", - ao_scheme_loops[AO_SCHEME_COLLECT_FULL], - ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf("loops per collect: full %f incremental %f\n", - (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL] / - (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], - (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL] / - (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf("freed per collect: full %f incremental %f\n", - (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / - (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], - (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / - (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf("freed per loop: full %f incremental %f\n", - (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / - (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL], - (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / - (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); -#endif - return 0; -} diff --git a/src/scheme/test/ao_scheme_test.scheme b/src/scheme/test/ao_scheme_test.scheme deleted file mode 100644 index 41aaeda1..00000000 --- a/src/scheme/test/ao_scheme_test.scheme +++ /dev/null @@ -1,175 +0,0 @@ - ; Basic syntax tests - -(define _assert-eq_ - (macro (a b) - (list cond - (list (list eq? a b) - ) - (list 'else - (list display "failed: ") - (list write (list quote a)) - (list newline) - (list exit 1) - ) - ) - ) - ) - -(define _assert-equal_ - (macro (a b) - (list cond - (list (list equal? a b) - ) - (list 'else - (list display "failed: ") - (list write (list quote a)) - (list newline) - (list exit 1) - ) - ) - ) - ) - -(_assert-eq_ (or #f #t) #t) -(_assert-eq_ (and #t #f) #f) -(_assert-eq_ (if (> 3 2) 'yes) 'yes) -(_assert-eq_ (if (> 3 2) 'yes 'no) 'yes) -(_assert-eq_ (if (> 2 3) 'no 'yes) 'yes) -(_assert-eq_ (if (> 2 3) 'no) #f) - -(_assert-eq_ (letrec ((a 1) (b a)) (+ a b)) 2) - -(_assert-eq_ (equal? '(a b c) '(a b c)) #t) -(_assert-eq_ (equal? '(a b c) '(a b b)) #f) - -(_assert-equal_ (cdar '((1 2) (3 4))) '(2)) - -(_assert-equal_ (cddr '(1 2 3)) '(3)) - -(_assert-equal_ (caddr '(1 2 3 4)) 3) - -(_assert-equal_ (member '(2) '((1) (2) (3))) '((2) (3))) -(_assert-equal_ (member '(4) '((1) (2) (3))) #f) - -(_assert-equal_ (memq 2 '(1 2 3)) '(2 3)) -(_assert-equal_ (memq 4 '(1 2 3)) #f) -(_assert-equal_ (memq '(2) '((1) (2) (3))) #f) - -(_assert-equal_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1)) -(_assert-equal_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2)) -(_assert-equal_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3)) - -(_assert-equal_ (map cadr '((a b) (d e) (g h))) '(b e h)) - -(_assert-equal_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) - - ; Advanced syntax tests - -(_assert-eq_ (equal? '(a b c) '(a b c)) #t) -(_assert-eq_ (equal? '(a b c) '(a b b)) #f) -(_assert-eq_ (equal? #(1 2 3) #(1 2 3)) #t) -(_assert-eq_ (equal? #(1 2 3) #(4 5 6)) #f) -(_assert-equal_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) -(_assert-equal_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3) -(_assert-equal_ (when #t (+ 1 2)) 3) -(_assert-equal_ (when #f (+ 1 2)) #f) -(_assert-equal_ (unless #f (+ 2 3)) 5) -(_assert-equal_ (unless #t (+ 2 3)) #f) -(_assert-equal_ (cdar '((1 2) (3 4))) '(2)) -(_assert-equal_ (cddr '(1 2 3)) '(3)) -(_assert-equal_ (caddr '(1 2 3 4)) 3) -(_assert-equal_ (reverse '(1 2 3)) '(3 2 1)) -(_assert-equal_ (make-list 10 'a) '(a a a a a a a a a a)) -(_assert-equal_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f)) -(_assert-equal_ (let ((a 0)) - (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) - a - ) - 6) -(_assert-equal_ (call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - ) - ) - -3) -(_assert-equal_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "one") -(_assert-equal_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "two") -(_assert-equal_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "three") -(_assert-equal_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "else") -(_assert-equal_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "twelve") -(_assert-equal_ (do ((x 1 (+ x 1)) - (y 0) - ) - ((= x 10) y) - (set! y (+ y x)) - ) - 45) - -(_assert-equal_ (do ((vec (make-vector 5)) - (i 0 (+ i 1))) - ((= i 5) vec) - (vector-set! vec i i)) - #(0 1 2 3 4)) - - ; vector tests - -(_assert-equal_ (vector->string #(#\a #\b #\c) 0 2) "ab") -(_assert-equal_ (string->vector "hello" 0 2) #(#\h #\e)) -(_assert-equal_ (vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5) #("f" "f" "f" "f" "f" "t" "t" "t" "t" "t")) -(_assert-equal_ (vector-copy #(1 2 3) 0 3) #(1 2 3)) -(_assert-equal_ (vector-append #(1 2 3) #(4 5 6) #(7 8 9)) #(1 2 3 4 5 6 7 8 9)) -(_assert-equal_ (vector-fill! (make-vector 3) #t 1 2) #(#f #t #f)) -(_assert-equal_ (vector-map + #(1 2 3) #(4 5 6)) #(5 7 9)) - - ; string tests - -(_assert-equal_ (string #\a #\b #\c) "abc") -(_assert-equal_ (string-map (lambda (x) (+ 1 x)) "HAL") "IBM") -(_assert-equal_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello ") -(_assert-equal_ (string-copy! (make-string 10) 1 "hello" 0 5) " hello ") -(_assert-equal_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello ") -(_assert-equal_ (string-copy "hello" 0 1) "h") -(_assert-equal_ (string-copy "hello" 1) "ello") -(_assert-equal_ (string-copy "hello") "hello") -(_assert-equal_ (string-fill! (make-string 10) #\a) "aaaaaaaaaa") -(_assert-equal_ (string-fill! (make-string 10) #\a 1 2) " a ") -;(_assert-equal_ (string-for-each write-char "IBM\n") #t) - - ; char tests - -(_assert-equal_ (char? #\q) #t) -(_assert-equal_ (char? "h") #f) -(_assert-equal_ (char-upper-case? #\a) #f) -(_assert-equal_ (char-upper-case? #\B) #t) -(_assert-equal_ (char-upper-case? #\0) #f) -(_assert-equal_ (char-upper-case? #\space) #f) -(_assert-equal_ (char-lower-case? #\a) #t) -(_assert-equal_ (char-lower-case? #\B) #f) -(_assert-equal_ (char-lower-case? #\0) #f) -(_assert-equal_ (char-lower-case? #\space) #f) -(_assert-equal_ (char-alphabetic? #\a) #t) -(_assert-equal_ (char-alphabetic? #\B) #t) -(_assert-equal_ (char-alphabetic? #\0) #f) -(_assert-equal_ (char-alphabetic? #\space) #f) -(_assert-equal_ (char-numeric? #\a) #f) -(_assert-equal_ (char-numeric? #\B) #f) -(_assert-equal_ (char-numeric? #\0) #t) -(_assert-equal_ (char-numeric? #\space) #f) -(_assert-equal_ (char-whitespace? #\a) #f) -(_assert-equal_ (char-whitespace? #\B) #f) -(_assert-equal_ (char-whitespace? #\0) #f) -(_assert-equal_ (char-whitespace? #\space) #t) -(_assert-equal_ (char-upcase #\a) #\A) -(_assert-equal_ (char-upcase #\B) #\B) -(_assert-equal_ (char-upcase #\0) #\0) -(_assert-equal_ (char-upcase #\space) #\space) -(_assert-equal_ (char-downcase #\a) #\a) -(_assert-equal_ (char-downcase #\B) #\b) -(_assert-equal_ (char-downcase #\0) #\0) -(_assert-equal_ (char-downcase #\space) #\space) -(_assert-equal_ (digit-value #\1) 1) -(_assert-equal_ (digit-value #\a) #f) - diff --git a/src/scheme/test/hanoi.scheme b/src/scheme/test/hanoi.scheme deleted file mode 100755 index 0180de1e..00000000 --- a/src/scheme/test/hanoi.scheme +++ /dev/null @@ -1,177 +0,0 @@ -#!/home/keithp/bin/ao-scheme -; -; Towers of Hanoi -; -; 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. -; - - ; ANSI control sequences - -(define (move-to col row) - (for-each display (list "\033[" row ";" col "H")) - ) - -(define (clear) - (display "\033[2J") - ) - -(define (display-string x y str) - (move-to x y) - (display str) - ) - -(define (make-piece num max) - ; A piece for position 'num' - ; is num + 1 + num stars - ; centered in a field of max * - ; 2 + 1 characters with spaces - ; on either side. This way, - ; every piece is the same - ; number of characters - - (define (chars n c) - (if (zero? n) "" - (+ c (chars (- n 1) c)) - ) - ) - (+ (chars (- max num 1) " ") - (chars (+ (* num 2) 1) "*") - (chars (- max num 1) " ") - ) - ) - -(define (make-pieces max) - ; Make a list of numbers from 0 to max-1 - (define (nums cur max) - (if (= cur max) () - (cons cur (nums (+ cur 1) max)) - ) - ) - ; Create a list of pieces - - (map (lambda (x) (make-piece x max)) (nums 0 max)) - ) - - ; Here's all of the towers of pieces - ; This is generated when the program is run - -(define towers ()) - - ; position of the bottom of - ; the stacks set at runtime -(define bottom-y 0) -(define left-x 0) - -(define move-delay 25) - - ; Display one tower, clearing any - ; space above it - -(define (display-tower x y clear tower) - (cond ((= 0 clear) - (cond ((not (null? tower)) - (display-string x y (car tower)) - (display-tower x (+ y 1) 0 (cdr tower)) - ) - ) - ) - (else - (display-string x y " ") - (display-tower x (+ y 1) (- clear 1) tower) - ) - ) - ) - - ; Position of the top of the tower on the screen - ; Shorter towers start further down the screen - -(define (tower-pos tower) - (- bottom-y (length tower)) - ) - - ; Display all of the towers, spaced 20 columns apart - -(define (display-towers x towers) - (cond ((not (null? towers)) - (display-tower x 0 (tower-pos (car towers)) (car towers)) - (display-towers (+ x 20) (cdr towers))) - ) - ) - - ; Display all of the towers, then move the cursor - ; out of the way and flush the output - -(define (display-hanoi) - (display-towers left-x towers) - (move-to 1 23) - (flush-output) - (delay move-delay) - ) - - ; Reset towers to the starting state, with - ; all of the pieces in the first tower and the - ; other two empty - -(define (reset-towers len) - (set! towers (list (make-pieces len) () ())) - (set! bottom-y (+ len 3)) - ) - - ; Move a piece from the top of one tower - ; to the top of another - -(define (move-piece from to) - - ; references to the cons holding the two towers - - (define from-tower (list-tail towers from)) - (define to-tower (list-tail towers to)) - - ; stick the car of from-tower onto to-tower - - (set-car! to-tower (cons (caar from-tower) (car to-tower))) - - ; remove the car of from-tower - - (set-car! from-tower (cdar from-tower)) - ) - - ; The implementation of the game - -(define (_hanoi n from to use) - (cond ((= 1 n) - (move-piece from to) - (display-hanoi) - ) - (else - (_hanoi (- n 1) from use to) - (_hanoi 1 from to use) - (_hanoi (- n 1) use to from) - ) - ) - ) - - ; A pretty interface which - ; resets the state of the game, - ; clears the screen and runs - ; the program - -(define (hanoi len) - (reset-towers len) - (clear) - (display-hanoi) - (_hanoi len 0 1 2) - #t - ) - -(unless (null? (command-line)) (hanoi 6)) diff --git a/src/scheme/tiny-test/.gitignore b/src/scheme/tiny-test/.gitignore deleted file mode 100644 index 7c4c3956..00000000 --- a/src/scheme/tiny-test/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao-scheme-tiny diff --git a/src/scheme/tiny-test/Makefile b/src/scheme/tiny-test/Makefile deleted file mode 100644 index 61ef687a..00000000 --- a/src/scheme/tiny-test/Makefile +++ /dev/null @@ -1,32 +0,0 @@ -include ../Makefile-inc - -vpath %.o . -vpath %.c .. -vpath ao_scheme_test.c ../test -vpath %.h .. -vpath %.scheme .. -vpath ao_scheme_make_const ../make-const - -DEFS= - -SRCS=$(SCHEME_SRCS) ao_scheme_test.c -HDRS=$(SCHEME_HDRS) ao_scheme_const.h - -OBJS=$(SRCS:.c=.o) - -CFLAGS=-O0 -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast - -ao-scheme-tiny: $(OBJS) - cc $(CFLAGS) -o $@ $(OBJS) -lm - ./ao-scheme-tiny ao_scheme_tiny_test.scheme - -$(OBJS): $(HDRS) - -ao_scheme_const.h: ao_scheme_make_const ao_scheme_basic_syntax.scheme ao_scheme_finish.scheme - $^ -o $@ -d FLOAT,VECTOR,QUASI,BIGINT,PORT,POSIX,GPIO,UNDEF - -clean:: - rm -f $(OBJS) ao-scheme-tiny ao_scheme_const.h - -install: ao-scheme-tiny - cp $^ $$HOME/bin diff --git a/src/scheme/tiny-test/ao_scheme_os.h b/src/scheme/tiny-test/ao_scheme_os.h deleted file mode 100644 index 17d66ae3..00000000 --- a/src/scheme/tiny-test/ao_scheme_os.h +++ /dev/null @@ -1,53 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_SCHEME_OS_H_ -#define _AO_SCHEME_OS_H_ - -#include -#include -#include - -#define AO_SCHEME_POOL_TOTAL 4096 - -static inline void -ao_scheme_abort(void) -{ - abort(); -} - -#define AO_SCHEME_JIFFIES_PER_SECOND 100 - -static inline void -ao_scheme_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_scheme_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); -} - -#endif diff --git a/src/scheme/tiny-test/ao_scheme_tiny_const.scheme b/src/scheme/tiny-test/ao_scheme_tiny_const.scheme deleted file mode 100644 index d0c0e578..00000000 --- a/src/scheme/tiny-test/ao_scheme_tiny_const.scheme +++ /dev/null @@ -1,389 +0,0 @@ -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Lisp code placed in ROM - - ; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (a b) - (list - def - (list quote a) - b) - ) - ) - -(begin - (def! append - (lambda args - (def! a-l - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (a-l (cdr a) b))) - ) - ) - ) - - (def! a-ls - (lambda (l) - (cond ((null? l) l) - ((null? (cdr l)) (car l)) - (else (a-l (car l) (a-ls (cdr l)))) - ) - ) - ) - (a-ls args) - ) - ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated. - ; - ; Also accepts the alternate - ; form for defining lambdas of - ; (define (name a y z) sexprs ...) - ; - -(begin - (def (quote define) - (macro (a . b) - ; check for alternate lambda definition form - - (cond ((list? a) - (set! b - (cons lambda (cons (cdr a) b))) - (set! a (car a)) - ) - (else - (set! b (car b)) - ) - ) - (cons begin - (cons - (cons def - (cons (cons quote (cons a '())) - (cons b '()) - ) - ) - (cons - (cons quote (cons a '())) - '()) - ) - ) - ) - ) - 'define - ) - - ; basic list accessors - -(define (caar l) (car (car l))) - -(define (cadr l) (car (cdr l))) - -(define (cdar l) (cdr (car l))) - -(define (caddr l) (car (cdr (cdr l)))) - - ; (if ) - ; (if 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) - - ; simple math operators - -(define zero? (macro (value) (list eqv? value 0))) - -(zero? 1) -(zero? 0) -(zero? "hello") - -(define positive? (macro (value) (list > value 0))) - -(positive? 12) -(positive? -12) - -(define negative? (macro (value) (list < value 0))) - -(negative? 12) -(negative? -12) - -(define (abs a) (if (>= a 0) a (- a))) - -(abs 12) -(abs -12) - -(define max (lambda (a . b) - (while (not (null? b)) - (cond ((< a (car b)) - (set! a (car b))) - ) - (set! b (cdr b)) - ) - a) - ) - -(max 1 2 3) -(max 3 2 1) - -(define min (lambda (a . b) - (while (not (null? b)) - (cond ((> a (car b)) - (set! a (car b))) - ) - (set! b (cdr b)) - ) - a) - ) - -(min 1 2 3) -(min 3 2 1) - -(define (even? a) (zero? (% a 2))) - -(even? 2) -(even? -2) -(even? 3) -(even? -1) - -(define (odd? a) (not (even? a))) - -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - - -(define (list-tail a b) - (if (zero? b) - a - (list-tail (cdr a (- b 1))) - ) - ) - -(define (list-ref a b) - (car (list-tail a b)) - ) - -(define (list-tail a b) - (if (zero? b) - a - (list-tail (cdr a) (- b 1)))) - -(list-tail '(1 2 3) 2) - -(define (list-ref a b) (car (list-tail a b))) - -(list-ref '(1 2 3) 2) - - - ; define a set of local - ; variables one at a time and - ; then evaluate a list of - ; sexprs - ; - ; (let* (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let* ((x 1) (y)) (set! y (+ x 1)) y) - -(define let* - (macro (a . b) - - ; - ; make the list of names in the let - ; - - (define (_n a) - (cond ((not (null? a)) - (cons (car (car a)) - (_n (cdr a)))) - (else ()) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (define (_v a b) - (cond ((null? a) b) (else - (cons - (list set - (list quote - (car (car a)) - ) - (cond ((null? (cdr (car a))) ()) - (else (cadr (car a)))) - ) - (_v (cdr a) b) - ) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (_z a) - (cond ((null? a) ()) - (else (cons () (_z (cdr a)))) - ) - ) - ; build the lambda. - - (cons (cons lambda (cons (_n a) (_v a b))) (_z a)) - ) - ) - -(let* ((a 1) (y a)) (+ a y)) - -(define let let*) - ; recursive equality - -(define (equal? a b) - (cond ((eq? a b) #t) - ((pair? a) - (cond ((pair? b) - (cond ((equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - ) - ) - ) - ) - ) - -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) - -(define member (lambda (obj a . test?) - (cond ((null? a) - #f - ) - (else - (if (null? test?) (set! test? equal?) (set! test? (car test?))) - (if (test? obj (car a)) - a - (member obj (cdr a) test?)) - ) - ) - ) - ) - -(member '(2) '((1) (2) (3))) - -(member '(4) '((1) (2) (3))) - -(define (memq obj a) (member obj a eq?)) - -(memq 2 '(1 2 3)) - -(memq 4 '(1 2 3)) - -(memq '(2) '((1) (2) (3))) - -(define (_assoc a b t?) - (if (null? b) - #f - (if (t? a (caar b)) - (car b) - (_assoc a (cdr b) t?) - ) - ) - ) - -(define (assq a b) (_assoc a b eq?)) -(define (assoc a b) (_assoc a b equal?)) - -(assq 'a '((a 1) (b 2) (c 3))) -(assoc '(c) '((a 1) (b 2) ((c) 3))) - -(define string (lambda a (list->string a))) - -(display "apply\n") -(apply cons '(a b)) - -(define map - (lambda (a . b) - (define (args b) - (cond ((null? b) ()) - (else - (cons (caar b) (args (cdr b))) - ) - ) - ) - (define (next b) - (cond ((null? b) ()) - (else - (cons (cdr (car b)) (next (cdr b))) - ) - ) - ) - (define (domap b) - (cond ((null? (car b)) ()) - (else - (cons (apply a (args b)) (domap (next b))) - ) - ) - ) - (domap b) - ) - ) - -(map cadr '((a b) (d e) (g h))) - -(define for-each (lambda (a . b) - (apply map a b) - #t)) - -(for-each display '("hello" " " "world" "\n")) - -(define (newline) (write-char #\newline)) - -(newline) diff --git a/src/scheme/tiny-test/ao_scheme_tiny_test.scheme b/src/scheme/tiny-test/ao_scheme_tiny_test.scheme deleted file mode 100644 index 94c90ffe..00000000 --- a/src/scheme/tiny-test/ao_scheme_tiny_test.scheme +++ /dev/null @@ -1,56 +0,0 @@ - ; Basic syntax tests - -(define _assert-eq_ - (macro (a b) - (list cond - (list (list eq? a b) - ) - (list 'else - (list display "failed: ") - (list write (list quote a)) - (list newline) - (list exit 1) - ) - ) - ) - ) - -(define _assert-equal_ - (macro (a b) - (list cond - (list (list equal? a b) - ) - (list 'else - (list display "failed: ") - (list write (list quote a)) - (list newline) - (list exit 1) - ) - ) - ) - ) - -(_assert-eq_ (or #f #t) #t) -(_assert-eq_ (and #t #f) #f) -(_assert-eq_ (if (> 3 2) 'yes) 'yes) -(_assert-eq_ (if (> 3 2) 'yes 'no) 'yes) -(_assert-eq_ (if (> 2 3) 'no 'yes) 'yes) -(_assert-eq_ (if (> 2 3) 'no) #f) - -(_assert-eq_ (letrec ((a 1) (b a)) (+ a b)) 2) - -(_assert-eq_ (equal? '(a b c) '(a b c)) #t) -(_assert-eq_ (equal? '(a b c) '(a b b)) #f) - -(_assert-equal_ (member '(2) '((1) (2) (3))) '((2) (3))) -(_assert-equal_ (member '(4) '((1) (2) (3))) #f) - -(_assert-equal_ (memq 2 '(1 2 3)) '(2 3)) -(_assert-equal_ (memq 4 '(1 2 3)) #f) -(_assert-equal_ (memq '(2) '((1) (2) (3))) #f) - -(_assert-equal_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1)) -(_assert-equal_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3)) - -(_assert-equal_ (map cadr '((a b) (d e) (g h))) '(b e h)) - diff --git a/src/stmf0/Makefile-stmf0.defs b/src/stmf0/Makefile-stmf0.defs index fa6e6e86..4e9fa551 100644 --- a/src/stmf0/Makefile-stmf0.defs +++ b/src/stmf0/Makefile-stmf0.defs @@ -4,7 +4,7 @@ endif include $(TOPDIR)/Makedefs -vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math:$(TOPDIR)/scheme +vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math vpath make-altitude $(TOPDIR)/util vpath make-kalman $(TOPDIR)/util vpath kalman.5c $(TOPDIR)/kalman -- 2.30.2