altos/scheme: Move ao-scheme to a separate repository

This way it can be incorporated into multiple operating systems more easily.

Signed-off-by: Keith Packard <keithp@keithp.com>

1 files changed, 0 insertions, 543 deletions

diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c
deleted file mode 100644
index 8561bf0b..00000000
--- a/src/scheme/ao_scheme_make_const.c
+++ /dev/null
@@ -1,543 +0,0 @@
-/*
- * Copyright © 2016 Keith Packard <keithp@keithp.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation, either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
- * General Public License for more details.
- */
-
-#include "ao_scheme.h"
-#include <stdlib.h>
-#include <ctype.h>
-#include <unistd.h>
-#include <getopt.h>
-#include <stdbool.h>
-
-static struct ao_scheme_builtin *
-ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) {
-	struct ao_scheme_builtin *b = ao_scheme_alloc(sizeof (struct ao_scheme_builtin));
-
-	b->type = AO_SCHEME_BUILTIN;
-	b->func = func;
-	b->args = args;
-	return b;
-}
-
-struct builtin_func {
-	const char	*feature;
-	const char	*name;
-	int		args;
-	enum ao_scheme_builtin_id	func;
-};
-
-struct builtin_atom {
-	const char	*feature;
-	const char	*name;
-};
-
-#define AO_SCHEME_BUILTIN_CONSTS
-#define AO_SCHEME_BUILTIN_ATOM_NAMES
-
-#include "ao_scheme_builtin.h"
-
-#define N_FUNC		(sizeof funcs / sizeof funcs[0])
-
-#define N_ATOM		(sizeof atoms / sizeof atoms[0])
-
-struct ao_scheme_frame	*globals;
-
-static int
-is_atom(int offset)
-{
-	struct ao_scheme_atom *a;
-
-	for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next))
-		if (((uint8_t *) a->name - ao_scheme_const) == offset)
-			return strlen(a->name);
-	return 0;
-}
-
-#define AO_FEC_CRC_INIT	0xffff
-
-static inline uint16_t
-ao_fec_crc_byte(uint8_t byte, uint16_t crc)
-{
-	uint8_t	bit;
-
-	for (bit = 0; bit < 8; bit++) {
-		if (((crc & 0x8000) >> 8) ^ (byte & 0x80))
-			crc = (crc << 1) ^ 0x8005;
-		else
-			crc = (crc << 1);
-		byte <<= 1;
-	}
-	return crc;
-}
-
-static uint16_t
-ao_fec_crc(const uint8_t *bytes, uint8_t len)
-{
-	uint16_t	crc = AO_FEC_CRC_INIT;
-
-	while (len--)
-		crc = ao_fec_crc_byte(*bytes++, crc);
-	return crc;
-}
-
-struct ao_scheme_macro_stack {
-	struct ao_scheme_macro_stack *next;
-	ao_poly	p;
-};
-
-struct ao_scheme_macro_stack *macro_stack;
-
-static int
-ao_scheme_macro_push(ao_poly p)
-{
-	struct ao_scheme_macro_stack *m = macro_stack;
-
-	while (m) {
-		if (m->p == p)
-			return 1;
-		m = m->next;
-	}
-	m = malloc (sizeof (struct ao_scheme_macro_stack));
-	m->p = p;
-	m->next = macro_stack;
-	macro_stack = m;
-	return 0;
-}
-
-static void
-ao_scheme_macro_pop(void)
-{
-	struct ao_scheme_macro_stack *m = macro_stack;
-
-	macro_stack = m->next;
-	free(m);
-}
-
-#define DBG_MACRO 0
-#if DBG_MACRO
-static int macro_scan_depth;
-
-static void indent(void)
-{
-	int i;
-	for (i = 0; i < macro_scan_depth; i++)
-		printf("  ");
-}
-#define MACRO_DEBUG(a)	a
-#else
-#define MACRO_DEBUG(a)
-#endif
-
-ao_poly
-ao_has_macro(ao_poly p);
-
-static ao_poly
-ao_macro_test_get(ao_poly atom)
-{
-	ao_poly	*ref = ao_scheme_atom_ref(atom, NULL);
-	if (ref)
-		return *ref;
-	return AO_SCHEME_NIL;
-}
-
-static ao_poly
-ao_is_macro(ao_poly p)
-{
-	struct ao_scheme_builtin	*builtin;
-	struct ao_scheme_lambda	*lambda;
-	ao_poly ret;
-
-	MACRO_DEBUG(indent(); ao_scheme_printf ("is macro %v\n", p); ++macro_scan_depth);
-	switch (ao_scheme_poly_type(p)) {
-	case AO_SCHEME_ATOM:
-		if (ao_scheme_macro_push(p))
-			ret = AO_SCHEME_NIL;
-		else {
-			if (ao_is_macro(ao_macro_test_get(p)))
-				ret = p;
-			else
-				ret = AO_SCHEME_NIL;
-			ao_scheme_macro_pop();
-		}
-		break;
-	case AO_SCHEME_CONS:
-		ret = ao_has_macro(p);
-		break;
-	case AO_SCHEME_BUILTIN:
-		builtin = ao_scheme_poly_builtin(p);
-		if ((builtin->args & AO_SCHEME_FUNC_MASK) == AO_SCHEME_FUNC_MACRO)
-			ret = p;
-		else
-			ret = 0;
-		break;
-
-	case AO_SCHEME_LAMBDA:
-		lambda = ao_scheme_poly_lambda(p);
-		if (lambda->args == AO_SCHEME_FUNC_MACRO)
-			ret = p;
-		else
-			ret = ao_has_macro(lambda->code);
-		break;
-	default:
-		ret = AO_SCHEME_NIL;
-		break;
-	}
-	MACRO_DEBUG(--macro_scan_depth;	indent(); ao_scheme_printf ("... %v\n", ret););
-	return ret;
-}
-
-ao_poly
-ao_has_macro(ao_poly p)
-{
-	struct ao_scheme_cons	*cons;
-	struct ao_scheme_lambda	*lambda;
-	ao_poly			m;
-	ao_poly			list;
-
-	if (p == AO_SCHEME_NIL)
-		return AO_SCHEME_NIL;
-
-	MACRO_DEBUG(indent(); ao_scheme_printf("has macro %v\n", p); ++macro_scan_depth);
-	switch (ao_scheme_poly_type(p)) {
-	case AO_SCHEME_LAMBDA:
-		lambda = ao_scheme_poly_lambda(p);
-		p = ao_has_macro(ao_scheme_poly_cons(lambda->code)->cdr);
-		break;
-	case AO_SCHEME_CONS:
-		cons = ao_scheme_poly_cons(p);
-		if ((p = ao_is_macro(cons->car)))
-			break;
-
-		list = cons->cdr;
-		p = AO_SCHEME_NIL;
-		while (ao_scheme_is_pair(list)) {
-			cons = ao_scheme_poly_cons(list);
-			m = ao_has_macro(cons->car);
-			if (m) {
-				p = m;
-				break;
-			}
-			list = cons->cdr;
-		}
-		break;
-
-	default:
-		p = AO_SCHEME_NIL;
-		break;
-	}
-	MACRO_DEBUG(--macro_scan_depth;	indent(); ao_scheme_printf("... %v\n", p));
-	return p;
-}
-
-static struct ao_scheme_builtin *
-ao_scheme_get_builtin(ao_poly p)
-{
-	if (ao_scheme_poly_type(p) == AO_SCHEME_BUILTIN)
-		return ao_scheme_poly_builtin(p);
-	return NULL;
-}
-
-struct seen_builtin {
-	struct seen_builtin 		*next;
-	struct ao_scheme_builtin	*builtin;
-};
-
-static struct seen_builtin *seen_builtins;
-
-static int
-ao_scheme_seen_builtin(struct ao_scheme_builtin *b)
-{
-	struct seen_builtin	*s;
-
-	for (s = seen_builtins; s; s = s->next)
-		if (s->builtin == b)
-			return 1;
-	s = malloc (sizeof (struct seen_builtin));
-	s->builtin = b;
-	s->next = seen_builtins;
-	seen_builtins = s;
-	return 0;
-}
-
-static int
-ao_scheme_read_eval_abort(FILE *read_file)
-{
-	ao_poly	in;
-
-	for(;;) {
-		in = ao_scheme_read(read_file);
-		if (in == _ao_scheme_atom_eof)
-			break;
-		(void) ao_scheme_eval(in);
-		if (ao_scheme_exception) {
-			ao_scheme_fprintf(stderr, "make_const failed on %v\n", in);
-			return 0;
-		}
-	}
-	return 1;
-}
-
-static FILE	*in;
-static FILE	*out;
-
-struct feature {
-	struct feature	*next;
-	char		name[];
-};
-
-static struct feature *enable;
-static struct feature *disable;
-
-static void
-ao_scheme_add_feature(struct feature **list, char *name)
-{
-	struct feature *feature = malloc (sizeof (struct feature) + strlen(name) + 1);
-	strcpy(feature->name, name);
-	feature->next = *list;
-	*list = feature;
-}
-
-static bool
-_ao_scheme_has_feature(struct feature *list, const char *name, bool skip_undef)
-{
-	if (skip_undef && !strcmp(name, "UNDEF"))
-		return false;
-
-	while (list) {
-		if (!strcmp(list->name, name))
-			return true;
-		list = list->next;
-	}
-	return false;
-}
-
-static bool
-ao_scheme_has_undef(struct feature *list)
-{
-	return _ao_scheme_has_feature(list, "UNDEF", false);
-}
-
-static bool
-ao_scheme_has_feature(struct feature *list, const char *name)
-{
-	return _ao_scheme_has_feature(list, name, true);
-}
-
-static void
-ao_scheme_add_features(struct feature **list, const char *names)
-{
-	char	*saveptr = NULL;
-	char	*name;
-	char	*copy = strdup(names);
-	char	*save = copy;
-
-	while ((name = strtok_r(copy, ",", &saveptr)) != NULL) {
-		copy = NULL;
-		if (!ao_scheme_has_feature(*list, name))
-			ao_scheme_add_feature(list, name);
-	}
-	free(save);
-}
-
-int
-ao_scheme_getc(void)
-{
-	return getc(in);
-}
-
-static const struct option options[] = {
-	{ .name = "out", .has_arg = 1, .val = 'o' },
-	{ .name = "disable", .has_arg = 1, .val = 'd' },
-	{ .name = "enable", .has_arg = 1, .val = 'e' },
-	{ 0, 0, 0, 0 }
-};
-
-static void usage(char *program)
-{
-	fprintf(stderr, "usage: %s [--out=<output>] [--disable={feature,...}] [--enable={feature,...} [input]\n", program);
-	exit(1);
-}
-
-int
-main(int argc, char **argv)
-{
-	int	f, o, an;
-	ao_poly	val;
-	struct ao_scheme_atom	*a;
-	struct ao_scheme_builtin	*b;
-	struct feature			*d;
-	int	in_atom = 0;
-	char	*out_name = NULL;
-	int	c;
-	enum ao_scheme_builtin_id	prev_func;
-	enum ao_scheme_builtin_id	target_func;
-	enum ao_scheme_builtin_id	func_map[_builtin_last];
-
-	in = stdin;
-	out = stdout;
-
-	while ((c = getopt_long(argc, argv, "o:d:e:", options, NULL)) != -1) {
-		switch (c) {
-		case 'o':
-			out_name = optarg;
-			break;
-		case 'd':
-			ao_scheme_add_features(&disable, optarg);
-			break;
-		case 'e':
-			ao_scheme_add_features(&enable, optarg);
-			break;
-		default:
-			usage(argv[0]);
-			break;
-		}
-	}
-
-	ao_scheme_frame_init();
-
-	/* Boolean values #f and #t */
-	ao_scheme_bool_get(0);
-	ao_scheme_bool_get(1);
-
-	prev_func = _builtin_last;
-	target_func = 0;
-	b = NULL;
-	for (f = 0; f < (int) N_FUNC; f++) {
-		if (ao_scheme_has_feature(enable, funcs[f].feature) || !ao_scheme_has_feature(disable, funcs[f].feature)) {
-			if (funcs[f].func != prev_func) {
-				prev_func = funcs[f].func;
-				b = ao_scheme_make_builtin(prev_func, funcs[f].args);
-
-				/* Target may have only a subset of
-				 * the enum values; record what those
-				 * values will be here. This obviously
-				 * depends on the functions in the
-				 * array being in the same order as
-				 * the enumeration; which
-				 * ao_scheme_make_builtin ensures.
-				 */
-				func_map[prev_func] = target_func++;
-			}
-			a = ao_scheme_atom_intern((char *) funcs[f].name);
-			ao_scheme_atom_def(ao_scheme_atom_poly(a),
-					   ao_scheme_builtin_poly(b));
-		}
-	}
-
-	/* atoms */
-	for (an = 0; an < (int) N_ATOM; an++) {
-		if (ao_scheme_has_feature(enable, atoms[an].feature) || !ao_scheme_has_feature(disable, atoms[an].feature))
-			a = ao_scheme_atom_intern((char *) atoms[an].name);
-	}
-
-	while (argv[optind]) {
-		in = fopen(argv[optind], "r");
-		if (!in) {
-			perror(argv[optind]);
-			exit(1);
-		}
-		if (!ao_scheme_read_eval_abort(in)) {
-			fprintf(stderr, "eval failed\n");
-			exit(1);
-		}
-		fclose(in);
-		optind++;
-	}
-
-	if (!ao_scheme_has_undef(enable) && ao_scheme_has_undef(disable)) {
-		struct ao_scheme_cons cons;
-
-		cons.car = _ao_scheme_atom_undef;
-		cons.cdr = AO_SCHEME_NIL;
-		ao_scheme_do_undef(&cons);
-	}
-
-	/* Reduce to referenced values */
-	ao_scheme_collect(AO_SCHEME_COLLECT_FULL);
-
-	for (f = 0; f < ao_scheme_frame_global->num; f++) {
-		struct ao_scheme_frame_vals	*vals = ao_scheme_poly_frame_vals(ao_scheme_frame_global->vals);
-
-		val = ao_has_macro(vals->vals[f].val);
-		if (val != AO_SCHEME_NIL) {
-			fprintf(stderr, "error: function %s contains unresolved macro: ",
-				ao_scheme_poly_atom(vals->vals[f].atom)->name);
-			ao_scheme_poly_write(stderr, val, true);
-			fprintf(stderr, "\n");
-			exit(1);
-		}
-
-		/* Remap builtin enum values to match target set */
-		b = ao_scheme_get_builtin(vals->vals[f].val);
-		if (b != NULL) {
-			if (!ao_scheme_seen_builtin(b))
-				b->func = func_map[b->func];
-		}
-	}
-
-	if (out_name) {
-		out = fopen(out_name, "w");
-		if (!out) {
-			perror(out_name);
-			exit(1);
-		}
-	}
-
-	fprintf(out, "/* Generated file, do not edit */\n\n");
-
-	for (d = disable; d; d = d->next)
-		fprintf(out, "#undef AO_SCHEME_FEATURE_%s\n", d->name);
-
-	fprintf(out, "#define AO_SCHEME_POOL_CONST %d\n", ao_scheme_top);
-	fprintf(out, "extern const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4)));\n");
-	fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_scheme_atom_poly(ao_scheme_atoms));
-	fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_scheme_frame_poly(ao_scheme_frame_global));
-	fprintf(out, "#define ao_scheme_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_scheme_const, ao_scheme_top));
-
-	fprintf(out, "#define _ao_scheme_bool_false 0x%04x\n", ao_scheme_bool_poly(ao_scheme_false));
-	fprintf(out, "#define _ao_scheme_bool_true 0x%04x\n", ao_scheme_bool_poly(ao_scheme_true));
-
-	for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) {
-		const char	*n = a->name;
-		char		ch;
-		fprintf(out, "#define _ao_scheme_atom_");
-		while ((ch = *n++)) {
-			if (isalnum(ch))
-				fprintf(out, "%c", ch);
-			else
-				fprintf(out, "%02x", ch);
-		}
-		fprintf(out, "  0x%04x\n", ao_scheme_atom_poly(a));
-	}
-	fprintf(out, "#ifdef AO_SCHEME_CONST_BITS\n");
-	fprintf(out, "const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute((aligned(4))) = {");
-	for (o = 0; o < ao_scheme_top; o++) {
-		uint8_t	ch;
-		if ((o & 0xf) == 0)
-			fprintf(out, "\n\t");
-		else
-			fprintf(out, " ");
-		ch = ao_scheme_const[o];
-		if (!in_atom)
-			in_atom = is_atom(o);
-		if (in_atom) {
-			fprintf(out, " '%c',", ch);
-			in_atom--;
-		} else {
-			fprintf(out, "0x%02x,", ch);
-		}
-	}
-	fprintf(out, "\n};\n");
-	fprintf(out, "#endif /* AO_SCHEME_CONST_BITS */\n");
-	exit(0);
-}