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