And lots of other changes, including freeing unreferenced atoms.
Signed-off-by: Keith Packard <keithp@keithp.com>
include ../scheme/Makefile-inc
+vpath %.scheme ../scheme
+vpath ao_scheme_make_const ../scheme/make-const
+
NEWLIB_FULL=-lm -lc -lgcc
LIBS=$(NEWLIB_FULL)
ao_product.c \
ao_cmd.c \
ao_notask.c \
- ao_led.c \
ao_stdio.c \
ao_stdio_newlib.c \
ao_panic.c \
MAP=$(PROG).map
NEWLIB=/local/newlib-mini
-MAPFILE=-Wl,-M=$(MAP)
+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_product.h: ao-make-product.5c ../Version
$(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@
-ao_scheme_const.h: ../scheme/make-const/ao_scheme_make_const ao_lambdakey_const.scheme
- ../scheme/make-const/ao_scheme_make_const -d FLOAT,VECTOR,QUASI,BIGINT -o $@ ao_lambdakey_const.scheme
+ao_scheme_const.h: ao_scheme_make_const ao_scheme_basic_syntax.scheme ao_scheme_finish.scheme
+ $^ -o $@ -d GPIO,FLOAT,VECTOR,QUASI,BIGINT,POSIX,PORT,SAVE,UNDEF
load: $(PROG)
stm-load $(PROG)
#include <ao_scheme.h>
static void scheme_cmd() {
- ao_scheme_read_eval_print();
+ ao_scheme_read_eval_print(stdin, stdout, true);
}
static const struct ao_cmds blink_cmds[] = {
void main(void)
{
+#ifdef LEDS_AVAILABLE
ao_led_init(LEDS_AVAILABLE);
+#endif
ao_clock_init();
ao_timer_init();
ao_usb_init();
; simple math operators
-(define zero? (macro (value) (list eqv? value 0)))
+(define zero? (macro (value) (list eq? value 0)))
(zero? 1)
(zero? 0)
(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))
)
;
; (let* ((x 1) (y)) (set! y (+ x 1)) y)
-(define let*
+(define letrec
(macro (a . b)
;
; expressions to evaluate
(define (_v a b)
- (cond ((null? a) b) (else
+ (cond ((null? a) b)
+ (else
(cons
(list set
(list quote
)
)
-(let* ((a 1) (y a)) (+ a y))
+(letrec ((a 1) (y a)) (+ a y))
-(define let let*)
+(define let letrec)
+(define let* letrec)
; recursive equality
(define (equal? a b)
(memq '(2) '((1) (2) (3)))
-(define (_as a b t?)
+(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)
- (_as a (cdr b) t?)
+ (assoc a (cdr b) t?)
)
)
)
-(define (assq a b) (_as a b eq?))
-(define (assoc a b) (_as a b equal?))
+(define (assq a b) (assoc a b eq?))
(assq 'a '((a 1) (b 2) (c 3)))
(assoc '(c) '((a 1) (b 2) ((c) 3)))
#ifndef _AO_PINS_H_
#define _AO_PINS_H_
+#define fprintf(file, ...) ({ (void) (file); printf(__VA_ARGS__); })
+#undef putc
+#define putc(c,file) ({ (void) (file); putchar(c); })
+#define fputs(s,file) ({ (void) (file); printf("%s", s); })
+#define puts(s) ({ printf("%s\n", s); })
+#undef getc
+#define getc(file) ({ (void) (file); getchar(); })
+
#define HAS_TASK 0
#define HAS_AO_DELAY 1
+#if 0
#define LED_PORT_ENABLE STM_RCC_AHBENR_IOPBEN
#define LED_PORT (&stm_gpiob)
#define LED_PIN_RED 4
#define AO_LED_RED (1 << LED_PIN_RED)
#define AO_LED_PANIC AO_LED_RED
+#define LEDS_AVAILABLE (AO_LED_RED)
+#endif
+
#define AO_CMD_LEN 128
-#define AO_LISP_POOL_TOTAL 3072
-#define AO_LISP_SAVE 1
+#define AO_LISP_POOL 5120
#define AO_STACK_SIZE 1024
+#if 0
/* need HSI active to write to flash */
#define AO_NEED_HSI 1
-
-#define LEDS_AVAILABLE (AO_LED_RED)
+#endif
#define AO_POWER_MANAGEMENT 0
ao_panic(1);
}
+#ifdef LEDS_AVAILABLE
static inline void
ao_scheme_os_led(int led)
{
ao_led_set(led);
}
+#endif
#define AO_SCHEME_JIFFIES_PER_SECOND AO_HERTZ
ao_scheme_save.c \
ao_scheme_stack.c \
ao_scheme_error.c \
- ao_scheme_vector.c
+ ao_scheme_vector.c \
+ ao_scheme_port.c
SCHEME_HDRS=\
ao_scheme.h \
ao_scheme_builtin.h
SCHEME_SCHEME=\
- ao_scheme_const.scheme \
+ ao_scheme_basic_syntax.scheme \
+ ao_scheme_advanced_syntax.scheme \
ao_scheme_vector.scheme \
- ao_scheme_string.scheme
+ ao_scheme_string.scheme \
+ ao_scheme_char.scheme \
+ ao_scheme_port.scheme \
+ ao_scheme_finish.scheme
#include <stdint.h>
#include <string.h>
#include <stdbool.h>
+#include <ao_scheme_os.h>
#define AO_SCHEME_BUILTIN_FEATURES
#include "ao_scheme_builtin.h"
#undef AO_SCHEME_BUILTIN_FEATURES
-#include <ao_scheme_os.h>
#ifndef __BYTE_ORDER
#include <endian.h>
#endif
typedef uint16_t ao_poly;
typedef int16_t ao_signed_poly;
-#if AO_SCHEME_SAVE
+#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;
};
#ifndef AO_SCHEME_POOL_TOTAL
-#error Must define AO_SCHEME_POOL_TOTAL for AO_SCHEME_SAVE
+#error Must define AO_SCHEME_POOL_TOTAL for AO_SCHEME_FEATURE_SAVE
#endif
#define AO_SCHEME_POOL_EXTRA (sizeof(struct ao_scheme_os_save))
int
ao_scheme_os_restore(void);
+#endif /* AO_SCHEME_FEATURE_SAVE */
-#endif
-
-#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"
#ifndef AO_SCHEME_POOL
#error Must define AO_SCHEME_POOL
#endif
#else
#define _AO_SCHEME_VECTOR _AO_SCHEME_FLOAT
#endif
-#define AO_SCHEME_NUM_TYPE (_AO_SCHEME_VECTOR+1)
+#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_UNDEFINED 0x08
#define AO_SCHEME_REDEFINED 0x10
#define AO_SCHEME_EOF 0x20
-#define AO_SCHEME_EXIT 0x40
+#define AO_SCHEME_FILEERROR 0x40
+#define AO_SCHEME_EXIT 0x80
extern uint8_t ao_scheme_exception;
};
#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)
}
#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];
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);
}
#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));
extern const struct ao_scheme_type ao_scheme_bool_type;
void
-ao_scheme_bool_write(ao_poly v, bool write);
+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;
ao_scheme_cons_free(struct ao_scheme_cons *cons);
void
-ao_scheme_cons_write(ao_poly, bool write);
+ao_scheme_cons_write(FILE *out, ao_poly, bool write);
int
ao_scheme_cons_length(struct ao_scheme_cons *cons);
-struct ao_scheme_cons *
-ao_scheme_cons_copy(struct ao_scheme_cons *cons);
-
/* string */
extern const struct ao_scheme_type ao_scheme_string_type;
-struct ao_scheme_string *
-ao_scheme_string_copy(struct ao_scheme_string *a);
-
struct ao_scheme_string *
ao_scheme_string_new(char *a);
-struct ao_scheme_string *
-ao_scheme_make_string(int32_t len, char fill);
-
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);
-ao_poly
-ao_scheme_string_pack(struct ao_scheme_cons *cons);
-
-ao_poly
-ao_scheme_string_unpack(struct ao_scheme_string *a);
-
void
-ao_scheme_string_write(ao_poly s, bool write);
+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_frame *ao_scheme_frame_current;
void
-ao_scheme_atom_write(ao_poly a, bool write);
+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_set(ao_poly atom, ao_poly val);
-
ao_poly
ao_scheme_atom_def(ao_poly atom, ao_poly val);
/* int */
void
-ao_scheme_int_write(ao_poly i, bool write);
+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, bool *fail);
+ao_scheme_poly_integer(ao_poly p);
ao_poly
ao_scheme_integer_poly(int32_t i);
}
void
-ao_scheme_bigint_write(ao_poly i, bool write);
+ao_scheme_bigint_write(FILE *out, ao_poly i, bool write);
extern const struct ao_scheme_type ao_scheme_bigint_type;
#else
-#define ao_scheme_poly_integer(a,b) ao_scheme_poly_int(a)
-#define ao_scheme_integer_poly ao_scheme_int_poly
+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)
/* vector */
+#ifdef AO_SCHEME_FEATURE_VECTOR
+
void
-ao_scheme_vector_write(ao_poly v, bool write);
+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);
-ao_poly
-ao_scheme_vector_get(ao_poly v, ao_poly i);
-
-ao_poly
-ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p);
-
struct ao_scheme_vector *
ao_scheme_list_to_vector(struct ao_scheme_cons *cons);
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))(ao_poly p, bool write);
+void (*ao_scheme_poly_write_func(ao_poly p))(FILE *out, ao_poly p, bool write);
static inline void
-ao_scheme_poly_write(ao_poly p, bool write) { (*ao_scheme_poly_write_func(p))(p, write); }
+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);
/* 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);
extern const struct ao_scheme_type ao_scheme_float_type;
void
-ao_scheme_float_write(ao_poly p, bool write);
+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 uint8_t
+static inline bool
ao_scheme_number_typep(uint8_t t)
{
return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT);
#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(ao_poly b, bool write);
+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);
extern struct ao_scheme_cons *ao_scheme_read_stack;
ao_poly
-ao_scheme_read(void);
+ao_scheme_read(FILE *in);
/* rep */
ao_poly
-ao_scheme_read_eval_print(void);
+ao_scheme_read_eval_print(FILE *read_file, FILE *write_file, bool interactive);
/* frame */
extern const struct ao_scheme_type ao_scheme_frame_type;
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(ao_poly p, bool write);
+ao_scheme_frame_write(FILE *out, ao_poly p, bool write);
void
ao_scheme_frame_init(void);
ao_scheme_lambda_new(ao_poly cons);
void
-ao_scheme_lambda_write(ao_poly lambda, bool write);
+ao_scheme_lambda_write(FILE *out, ao_poly lambda, bool write);
ao_poly
ao_scheme_lambda_eval(void);
ao_scheme_stack_pop(void);
void
-ao_scheme_stack_clear(void);
-
-void
-ao_scheme_stack_write(ao_poly stack, bool write);
+ao_scheme_stack_write(FILE *out, ao_poly stack, bool write);
ao_poly
ao_scheme_stack_eval(void);
/* error */
void
-ao_scheme_vprintf(const char *format, va_list args);
+ao_scheme_vfprintf(FILE *out, const char *format, va_list args);
void
-ao_scheme_printf(const char *format, ...);
+ao_scheme_fprintf(FILE *out, const char *format, ...);
ao_poly
ao_scheme_error(int error, const char *format, ...);
#define DBG_IN() (++ao_scheme_stack_depth)
#define DBG_OUT() (--ao_scheme_stack_depth)
#define DBG_RESET() (ao_scheme_stack_depth = 0)
-#define DBG(...) ao_scheme_printf(__VA_ARGS__)
+#define 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(ao_scheme_cons_poly(a), true)
-#define DBG_POLY(a) ao_scheme_poly_write(a, true)
+#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(ao_scheme_stack_poly(ao_scheme_stack), true)
+#define DBG_STACK() ao_scheme_stack_write(stdout, ao_scheme_stack_poly(ao_scheme_stack), true)
static inline void
ao_scheme_frames_dump(void)
{
#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0)
#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0)
#define MDBG_MOVE_IN() (dbg_move_depth++)
-#define MDBG_MOVE_OUT() (assert(--dbg_move_depth >= 0))
+#define MDBG_MOVE_OUT() (--dbg_move_depth)
#else
--- /dev/null
+;
+; Copyright © 2018 Keith Packard <keithp@keithp.com>
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation, either version 2 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful, but
+; WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+; General Public License for more details.
+;
+; 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)) #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)
+
+(define (_??_ a b)
+ (cond ((equal? a b)
+ a
+ )
+ (else
+ (exit 1)
+ )
+ )
+ )
+
+(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) '(hello 3 1 2 3 (quasiquote 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)) 3)
+
+(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 (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)
+
+(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 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)
+
+(_??_ (call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x)
+ (if (negative? x)
+ (exit x)))
+ '(54 0 37 -3 245 19))
+ #t))
+ -3)
+
+(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)
+ )
+ )
+ )
+
+(_??_ (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))
static void atom_mark(void *addr)
{
- struct ao_scheme_atom *atom = addr;
-
- for (;;) {
- atom = ao_scheme_poly_atom(atom->next);
- if (!atom)
- break;
- if (ao_scheme_mark_memory(&ao_scheme_atom_type, atom))
- break;
- }
+ MDBG_MOVE("mark atom %s\n", ((struct ao_scheme_atom *) addr)->name);
+ (void) addr;
}
static void atom_move(void *addr)
{
- struct ao_scheme_atom *atom = addr;
- int ret;
-
- for (;;) {
- struct ao_scheme_atom *next = ao_scheme_poly_atom(atom->next);
-
- if (!next)
- break;
- ret = ao_scheme_move_memory(&ao_scheme_atom_type, (void **) &next);
- if (next != ao_scheme_poly_atom(atom->next))
- atom->next = ao_scheme_atom_poly(next);
- if (ret)
- break;
- atom = next;
- }
+ (void) addr;
}
const struct ao_scheme_type ao_scheme_atom_type = {
struct ao_scheme_atom *ao_scheme_atoms;
static struct ao_scheme_atom *
-ao_scheme_atom_find(char *name)
+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;
}
-#ifdef ao_builtin_atoms
- for (atom = ao_scheme_poly_atom(ao_builtin_atoms); atom; atom = ao_scheme_poly_atom(atom->next)) {
- if (!strcmp(atom->name, name))
- return atom;
+ 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
- return NULL;
+
+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
return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name);
}
-ao_poly
-ao_scheme_atom_set(ao_poly atom, ao_poly val)
-{
- ao_poly *ref = ao_scheme_atom_ref(atom, NULL);
-
- if (!ref)
- return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name);
- *ref = val;
- return val;
-}
-
ao_poly
ao_scheme_atom_def(ao_poly atom, ao_poly val)
{
}
void
-ao_scheme_atom_write(ao_poly a, bool write)
+ao_scheme_atom_write(FILE *out, ao_poly a, bool write)
{
struct ao_scheme_atom *atom = ao_scheme_poly_atom(a);
(void) write;
- printf("%s", atom->name);
+ 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
--- /dev/null
+;
+; Copyright © 2018 Keith Packard <keithp@keithp.com>
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation, either version 2 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful, but
+; WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+; General Public License for more details.
+;
+; Basic syntax placed in ROM
+
+(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit 1)))))
+
+(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
+ (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 args)
+ )
+ )
+ '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) #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) #f)
+
+ ; (if <condition> <if-true>)
+ ; (if <condition> <if-true> <if-false)
+
+(define if
+ (macro (a . b)
+ (cond ((null? (cdr b))
+ (list cond (list a (car b)))
+ )
+ (else
+ (list cond
+ (list a (car b))
+ (list 'else (car (cdr b)))
+ )
+ )
+ )
+ )
+ )
+
+(_?_ (if (> 3 2) 'yes) 'yes)
+(_?_ (if (> 3 2) 'yes 'no) 'yes)
+(_?_ (if (> 2 3) 'no 'yes) 'yes)
+(_?_ (if (> 2 3) 'no) #f)
+
+(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)) 2)
+
+ ; 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)) #t)
+(_?_ (equal? '(a b c) '(a b b)) #f)
+
+(def (quote _??_) (lambda (a b) (cond ((equal? a b) a) (else (exit 1)))))
+
+ ; basic list accessors
+
+(define (caar a) (car (car a)))
+
+(define (cadr a) (car (cdr a)))
+
+(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)
+
+(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))) '((2) (3)))
+(_??_ (member '(4) '((1) (2) (3))) #f)
+
+(define (memq a b) (member a b eq?))
+
+(_??_ (memq 2 '(1 2 3)) '(2 3))
+(_??_ (memq 4 '(1 2 3)) #f)
+(_??_ (memq '(2) '((1) (2) (3))) #f)
+
+(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?)
+ )
+ )
+ )
+
+(define (assq a b) (assoc a b eq?))
+(define assv assq)
+
+(_??_ (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 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))
+
+ ; 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)
+
+(define (eof-object? a)
+ (equal? a 'eof)
+ )
+
};
void
-ao_scheme_bool_write(ao_poly v, bool write)
+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)
- printf("#t");
+ fprintf(out, "#t");
else
- printf("#f");
+ 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
* General Public License for more details.
*/
+#define _GNU_SOURCE
#include "ao_scheme.h"
#include <limits.h>
#include <math.h>
+#include <stdarg.h>
static int
builtin_size(void *addr)
#endif
void
-ao_scheme_builtin_write(ao_poly b, bool write)
+ao_scheme_builtin_write(FILE *out, ao_poly b, bool write)
{
struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b);
(void) write;
- printf("%s", ao_scheme_builtin_name(builtin->func));
+ fputs(ao_scheme_builtin_name(builtin->func), out);
}
-ao_poly
-ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max)
-{
- int argc = 0;
+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;
- while (cons && argc <= max) {
+ 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++;
- cons = ao_scheme_cons_cdr(cons);
}
- if (argc < min || argc > max)
- return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name);
- return _ao_scheme_bool_true;
+ if (cons) {
+ bad_args:
+ ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid arg count", name);
+ return 0;
+ }
+ return 1;
}
-static ao_poly
-ao_scheme_opt_arg(struct ao_scheme_cons *cons, int argc, ao_poly def)
+ao_poly
+ao_scheme_arg(struct ao_scheme_cons *cons, int argc)
{
for (;;) {
if (!cons)
- return def;
+ return AO_SCHEME_NIL;
if (argc == 0)
return cons->car;
cons = ao_scheme_cons_cdr(cons);
}
}
-ao_poly
-ao_scheme_arg(struct ao_scheme_cons *cons, int argc)
-{
- return ao_scheme_opt_arg(cons, argc, AO_SCHEME_NIL);
-}
-
-ao_poly
-ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok)
-{
- ao_poly car = ao_scheme_arg(cons, argc);
-
- if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type)
- return ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car);
- return _ao_scheme_bool_true;
-}
-
-static int32_t
-ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc)
-{
- ao_poly p = ao_scheme_arg(cons, argc);
- bool fail = false;
- int32_t i = ao_scheme_poly_integer(p, &fail);
-
- if (fail)
- (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p);
- return i;
-}
-
-static int32_t
-ao_scheme_opt_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc, int def)
-{
- ao_poly p = ao_scheme_opt_arg(cons, argc, ao_scheme_int_poly(def));
- bool fail = false;
- int32_t i = ao_scheme_poly_integer(p, &fail);
-
- if (fail)
- (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p);
- return i;
-}
-
-ao_poly
-ao_scheme_do_car(struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0))
- return AO_SCHEME_NIL;
- return ao_scheme_poly_cons(cons->car)->car;
-}
-
-ao_poly
-ao_scheme_do_cdr(struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0))
- return AO_SCHEME_NIL;
- return ao_scheme_poly_cons(cons->car)->cdr;
-}
-
-ao_poly
-ao_scheme_do_cons(struct ao_scheme_cons *cons)
-{
- ao_poly car, cdr;
- if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2))
- return AO_SCHEME_NIL;
- car = ao_scheme_arg(cons, 0);
- cdr = ao_scheme_arg(cons, 1);
- return ao_scheme_cons(car, cdr);
-}
-
-ao_poly
-ao_scheme_do_last(struct ao_scheme_cons *cons)
-{
- struct ao_scheme_cons *list;
- if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1))
- return AO_SCHEME_NIL;
- for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0));
- list;
- list = ao_scheme_cons_cdr(list))
- {
- if (!list->cdr)
- return list->car;
- }
- return AO_SCHEME_NIL;
-}
-
-ao_poly
-ao_scheme_do_length(struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1))
- return AO_SCHEME_NIL;
- return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))));
-}
-
-ao_poly
-ao_scheme_do_list_copy(struct ao_scheme_cons *cons)
-{
- struct ao_scheme_cons *new;
-
- if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1))
- return AO_SCHEME_NIL;
- new = ao_scheme_cons_copy(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)));
- return ao_scheme_cons_poly(new);
-}
-
-ao_poly
-ao_scheme_do_list_tail(struct ao_scheme_cons *cons)
-{
- ao_poly list;
- int32_t v;
-
- if (!ao_scheme_check_argc(_ao_scheme_atom_list2dtail, cons, 2, 2))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_list2dtail, cons, 0, AO_SCHEME_CONS, 1))
- return AO_SCHEME_NIL;
- list = ao_scheme_arg(cons, 0);
- v = ao_scheme_arg_int(_ao_scheme_atom_list2dtail, cons, 1);
- if (ao_scheme_exception)
- 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_quote(struct ao_scheme_cons *cons)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1))
- return AO_SCHEME_NIL;
- return ao_scheme_arg(cons, 0);
-}
-
-ao_poly
-ao_scheme_do_set(struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0))
- return AO_SCHEME_NIL;
-
- return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1));
-}
-
-ao_poly
-ao_scheme_do_def(struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0))
- return AO_SCHEME_NIL;
-
- return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1));
-}
+ ao_poly val;
-ao_poly
-ao_scheme_do_setq(struct ao_scheme_cons *cons)
-{
- ao_poly name;
- if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2))
+ if (!ao_scheme_parse_args(_ao_scheme_atom_quote, cons,
+ AO_SCHEME_POLY, &val,
+ AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
- name = cons->car;
- if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM)
- return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name);
- if (!ao_scheme_atom_ref(name, NULL))
- return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name);
- return ao_scheme_cons(_ao_scheme_atom_set,
- ao_scheme_cons(ao_scheme_cons(_ao_scheme_atom_quote,
- ao_scheme_cons(name, AO_SCHEME_NIL)),
- cons->cdr));
+ return val;
}
ao_poly
return AO_SCHEME_NIL;
}
-ao_poly
-ao_scheme_do_write(struct ao_scheme_cons *cons)
+static ao_poly
+ao_scheme_do_display_or_write(ao_poly proc, struct ao_scheme_cons *cons, bool write)
{
- ao_poly val = AO_SCHEME_NIL;
- while (cons) {
- val = cons->car;
- ao_scheme_poly_write(val, true);
- cons = ao_scheme_cons_cdr(cons);
- if (cons)
- printf(" ");
+#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)
{
- ao_poly val = AO_SCHEME_NIL;
- while (cons) {
- val = cons->car;
- ao_scheme_poly_write(val, false);
- cons = ao_scheme_cons_cdr(cons);
- }
- return _ao_scheme_bool_true;
+ return ao_scheme_do_display_or_write(_ao_scheme_atom_display, cons, false);
}
static ao_poly
switch (op) {
case builtin_minus:
if (ao_scheme_integer_typep(ct))
- ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret, NULL));
+ 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, NULL) == 1) {
+ if (ao_scheme_poly_integer(ret) == 1) {
} else {
#ifdef AO_SCHEME_FEATURE_FLOAT
if (ao_scheme_number_typep(ct)) {
}
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, NULL);
- int32_t c = ao_scheme_poly_integer(car, NULL);
+ 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
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, NULL);
- int32_t r = ao_scheme_poly_integer(right, NULL);
+ int32_t l = ao_scheme_poly_integer(left);
+ int32_t r = ao_scheme_poly_integer(right);
switch (op) {
case builtin_less:
return ao_scheme_compare(cons, builtin_greater_equal);
}
-ao_poly
-ao_scheme_do_list_to_string(struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1))
- return AO_SCHEME_NIL;
- return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)));
-}
-
-ao_poly
-ao_scheme_do_string_to_list(struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0))
- return AO_SCHEME_NIL;
- return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0)));
-}
-
-ao_poly
-ao_scheme_do_string_ref(struct ao_scheme_cons *cons)
-{
- char *string;
- int32_t ref;
- if (!ao_scheme_check_argc(_ao_scheme_atom_string2dref, cons, 2, 2))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_string2dref, cons, 0, AO_SCHEME_STRING, 0))
- return AO_SCHEME_NIL;
- ref = ao_scheme_arg_int(_ao_scheme_atom_string2dref, cons, 1);
- if (ao_scheme_exception)
- return AO_SCHEME_NIL;
- string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val;
- while (*string && ref) {
- ++string;
- --ref;
- }
- if (!*string)
- return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid",
- _ao_scheme_atom_string2dref,
- ao_scheme_arg(cons, 0),
- ao_scheme_arg(cons, 1));
- return ao_scheme_int_poly(*string);
-}
-
-ao_poly
-ao_scheme_do_string_length(struct ao_scheme_cons *cons)
-{
- struct ao_scheme_string *string;
-
- if (!ao_scheme_check_argc(_ao_scheme_atom_string2dlength, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_string2dlength, cons, 0, AO_SCHEME_STRING, 0))
- return AO_SCHEME_NIL;
- string = ao_scheme_poly_string(ao_scheme_arg(cons, 0));
- return ao_scheme_integer_poly(strlen(string->val));
-}
-
-ao_poly
-ao_scheme_do_string_copy(struct ao_scheme_cons *cons)
-{
- struct ao_scheme_string *string;
-
- if (!ao_scheme_check_argc(_ao_scheme_atom_string2dcopy, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_string2dcopy, cons, 0, AO_SCHEME_STRING, 0))
- return AO_SCHEME_NIL;
- string = ao_scheme_poly_string(ao_scheme_arg(cons, 0));
- return ao_scheme_string_poly(ao_scheme_string_copy(string));
-}
-
-ao_poly
-ao_scheme_do_string_set(struct ao_scheme_cons *cons)
-{
- char *string;
- int32_t ref;
- int32_t val;
-
- if (!ao_scheme_check_argc(_ao_scheme_atom_string2dset21, cons, 3, 3))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_string2dset21, cons, 0, AO_SCHEME_STRING, 0))
- return AO_SCHEME_NIL;
- string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val;
- ref = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 1);
- if (ao_scheme_exception)
- return AO_SCHEME_NIL;
- val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2);
- if (ao_scheme_exception)
- return AO_SCHEME_NIL;
- if (!val)
- goto fail;
- while (*string && ref) {
- ++string;
- --ref;
- }
- if (!*string)
- goto fail;
- *string = val;
- return ao_scheme_int_poly(*string);
-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;
- char fill;
-
- if (!ao_scheme_check_argc(_ao_scheme_atom_make2dstring, cons, 1, 2))
- return AO_SCHEME_NIL;
- len = ao_scheme_arg_int(_ao_scheme_atom_make2dstring, cons, 0);
- if (ao_scheme_exception)
- return AO_SCHEME_NIL;
- fill = ao_scheme_opt_arg_int(_ao_scheme_atom_make2dstring, cons, 1, ' ');
- if (ao_scheme_exception)
- return AO_SCHEME_NIL;
- return ao_scheme_string_poly(ao_scheme_make_string(len, fill));
-}
-
ao_poly
ao_scheme_do_flush_output(struct ao_scheme_cons *cons)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0))
+#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;
- ao_scheme_os_flush();
+ 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_check_argc(_ao_scheme_atom_led, cons, 1, 1))
- return AO_SCHEME_NIL;
- led = ao_scheme_arg_int(_ao_scheme_atom_led, cons, 0);
- if (ao_scheme_exception)
+ if (!ao_scheme_parse_args(_ao_scheme_atom_led, cons,
+ AO_SCHEME_INT, &led,
+ AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
- led = ao_scheme_arg(cons, 0);
- ao_scheme_os_led(ao_scheme_poly_int(led));
- return led;
+ ao_scheme_os_led(led);
+ return _ao_scheme_bool_true;
}
-ao_poly
-ao_scheme_do_delay(struct ao_scheme_cons *cons)
-{
- int32_t delay;
-
- if (!ao_scheme_check_argc(_ao_scheme_atom_delay, cons, 1, 1))
- return AO_SCHEME_NIL;
- delay = ao_scheme_arg_int(_ao_scheme_atom_delay, cons, 0);
- if (ao_scheme_exception)
- return AO_SCHEME_NIL;
- ao_scheme_os_delay(delay);
- return delay;
-}
+#endif
ao_poly
ao_scheme_do_eval(struct ao_scheme_cons *cons)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1))
+ 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;
- return cons->car;
+ 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)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX))
- return AO_SCHEME_NIL;
ao_scheme_stack->state = eval_apply;
return ao_scheme_cons_poly(cons);
}
ao_poly
ao_scheme_do_read(struct ao_scheme_cons *cons)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0))
+ 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;
- return ao_scheme_read();
+ if (port) {
+ file = port->file;
+ if (!file)
+ return _ao_scheme_atom_eof;
+ }
+#endif
+ return ao_scheme_read(file);
}
ao_poly
ao_poly
ao_scheme_do_nullp(struct ao_scheme_cons *cons)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
+ 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 (ao_scheme_arg(cons, 0) == 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)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
+ 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 (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false)
+ if (val == _ao_scheme_bool_false)
return _ao_scheme_bool_true;
else
return _ao_scheme_bool_false;
}
-static ao_poly
-ao_scheme_do_typep(int type, struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type)
- return _ao_scheme_bool_true;
- return _ao_scheme_bool_false;
-}
-
-ao_poly
-ao_scheme_do_pairp(struct ao_scheme_cons *cons)
-{
- ao_poly v;
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
- return AO_SCHEME_NIL;
- v = ao_scheme_arg(cons, 0);
- if (ao_scheme_is_pair(v))
- return _ao_scheme_bool_true;
- return _ao_scheme_bool_false;
-}
-
ao_poly
-ao_scheme_do_integerp(struct ao_scheme_cons *cons)
+ao_scheme_do_typep(ao_poly proc, int type, struct ao_scheme_cons *cons)
{
-#ifdef AO_SCHEME_FEATURE_BIGINT
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
- return AO_SCHEME_NIL;
- switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
- case AO_SCHEME_INT:
- case AO_SCHEME_BIGINT:
- return _ao_scheme_bool_true;
- default:
- return _ao_scheme_bool_false;
- }
-#else
- return ao_scheme_do_typep(AO_SCHEME_INT, cons);
-#endif
-}
+ ao_poly val;
-ao_poly
-ao_scheme_do_numberp(struct ao_scheme_cons *cons)
-{
-#if defined(AO_SCHEME_FEATURE_BIGINT) || defined(AO_SCHEME_FEATURE_FLOAT)
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
+ if (!ao_scheme_parse_args(proc, cons,
+ AO_SCHEME_POLY, &val,
+ AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
- switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
- case AO_SCHEME_INT:
-#ifdef AO_SCHEME_FEATURE_BIGINT
- case AO_SCHEME_BIGINT:
-#endif
-#ifdef AO_SCHEME_FEATURE_FLOAT
- case AO_SCHEME_FLOAT:
-#endif
+ if (ao_scheme_poly_type(val) == type)
return _ao_scheme_bool_true;
- default:
- return _ao_scheme_bool_false;
- }
-#else
- return ao_scheme_do_integerp(cons);
-#endif
-}
-
-ao_poly
-ao_scheme_do_stringp(struct ao_scheme_cons *cons)
-{
- return ao_scheme_do_typep(AO_SCHEME_STRING, cons);
-}
-
-ao_poly
-ao_scheme_do_symbolp(struct ao_scheme_cons *cons)
-{
- return ao_scheme_do_typep(AO_SCHEME_ATOM, cons);
-}
-
-ao_poly
-ao_scheme_do_booleanp(struct ao_scheme_cons *cons)
-{
- return ao_scheme_do_typep(AO_SCHEME_BOOL, cons);
+ return _ao_scheme_bool_false;
}
ao_poly
ao_scheme_do_procedurep(struct ao_scheme_cons *cons)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
+ 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(ao_scheme_arg(cons, 0))) {
+ 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;
- }
-}
-
-/* This one is special -- a list is either nil or
- * a 'proper' list with only cons cells
- */
-ao_poly
-ao_scheme_do_listp(struct ao_scheme_cons *cons)
-{
- ao_poly v;
- if (!ao_scheme_check_argc(_ao_scheme_atom_list3f, cons, 1, 1))
- return AO_SCHEME_NIL;
- v = ao_scheme_arg(cons, 0);
- for (;;) {
- if (v == AO_SCHEME_NIL)
- return _ao_scheme_bool_true;
- if (!ao_scheme_is_cons(v))
- return _ao_scheme_bool_false;
- v = ao_scheme_poly_cons(v)->cdr;
+ return _ao_scheme_bool_false;
}
}
-ao_poly
-ao_scheme_do_set_car(struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0))
- return AO_SCHEME_NIL;
- return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1);
-}
-
-ao_poly
-ao_scheme_do_set_cdr(struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0))
- return AO_SCHEME_NIL;
- return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1);
-}
-
-ao_poly
-ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0))
- return AO_SCHEME_NIL;
- return ao_scheme_string_poly(ao_scheme_atom_to_string(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))));
-}
-
-ao_poly
-ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0))
- return AO_SCHEME_NIL;
-
- return ao_scheme_atom_poly(ao_scheme_string_to_atom(ao_scheme_poly_string(ao_scheme_arg(cons, 0))));;
-}
-
ao_poly
ao_scheme_do_read_char(struct ao_scheme_cons *cons)
{
int c;
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
+#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();
- return ao_scheme_int_poly(c);
+#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)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0))
+ 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(ao_scheme_poly_integer(ao_scheme_arg(cons, 0), NULL));
+ 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)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
+ 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 _ao_scheme_bool_true;
+ return val;
}
+#ifdef AO_SCHEME_FEATURE_TIME
+
ao_poly
ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons)
{
- int jiffy;
-
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
+ if (!ao_scheme_parse_args(_ao_scheme_atom_current2djiffy, cons,
+ AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
- jiffy = ao_scheme_os_jiffy();
- return (ao_scheme_int_poly(jiffy));
+ return ao_scheme_integer_poly(ao_scheme_os_jiffy());
}
ao_poly
-ao_scheme_do_current_second(struct ao_scheme_cons *cons)
+ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons)
{
- int second;
-
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
+ if (!ao_scheme_parse_args(_ao_scheme_atom_jiffies2dper2dsecond, cons,
+ AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
- second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND;
- return (ao_scheme_int_poly(second));
+ return ao_scheme_integer_poly(AO_SCHEME_JIFFIES_PER_SECOND);
}
ao_poly
-ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons)
+ao_scheme_do_delay(struct ao_scheme_cons *cons)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
+ 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;
- return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND));
+ ao_scheme_os_delay(delay);
+ return cons->car;
}
+#endif
-#ifdef AO_SCHEME_FEATURE_VECTOR
+#ifdef AO_SCHEME_FEATURE_POSIX
-ao_poly
-ao_scheme_do_vector(struct ao_scheme_cons *cons)
+#include <unistd.h>
+
+static char **ao_scheme_argv;
+
+void
+ao_scheme_set_argv(char **argv)
{
- return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons));
+ ao_scheme_argv = argv;
}
ao_poly
-ao_scheme_do_make_vector(struct ao_scheme_cons *cons)
+ao_scheme_do_command_line(struct ao_scheme_cons *cons)
{
- int32_t k;
+ ao_poly args = AO_SCHEME_NIL;
+ ao_poly arg;
+ int i;
- if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 1, 2))
+ if (!ao_scheme_parse_args(_ao_scheme_atom_command2dline, cons,
+ AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
- k = ao_scheme_arg_int(_ao_scheme_atom_make2dvector, cons, 0);
- if (ao_scheme_exception)
- return AO_SCHEME_NIL;
- return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_opt_arg(cons, 1, _ao_scheme_bool_false)));
-}
-ao_poly
-ao_scheme_do_vector_ref(struct ao_scheme_cons *cons)
-{
- if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dref, cons, 2, 2))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dref, cons, 0, AO_SCHEME_VECTOR, 0))
- return AO_SCHEME_NIL;
- return ao_scheme_vector_get(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1));
+ 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_vector_set(struct ao_scheme_cons *cons)
+ao_scheme_do_get_environment_variables(struct ao_scheme_cons *cons)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dset21, cons, 3, 3))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dset21, cons, 0, AO_SCHEME_VECTOR, 0))
+ 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;
- return ao_scheme_vector_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1), ao_scheme_arg(cons, 2));
+ 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_list_to_vector(struct ao_scheme_cons *cons)
+ao_scheme_do_get_environment_variable(struct ao_scheme_cons *cons)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3evector, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3evector, cons, 0, AO_SCHEME_CONS, 0))
+ 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;
- return ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))));
+ 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_vector_to_list(struct ao_scheme_cons *cons)
+ao_scheme_do_file_existsp(struct ao_scheme_cons *cons)
{
- int start, end;
+ struct ao_scheme_string *name;
- if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 3))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0))
- return AO_SCHEME_NIL;
- start = ao_scheme_opt_arg_int(_ao_scheme_atom_vector2d3elist, cons, 1, ao_scheme_int_poly(0));
- if (ao_scheme_exception)
+ if (!ao_scheme_parse_args(_ao_scheme_atom_file2dexists3f, cons,
+ AO_SCHEME_STRING, &name,
+ AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
- end = ao_scheme_opt_arg_int(_ao_scheme_atom_vector2d3elist, cons, 2, ao_scheme_int_poly(-1));
- if (ao_scheme_exception)
- return AO_SCHEME_NIL;
- return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0)),
- start,
- end));
+ if (access(name->val, F_OK) == 0)
+ return _ao_scheme_bool_true;
+ return _ao_scheme_bool_false;
}
ao_poly
-ao_scheme_do_vector_length(struct ao_scheme_cons *cons)
+ao_scheme_do_delete_file(struct ao_scheme_cons *cons)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1))
- return AO_SCHEME_NIL;
- if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0))
+ 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;
- return ao_scheme_integer_poly(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))->length);
+ if (unlink(name->val) == 0)
+ return _ao_scheme_bool_true;
+ return _ao_scheme_bool_false;
}
ao_poly
-ao_scheme_do_vectorp(struct ao_scheme_cons *cons)
+ao_scheme_do_current_second(struct ao_scheme_cons *cons)
{
- return ao_scheme_do_typep(AO_SCHEME_VECTOR, 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_VECTOR */
+#endif /* AO_SCHEME_FEATURE_POSIX */
#define AO_SCHEME_BUILTIN_FUNCS
#include "ao_scheme_builtin.h"
all f_lambda flush_output flush-output
TIME f_lambda delay
GPIO f_lambda led
-all f_lambda save
-all f_lambda restore
+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 stringp string?
all f_lambda string_ref string-ref
all f_lambda string_set string-set!
-all f_lambda string_copy string-copy
all f_lambda string_length string-length
all f_lambda make_string make-string
all f_lambda procedurep procedure?
all f_lambda write_char write-char
all f_lambda exit
TIME f_lambda current_jiffy current-jiffy
-TIME f_lambda current_second current-second
TIME f_lambda jiffies_per_second jiffies-per-second
FLOAT f_lambda finitep finite?
FLOAT f_lambda infinitep infinite?
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
--- /dev/null
+;
+; Copyright © 2018 Keith Packard <keithp@keithp.com>
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation, either version 2 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful, but
+; WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+; General Public License for more details.
+;
+; Char primitives placed in ROM
+
+(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)
return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr));
}
-struct ao_scheme_cons *
+static struct ao_scheme_cons *
ao_scheme_cons_copy(struct ao_scheme_cons *cons)
{
struct ao_scheme_cons *head = NULL;
}
void
-ao_scheme_cons_write(ao_poly c, bool write)
+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;
int written = 0;
ao_scheme_print_start();
- printf("(");
+ fprintf(out, "(");
while (cons) {
if (written != 0)
- printf(" ");
+ 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)) {
- printf("...");
+ fprintf(out, "...");
break;
}
- ao_scheme_poly_write(cons->car, write);
+ 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)) {
- printf(" . ");
- ao_scheme_poly_write(cdr, write);
+ fprintf(out, " . ");
+ ao_scheme_poly_write(out, cdr, write);
break;
}
cons = ao_scheme_poly_cons(cdr);
}
- printf(")");
+ fprintf(out, ")");
if (ao_scheme_print_stop()) {
}
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;
+}
+
;
; Lisp code placed in ROM
-(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit)))))
+(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))
;
; (let* ((x 1) (y)) (set! y (+ x 1)) y)
-(define let*
+(define letrec
(macro (vars . exprs)
;
)
)
-(_??_ (let* ((x 1) (y x)) (+ x y)) 2)
+(_??_ (letrec ((x 1) (y x)) (+ x y)) 2)
+
+ ; letrec is sufficient for let*
+
+(define let* letrec)
(define when (macro (test . l) `(cond (,test ,@l))))
)
)
-(for-each display '("hello" " " "world" "\n"))
+(_??_ (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)
- (write "test" x)
- (if (negative? x)
- (exit x)))
- '(54 0 37 -3 245 19))
- #t))
+(_??_ (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)
)
(repeat 2 (write 'hello))
-(repeat (x 3) (write 'goodbye x))
+(repeat (x 3) (write (list 'goodbye x)))
(define case
(macro (test . l)
)
)
-(_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "one")
-(_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "two")
-(_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x) "three")) (12 "twelve") (else "else")) "three")
-(_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "else")
-(_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "twelve")
+(_??_ (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)
)
)
-(do ((x 1 (+ x 1)))
- ((= x 10) "done")
- (display "x: ")
- (write x)
- (newline)
+(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)
--- /dev/null
+(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))
#include <stdarg.h>
void
-ao_scheme_vprintf(const char *format, va_list args)
+ao_scheme_vfprintf(FILE *out, const char *format, va_list args)
{
char c;
if (c == '%') {
switch (c = *format++) {
case 'v':
- ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int), true);
+ ao_scheme_poly_write(out, (ao_poly) va_arg(args, unsigned int), true);
break;
case 'V':
- ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int), false);
+ ao_scheme_poly_write(out, (ao_poly) va_arg(args, unsigned int), false);
break;
case 'p':
- printf("%p", va_arg(args, void *));
+ fprintf(out, "%p", va_arg(args, void *));
break;
case 'd':
- printf("%d", va_arg(args, int));
+ fprintf(out, "%d", va_arg(args, int));
break;
case 'x':
- printf("%x", va_arg(args, int));
+ fprintf(out, "%x", va_arg(args, int));
break;
case 's':
- printf("%s", va_arg(args, char *));
+ fprintf(out, "%s", va_arg(args, char *));
break;
default:
- putchar(c);
+ putc(c, out);
break;
}
} else
- putchar(c);
+ putc(c, out);
}
}
void
-ao_scheme_printf(const char *format, ...)
+ao_scheme_fprintf(FILE *out, const char *format, ...)
{
va_list args;
va_start(args, format);
- ao_scheme_vprintf(format, args);
+ ao_scheme_vfprintf(out, format, args);
va_end(args);
}
ao_scheme_exception |= error;
va_start(args, format);
- ao_scheme_vprintf(format, args);
+ ao_scheme_vfprintf(stdout, format, args);
putchar('\n');
va_end(args);
- ao_scheme_printf("Value: %v\n", ao_scheme_v);
- ao_scheme_printf("Frame: %v\n", ao_scheme_frame_poly(ao_scheme_frame_current));
+ 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(ao_scheme_stack_poly(ao_scheme_stack), true);
- ao_scheme_printf("Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global));
+ 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;
}
}
ao_scheme_v = v;
- ao_scheme_stack->values = AO_SCHEME_NIL;
- ao_scheme_stack->values_tail = AO_SCHEME_NIL;
+ 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;
[eval_macro] = "macro",
};
+#ifdef AO_SCHEME_FEATURE_SAVE
/*
* Called at restore time to reset all execution state
*/
{
return ao_scheme_stack_push();
}
+#endif /* AO_SCHEME_FEATURE_SAVE */
ao_poly
ao_scheme_eval(ao_poly _v)
return AO_SCHEME_NIL;
while (ao_scheme_stack) {
- if (!(*evals[ao_scheme_stack->state])() || ao_scheme_exception) {
- ao_scheme_stack_clear();
- return AO_SCHEME_NIL;
- }
+ 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;
}
--- /dev/null
+;
+; Copyright © 2018 Keith Packard <keithp@keithp.com>
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation, either version 2 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful, but
+; WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+; General Public License for more details.
+;
+; Finish setting up ROM lisp code
+
+(undef '_?_)
+(undef '_??_)
#endif
void
-ao_scheme_float_write(ao_poly p, bool write)
+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))
- printf("+nan.0");
+ fputs("+nan.0", out);
else if (isinff(v)) {
if (v < 0)
- printf("-");
+ putc('-', out);
else
- printf("+");
- printf("inf.0");
+ putc('+', out);
+ fputs("inf.0", out);
} else
- printf (FLOAT_FORMAT, v);
+ fprintf(out, FLOAT_FORMAT, v);
}
float
ao_poly
ao_scheme_do_inexactp(struct ao_scheme_cons *cons)
{
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
+ 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(ao_scheme_arg(cons, 0)) == AO_SCHEME_FLOAT)
+ 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 value;
+ ao_poly val;
float f;
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
+ if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons,
+ AO_SCHEME_POLY, &val,
+ AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
- value = ao_scheme_arg(cons, 0);
- switch (ao_scheme_poly_type(value)) {
+ 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(value)->value;
+ f = ao_scheme_poly_float(val)->value;
if (!isnan(f) && !isinf(f))
return _ao_scheme_bool_true;
}
ao_poly
ao_scheme_do_infinitep(struct ao_scheme_cons *cons)
{
- ao_poly value;
+ ao_poly val;
float f;
- if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
+ if (!ao_scheme_parse_args(_ao_scheme_atom_inexact3f, cons,
+ AO_SCHEME_POLY, &val,
+ AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
- value = ao_scheme_arg(cons, 0);
- switch (ao_scheme_poly_type(value)) {
+ switch (ao_scheme_poly_type(val)) {
case AO_SCHEME_FLOAT:
- f = ao_scheme_poly_float(value)->value;
+ f = ao_scheme_poly_float(val)->value;
if (isinf(f))
return _ao_scheme_bool_true;
}
ao_poly
ao_scheme_do_sqrt(struct ao_scheme_cons *cons)
{
- ao_poly value;
+ float f;
- if (!ao_scheme_check_argc(_ao_scheme_atom_sqrt, cons, 1, 1))
+ if (!ao_scheme_parse_args(_ao_scheme_atom_sqrt, cons,
+ AO_SCHEME_FLOAT, &f,
+ AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
- value = ao_scheme_arg(cons, 0);
- if (!ao_scheme_number_typep(ao_scheme_poly_type(value)))
- return ao_scheme_error(AO_SCHEME_INVALID, "%s: non-numeric", ao_scheme_poly_atom(_ao_scheme_atom_sqrt)->name);
- return ao_scheme_float_get(sqrtf(ao_scheme_poly_number(value)));
+ return ao_scheme_float_get(sqrtf(f));
}
#endif
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 ",
+ 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);
- MDBG_DO(printf("\n"));
}
}
int ao_scheme_frame_print_indent;
static void
-ao_scheme_frame_indent(int extra)
+ao_scheme_frame_indent(FILE *out, int extra)
{
int i;
- putchar('\n');
+ putc('\n', out);
for (i = 0; i < ao_scheme_frame_print_indent+extra; i++)
- putchar('\t');
+ putc('\t', out);
}
void
-ao_scheme_frame_write(ao_poly p, bool write)
+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;
struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals);
if (written != 0)
- printf(", ");
+ fputs(", ", out);
if (ao_scheme_print_mark_addr(frame)) {
- printf("recurse...");
+ fputs("recurse...", out);
break;
}
- putchar('{');
+ putc('{', out);
written++;
for (f = 0; f < frame->num; f++) {
- ao_scheme_frame_indent(1);
- ao_scheme_poly_write(vals->vals[f].atom, write);
- printf(" = ");
- ao_scheme_poly_write(vals->vals[f].val, write);
+ 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(0);
- putchar('}');
+ ao_scheme_frame_indent(out, 0);
+ putc('}', out);
}
if (ao_scheme_print_stop()) {
while (written--) {
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;
#include "ao_scheme.h"
void
-ao_scheme_int_write(ao_poly p, bool write)
+ao_scheme_int_write(FILE *out, ao_poly p, bool write)
{
int i = ao_scheme_poly_int(p);
(void) write;
- printf("%d", i);
+ 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, bool *fail)
+ao_scheme_poly_integer(ao_poly p)
{
- if (fail)
- *fail = false;
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;
}
- if (fail)
- *fail = true;
return 0;
}
};
void
-ao_scheme_bigint_write(ao_poly p, bool write)
+ao_scheme_bigint_write(FILE *out, ao_poly p, bool write)
{
struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p);
(void) write;
- printf("%d", bi->value);
+ fprintf(out, "%d", bi->value);
}
#endif /* AO_SCHEME_FEATURE_BIGINT */
};
void
-ao_scheme_lambda_write(ao_poly poly, bool write)
+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);
- printf("(");
- printf("%s", ao_scheme_args_name(lambda->args));
+ putc('(', out);
+ fputs(ao_scheme_args_name(lambda->args), out);
while (cons) {
- printf(" ");
- ao_scheme_poly_write(cons->car, write);
+ putc(' ', out);
+ ao_scheme_poly_write(out, cons->car, write);
cons = ao_scheme_poly_cons(cons->cdr);
}
- printf(")");
+ putc(')', out);
}
static ao_poly
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]);
+ }
+ }
+ }
+ printf("};\n");
+ printf("#endif /* AO_SCHEME_BUILTIN_SYNTAX_ATOMS */\n");
+}
+
bool
has_feature(string[*] features, string feature)
{
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);
}
}
}
dump_consts(builtins);
dump_atoms(builtins);
dump_atom_names(builtins);
+ dump_syntax_atoms(builtins);
dump_features(builtins);
}
}
}
static int
-ao_scheme_read_eval_abort(void)
+ao_scheme_read_eval_abort(FILE *read_file)
{
- ao_poly in, out = AO_SCHEME_NIL;
+ ao_poly in;
+
for(;;) {
- in = ao_scheme_read();
+ in = ao_scheme_read(read_file);
if (in == _ao_scheme_atom_eof)
break;
- out = ao_scheme_eval(in);
- if (ao_scheme_exception)
+ (void) ao_scheme_eval(in);
+ if (ao_scheme_exception) {
+ ao_scheme_fprintf(stderr, "make_const failed on %v\n", in);
return 0;
- ao_scheme_poly_write(out, true);
- putchar ('\n');
+ }
}
return 1;
}
}
static bool
-ao_scheme_has_feature(struct feature *list, const char *name)
+_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;
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)
{
perror(argv[optind]);
exit(1);
}
- if (!ao_scheme_read_eval_abort()) {
+ if (!ao_scheme_read_eval_abort(in)) {
fprintf(stderr, "eval failed\n");
exit(1);
}
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);
val = ao_has_macro(vals->vals[f].val);
if (val != AO_SCHEME_NIL) {
- printf("error: function %s contains unresolved macro: ",
- ao_scheme_poly_atom(vals->vals[f].atom)->name);
- ao_scheme_poly_write(val, true);
- printf("\n");
+ 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);
}
.type = NULL,
.addr = (void **) (void *) &stash_poly[5]
},
- {
- .type = &ao_scheme_atom_type,
- .addr = (void **) &ao_scheme_atoms
- },
{
.type = &ao_scheme_frame_type,
.addr = (void **) &ao_scheme_frame_global,
.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,
};
};
-#define AO_SCHEME_NCHUNK 64
+#define AO_SCHEME_NCHUNK (AO_SCHEME_POOL / 64)
static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK];
#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_VECTOR
[AO_SCHEME_VECTOR] = &ao_scheme_vector_type,
#endif
+#ifdef AO_SCHEME_FEATURE_PORT
+ [AO_SCHEME_PORT] = &ao_scheme_port_type,
+#endif
};
static int
#endif
MDBG_MOVE("collect %lu\n", ao_scheme_collects[style]);
- MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global)));
+ 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();
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();
ao_scheme_record_compare("mark", move_record, mark_record);
#endif
+ DUMP_ATOMS(1);
DUMP_BUSY();
/* Find the first moving object */
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);
if (mark_record && move_record)
ao_scheme_record_compare("move", mark_record, move_record);
#endif
+ DUMP_ATOMS(0);
}
#if DBG_MEM_STATS
ao_scheme_mark(const struct ao_scheme_type *type, void *addr)
{
int ret;
- MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr));
+ MDBG_MOVE("mark offset %d\n", MDBG_OFFSET(addr));
MDBG_MOVE_IN();
ret = ao_scheme_mark_memory(type, addr);
if (!ret) {
ao_scheme_abort();
#endif
- MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr));
+ MDBG_MOVE("poly_mark offset %d\n", MDBG_OFFSET(addr));
MDBG_MOVE_IN();
ret = ao_scheme_mark_memory(lisp_type, addr);
if (!ret) {
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)
#include "ao_scheme.h"
-static void ao_scheme_invalid_write(ao_poly p, bool write) {
- printf("??? type %d poly 0x%04x ???", ao_scheme_poly_type (p), p);
+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]) (ao_poly p, bool write) = {
+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,
#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))(ao_poly p, bool write)
+void (*ao_scheme_poly_write_func(ao_poly p))(FILE *out, ao_poly p, bool write)
{
uint8_t type = ao_scheme_poly_type(p);
--- /dev/null
+/*
+ * Copyright © 2018 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ */
+
+#include "ao_scheme.h"
+
+#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 */
--- /dev/null
+;
+; Copyright © 2018 Keith Packard <keithp@keithp.com>
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation, either version 2 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful, but
+; WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+; General Public License for more details.
+;
+; 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 (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")
#include <stdlib.h>
static const uint16_t lex_classes[128] = {
- IGNORE, /* ^@ */
- IGNORE, /* ^A */
- IGNORE, /* ^B */
- IGNORE, /* ^C */
- IGNORE, /* ^D */
- IGNORE, /* ^E */
- IGNORE, /* ^F */
- IGNORE, /* ^G */
- IGNORE, /* ^H */
- WHITE, /* ^I */
- WHITE, /* ^J */
- WHITE, /* ^K */
- WHITE, /* ^L */
- WHITE, /* ^M */
- IGNORE, /* ^N */
- IGNORE, /* ^O */
- IGNORE, /* ^P */
- IGNORE, /* ^Q */
- IGNORE, /* ^R */
- IGNORE, /* ^S */
- IGNORE, /* ^T */
- IGNORE, /* ^U */
- IGNORE, /* ^V */
- IGNORE, /* ^W */
- IGNORE, /* ^X */
- IGNORE, /* ^Y */
- IGNORE, /* ^Z */
- IGNORE, /* ^[ */
- IGNORE, /* ^\ */
- IGNORE, /* ^] */
- IGNORE, /* ^^ */
- IGNORE, /* ^_ */
- PRINTABLE|WHITE, /* */
- PRINTABLE, /* ! */
- PRINTABLE|STRINGC, /* " */
- PRINTABLE, /* # */
- PRINTABLE, /* $ */
- PRINTABLE, /* % */
- PRINTABLE, /* & */
- PRINTABLE|SPECIAL, /* ' */
- PRINTABLE|SPECIAL, /* ( */
- PRINTABLE|SPECIAL, /* ) */
- PRINTABLE, /* * */
- PRINTABLE|SIGN, /* + */
+ 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|DOTC|FLOATC, /* . */
- PRINTABLE, /* / */
- PRINTABLE|DIGIT, /* 0 */
- PRINTABLE|DIGIT, /* 1 */
- PRINTABLE|DIGIT, /* 2 */
- PRINTABLE|DIGIT, /* 3 */
- PRINTABLE|DIGIT, /* 4 */
- PRINTABLE|DIGIT, /* 5 */
- PRINTABLE|DIGIT, /* 6 */
- PRINTABLE|DIGIT, /* 7 */
- PRINTABLE|DIGIT, /* 8 */
- PRINTABLE|DIGIT, /* 9 */
- PRINTABLE, /* : */
- PRINTABLE|COMMENT, /* ; */
- PRINTABLE, /* < */
- PRINTABLE, /* = */
- PRINTABLE, /* > */
- PRINTABLE, /* ? */
- PRINTABLE, /* @ */
- PRINTABLE|HEX_LETTER, /* A */
- PRINTABLE|HEX_LETTER, /* B */
- PRINTABLE|HEX_LETTER, /* C */
- PRINTABLE|HEX_LETTER, /* D */
- PRINTABLE|FLOATC|HEX_LETTER,/* E */
- PRINTABLE|HEX_LETTER, /* F */
- PRINTABLE, /* G */
- PRINTABLE, /* H */
- PRINTABLE, /* I */
- PRINTABLE, /* J */
- PRINTABLE, /* K */
- PRINTABLE, /* L */
- PRINTABLE, /* M */
- PRINTABLE, /* N */
- PRINTABLE, /* O */
- PRINTABLE, /* P */
- PRINTABLE, /* Q */
- PRINTABLE, /* R */
- PRINTABLE, /* S */
- PRINTABLE, /* T */
- PRINTABLE, /* U */
- PRINTABLE, /* V */
- PRINTABLE, /* W */
- PRINTABLE, /* X */
- PRINTABLE, /* Y */
- PRINTABLE, /* Z */
- PRINTABLE, /* [ */
- PRINTABLE, /* \ */
- PRINTABLE, /* ] */
- PRINTABLE, /* ^ */
- PRINTABLE, /* _ */
+ 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|HEX_LETTER, /* a */
- PRINTABLE|HEX_LETTER, /* b */
- PRINTABLE|HEX_LETTER, /* c */
- PRINTABLE|HEX_LETTER, /* d */
- PRINTABLE|FLOATC|HEX_LETTER,/* e */
- PRINTABLE|HEX_LETTER, /* f */
- PRINTABLE, /* g */
- PRINTABLE, /* h */
- PRINTABLE, /* i */
- PRINTABLE, /* j */
- PRINTABLE, /* k */
- PRINTABLE, /* l */
- PRINTABLE, /* m */
- PRINTABLE, /* n */
- PRINTABLE, /* o */
- PRINTABLE, /* p */
- PRINTABLE, /* q */
- PRINTABLE, /* r */
- PRINTABLE, /* s */
- PRINTABLE, /* t */
- PRINTABLE, /* u */
- PRINTABLE, /* v */
- PRINTABLE, /* w */
- PRINTABLE, /* x */
- PRINTABLE, /* y */
- PRINTABLE, /* z */
- PRINTABLE, /* { */
- PRINTABLE, /* | */
- PRINTABLE, /* } */
- PRINTABLE, /* ~ */
- IGNORE, /* ^? */
+ 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;
static inline int
-lex_get(void)
+lex_get(FILE *in)
{
int c;
if (lex_unget_c) {
c = lex_unget_c;
lex_unget_c = 0;
} else {
- c = ao_scheme_getc();
+ c = getc(in);
}
return c;
}
static uint16_t lex_class;
static int
-lexc(void)
+lexc(FILE *in)
{
int c;
do {
- c = lex_get();
+ c = lex_get(in);
if (c == EOF) {
c = 0;
lex_class = ENDOFFILE;
}
static int
-lex_quoted(void)
+lex_quoted(FILE *in)
{
int c;
int v;
int count;
- c = lex_get();
+ c = lex_get(in);
if (c == EOF) {
+ eof:
lex_class = ENDOFFILE;
return 0;
}
v = c - '0';
count = 1;
while (count <= 3) {
- c = lex_get();
+ c = lex_get(in);
if (c == EOF)
- return EOF;
+ goto eof;
c &= 0x7f;
if (c < '0' || '7' < c) {
lex_unget(c);
static int32_t token_int;
static int token_len;
-static inline void add_token(int c) {
- if (c && token_len < AO_SCHEME_TOKEN_MAX - 1)
- token_string[token_len++] = c;
+static void start_token(void) {
+ token_len = 0;
}
-static inline void del_token(void) {
- if (token_len > 0)
- token_len--;
+static void add_token(int c) {
+ if (c && token_len < AO_SCHEME_TOKEN_MAX - 1)
+ token_string[token_len++] = c;
}
-static inline void end_token(void) {
+static void end_token(void) {
token_string[token_len] = '\0';
}
#endif
static int
-parse_int(int base)
+parse_int(FILE *in, int base)
{
int cval;
int c;
token_int = 0;
for (;;) {
- c = lexc();
+ c = lexc(in);
if ((lex_class & HEX_DIGIT) == 0) {
lex_unget(c);
- end_token();
return NUM;
}
- add_token(c);
if ('0' <= c && c <= '9')
cval = c - '0';
else
}
static int
-_lex(void)
+_lex(FILE *in)
{
int c;
- token_len = 0;
+ start_token();
for (;;) {
- c = lexc();
+ c = lexc(in);
if (lex_class & ENDOFFILE)
return END;
continue;
if (lex_class & COMMENT) {
- while ((c = lexc()) != '\n') {
+ while ((c = lexc(in)) != '\n') {
if (lex_class & ENDOFFILE)
return END;
}
continue;
}
- if (lex_class & (SPECIAL|DOTC)) {
- add_token(c);
- end_token();
+ if (lex_class & SPECIAL) {
switch (c) {
case '(':
case '[':
case '`':
return QUASIQUOTE;
case ',':
- c = lexc();
+ c = lexc(in);
if (c == '@') {
- add_token(c);
- end_token();
return UNQUOTE_SPLICING;
} else {
lex_unget(c);
}
}
if (c == '#') {
- c = lexc();
+ c = lexc(in);
switch (c) {
case 't':
- add_token(c);
- end_token();
- return BOOL;
+ return TRUE_TOKEN;
case 'f':
- add_token(c);
- end_token();
- return BOOL;
+ return FALSE_TOKEN;
#ifdef AO_SCHEME_FEATURE_VECTOR
case '(':
return OPEN_VECTOR;
#endif
case '\\':
for (;;) {
- int alphabetic;
- c = lexc();
- alphabetic = (('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z'));
+ c = lexc(in);
if (token_len == 0) {
add_token(c);
- if (!alphabetic)
+ if (!(lex_class & ALPHA))
break;
} else {
- if (alphabetic)
+ if (lex_class & ALPHA)
add_token(c);
else {
lex_unget(c);
}
return NUM;
case 'x':
- return parse_int(16);
+ return parse_int(in, 16);
case 'o':
- return parse_int(8);
+ return parse_int(in, 8);
case 'b':
- return parse_int(2);
+ return parse_int(in, 2);
}
}
if (lex_class & STRINGC) {
for (;;) {
- c = lexc();
+ c = lexc(in);
if (c == '\\')
- c = lex_quoted();
+ c = lex_quoted(in);
if (lex_class & (STRINGC|ENDOFFILE)) {
end_token();
return STRING;
}
}
add_token (c);
- c = lexc ();
+ c = lexc (in);
if ((lex_class & (NOTNAME))
#ifdef AO_SCHEME_FEATURE_FLOAT
&& (c != '.' || !isfloat)
#ifdef AO_SCHEME_FEATURE_FLOAT
unsigned int u;
#endif
-// if (lex_class & ENDOFFILE)
-// clearerr (f);
lex_unget(c);
end_token ();
if (isint && hasdigit) {
}
}
-static inline int lex(void)
+static inline int lex(FILE *in)
{
- int parse_token = _lex();
+ int parse_token = _lex(in);
RDBGI("token %d \"%s\"\n", parse_token, token_string);
return parse_token;
}
#endif
ao_poly
-ao_scheme_read(void)
+ao_scheme_read(FILE *in)
{
struct ao_scheme_atom *atom;
struct ao_scheme_string *string;
read_state = 0;
ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = NULL;
for (;;) {
- parse_token = lex();
+ parse_token = lex(in);
while (is_open(parse_token)) {
#ifdef AO_SCHEME_FEATURE_VECTOR
if (parse_token == OPEN_VECTOR)
return AO_SCHEME_NIL;
ao_scheme_read_list++;
read_state = 0;
- parse_token = lex();
+ parse_token = lex(in);
}
switch (parse_token) {
v = ao_scheme_float_get(token_float);
break;
#endif
- case BOOL:
- if (token_string[0] == 't')
- v = _ao_scheme_bool_true;
- else
- v = _ao_scheme_bool_false;
+ 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);
# define FLOAT 10
#endif
# define DOT 11
-# define BOOL 12
+# define TRUE_TOKEN 12
+# define FALSE_TOKEN 13
#ifdef AO_SCHEME_FEATURE_VECTOR
-# define OPEN_VECTOR 13
+# define OPEN_VECTOR 14
#endif
/*
#else
# define SPECIAL_QUASI 0
#endif
-# define DOTC 0x0004 /* . */
+#
+# define ALPHA 0x0004 /* A-Z a-z */
# define WHITE 0x0008 /* ' ' \t \n */
# define DIGIT 0x0010 /* [0-9] */
# define SIGN 0x0020 /* +- */
#include "ao_scheme.h"
ao_poly
-ao_scheme_read_eval_print(void)
+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(;;) {
- in = ao_scheme_read();
+ if (interactive)
+ fputs("> ", write_file);
+ in = ao_scheme_read(read_file);
if (in == _ao_scheme_atom_eof)
break;
out = ao_scheme_eval(in);
break;
ao_scheme_exception = 0;
} else {
- ao_scheme_poly_write(out, true);
- putchar ('\n');
+ if (write_file) {
+ ao_scheme_poly_write(write_file, out, true);
+ putc('\n', write_file);
+ }
}
}
return out;
#include "ao_scheme.h"
+#ifdef AO_SCHEME_FEATURE_SAVE
ao_poly
ao_scheme_do_save(struct ao_scheme_cons *cons)
{
-#ifdef AO_SCHEME_SAVE
+#ifndef AO_SCHEME_MAKE_CONST
struct ao_scheme_os_save *os;
-#endif
- if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0))
+ if (!ao_scheme_parse_args(_ao_scheme_atom_save, cons,
+ AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
-#ifdef AO_SCHEME_SAVE
os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL];
ao_scheme_collect(AO_SCHEME_COLLECT_FULL);
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)
{
-#ifdef AO_SCHEME_SAVE
+#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];
-#endif
- if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0))
+ if (!ao_scheme_parse_args(_ao_scheme_atom_restore, cons,
+ AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
-#ifdef AO_SCHEME_SAVE
os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL];
if (!ao_scheme_os_restore_save(&save, AO_SCHEME_POOL))
return _ao_scheme_bool_true;
}
+#else
+ (void) cons;
#endif
return _ao_scheme_bool_false;
}
+
+#endif /* AO_SCHEME_FEATURE_SAVE */
{
struct ao_scheme_stack *stack = addr;
for (;;) {
- ao_scheme_poly_mark(stack->sexprs, 0);
- ao_scheme_poly_mark(stack->values, 0);
+ 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, 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;
while (stack) {
struct ao_scheme_stack *prev;
int ret;
- (void) ao_scheme_poly_move(&stack->sexprs, 0);
- (void) ao_scheme_poly_move(&stack->values, 0);
+ (void) ao_scheme_poly_move(&stack->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, 0);
+ (void) ao_scheme_poly_move(&stack->list, 1);
prev = ao_scheme_poly_stack(stack->prev);
if (!prev)
break;
}
void
-ao_scheme_stack_clear(void)
-{
- ao_scheme_stack = NULL;
- ao_scheme_frame_current = NULL;
- ao_scheme_v = AO_SCHEME_NIL;
-}
-
-void
-ao_scheme_stack_write(ao_poly poly, bool write)
+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;
ao_scheme_frame_print_indent += 2;
while (s) {
if (ao_scheme_print_mark_addr(s)) {
- printf("[recurse...]");
+ fputs("[recurse...]", out);
break;
}
written++;
- printf("\t[\n");
- ao_scheme_printf("\t\texpr: %v\n", s->list);
- ao_scheme_printf("\t\tvalues: %v\n", s->values);
- ao_scheme_printf("\t\tframe: %v\n", s->frame);
- printf("\t]\n");
+ 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;
struct ao_scheme_stack *new;
ao_poly v;
- /* Make sure the single parameter is a lambda */
- if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1))
+ 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;
- if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0))
- return AO_SCHEME_NIL;
-
- /* go get the lambda */
- ao_scheme_v = ao_scheme_arg(cons, 0);
+ 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);
cons->car = ao_scheme_stack_poly(new);
cons->cdr = AO_SCHEME_NIL;
- v = ao_scheme_lambda_eval();
- ao_scheme_stack->sexprs = v;
- ao_scheme_stack->state = eval_begin;
- return AO_SCHEME_NIL;
+
+ ao_scheme_stack->state = eval_exec;
+ return v;
}
return s;
}
-struct ao_scheme_string *
-ao_scheme_string_copy(struct ao_scheme_string *a)
-{
- int alen = strlen(a->val);
- struct ao_scheme_string *r;
-
- ao_scheme_string_stash(a);
- r = ao_scheme_string_alloc(alen);
- a = ao_scheme_string_fetch();
- if (!r)
- return NULL;
- strcpy(r->val, a->val);
- return r;
-}
-
-struct ao_scheme_string *
-ao_scheme_make_string(int32_t len, char fill)
-{
- struct ao_scheme_string *r;
-
- r = ao_scheme_string_alloc(len);
- if (!r)
- return NULL;
- memset(r->val, fill, len);
- return r;
-}
-
struct ao_scheme_string *
ao_scheme_string_new(char *a)
{
return r;
}
-ao_poly
+static ao_poly
ao_scheme_string_pack(struct ao_scheme_cons *cons)
{
- struct ao_scheme_string *r;
- char *rval;
+ struct ao_scheme_string *string;
+ char *s;
int len;
len = ao_scheme_cons_length(cons);
ao_scheme_cons_stash(cons);
- r = ao_scheme_string_alloc(len);
+ string = ao_scheme_string_alloc(len);
cons = ao_scheme_cons_fetch();
- if (!r)
+ if (!string)
return AO_SCHEME_NIL;
- rval = r->val;
+ s = string->val;
while (cons) {
- bool fail = false;
ao_poly car = cons->car;
- *rval++ = ao_scheme_poly_integer(car, &fail);
- if (fail)
- return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack");
+ 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(r);
+ return ao_scheme_string_poly(string);
}
-ao_poly
+static ao_poly
ao_scheme_string_unpack(struct ao_scheme_string *a)
{
- struct ao_scheme_cons *cons = NULL, *tail = NULL;
- int c;
- int i;
+ ao_poly cons = AO_SCHEME_NIL;
+ int i;
- for (i = 0; (c = a->val[i]); i++) {
- struct ao_scheme_cons *n;
- ao_scheme_cons_stash(cons);
- ao_scheme_cons_stash(tail);
+ for (i = strlen(a->val); --i >= 0;) {
ao_scheme_string_stash(a);
- n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL);
+ cons = ao_scheme_cons(ao_scheme_int_poly(a->val[i]), cons);
a = ao_scheme_string_fetch();
- tail = ao_scheme_cons_fetch();
- cons = ao_scheme_cons_fetch();
-
- if (!n) {
- cons = NULL;
+ if (!cons)
break;
- }
- if (tail)
- tail->cdr = ao_scheme_cons_poly(n);
- else
- cons = n;
- tail = n;
}
- return ao_scheme_cons_poly(cons);
+ return cons;
}
void
-ao_scheme_string_write(ao_poly p, bool write)
+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) {
- putchar('"');
+ putc('"', out);
while ((c = *sval++)) {
switch (c) {
case '\a':
- printf("\\a");
+ fputs("\\a", out);
break;
case '\b':
- printf("\\b");
+ fputs("\\b", out);
break;
case '\t':
- printf ("\\t");
+ fputs("\\t", out);
break;
case '\n':
- printf ("\\n");
+ fputs("\\n", out);
break;
case '\r':
- printf ("\\r");
+ fputs("\\r", out);
break;
case '\f':
- printf("\\f");
+ fputs("\\f", out);
break;
case '\v':
- printf("\\v");
+ fputs("\\v", out);
break;
case '\"':
- printf("\\\"");
+ fputs("\\\"", out);
break;
case '\\':
- printf("\\\\");
+ fputs("\\\\", out);
break;
default:
if (c < ' ')
- printf("\\%03o", c);
+ fprintf(out, "\\%03o", c);
else
- putchar(c);
+ putc(c, out);
break;
}
}
- putchar('"');
+ putc('"', out);
} else {
while ((c = *sval++))
- putchar(c);
+ 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));
+}
;
; string functions placed in ROM
+(define string (lambda chars (list->string chars)))
+
+(_??_ (string #\a #\b #\c) "abc")
+
(define string-map
(lambda (proc . strings)
; result length is min of arg lengths
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(ao_poly v, bool write)
+ao_scheme_vector_write(FILE *out, ao_poly v, bool write)
{
struct ao_scheme_vector *vector = ao_scheme_poly_vector(v);
- unsigned int i;
+ unsigned int i, j;
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) {
- printf ("...");
+ fputs("...", out);
} else {
- printf("#(");
+ fputs("#(\n", out);
for (i = 0; i < vector->length; i++) {
- if (i != 0)
- printf(" ");
- ao_scheme_poly_write(vector->vals[i], write);
+ printf("%3d: ", i);
+ for (j = 0; j < vd; j++)
+ printf(".");
+ ao_scheme_poly_write(out, vector->vals[i], write);
+ printf("\n");
}
+ printf(" ");
+ for (j = 0; j < vd; j++)
+ printf(".");
printf(")");
}
if (ao_scheme_print_stop() && !was_marked)
ao_scheme_print_clear_addr(vector);
-}
-
-static int32_t
-ao_scheme_vector_offset(struct ao_scheme_vector *vector, ao_poly i)
-{
- bool fail;
- int32_t offset = ao_scheme_poly_integer(i, &fail);
-
- if (fail)
- ao_scheme_error(AO_SCHEME_INVALID, "vector index %v not integer", i);
- if (offset < 0 || vector->length <= offset) {
- ao_scheme_error(AO_SCHEME_INVALID, "vector index %v out of range (max %d)",
- i, vector->length);
- offset = -1;
- }
- return offset;
-}
-
-ao_poly
-ao_scheme_vector_get(ao_poly v, ao_poly i)
-{
- struct ao_scheme_vector *vector = ao_scheme_poly_vector(v);
- int32_t offset = ao_scheme_vector_offset(vector, i);
-
- if (offset < 0)
- return AO_SCHEME_NIL;
- return vector->vals[offset];
-}
-
-ao_poly
-ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p)
-{
- struct ao_scheme_vector *vector = ao_scheme_poly_vector(v);
- int32_t offset = ao_scheme_vector_offset(vector, i);
-
- if (offset < 0)
- return AO_SCHEME_NIL;
- return vector->vals[offset] = p;
+ if (vl != ve)
+ abort();
+ vl = ve->prev;
+ free(ve);
+ --vd;
}
struct ao_scheme_vector *
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 */
$(OBJS): $(HDRS)
ao_scheme_const.h: ao_scheme_make_const $(SCHEME_SCHEME)
- $^ -o $@
+ $^ -o $@ -d GPIO
clean::
rm -f $(OBJS) ao-scheme ao_scheme_const.h
#include <time.h>
#define AO_SCHEME_POOL_TOTAL 32768
-#define AO_SCHEME_SAVE 1
-
-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
#include "ao_scheme.h"
#include <stdio.h>
-
-static FILE *ao_scheme_file;
-static int newline = 1;
+#include <unistd.h>
+#include <getopt.h>
static char save_file[] = "scheme.image";
return 1;
}
-int
-ao_scheme_getc(void)
+static const struct option options[] = {
+ { .name = "load", .has_arg = 1, .val = 'l' },
+ { 0, 0, 0, 0 },
+};
+
+static void usage(char *program)
{
- int c;
+ fprintf(stderr, "usage: %s [--load=<library> ...] <program ...>\n", program);
+}
- if (ao_scheme_file)
- return getc(ao_scheme_file);
+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);
+ }
+}
- if (newline) {
- if (ao_scheme_read_list)
- printf("+ ");
- else
- printf("> ");
- newline = 0;
+static void
+run_file(char *name)
+{
+ FILE *in;
+ int c;
+ ao_poly v;
+
+ in = fopen(name, "r");
+ if (!in) {
+ perror(name);
+ exit(1);
}
- c = getchar();
- if (c == '\n')
- newline = 1;
- return c;
+ 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)
{
- (void) argc;
-
- while (*++argv) {
- ao_scheme_file = fopen(*argv, "r");
- if (!ao_scheme_file) {
- perror(*argv);
+ int o;
+
+ while ((o = getopt_long(argc, argv, "?l:", options, NULL)) != -1) {
+ switch (o) {
+ case '?':
+ usage(argv[0]);
+ exit(0);
+ case 'l':
+ ao_scheme_set_argv(&argv[argc]);
+ run_file(optarg);
+ break;
+ default:
+ usage(argv[0]);
exit(1);
}
- ao_scheme_read_eval_print();
- fclose(ao_scheme_file);
- ao_scheme_file = NULL;
}
- ao_scheme_read_eval_print();
+ ao_scheme_set_argv(argv + optind);
+ 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",
(double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] /
(double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]);
#endif
+ return 0;
}
+#!/home/keithp/bin/ao-scheme
;
; Towers of Hanoi
;
(_hanoi len 0 1 2)
#t
)
+
+(unless (null? (command-line)) (hanoi 6))
vpath %.o .
vpath %.c ..
vpath %.h ..
+vpath %.scheme ..
+vpath ao_scheme_make_const ../make-const
DEFS=
$(OBJS): $(HDRS)
-ao_scheme_const.h: ../make-const/ao_scheme_make_const ao_scheme_tiny_const.scheme
- ../make-const/ao_scheme_make_const -o $@ -d FLOAT,VECTOR,QUASI,BIGINT ao_scheme_tiny_const.scheme
+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
#include <time.h>
#define AO_SCHEME_POOL_TOTAL 4096
-#define AO_SCHEME_SAVE 1
-
-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
#include "ao_scheme.h"
#include <stdio.h>
-static FILE *ao_scheme_file;
-static int newline = 1;
-
static char save_file[] = "scheme.image";
int
return 1;
}
-int
-ao_scheme_getc(void)
-{
- int c;
-
- if (ao_scheme_file)
- return getc(ao_scheme_file);
-
- if (newline) {
- if (ao_scheme_read_list)
- printf("+ ");
- else
- printf("> ");
- newline = 0;
- }
- c = getchar();
- if (c == '\n')
- newline = 1;
- return c;
-}
-
int
main (int argc, char **argv)
{
(void) argc;
while (*++argv) {
- ao_scheme_file = fopen(*argv, "r");
- if (!ao_scheme_file) {
+ FILE *in = fopen(*argv, "r");
+ if (!in) {
perror(*argv);
exit(1);
}
- ao_scheme_read_eval_print();
- fclose(ao_scheme_file);
- ao_scheme_file = NULL;
+ ao_scheme_read_eval_print(in, stdout, false);
+ fclose(in);
}
- ao_scheme_read_eval_print();
+ ao_scheme_read_eval_print(stdin, stdout, true);
#ifdef DBG_MEM_STATS
printf ("collects: full: %lu incremental %lu\n",
projects / fw / altos / commitdiff