-all: ao_scheme_builtin.h ao_scheme_const.h test/ao_scheme_test
+all: ao_scheme_builtin.h make-const/ao_scheme_make_const test/ao-scheme tiny-test/ao-scheme-tiny
clean:
+cd make-const && make clean
+cd test && make clean
- rm -f ao_scheme_const.h ao_scheme_builtin.h
-
-ao_scheme_const.h: ao_scheme_const.scheme make-const/ao_scheme_make_const
- make-const/ao_scheme_make_const -o $@ ao_scheme_const.scheme
+ +cd tiny-test && make clean
+ rm -f ao_scheme_builtin.h
ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt
nickle ao_scheme_make_builtin ao_scheme_builtin.txt > $@
make-const/ao_scheme_make_const: FRC ao_scheme_builtin.h
+cd make-const && make ao_scheme_make_const
-test/ao_scheme_test: FRC ao_scheme_const.h ao_scheme_builtin.h
- +cd test && make ao_scheme_test
+test/ao-scheme: FRC ao_scheme_builtin.h make-const/ao_scheme_make_const
+ +cd test && make
+
+tiny-test/ao-scheme-tiny: FRC ao_scheme_builtin.h make-const/ao_scheme_make_const
+ +cd tiny-test && make
FRC:
#include <stdint.h>
#include <string.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>
#define AO_SCHEME_LAMBDA 8
#define AO_SCHEME_STACK 9
#define AO_SCHEME_BOOL 10
+#ifdef AO_SCHEME_FEATURE_BIGINT
#define AO_SCHEME_BIGINT 11
-#define AO_SCHEME_FLOAT 12
+#define _AO_SCHEME_BIGINT AO_SCHEME_BIGINT
+#else
+#define _AO_SCHEME_BIGINT AO_SCHEME_BOOL
+#endif
+#ifdef AO_SCHEME_FEATURE_FLOAT
+#define AO_SCHEME_FLOAT (_AO_SCHEME_BIGINT + 1)
+#define _AO_SCHEME_FLOAT AO_SCHEME_FLOAT
+#else
+#define _AO_SCHEME_FLOAT _AO_SCHEME_BIGINT
+#endif
+#ifdef AO_SCHEME_FEATURE_VECTOR
#define AO_SCHEME_VECTOR 13
-#define AO_SCHEME_NUM_TYPE 14
+#define _AO_SCHEME_VECTOR AO_SCHEME_VECTOR
+#else
+#define _AO_SCHEME_VECTOR _AO_SCHEME_FLOAT
+#endif
+#define AO_SCHEME_NUM_TYPE (_AO_SCHEME_VECTOR+1)
/* Leave two bits for types to use as they please */
#define AO_SCHEME_OTHER_TYPE_MASK 0x3f
uint16_t pad;
};
-struct ao_scheme_bigint {
- uint32_t value;
-};
+#ifdef AO_SCHEME_FEATURE_FLOAT
struct ao_scheme_float {
uint8_t type;
uint8_t pad1;
uint16_t pad2;
float value;
};
+#endif
+#ifdef AO_SCHEME_FEATURE_VECTOR
struct ao_scheme_vector {
uint8_t type;
uint8_t pad1;
uint16_t length;
ao_poly vals[];
};
+#endif
+
+#define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT)))
+#define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1)
+
+#ifdef AO_SCHEME_FEATURE_BIGINT
+struct ao_scheme_bigint {
+ uint32_t value;
+};
+
+#define AO_SCHEME_MIN_BIGINT (-(1 << 24))
+#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1)
#if __BYTE_ORDER == __LITTLE_ENDIAN
+
static inline uint32_t
ao_scheme_int_bigint(int32_t i) {
return AO_SCHEME_BIGINT | (i << 8);
ao_scheme_bigint_int(uint32_t bi) {
return (int32_t) (bi << 8) >> 8;
}
-#endif
-#define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT)))
-#define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1)
-#define AO_SCHEME_MIN_BIGINT (-(1 << 24))
-#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1)
+#endif /* __BYTE_ORDER */
+#endif /* AO_SCHEME_FEATURE_BIGINT */
#define AO_SCHEME_NOT_INTEGER 0x7fffffff
return ((ao_poly) i << 2) | AO_SCHEME_INT;
}
+#ifdef AO_SCHEME_FEATURE_BIGINT
static inline struct ao_scheme_bigint *
ao_scheme_poly_bigint(ao_poly poly)
{
{
return ao_scheme_poly(bi, AO_SCHEME_OTHER);
}
+#endif /* AO_SCHEME_FEATURE_BIGINT */
static inline char *
ao_scheme_poly_string(ao_poly poly)
return ao_scheme_ref(poly);
}
+#ifdef AO_SCHEME_FEATURE_FLOAT
static inline ao_poly
ao_scheme_float_poly(struct ao_scheme_float *f)
{
float
ao_scheme_poly_number(ao_poly p);
+#endif
+#ifdef AO_SCHEME_FEATURE_VECTOR
static inline ao_poly
ao_scheme_vector_poly(struct ao_scheme_vector *v)
{
{
return ao_scheme_ref(poly);
}
+#endif
/* memory functions */
void
ao_scheme_int_write(ao_poly i);
+#ifdef AO_SCHEME_FEATURE_BIGINT
int32_t
ao_scheme_poly_integer(ao_poly p);
extern const struct ao_scheme_type ao_scheme_bigint_type;
+#else
+
+#define ao_scheme_poly_integer ao_scheme_poly_int
+#define ao_scheme_integer_poly ao_scheme_int_poly
+
+static inline int
+ao_scheme_integer_typep(uint8_t t)
+{
+ return (t == AO_SCHEME_INT);
+}
+
+#endif /* AO_SCHEME_FEATURE_BIGINT */
+
/* vector */
void
extern const struct ao_scheme_type ao_scheme_vector_type;
/* prim */
-void
-ao_scheme_poly_write(ao_poly p);
+void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p);
+void (*ao_scheme_poly_display_func(ao_poly p))(ao_poly p);
-void
-ao_scheme_poly_display(ao_poly p);
+static inline void
+ao_scheme_poly_write(ao_poly p) { (*ao_scheme_poly_write_func(p))(p); }
+
+static inline void
+ao_scheme_poly_display(ao_poly p) { (*ao_scheme_poly_display_func(p))(p); }
int
ao_scheme_poly_mark(ao_poly p, uint8_t note_cons);
ao_scheme_set_cond(struct ao_scheme_cons *cons);
/* float */
+#ifdef AO_SCHEME_FEATURE_FLOAT
extern const struct ao_scheme_type ao_scheme_float_type;
void
ao_poly
ao_scheme_float_get(float value);
+#endif
+#ifdef AO_SCHEME_FEATURE_FLOAT
static inline uint8_t
ao_scheme_number_typep(uint8_t t)
{
float
ao_scheme_poly_number(ao_poly p);
+#else
+#define ao_scheme_number_typep ao_scheme_integer_typep
+#define ao_scheme_poly_number ao_scheme_poly_integer
+#endif
/* builtin */
void
case builtin_minus:
if (ao_scheme_integer_typep(ct))
ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret));
+#ifdef AO_SCHEME_FEATURE_FLOAT
else if (ct == AO_SCHEME_FLOAT)
ret = ao_scheme_float_get(-ao_scheme_poly_number(ret));
+#endif
break;
case builtin_divide:
- if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1)
- ;
- else if (ao_scheme_number_typep(ct)) {
- float v = ao_scheme_poly_number(ret);
- ret = ao_scheme_float_get(1/v);
+ if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) {
+ } else {
+#ifdef AO_SCHEME_FEATURE_FLOAT
+ if (ao_scheme_number_typep(ct)) {
+ float v = ao_scheme_poly_number(ret);
+ ret = ao_scheme_float_get(1/v);
+ }
+#else
+ ret = ao_scheme_integer_poly(0);
+#endif
}
break;
default:
} else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) {
int32_t r = ao_scheme_poly_integer(ret);
int32_t c = ao_scheme_poly_integer(car);
+#ifdef AO_SCHEME_FEATURE_FLOAT
int64_t t;
+#endif
switch(op) {
case builtin_plus:
r += c;
check_overflow:
+#ifdef AO_SCHEME_FEATURE_FLOAT
if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r)
goto inexact;
+#endif
break;
case builtin_minus:
r -= c;
goto check_overflow;
break;
case builtin_times:
+#ifdef AO_SCHEME_FEATURE_FLOAT
t = (int64_t) r * (int64_t) c;
if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t)
goto inexact;
r = (int32_t) t;
+#else
+ r = r * c;
+#endif
break;
case builtin_divide:
+#ifdef AO_SCHEME_FEATURE_FLOAT
if (c != 0 && (r % c) == 0)
r /= c;
else
goto inexact;
+#else
+ r /= c;
+#endif
break;
case builtin_quotient:
if (c == 0)
ao_scheme_cons_stash(0, cons);
ret = ao_scheme_integer_poly(r);
cons = ao_scheme_cons_fetch(0);
+#ifdef AO_SCHEME_FEATURE_FLOAT
} else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) {
float r, c;
inexact:
ao_scheme_cons_stash(0, cons);
ret = ao_scheme_float_get(r);
cons = ao_scheme_cons_fetch(0);
+#endif
}
else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) {
ao_scheme_cons_stash(0, cons);
ao_poly
ao_scheme_do_integerp(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))) {
default:
return _ao_scheme_bool_false;
}
+#else
+ return ao_scheme_do_typep(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)
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:
+#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
}
ao_poly
return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND));
}
+#ifdef AO_SCHEME_FEATURE_VECTOR
+
ao_poly
ao_scheme_do_vector(struct ao_scheme_cons *cons)
{
return ao_scheme_do_typep(AO_SCHEME_VECTOR, cons);
}
+#endif /* AO_SCHEME_FEATURE_VECTOR */
+
#define AO_SCHEME_BUILTIN_FUNCS
#include "ao_scheme_builtin.h"
-f_lambda eval
-f_lambda read
-nlambda lambda
-nlambda nlambda
-nlambda macro
-f_lambda car
-f_lambda cdr
-f_lambda cons
-f_lambda last
-f_lambda length
-f_lambda list_copy list-copy
-nlambda quote
-atom quasiquote
-atom unquote
-atom unquote_splicing unquote-splicing
-f_lambda set
-macro setq set!
-f_lambda def
-nlambda cond
-nlambda begin
-nlambda while
-f_lambda write
-f_lambda display
-f_lambda plus + string-append
-f_lambda minus -
-f_lambda times *
-f_lambda divide /
-f_lambda modulo modulo %
-f_lambda remainder
-f_lambda quotient
-f_lambda equal = eq? eqv?
-f_lambda less < string<?
-f_lambda greater > string>?
-f_lambda less_equal <= string<=?
-f_lambda greater_equal >= string>=?
-f_lambda flush_output flush-output
-f_lambda delay
-f_lambda led
-f_lambda save
-f_lambda restore
-f_lambda call_cc call-with-current-continuation call/cc
-f_lambda collect
-f_lambda nullp null?
-f_lambda not
-f_lambda listp list?
-f_lambda pairp pair?
-f_lambda integerp integer? exact? exact-integer?
-f_lambda numberp number? real?
-f_lambda booleanp boolean?
-f_lambda set_car set-car!
-f_lambda set_cdr set-cdr!
-f_lambda symbolp symbol?
-f_lambda list_to_string list->string
-f_lambda string_to_list string->list
-f_lambda symbol_to_string symbol->string
-f_lambda string_to_symbol string->symbol
-f_lambda stringp string?
-f_lambda string_ref string-ref
-f_lambda string_set string-set!
-f_lambda string_copy string-copy
-f_lambda string_length string-length
-f_lambda procedurep procedure?
-lambda apply
-f_lambda read_char read-char
-f_lambda write_char write-char
-f_lambda exit
-f_lambda current_jiffy current-jiffy
-f_lambda current_second current-second
-f_lambda jiffies_per_second jiffies-per-second
-f_lambda finitep finite?
-f_lambda infinitep infinite?
-f_lambda inexactp inexact?
-f_lambda sqrt
-f_lambda vector_ref vector-ref
-f_lambda vector_set vector-set!
-f_lambda vector
-f_lambda make_vector make-vector
-f_lambda list_to_vector list->vector
-f_lambda vector_to_list vector->list
-f_lambda vector_length vector-length
-f_lambda vectorp vector?
+BIGINT feature bigint
+all atom eof
+all atom else
+all f_lambda eval
+all f_lambda read
+all nlambda lambda
+all nlambda nlambda
+all nlambda macro
+all f_lambda car
+all f_lambda cdr
+all f_lambda cons
+all f_lambda last
+all f_lambda length
+all f_lambda list_copy list-copy
+all nlambda quote
+QUASI atom quasiquote
+QUASI atom unquote
+QUASI atom unquote_splicing unquote-splicing
+all f_lambda set
+all macro setq set!
+all f_lambda def
+all nlambda cond
+all nlambda begin
+all nlambda while
+all f_lambda write
+all f_lambda display
+all f_lambda plus + string-append
+all f_lambda minus -
+all f_lambda times *
+all f_lambda divide /
+all f_lambda modulo modulo %
+all f_lambda remainder
+all f_lambda quotient
+all f_lambda equal = eq? eqv?
+all f_lambda less < string<?
+all f_lambda greater > string>?
+all f_lambda less_equal <= string<=?
+all f_lambda greater_equal >= string>=?
+all f_lambda flush_output flush-output
+TIME f_lambda delay
+GPIO f_lambda led
+all f_lambda save
+all f_lambda restore
+all f_lambda call_cc call-with-current-continuation call/cc
+all f_lambda collect
+all f_lambda nullp null?
+all f_lambda not
+all f_lambda listp list?
+all f_lambda pairp pair?
+FLOAT f_lambda integerp integer? exact? exact-integer?
+all f_lambda numberp number? real?
+all f_lambda booleanp boolean?
+all f_lambda set_car set-car!
+all f_lambda set_cdr set-cdr!
+all f_lambda symbolp symbol?
+all f_lambda list_to_string list->string
+all f_lambda string_to_list string->list
+all f_lambda symbol_to_string symbol->string
+all f_lambda string_to_symbol string->symbol
+all f_lambda stringp string?
+all f_lambda string_ref string-ref
+all f_lambda string_set string-set!
+all f_lambda string_copy string-copy
+all f_lambda string_length string-length
+all f_lambda procedurep procedure?
+all lambda apply
+all f_lambda read_char read-char
+all f_lambda write_char write-char
+all f_lambda exit
+TIME f_lambda current_jiffy current-jiffy
+TIME f_lambda current_second current-second
+TIME f_lambda jiffies_per_second jiffies-per-second
+FLOAT f_lambda finitep finite?
+FLOAT f_lambda infinitep infinite?
+FLOAT f_lambda inexactp inexact?
+FLOAT f_lambda sqrt
+VECTOR f_lambda vector_ref vector-ref
+VECTOR f_lambda vector_set vector-set!
+VECTOR f_lambda vector
+VECTOR f_lambda make_vector make-vector
+VECTOR f_lambda list_to_vector list->vector
+VECTOR f_lambda vector_to_list vector->list
+VECTOR f_lambda vector_length vector-length
+VECTOR f_lambda vectorp vector?
)
(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else"))
-
-;(define number->string (lambda (arg . opt)
-; (let ((base (if (null? opt) 10 (car opt)))
- ;
-;
-
#include "ao_scheme.h"
#include <math.h>
+#ifdef AO_SCHEME_FEATURE_FLOAT
+
static void float_mark(void *addr)
{
(void) addr;
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)));
}
+#endif
printf("%d", i);
}
+#ifdef AO_SCHEME_FEATURE_BIGINT
+
int32_t
ao_scheme_poly_integer(ao_poly p)
{
printf("%d", ao_scheme_bigint_int(bi->value));
}
+#endif /* AO_SCHEME_FEATURE_BIGINT */
#!/usr/bin/nickle
typedef struct {
+ string feature;
string type;
string c_name;
string[*] lisp_names;
"macro" => "MACRO",
"f_lambda" => "F_LAMBDA",
"atom" => "atom",
+ "feature" => "feature",
};
string[*]
{
string[...] lisp = {};
- if (dim(tokens) < 3)
+ if (dim(tokens) < 4)
return (string[1]) { tokens[dim(tokens) - 1] };
- return (string[dim(tokens)-2]) { [i] = tokens[i+2] };
+ return (string[dim(tokens)-3]) { [i] = tokens[i+3] };
}
builtin_t
string[*] tokens = String::wordsplit(line, " \t");
return (builtin_t) {
- .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#",
- .c_name = dim(tokens) > 1 ? tokens[1] : "#",
+ .feature = dim(tokens) > 0 ? tokens[0] : "#",
+ .type = dim(tokens) > 1 ? type_map[tokens[1]] : "#",
+ .c_name = dim(tokens) > 2 ? tokens[2] : "#",
.lisp_names = make_lisp(tokens),
};
}
return builtins;
}
+void
+dump_ifdef(builtin_t builtin)
+{
+ if (builtin.feature != "all")
+ printf("#ifdef AO_SCHEME_FEATURE_%s\n", builtin.feature);
+}
+
+void
+dump_endif(builtin_t builtin)
+{
+ if (builtin.feature != "all")
+ printf("#endif /* AO_SCHEME_FEATURE_%s */\n", builtin.feature);
+}
+
bool is_atom(builtin_t b) = b.type == "atom";
+bool is_func(builtin_t b) = b.type != "atom" && b.type != "feature";
+
+bool is_feature(builtin_t b) = b.type == "feature";
+
void
dump_ids(builtin_t[*] builtins) {
printf("#ifdef AO_SCHEME_BUILTIN_ID\n");
printf("#undef AO_SCHEME_BUILTIN_ID\n");
printf("enum ao_scheme_builtin_id {\n");
for (int i = 0; i < dim(builtins); i++)
- if (!is_atom(builtins[i]))
+ if (is_func(builtins[i])) {
+ dump_ifdef(builtins[i]);
printf("\tbuiltin_%s,\n", builtins[i].c_name);
+ dump_endif(builtins[i]);
+ }
printf("\t_builtin_last\n");
printf("};\n");
printf("#endif /* AO_SCHEME_BUILTIN_ID */\n");
printf("static char *ao_scheme_builtin_name(enum ao_scheme_builtin_id b) {\n");
printf("\tswitch(b) {\n");
for (int i = 0; i < dim(builtins); i++)
- if (!is_atom(builtins[i]))
+ if (is_func(builtins[i])) {
+ dump_ifdef(builtins[i]);
printf("\tcase builtin_%s: return ao_scheme_poly_atom(_atom(\"%s\"))->name;\n",
builtins[i].c_name, builtins[i].lisp_names[0]);
+ dump_endif(builtins[i]);
+ }
printf("\tdefault: return \"???\";\n");
printf("\t}\n");
printf("}\n");
printf("#undef AO_SCHEME_BUILTIN_ARRAYNAME\n");
printf("static const ao_poly builtin_names[] = {\n");
for (int i = 0; i < dim(builtins); i++) {
- if (!is_atom(builtins[i])) {
+ if (is_func(builtins[i])) {
+ dump_ifdef(builtins[i]);
printf("\t[builtin_%s] = _ao_scheme_atom_",
builtins[i].c_name);
cify_lisp(builtins[i].lisp_names[0]);
printf(",\n");
+ dump_endif(builtins[i]);
}
}
printf("};\n");
printf("#undef AO_SCHEME_BUILTIN_FUNCS\n");
printf("const ao_scheme_func_t ao_scheme_builtins[] = {\n");
for (int i = 0; i < dim(builtins); i++) {
- if (!is_atom(builtins[i]))
+ if (is_func(builtins[i])) {
+ dump_ifdef(builtins[i]);
printf("\t[builtin_%s] = ao_scheme_do_%s,\n",
builtins[i].c_name,
builtins[i].c_name);
+ dump_endif(builtins[i]);
+ }
}
printf("};\n");
printf("#endif /* AO_SCHEME_BUILTIN_FUNCS */\n");
printf("#ifdef AO_SCHEME_BUILTIN_DECLS\n");
printf("#undef AO_SCHEME_BUILTIN_DECLS\n");
for (int i = 0; i < dim(builtins); i++) {
- if (!is_atom(builtins[i])) {
+ if (is_func(builtins[i])) {
+ dump_ifdef(builtins[i]);
printf("ao_poly\n");
printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n",
builtins[i].c_name);
+ dump_endif(builtins[i]);
}
}
printf("#endif /* AO_SCHEME_BUILTIN_DECLS */\n");
printf("#undef AO_SCHEME_BUILTIN_CONSTS\n");
printf("struct builtin_func funcs[] = {\n");
for (int i = 0; i < dim(builtins); i++) {
- if (!is_atom(builtins[i])) {
+ if (is_func(builtins[i])) {
+ dump_ifdef(builtins[i]);
for (int j = 0; j < dim(builtins[i].lisp_names); j++) {
- printf ("\t{ .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n",
+ printf ("\t{ .feature = \"%s\", .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n",
+ builtins[i].feature,
builtins[i].lisp_names[j],
builtins[i].type,
builtins[i].c_name);
}
+ dump_endif(builtins[i]);
}
}
printf("};\n");
printf("#ifdef AO_SCHEME_BUILTIN_ATOMS\n");
printf("#undef AO_SCHEME_BUILTIN_ATOMS\n");
for (int i = 0; i < dim(builtins); i++) {
- for (int j = 0; j < dim(builtins[i].lisp_names); j++) {
- printf("#define _ao_scheme_atom_");
- cify_lisp(builtins[i].lisp_names[j]);
- printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]);
+ if (!is_feature(builtins[i])) {
+ for (int j = 0; j < dim(builtins[i].lisp_names); j++) {
+ printf("#define _ao_scheme_atom_");
+ cify_lisp(builtins[i].lisp_names[j]);
+ printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]);
+ }
}
}
printf("#endif /* AO_SCHEME_BUILTIN_ATOMS */\n");
}
+void
+dump_atom_names(builtin_t[*] builtins) {
+ printf("#ifdef AO_SCHEME_BUILTIN_ATOM_NAMES\n");
+ printf("#undef AO_SCHEME_BUILTIN_ATOM_NAMES\n");
+ printf("static struct builtin_atom atoms[] = {\n");
+ for (int i = 0; i < dim(builtins); i++) {
+ if (is_atom(builtins[i])) {
+ for (int j = 0; j < dim(builtins[i].lisp_names); j++) {
+ printf("\t{ .feature = \"%s\", .name = \"%s\" },\n",
+ builtins[i].feature,
+ builtins[i].lisp_names[j]);
+ }
+ }
+ }
+ printf("};\n");
+ printf("#endif /* AO_SCHEME_BUILTIN_ATOM_NAMES */\n");
+}
+
+bool
+has_feature(string[*] features, string feature)
+{
+ for (int i = 0; i < dim(features); i++)
+ if (features[i] == feature)
+ return true;
+ return false;
+}
+
+void
+dump_features(builtin_t[*] builtins) {
+ string[...] features = {};
+ printf("#ifdef AO_SCHEME_BUILTIN_FEATURES\n");
+ for (int i = 0; i < dim(builtins); i++) {
+ if (builtins[i].feature != "all") {
+ string feature = builtins[i].feature;
+ if (!has_feature(features, feature)) {
+ features[dim(features)] = feature;
+ printf("#define AO_SCHEME_FEATURE_%s\n", feature);
+ }
+ }
+ }
+ printf("#endif /* AO_SCHEME_BUILTIN_FEATURES */\n");
+}
+
void main() {
if (dim(argv) < 2) {
File::fprintf(stderr, "usage: %s <file>\n", argv[0]);
}
twixt(file f = File::open(argv[1], "r"); File::close(f)) {
builtin_t[*] builtins = read_builtins(f);
+
+ printf("/* %d builtins */\n", dim(builtins));
dump_ids(builtins);
dump_casename(builtins);
dump_arrayname(builtins);
dump_decls(builtins);
dump_consts(builtins);
dump_atoms(builtins);
+ dump_atom_names(builtins);
+ dump_features(builtins);
}
}
#include <ctype.h>
#include <unistd.h>
#include <getopt.h>
+#include <stdbool.h>
static struct ao_scheme_builtin *
ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) {
}
struct builtin_func {
+ char *feature;
char *name;
int args;
enum ao_scheme_builtin_id func;
};
+struct builtin_atom {
+ char *feature;
+ char *name;
+};
+
#define AO_SCHEME_BUILTIN_CONSTS
+#define AO_SCHEME_BUILTIN_ATOM_NAMES
+
#include "ao_scheme_builtin.h"
-#define N_FUNC (sizeof funcs / sizeof funcs[0])
+#define N_FUNC (sizeof funcs / sizeof funcs[0])
+
+#define N_ATOM (sizeof atoms / sizeof atoms[0])
struct ao_scheme_frame *globals;
return p;
}
+static struct ao_scheme_builtin *
+ao_scheme_get_builtin(ao_poly p)
+{
+ if (ao_scheme_poly_type(p) == AO_SCHEME_BUILTIN)
+ return ao_scheme_poly_builtin(p);
+ return NULL;
+}
+
+struct seen_builtin {
+ struct seen_builtin *next;
+ struct ao_scheme_builtin *builtin;
+};
+
+static struct seen_builtin *seen_builtins;
+
+static int
+ao_scheme_seen_builtin(struct ao_scheme_builtin *b)
+{
+ struct seen_builtin *s;
+
+ for (s = seen_builtins; s; s = s->next)
+ if (s->builtin == b)
+ return 1;
+ s = malloc (sizeof (struct seen_builtin));
+ s->builtin = b;
+ s->next = seen_builtins;
+ seen_builtins = s;
+ return 0;
+}
+
int
ao_scheme_read_eval_abort(void)
{
static FILE *in;
static FILE *out;
+struct feature {
+ struct feature *next;
+ char name[];
+};
+
+static struct feature *enable;
+static struct feature *disable;
+
+void
+ao_scheme_add_feature(struct feature **list, char *name)
+{
+ struct feature *feature = malloc (sizeof (struct feature) + strlen(name) + 1);
+ strcpy(feature->name, name);
+ feature->next = *list;
+ *list = feature;
+}
+
+bool
+ao_scheme_has_feature(struct feature *list, char *name)
+{
+ while (list) {
+ if (!strcmp(list->name, name))
+ return true;
+ list = list->next;
+ }
+ return false;
+}
+
+void
+ao_scheme_add_features(struct feature **list, char *names)
+{
+ char *saveptr = NULL;
+ char *name;
+
+ while ((name = strtok_r(names, ",", &saveptr)) != NULL) {
+ names = NULL;
+ if (!ao_scheme_has_feature(*list, name))
+ ao_scheme_add_feature(list, name);
+ }
+}
+
int
ao_scheme_getc(void)
{
static const struct option options[] = {
{ .name = "out", .has_arg = 1, .val = 'o' },
+ { .name = "disable", .has_arg = 1, .val = 'd' },
+ { .name = "enable", .has_arg = 1, .val = 'e' },
{ 0, 0, 0, 0 }
};
static void usage(char *program)
{
- fprintf(stderr, "usage: %s [--out=<output>] [input]\n", program);
+ fprintf(stderr, "usage: %s [--out=<output>] [--disable={feature,...}] [--enable={feature,...} [input]\n", program);
exit(1);
}
int
main(int argc, char **argv)
{
- int f, o;
+ int f, o, an;
ao_poly val;
struct ao_scheme_atom *a;
struct ao_scheme_builtin *b;
char *out_name = NULL;
int c;
enum ao_scheme_builtin_id prev_func;
+ enum ao_scheme_builtin_id target_func;
+ enum ao_scheme_builtin_id func_map[_builtin_last];
in = stdin;
out = stdout;
- while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) {
+ while ((c = getopt_long(argc, argv, "o:d:e:", options, NULL)) != -1) {
switch (c) {
case 'o':
out_name = optarg;
break;
+ case 'd':
+ ao_scheme_add_features(&disable, optarg);
+ break;
+ case 'e':
+ ao_scheme_add_features(&enable, optarg);
+ break;
default:
usage(argv[0]);
break;
ao_scheme_bool_get(1);
prev_func = _builtin_last;
+ target_func = 0;
for (f = 0; f < (int) N_FUNC; f++) {
- if (funcs[f].func != prev_func)
- b = ao_scheme_make_builtin(funcs[f].func, funcs[f].args);
- a = ao_scheme_atom_intern(funcs[f].name);
- ao_scheme_atom_def(ao_scheme_atom_poly(a),
- ao_scheme_builtin_poly(b));
+ if (ao_scheme_has_feature(enable, funcs[f].feature) || !ao_scheme_has_feature(disable, funcs[f].feature)) {
+ if (funcs[f].func != prev_func) {
+ prev_func = funcs[f].func;
+ b = ao_scheme_make_builtin(prev_func, funcs[f].args);
+
+ /* Target may have only a subset of
+ * the enum values; record what those
+ * values will be here. This obviously
+ * depends on the functions in the
+ * array being in the same order as
+ * the enumeration; which
+ * ao_scheme_make_builtin ensures.
+ */
+ func_map[prev_func] = target_func++;
+ }
+ a = ao_scheme_atom_intern(funcs[f].name);
+ ao_scheme_atom_def(ao_scheme_atom_poly(a),
+ ao_scheme_builtin_poly(b));
+ }
}
- /* end of file value */
- a = ao_scheme_atom_intern("eof");
- ao_scheme_atom_def(ao_scheme_atom_poly(a),
- ao_scheme_atom_poly(a));
-
- /* 'else' */
- a = ao_scheme_atom_intern("else");
+ /* atoms */
+ for (an = 0; an < (int) N_ATOM; an++) {
+ if (ao_scheme_has_feature(enable, atoms[an].feature) || !ao_scheme_has_feature(disable, atoms[an].feature))
+ a = ao_scheme_atom_intern((char *) atoms[an].name);
+ }
if (argv[optind]){
in = fopen(argv[optind], "r");
for (f = 0; f < ao_scheme_frame_global->num; f++) {
struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(ao_scheme_frame_global->vals);
+
val = ao_has_macro(vals->vals[f].val);
if (val != AO_SCHEME_NIL) {
printf("error: function %s contains unresolved macro: ",
printf("\n");
exit(1);
}
+
+ /* Remap builtin enum values to match target set */
+ b = ao_scheme_get_builtin(vals->vals[f].val);
+ if (b != NULL) {
+ if (!ao_scheme_seen_builtin(b))
+ b->func = func_map[b->func];
+ }
}
if (out_name) {
[AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type,
[AO_SCHEME_STACK] = &ao_scheme_stack_type,
[AO_SCHEME_BOOL] = &ao_scheme_bool_type,
+#ifdef AO_SCHEME_FEATURE_BIGINT
[AO_SCHEME_BIGINT] = &ao_scheme_bigint_type,
+#endif
+#ifdef AO_SCHEME_FEATURE_FLOAT
[AO_SCHEME_FLOAT] = &ao_scheme_float_type,
+#endif
+#ifdef AO_SCHEME_FEATURE_VECTOR
[AO_SCHEME_VECTOR] = &ao_scheme_vector_type,
+#endif
};
static int
.write = ao_scheme_bool_write,
.display = ao_scheme_bool_write,
},
+#ifdef AO_SCHEME_FEATURE_BIGINT
[AO_SCHEME_BIGINT] = {
.write = ao_scheme_bigint_write,
.display = ao_scheme_bigint_write,
},
+#endif
+#ifdef AO_SCHEME_FEATURE_FLOAT
[AO_SCHEME_FLOAT] = {
.write = ao_scheme_float_write,
.display = ao_scheme_float_write,
},
+#endif
+#ifdef AO_SCHEME_FEATURE_VECTOR
[AO_SCHEME_VECTOR] = {
.write = ao_scheme_vector_write,
.display = ao_scheme_vector_display
},
+#endif
+};
+
+static void ao_scheme_invalid_write(ao_poly p) {
+ printf("??? 0x%04x ???", p);
+}
+
+static const struct ao_scheme_funcs ao_scheme_invalid_funcs = {
+ .write = ao_scheme_invalid_write,
+ .display = ao_scheme_invalid_write,
};
static const struct ao_scheme_funcs *
if (type < AO_SCHEME_NUM_TYPE)
return &ao_scheme_funcs[type];
- return NULL;
+ return &ao_scheme_invalid_funcs;
}
-void
-ao_scheme_poly_write(ao_poly p)
+void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p)
{
- const struct ao_scheme_funcs *f = funcs(p);
-
- if (f && f->write)
- f->write(p);
+ return funcs(p)->write;
}
-void
-ao_scheme_poly_display(ao_poly p)
+void (*ao_scheme_poly_display_func(ao_poly p))(ao_poly p)
{
- const struct ao_scheme_funcs *f = funcs(p);
-
- if (f && f->display)
- f->display(p);
+ return funcs(p)->display;
}
void *
PRINTABLE|SPECIAL, /* ) */
PRINTABLE, /* * */
PRINTABLE|SIGN, /* + */
- PRINTABLE|SPECIAL, /* , */
+ PRINTABLE|SPECIAL_QUASI, /* , */
PRINTABLE|SIGN, /* - */
PRINTABLE|DOTC|FLOATC, /* . */
PRINTABLE, /* / */
PRINTABLE, /* ] */
PRINTABLE, /* ^ */
PRINTABLE, /* _ */
- PRINTABLE|SPECIAL, /* ` */
+ PRINTABLE|SPECIAL_QUASI, /* ` */
PRINTABLE, /* a */
PRINTABLE, /* b */
PRINTABLE, /* c */
}
}
+#ifndef AO_SCHEME_TOKEN_MAX
#define AO_SCHEME_TOKEN_MAX 128
+#endif
static char token_string[AO_SCHEME_TOKEN_MAX];
static int32_t token_int;
static int token_len;
-static float token_float;
static inline void add_token(int c) {
if (c && token_len < AO_SCHEME_TOKEN_MAX - 1)
token_string[token_len] = '\0';
}
+#ifdef AO_SCHEME_FEATURE_FLOAT
+static float token_float;
+
struct namedfloat {
const char *name;
float value;
};
#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0])
+#endif
static int
_lex(void)
return QUOTE;
case '.':
return DOT;
+#ifdef AO_SCHEME_FEATURE_QUASI
case '`':
return QUASIQUOTE;
case ',':
lex_unget(c);
return UNQUOTE;
}
+#endif
}
}
if (lex_class & POUND) {
add_token(c);
end_token();
return BOOL;
+#ifdef AO_SCHEME_FEATURE_VECTOR
case '(':
return OPEN_VECTOR;
+#endif
case '\\':
for (;;) {
int alphabetic;
}
}
if (lex_class & PRINTABLE) {
- int isfloat;
- int hasdigit;
- int isneg;
- int isint;
- int epos;
-
- isfloat = 1;
- isint = 1;
- hasdigit = 0;
+#ifdef AO_SCHEME_FEATURE_FLOAT
+ int isfloat = 1;
+ int epos = 0;
+#endif
+ int hasdigit = 0;
+ int isneg = 0;
+ int isint = 1;
+
token_int = 0;
- isneg = 0;
- epos = 0;
for (;;) {
if (!(lex_class & NUMBER)) {
isint = 0;
+#ifdef AO_SCHEME_FEATURE_FLOAT
isfloat = 0;
+#endif
} else {
+#ifdef AO_SCHEME_FEATURE_FLOAT
if (!(lex_class & INTEGER))
isint = 0;
if (token_len != epos &&
isint = 0;
isfloat = 0;
}
+#endif
if (c == '-')
isneg = 1;
+#ifdef AO_SCHEME_FEATURE_FLOAT
if (c == '.' && epos != 0)
isfloat = 0;
if (c == 'e' || c == 'E') {
else
epos = token_len + 1;
}
+#endif
if (lex_class & DIGIT) {
hasdigit = 1;
if (isint)
}
add_token (c);
c = lexc ();
- if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) {
+ if ((lex_class & (NOTNAME))
+#ifdef AO_SCHEME_FEATURE_FLOAT
+ && (c != '.' || !isfloat)
+#endif
+ ) {
+#ifdef AO_SCHEME_FEATURE_FLOAT
unsigned int u;
+#endif
// if (lex_class & ENDOFFILE)
// clearerr (f);
lex_unget(c);
token_int = -token_int;
return NUM;
}
+#ifdef AO_SCHEME_FEATURE_FLOAT
if (isfloat && hasdigit) {
token_float = strtof(token_string, NULL);
return FLOAT;
token_float = namedfloats[u].value;
return FLOAT;
}
+#endif
return NAME;
}
}
return read_state;
}
+#ifdef AO_SCHEME_FEATURE_VECTOR
+#define is_open(t) ((t) == OPEN || (t) == OPEN_VECTOR)
+#else
+#define is_open(t) ((t) == OPEN)
+#endif
+
ao_poly
ao_scheme_read(void)
{
ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0;
for (;;) {
parse_token = lex();
- while (parse_token == OPEN || parse_token == OPEN_VECTOR) {
+ while (is_open(parse_token)) {
+#ifdef AO_SCHEME_FEATURE_VECTOR
if (parse_token == OPEN_VECTOR)
read_state |= READ_SAW_VECTOR;
+#endif
if (!push_read_stack(read_state))
return AO_SCHEME_NIL;
ao_scheme_read_list++;
case NUM:
v = ao_scheme_integer_poly(token_int);
break;
+#ifdef AO_SCHEME_FEATURE_FLOAT
case FLOAT:
v = ao_scheme_float_get(token_float);
break;
+#endif
case BOOL:
if (token_string[0] == 't')
v = _ao_scheme_bool_true;
v = AO_SCHEME_NIL;
break;
case QUOTE:
+#ifdef AO_SCHEME_FEATURE_QUASI
case QUASIQUOTE:
case UNQUOTE:
case UNQUOTE_SPLICING:
+#endif
if (!push_read_stack(read_state))
return AO_SCHEME_NIL;
ao_scheme_read_list++;
case QUOTE:
v = _ao_scheme_atom_quote;
break;
+#ifdef AO_SCHEME_FEATURE_QUASI
case QUASIQUOTE:
v = _ao_scheme_atom_quasiquote;
break;
case UNQUOTE_SPLICING:
v = _ao_scheme_atom_unquote2dsplicing;
break;
+#endif
}
break;
case CLOSE:
v = ao_scheme_cons_poly(ao_scheme_read_cons);
--ao_scheme_read_list;
read_state = pop_read_stack();
+#ifdef AO_SCHEME_FEATURE_VECTOR
if (read_state & READ_SAW_VECTOR)
v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v)));
+#endif
break;
case DOT:
if (!ao_scheme_read_list) {
# define OPEN 2
# define CLOSE 3
# define QUOTE 4
+#ifdef AO_SCHEME_FEATURE_QUASI
# define QUASIQUOTE 5
# define UNQUOTE 6
# define UNQUOTE_SPLICING 7
+#endif
# define STRING 8
# define NUM 9
+#ifdef AO_SCHEME_FEATURE_FLOAT
# define FLOAT 10
+#endif
# define DOT 11
# define BOOL 12
+#ifdef AO_SCHEME_FEATURE_VECTOR
# define OPEN_VECTOR 13
+#endif
/*
* character classes
# define PRINTABLE 0x0001 /* \t \n ' ' - ~ */
# define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */
+#ifdef AO_SCHEME_FEATURE_QUASI
+# define SPECIAL_QUASI SPECIAL
+#else
+# define SPECIAL_QUASI 0
+#endif
# define DOTC 0x0004 /* . */
# define WHITE 0x0008 /* ' ' \t \n */
# define DIGIT 0x0010 /* [0-9] */
# define SIGN 0x0020 /* +- */
+#ifdef AO_SCHEME_FEATURE_FLOAT
# define FLOATC 0x0040 /* . e E */
+#else
+# define FLOATC 0
+#endif
# define ENDOFFILE 0x0080 /* end of file */
# define COMMENT 0x0100 /* ; */
# define IGNORE 0x0200 /* \0 - ' ' */
-ao_scheme_test
+ao-scheme
vpath %.h ..
SRCS=$(SCHEME_SRCS) ao_scheme_test.c
+HDRS=$(SCHEME_HDRS) ao_scheme_const.h
OBJS=$(SRCS:.c=.o)
CFLAGS=-O2 -g -Wall -Wextra -I. -I..
-ao_scheme_test: $(OBJS)
+ao-scheme: $(OBJS)
cc $(CFLAGS) -o $@ $(OBJS) -lm
-$(OBJS): $(SCHEME_HDRS)
+$(OBJS): $(HDRS)
+
+ao_scheme_const.h: ../make-const/ao_scheme_make_const ../ao_scheme_const.scheme
+ ../make-const/ao_scheme_make_const -o $@ ../ao_scheme_const.scheme
clean::
- rm -f $(OBJS) ao_scheme_test
+ rm -f $(OBJS) ao-scheme ao_scheme_const.h
-install: ao_scheme_test
- cp ao_scheme_test $$HOME/bin/ao-scheme
+install: ao-scheme
+ cp $^ $$HOME/bin
#define AO_SCHEME_POOL_TOTAL 32768
#define AO_SCHEME_SAVE 1
-#define DBG_MEM_STATS 1
extern int ao_scheme_getc(void);
}
ao_scheme_read_eval_print();
+#ifdef DBG_MEM_STATS
printf ("collects: full: %lu incremental %lu\n",
ao_scheme_collects[AO_SCHEME_COLLECT_FULL],
ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]);
(double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL],
(double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] /
(double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]);
+#endif
}
--- /dev/null
+ao-scheme-tiny
--- /dev/null
+include ../Makefile-inc
+
+vpath %.o .
+vpath %.c ..
+vpath %.h ..
+
+DEFS=
+
+SRCS=$(SCHEME_SRCS) ao_scheme_test.c
+HDRS=$(SCHEME_HDRS) ao_scheme_const.h
+
+OBJS=$(SRCS:.c=.o)
+
+CFLAGS=-O0 -g -Wall -Wextra -I. -I..
+
+ao-scheme-tiny: $(OBJS)
+ cc $(CFLAGS) -o $@ $(OBJS) -lm
+
+$(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
+
+clean::
+ rm -f $(OBJS) ao-scheme-tiny ao_scheme_const.h
+
+install: ao-scheme-tiny
+ cp $^ $$HOME/bin
--- /dev/null
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; version 2 of the License.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
+ */
+
+#ifndef _AO_SCHEME_OS_H_
+#define _AO_SCHEME_OS_H_
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <time.h>
+
+#undef AO_SCHEME_FEATURE_FLOAT
+#undef AO_SCHEME_FEATURE_VECTOR
+#undef AO_SCHEME_FEATURE_QUASI
+#undef AO_SCHEME_FEATURE_BIGINT
+
+#define AO_SCHEME_POOL_TOTAL 4096
+#define AO_SCHEME_SAVE 1
+
+extern int ao_scheme_getc(void);
+
+static inline void
+ao_scheme_os_flush() {
+ fflush(stdout);
+}
+
+static inline void
+ao_scheme_abort(void)
+{
+ abort();
+}
+
+static inline void
+ao_scheme_os_led(int led)
+{
+ printf("leds set to 0x%x\n", led);
+}
+
+#define AO_SCHEME_JIFFIES_PER_SECOND 100
+
+static inline void
+ao_scheme_os_delay(int jiffies)
+{
+ struct timespec ts = {
+ .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND,
+ .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)
+ };
+ nanosleep(&ts, NULL);
+}
+
+static inline int
+ao_scheme_os_jiffy(void)
+{
+ struct timespec tp;
+ clock_gettime(CLOCK_MONOTONIC, &tp);
+ return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND));
+}
+
+#endif
--- /dev/null
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ */
+
+#include "ao_scheme.h"
+#include <stdio.h>
+
+static FILE *ao_scheme_file;
+static int newline = 1;
+
+static char save_file[] = "scheme.image";
+
+int
+ao_scheme_os_save(void)
+{
+ FILE *save = fopen(save_file, "w");
+
+ if (!save) {
+ perror(save_file);
+ return 0;
+ }
+ fwrite(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, save);
+ fclose(save);
+ return 1;
+}
+
+int
+ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset)
+{
+ FILE *restore = fopen(save_file, "r");
+ size_t ret;
+
+ if (!restore) {
+ perror(save_file);
+ return 0;
+ }
+ fseek(restore, offset, SEEK_SET);
+ ret = fread(save, sizeof (struct ao_scheme_os_save), 1, restore);
+ fclose(restore);
+ if (ret != 1)
+ return 0;
+ return 1;
+}
+
+int
+ao_scheme_os_restore(void)
+{
+ FILE *restore = fopen(save_file, "r");
+ size_t ret;
+
+ if (!restore) {
+ perror(save_file);
+ return 0;
+ }
+ ret = fread(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, restore);
+ fclose(restore);
+ if (ret != AO_SCHEME_POOL_TOTAL)
+ return 0;
+ return 1;
+}
+
+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) {
+ perror(*argv);
+ exit(1);
+ }
+ ao_scheme_read_eval_print();
+ fclose(ao_scheme_file);
+ ao_scheme_file = NULL;
+ }
+ ao_scheme_read_eval_print();
+
+#ifdef DBG_MEM_STATS
+ printf ("collects: full: %lu incremental %lu\n",
+ ao_scheme_collects[AO_SCHEME_COLLECT_FULL],
+ ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]);
+
+ printf ("freed: full %lu incremental %lu\n",
+ ao_scheme_freed[AO_SCHEME_COLLECT_FULL],
+ ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]);
+
+ printf("loops: full %lu incremental %lu\n",
+ ao_scheme_loops[AO_SCHEME_COLLECT_FULL],
+ ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]);
+
+ printf("loops per collect: full %f incremental %f\n",
+ (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL] /
+ (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL],
+ (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL] /
+ (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]);
+
+ printf("freed per collect: full %f incremental %f\n",
+ (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] /
+ (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL],
+ (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] /
+ (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]);
+
+ printf("freed per loop: full %f incremental %f\n",
+ (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] /
+ (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL],
+ (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] /
+ (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]);
+#endif
+}
--- /dev/null
+;
+; Copyright © 2016 Keith Packard <keithp@keithp.com>
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation, either version 2 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful, but
+; WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+; General Public License for more details.
+;
+; Lisp code placed in ROM
+
+ ; return a list containing all of the arguments
+(def (quote list) (lambda l l))
+
+(def (quote def!)
+ (macro (a b)
+ (list
+ def
+ (list quote a)
+ b)
+ )
+ )
+
+(begin
+ (def! append
+ (lambda args
+ (def! a-l
+ (lambda (a b)
+ (cond ((null? a) b)
+ (else (cons (car a) (a-l (cdr a) b)))
+ )
+ )
+ )
+
+ (def! a-ls
+ (lambda (l)
+ (cond ((null? l) l)
+ ((null? (cdr l)) (car l))
+ (else (a-l (car l) (a-ls (cdr l))))
+ )
+ )
+ )
+ (a-ls args)
+ )
+ )
+ 'append)
+
+(append '(a b c) '(d e f) '(g h i))
+
+ ;
+ ; Define a variable without returning the value
+ ; Useful when defining functions to avoid
+ ; having lots of output generated.
+ ;
+ ; Also accepts the alternate
+ ; form for defining lambdas of
+ ; (define (name a y z) sexprs ...)
+ ;
+
+(begin
+ (def (quote define)
+ (macro (a . b)
+ ; check for alternate lambda definition form
+
+ (cond ((list? a)
+ (set! b
+ (cons lambda (cons (cdr a) b)))
+ (set! a (car a))
+ )
+ (else
+ (set! b (car b))
+ )
+ )
+ (cons begin
+ (cons
+ (cons def
+ (cons (cons quote (cons a '()))
+ (cons b '())
+ )
+ )
+ (cons
+ (cons quote (cons a '()))
+ '())
+ )
+ )
+ )
+ )
+ 'define
+ )
+
+ ; basic list accessors
+
+(define (caar l) (car (car l)))
+
+(define (cadr l) (car (cdr l)))
+
+(define (cdar l) (cdr (car l)))
+
+(define (caddr l) (car (cdr (cdr l))))
+
+ ; (if <condition> <if-true>)
+ ; (if <condition> <if-true> <if-false)
+
+(define if
+ (macro (test . args)
+ (cond ((null? (cdr args))
+ (list cond (list test (car args)))
+ )
+ (else
+ (list cond
+ (list test (car args))
+ (list 'else (cadr args))
+ )
+ )
+ )
+ )
+ )
+
+(if (> 3 2) 'yes)
+(if (> 3 2) 'yes 'no)
+(if (> 2 3) 'no 'yes)
+(if (> 2 3) 'no)
+
+ ; simple math operators
+
+(define zero? (macro (value) (list eqv? value 0)))
+
+(zero? 1)
+(zero? 0)
+(zero? "hello")
+
+(define positive? (macro (value) (list > value 0)))
+
+(positive? 12)
+(positive? -12)
+
+(define negative? (macro (value) (list < value 0)))
+
+(negative? 12)
+(negative? -12)
+
+(define (abs a) (if (>= a 0) a (- a)))
+
+(abs 12)
+(abs -12)
+
+(define max (lambda (a . b)
+ (while (not (null? b))
+ (cond ((< a (car b))
+ (set! a (car b)))
+ )
+ (set! b (cdr b))
+ )
+ a)
+ )
+
+(max 1 2 3)
+(max 3 2 1)
+
+(define min (lambda (a . b)
+ (while (not (null? b))
+ (cond ((> a (car b))
+ (set! a (car b)))
+ )
+ (set! b (cdr b))
+ )
+ a)
+ )
+
+(min 1 2 3)
+(min 3 2 1)
+
+(define (even? a) (zero? (% a 2)))
+
+(even? 2)
+(even? -2)
+(even? 3)
+(even? -1)
+
+(define (odd? a) (not (even? a)))
+
+(odd? 2)
+(odd? -2)
+(odd? 3)
+(odd? -1)
+
+
+(define (list-tail a b)
+ (if (zero? b)
+ a
+ (list-tail (cdr a (- b 1)))
+ )
+ )
+
+(define (list-ref a b)
+ (car (list-tail a b))
+ )
+
+(define (list-tail a b)
+ (if (zero? b)
+ a
+ (list-tail (cdr a) (- b 1))))
+
+(list-tail '(1 2 3) 2)
+
+(define (list-ref a b) (car (list-tail a b)))
+
+(list-ref '(1 2 3) 2)
+
+
+ ; define a set of local
+ ; variables one at a time and
+ ; then evaluate a list of
+ ; sexprs
+ ;
+ ; (let* (var-defines) sexprs)
+ ;
+ ; where var-defines are either
+ ;
+ ; (name value)
+ ;
+ ; or
+ ;
+ ; (name)
+ ;
+ ; e.g.
+ ;
+ ; (let* ((x 1) (y)) (set! y (+ x 1)) y)
+
+(define let*
+ (macro (a . b)
+
+ ;
+ ; make the list of names in the let
+ ;
+
+ (define (_n a)
+ (cond ((not (null? a))
+ (cons (car (car a))
+ (_n (cdr a))))
+ (else ())
+ )
+ )
+
+ ; the set of expressions is
+ ; the list of set expressions
+ ; pre-pended to the
+ ; expressions to evaluate
+
+ (define (_v a b)
+ (cond ((null? a) b) (else
+ (cons
+ (list set
+ (list quote
+ (car (car a))
+ )
+ (cond ((null? (cdr (car a))) ())
+ (else (cadr (car a))))
+ )
+ (_v (cdr a) b)
+ )
+ )
+ )
+ )
+
+ ; the parameters to the lambda is a list
+ ; of nils of the right length
+
+ (define (_z a)
+ (cond ((null? a) ())
+ (else (cons () (_z (cdr a))))
+ )
+ )
+ ; build the lambda.
+
+ (cons (cons lambda (cons (_n a) (_v a b))) (_z a))
+ )
+ )
+
+(let* ((a 1) (y a)) (+ a y))
+
+(define let let*)
+ ; recursive equality
+
+(define (equal? a b)
+ (cond ((eq? a b) #t)
+ ((pair? a)
+ (cond ((pair? b)
+ (cond ((equal? (car a) (car b))
+ (equal? (cdr a) (cdr b)))
+ )
+ )
+ )
+ )
+ )
+ )
+
+(equal? '(a b c) '(a b c))
+(equal? '(a b c) '(a b b))
+
+(define member (lambda (obj a . test?)
+ (cond ((null? a)
+ #f
+ )
+ (else
+ (if (null? test?) (set! test? equal?) (set! test? (car test?)))
+ (if (test? obj (car a))
+ a
+ (member obj (cdr a) test?))
+ )
+ )
+ )
+ )
+
+(member '(2) '((1) (2) (3)))
+
+(member '(4) '((1) (2) (3)))
+
+(define (memq obj a) (member obj a eq?))
+
+(memq 2 '(1 2 3))
+
+(memq 4 '(1 2 3))
+
+(memq '(2) '((1) (2) (3)))
+
+(define (_assoc a b t?)
+ (if (null? b)
+ #f
+ (if (t? a (caar b))
+ (car b)
+ (_assoc a (cdr b) t?)
+ )
+ )
+ )
+
+(define (assq a b) (_assoc a b eq?))
+(define (assoc a b) (_assoc a b equal?))
+
+(assq 'a '((a 1) (b 2) (c 3)))
+(assoc '(c) '((a 1) (b 2) ((c) 3)))
+
+(define string (lambda a (list->string a)))
+
+(display "apply\n")
+(apply cons '(a b))
+
+(define map
+ (lambda (a . b)
+ (define (args b)
+ (cond ((null? b) ())
+ (else
+ (cons (caar b) (args (cdr b)))
+ )
+ )
+ )
+ (define (next b)
+ (cond ((null? b) ())
+ (else
+ (cons (cdr (car b)) (next (cdr b)))
+ )
+ )
+ )
+ (define (domap b)
+ (cond ((null? (car b)) ())
+ (else
+ (cons (apply a (args b)) (domap (next b)))
+ )
+ )
+ )
+ (domap b)
+ )
+ )
+
+(map cadr '((a b) (d e) (g h)))
+
+(define for-each (lambda (a . b)
+ (apply map a b)
+ #t))
+
+(for-each display '("hello" " " "world" "\n"))
+
+(define (newline) (write-char #\newline))
+
+(newline)
projects / fw / altos / commitdiff