diff --git a/GNUmakefile b/GNUmakefile index 1e9b57b5..791f8a70 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -5,10 +5,10 @@ default: all ./configure OUT:=out -#CFLAGS:=-std=c99 -O3 -finline-functions +CFLAGS:=-std=c99 -O3 -finline-functions #CFLAGS:=-std=c99 -O0 #CFLAGS:=-pg -std=c99 -O0 -CFLAGS:=-std=c99 -O0 -g +#CFLAGS:=-std=c99 -O0 -g export BOOT ifneq ($(BOOT),) @@ -24,11 +24,14 @@ all: mes mes.o: mes.c mes.o: mes.c mes.h mes.i mes.environment.i mes.symbols.i +mes.o: cache.c cache.h cache.i cache.environment.i mes.o: define.c define.h define.i define.environment.i +mes.o: display.c display.h display.i display.environment.i mes.o: lib.c lib.h lib.i lib.environment.i mes.o: math.c math.h math.i math.environment.i mes.o: posix.c posix.h posix.i posix.environment.i mes.o: quasiquote.c quasiquote.h quasiquote.i quasiquote.environment.i +mes.o: reader.c reader.h reader.i reader.environment.i mes.o: string.c string.h string.i string.environment.i mes.o: type.c type.h type.i type.environment.i diff --git a/cache.c b/cache.c new file mode 100644 index 00000000..58e03f18 --- /dev/null +++ b/cache.c @@ -0,0 +1,103 @@ +/* -*-comment-start: "//";comment-end:""-*- + * Mes --- Maxwell Equations of Software + * Copyright © 2016 Jan Nieuwenhuizen + * + * This file is part of Mes. + * + * Mes 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 3 of the License, or (at + * your option) any later version. + * + * Mes 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 Mes. If not, see . + */ + +#define CACHE_SIZE 30 +#define ENV_HEAD 15 + +#if! ENV_CACHE +SCM cache_invalidate (SCM x){} +SCM cache_invalidate_range (SCM p,SCM a){} +SCM cache_save (SCM p){} +SCM cache_lookup (SCM x){} +#else // ENV_CACHE + +SCM env_cache_cars[CACHE_SIZE]; +SCM env_cache_cdrs[CACHE_SIZE]; +int cache_threshold = 0; +SCM +cache_save (SCM p) +{ + int n = g_cells[car (p)].hits; + if (n < cache_threshold) return cell_unspecified; + int j = -1; + for (int i=0; i < CACHE_SIZE; i++) { + if (!env_cache_cars[i]) { + j = i; + break; + } + if (env_cache_cars[i] == car (p)) return cell_unspecified; + if (n > g_cells[env_cache_cars[i]].hits) { + n = g_cells[env_cache_cars[i]].hits; + j = i; + } + } + if (j >= 0) { + cache_threshold = g_cells[car (p)].hits; + env_cache_cars[j] = car (p); + env_cache_cdrs[j] = cdr (p); + } + return cell_unspecified; +} + +SCM +cache_lookup (SCM x) +{ + for (int i=0; i < CACHE_SIZE; i++) { + if (!env_cache_cars[i]) break; + if (env_cache_cars[i] == x) return env_cache_cdrs[i]; + } + return cell_undefined; +} + +SCM +cache_invalidate (SCM x) +{ + for (int i=0; i < CACHE_SIZE; i++) { + if (env_cache_cars[i] == x) { + env_cache_cars[i] = 0; + break; + } + } + return cell_unspecified; +} + +SCM +cache_invalidate_range (SCM p, SCM a) +{ + do { + cache_invalidate (caar (p)); + p = cdr (p); + } while (p != a); + return cell_unspecified; +} + +SCM +assq_ref_cache (SCM x, SCM a) ///((internal)) +{ + g_cells[x].hits++; + SCM c = cache_lookup (x); + if (c != cell_undefined) return c; + int i = 0; + while (a != cell_nil && x != CAAR (a)) {i++;a = cdr (a);} + if (a == cell_nil) return cell_undefined; + if (i>ENV_HEAD) cache_save (car (a)); + return cdar (a); +} +#endif // ENV_CACHE diff --git a/display.c b/display.c new file mode 100644 index 00000000..4c856721 --- /dev/null +++ b/display.c @@ -0,0 +1,144 @@ +/* -*-comment-start: "//";comment-end:""-*- + * Mes --- Maxwell Equations of Software + * Copyright © 2016 Jan Nieuwenhuizen + * + * This file is part of Mes. + * + * Mes 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 3 of the License, or (at + * your option) any later version. + * + * Mes 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 Mes. If not, see . + */ + +SCM display_helper (FILE*, SCM , bool, char const*, bool); + +SCM +display (SCM x) ///((arity . n)) +{ + SCM e = car (x); + SCM p = cdr (x); + int fd = 1; + if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = HITS (car (p)); + FILE *f = fd == 1 ? stdout : stderr; + return display_helper (f, e, false, "", false); +} + +SCM +newline (SCM p) ///((arity . n)) +{ + int fd = 1; + if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = VALUE (car (p)); + FILE *f = fd == 1 ? stdout : stderr; + fputs ("\n", f); + return cell_unspecified; +} + +SCM +display_ (FILE* f, SCM x) +{ + return display_helper (f, x, false, "", false); +} + +SCM +display_helper (FILE* f, SCM x, bool cont, char const *sep, bool quote) +{ + SCM r; + fprintf (f, "%s", sep); + switch (TYPE (x)) + { + case CHAR: + { + char const *name = 0; + if (VALUE (x) == char_nul.value) name = char_nul.name; + else if (VALUE (x) == char_backspace.value) name = char_backspace.name; + else if (VALUE (x) == char_tab.value) name = char_tab.name; + else if (VALUE (x) == char_newline.value) name = char_newline.name; + else if (VALUE (x) == char_vt.value) name = char_vt.name; + else if (VALUE (x) == char_page.value) name = char_page.name; + else if (VALUE (x) == char_return.value) name = char_return.name; + else if (VALUE (x) == char_space.value) name = char_space.name; + if (name) fprintf (f, "#\\%s", name); + else fprintf (f, "#\\%c", VALUE (x)); + break; + } + case MACRO: + fprintf (f, "(*macro* "); + display_helper (f, g_cells[x].macro, cont, sep, quote); + fprintf (f, ")"); + break; + case NUMBER: fprintf (f, "%d", VALUE (x)); break; + case PAIR: + { + if (car (x) == cell_circular) { + fprintf (f, "(*circ* . #-1#)"); + return cell_unspecified; + } + if (car (x) == cell_closure) { + fprintf (f, "(*closure* . #-1#)"); + return cell_unspecified; + } + if (car (x) == cell_symbol_quote) { + fprintf (f, "'"); + return display_helper (f, car (cdr (x)), cont, "", true); + } + if (!cont) fprintf (f, "("); + display_ (f, car (x)); + if (cdr (x) && TYPE (cdr (x)) == PAIR) + display_helper (f, cdr (x), true, " ", false); + else if (cdr (x) != cell_nil) { + fprintf (f, " . "); + display_ (f, cdr (x)); + } + if (!cont) fprintf (f, ")"); + break; + } + case VECTOR: + { + fprintf (f, "#("); + for (int i = 0; i < LENGTH (x); i++) { + if (TYPE (VECTOR (x)+i) == VECTOR + || (TYPE (VECTOR (x)+i) == REF + && TYPE (REF (VECTOR (x)+i)) == VECTOR)) + fprintf (f, "%s#(...)", i ? " " : ""); + else + display_helper (f,VECTOR (x)+i, false, i ? " " : "", false); + } + fprintf (f, ")"); + break; + } + case REF: display_helper (f, g_cells[x].ref, cont, "", true); break; + case FUNCTION: + { + fprintf (f, "#= g_free.value || TYPE (p) != PAIR) + fprintf (f, "%s", NAME (x)); + else + display_ (f, STRING (x)); + fprintf (f, ">"); + break; + } + case BROKEN_HEART: fprintf (f, "<3"); break; + default: + if (STRING (x)) + { + SCM p = STRING (x); + assert (p); + while (p != cell_nil) { + assert (TYPE (car (p)) == CHAR); + fputc (VALUE (car (p)), f); + p = cdr (p); + } + } + else if (TYPE (x) != PAIR && NAME (x)) fprintf (f, "%s", NAME (x)); + } + return cell_unspecified; +} diff --git a/mes.c b/mes.c index f8d83485..cfb2925b 100644 --- a/mes.c +++ b/mes.c @@ -29,21 +29,12 @@ #define DEBUG 0 #define QUASIQUOTE 1 -//#define QUASISYNTAX 0 +#define QUASISYNTAX 0 +#define ENV_CACHE 1 -#define GC 1 -#define MES_FULL 1 -#define MES_MINI 0 // 1 for gc-2a.test, gc-3.test - -#if MES_FULL int ARENA_SIZE = 200000000; int GC_SAFETY = 10000; int GC_FREE = 20000; -#else -int ARENA_SIZE = 15000; -int GC_SAFETY = 1000; -int GC_FREE = 100; -#endif typedef long SCM; enum type_t {CHAR, FUNCTION, MACRO, NUMBER, PAIR, SPECIAL, STRING, SYMBOL, REF, VALUES, VECTOR, BROKEN_HEART}; @@ -86,18 +77,18 @@ function functions[200]; int g_function = 0; #include "mes.symbols.h" +#include "cache.h" #include "define.h" +#include "display.h" #include "lib.h" #include "math.h" #include "mes.h" #include "posix.h" #include "quasiquote.h" +#include "reader.h" #include "string.h" #include "type.h" -SCM display_ (FILE* f, SCM x); -SCM display_helper (FILE*, SCM , bool, char const*, bool); - SCM symbols = 0; SCM stack = 0; SCM r0 = 0; // a/env @@ -105,6 +96,12 @@ SCM r1 = 0; // param 1 SCM r2 = 0; // param 2 SCM r3 = 0; // param 3 +SCM tmp; +SCM tmp_num; +SCM tmp_num2; +SCM tmp_num3; +SCM tmp_num4; + scm scm_nil = {SPECIAL, "()"}; scm scm_f = {SPECIAL, "#f"}; scm scm_t = {SPECIAL, "#t"}; @@ -182,22 +179,11 @@ scm *g_news = 0; #define CDADAR(x) CAR (CDR (CAR (CDR (x)))) #define CADR(x) CAR (CDR (x)) -SCM -car (SCM x) -{ - assert (TYPE (x) == PAIR); - return CAR (x); -} +SCM display_ (FILE* f, SCM x); +SCM vm_call (function0_t f, SCM p1, SCM p2, SCM a); SCM -cdr (SCM x) -{ - assert (TYPE (x) == PAIR); - return CDR (x); -} - -SCM -gc_alloc (int n) +alloc (int n) { assert (g_free.value + n < ARENA_SIZE); SCM x = g_free.value; @@ -205,134 +191,10 @@ gc_alloc (int n) return x; } -SCM g_start; -scm * -gc_news () -{ - g_news = (scm *)malloc (ARENA_SIZE*sizeof(scm)); - g_news[0].type = VECTOR; - g_news[0].length = 1000; - g_news[0].vector = 0; - g_news++; - g_news[0].type = CHAR; - g_news[0].value = 'n'; - return g_news; -} - -SCM -gc () -{ - fprintf (stderr, "***gc[%d]...", g_free.value); - g_free.value = 1; - if (!g_news) - gc_news (); - for (int i=g_free.value; i jam[%d]\n", g_free.value); - return stack; -} - -SCM -gc_show () -{ - fprintf (stderr, "cells: "); - scm *t = g_cells; - display_ (stderr, -1); - fprintf (stderr, "\n"); - if (g_news) - { - fprintf (stderr, "news: "); - g_cells = g_news; - display_ (stderr, -1); - fprintf (stderr, "\n"); - } - g_cells = t; - return cell_unspecified; -} - -SCM tmp; -SCM tmp_num; -SCM tmp_num2; -SCM tmp_num3; -SCM tmp_num4; - SCM make_cell (SCM type, SCM car, SCM cdr) { - SCM x = gc_alloc (1); + SCM x = alloc (1); assert (TYPE (type) == NUMBER); TYPE (x) = VALUE (type); if (VALUE (type) == CHAR || VALUE (type) == NUMBER) { @@ -355,6 +217,20 @@ cons (SCM x, SCM y) return make_cell (tmp_num, x, y); } +SCM +car (SCM x) +{ + assert (TYPE (x) == PAIR); + return CAR (x); +} + +SCM +cdr (SCM x) +{ + assert (TYPE (x) == PAIR); + return CDR (x); +} + SCM eq_p (SCM x, SCM y) { @@ -432,11 +308,7 @@ assq (SCM x, SCM a) return a != cell_nil ? car (a) : cell_f; } -#define ENV_CACHE 1 -#define CACHE_SIZE 30 -#define ENV_HEAD 15 - -#if !ENV_CACHE +#if! ENV_CACHE SCM assq_ref_cache (SCM x, SCM a) { @@ -444,86 +316,7 @@ assq_ref_cache (SCM x, SCM a) if (x == cell_f) return cell_undefined; return cdr (x); } -SCM cache_invalidate (SCM x){} -SCM cache_invalidate_range (SCM p,SCM a){} -SCM cache_save (SCM p){} -SCM cache_lookup (SCM x){} - -#else // ENV_CACHE - -SCM env_cache_cars[CACHE_SIZE]; -SCM env_cache_cdrs[CACHE_SIZE]; -int cache_threshold = 0; -SCM -cache_save (SCM p) -{ - int n = g_cells[car (p)].hits; - if (n < cache_threshold) return cell_unspecified; - int j = -1; - for (int i=0; i < CACHE_SIZE; i++) { - if (!env_cache_cars[i]) { - j = i; - break; - } - if (env_cache_cars[i] == car (p)) return cell_unspecified; - if (n > g_cells[env_cache_cars[i]].hits) { - n = g_cells[env_cache_cars[i]].hits; - j = i; - } - } - if (j >= 0) { - cache_threshold = g_cells[car (p)].hits; - env_cache_cars[j] = car (p); - env_cache_cdrs[j] = cdr (p); - } - return cell_unspecified; -} - -SCM -cache_lookup (SCM x) -{ - for (int i=0; i < CACHE_SIZE; i++) { - if (!env_cache_cars[i]) break; - if (env_cache_cars[i] == x) return env_cache_cdrs[i]; - } - return cell_undefined; -} - -SCM -cache_invalidate (SCM x) -{ - for (int i=0; i < CACHE_SIZE; i++) { - if (env_cache_cars[i] == x) { - env_cache_cars[i] = 0; - break; - } - } - return cell_unspecified; -} - -SCM -cache_invalidate_range (SCM p, SCM a) -{ - do { - cache_invalidate (caar (p)); - p = cdr (p); - } while (p != a); - return cell_unspecified; -} - -SCM -assq_ref_cache (SCM x, SCM a) -{ - g_cells[x].hits++; - SCM c = cache_lookup (x); - if (c != cell_undefined) return c; - int i = 0; - while (a != cell_nil && x != CAAR (a)) {i++;a = cdr (a);} - if (a == cell_nil) return cell_undefined; - if (i>ENV_HEAD) cache_save (car (a)); - return cdar (a); -} -#endif // ENV_CACHE +#endif // !ENV_CACHE SCM assert_defined (SCM x, SCM e) @@ -538,99 +331,6 @@ assert_defined (SCM x, SCM e) return e; } -SCM -gc_frame (SCM stack) -{ - SCM frame = car (stack); - r1 = car (frame); - r2 = cadr (frame); - r3 = caddr (frame); - r0 = cadddr (frame); - return frame; -} - -SCM -gc_stack (SCM a) -{ - SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil)))); - stack = cons (frame, stack); - stack = gc (stack); - gc_frame (stack); - stack = cdr (stack); - return stack; -} - -SCM -vm_call (function0_t f, SCM p1, SCM p2, SCM a) -{ - SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil)))); - stack = cons (frame, stack); - r1 = p1; - r2 = p2; - r0 = a; - if (f == vm_if_env && g_free.value + GC_SAFETY > ARENA_SIZE) - { - cache_invalidate_range (r0, cell_nil); - gc_stack (stack); - frame = car (stack); - } - - SCM r = f (); - frame = gc_frame (stack); - stack = cdr (stack); - return r; -} - -SCM -evlis_env (SCM m, SCM a) -{ - return vm_call (vm_evlis_env, m, cell_undefined, a); -} - -SCM -apply_env (SCM fn, SCM x, SCM a) -{ - return vm_call (vm_apply_env, fn, x, a); -} - -SCM -eval_env (SCM e, SCM a) -{ - return vm_call (vm_eval_env, e, cell_undefined, a); -} - -SCM -expand_macro_env (SCM e, SCM a) -{ - return vm_call (vm_expand_macro_env, e, cell_undefined, a); -} - -SCM -begin_env (SCM e, SCM a) -{ - return vm_call (vm_begin_env, e, cell_undefined, a); -} - -SCM -if_env (SCM e, SCM a) -{ - return vm_call (vm_if_env, e, cell_undefined, a); -} - -SCM -call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal)) -{ - SCM cl = cons (cons (cell_closure, x), x); - r1 = e; - r0 = cl; - r2 = a; - r3 = aa; - cache_invalidate_range (r0, CDR (r3)); - SCM r = vm_call_lambda (); - cache_invalidate_range (r0, CDR (r3)); - return r; -} - SCM vm_evlis_env () { @@ -647,6 +347,20 @@ vm_call_lambda () return vm_call (vm_begin_env, r1, cell_undefined, r0); } +SCM +call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal)) +{ + SCM cl = cons (cons (cell_closure, x), x); + r1 = e; + r0 = cl; + r2 = a; + r3 = aa; + cache_invalidate_range (r0, CDR (r3)); + SCM r = vm_call_lambda (); + cache_invalidate_range (r0, CDR (r3)); + return r; +} + SCM vm_apply_env () { @@ -695,8 +409,6 @@ vm_apply_env () return apply_env (e, r2, r0); } -SCM cstring_to_list (char const* s); - SCM vm_eval_env () { @@ -833,6 +545,85 @@ call (SCM fn, SCM x) return cell_unspecified; } +SCM +gc_frame (SCM stack) +{ + SCM frame = car (stack); + r1 = car (frame); + r2 = cadr (frame); + r3 = caddr (frame); + r0 = cadddr (frame); + return frame; +} + +SCM +gc_stack (SCM a) +{ + SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil)))); + stack = cons (frame, stack); + stack = gc (stack); + gc_frame (stack); + stack = cdr (stack); + return stack; +} + +SCM +vm_call (function0_t f, SCM p1, SCM p2, SCM a) +{ + SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil)))); + stack = cons (frame, stack); + r1 = p1; + r2 = p2; + r0 = a; + if (g_free.value + GC_SAFETY > ARENA_SIZE) + { + cache_invalidate_range (r0, cell_nil); + gc_stack (stack); + frame = car (stack); + } + + SCM r = f (); + frame = gc_frame (stack); + stack = cdr (stack); + return r; +} + +SCM +evlis_env (SCM m, SCM a) +{ + return vm_call (vm_evlis_env, m, cell_undefined, a); +} + +SCM +apply_env (SCM fn, SCM x, SCM a) +{ + return vm_call (vm_apply_env, fn, x, a); +} + +SCM +eval_env (SCM e, SCM a) +{ + return vm_call (vm_eval_env, e, cell_undefined, a); +} + +SCM +expand_macro_env (SCM e, SCM a) +{ + return vm_call (vm_expand_macro_env, e, cell_undefined, a); +} + +SCM +begin_env (SCM e, SCM a) +{ + return vm_call (vm_begin_env, e, cell_undefined, a); +} + +SCM +if_env (SCM e, SCM a) +{ + return vm_call (vm_if_env, e, cell_undefined, a); +} + SCM append2 (SCM x, SCM y) { @@ -905,44 +696,12 @@ cstring_to_list (char const* s) return p; } -/// read: from type.c SCM null_p (SCM x) { return x == cell_nil ? cell_t : cell_f; } -SCM -list_of_char_equal_p (SCM a, SCM b) -{ - while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) { - assert (TYPE (car (a)) == CHAR); - assert (TYPE (car (b)) == CHAR); - a = cdr (a); - b = cdr (b); - } - return (a == cell_nil && b == cell_nil) ? cell_t : cell_f; -} - -SCM -internal_lookup_symbol (SCM s) -{ - SCM x = symbols; - while (x) { - // .string and .name is the same field; .name is used as a handy - // static field initializer. A string can only be mistaken for a - // cell with type == PAIR for the one character long, zero-padded - // #\etx. - SCM p = STRING (car (x)); - if (p < 0 || p >= g_free.value || TYPE (p) != PAIR) - STRING (car (x)) = cstring_to_list (NAME (car (x))); - if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break; - x = cdr (x); - } - if (x) x = car (x); - return x; -} - SCM internal_make_symbol (SCM s) { @@ -964,7 +723,7 @@ make_vector (SCM n) { int k = VALUE (n); g_cells[tmp_num].value = VECTOR; - SCM v = gc_alloc (k); + SCM v = alloc (k); SCM x = make_cell (tmp_num, k, v); for (int i=0; i= g_free.value || TYPE (p) != PAIR) - fprintf (f, "%s", NAME (x)); - else - display_ (f, STRING (x)); - fprintf (f, ">"); - break; - } - case BROKEN_HEART: fprintf (f, "<3"); break; - default: - if (STRING (x)) - { - SCM p = STRING (x); - assert (p); - while (p != cell_nil) { - assert (TYPE (car (p)) == CHAR); - fputc (VALUE (car (p)), f); - p = cdr (p); - } - } - else if (TYPE (x) != PAIR && NAME (x)) fprintf (f, "%s", NAME (x)); - } - return cell_unspecified; -} - -// READ - FILE *g_stdin; int getchar () @@ -1258,24 +833,6 @@ unread_byte (SCM i) return ungetchar (VALUE (i)); } -SCM -peek_char () -{ - return make_char (peekchar ()); -} - -SCM -read_char () -{ - return make_char (getchar ()); -} - -SCM -unread_char (SCM c) -{ - return ungetchar (VALUE (c)); -} - SCM write_char (SCM x) ///((arity . n)) { @@ -1289,14 +846,6 @@ write_char (SCM x) ///((arity . n)) return c; } -SCM -unget_char (SCM c) -{ - assert (TYPE (c) == NUMBER || TYPE (c) == CHAR); - ungetchar (VALUE (c)); - return c; -} - SCM symbol_to_list (SCM x) { @@ -1318,166 +867,126 @@ integer_to_char (SCM x) return make_char (VALUE (x)); } -int -readcomment (int c) +// Jam Collector +SCM g_start; +scm * +gc_news () { - if (c == '\n') return c; - return readcomment (getchar ()); -} - -int -readblock (int c) -{ - if (c == '!' && peekchar () == '#') return getchar (); - return readblock (getchar ()); + g_news = (scm *)malloc (ARENA_SIZE*sizeof(scm)); + g_news[0].type = VECTOR; + g_news[0].length = 1000; + g_news[0].vector = 0; + g_news++; + g_news[0].type = CHAR; + g_news[0].value = 'n'; + return g_news; } SCM -readword (int c, SCM w, SCM a) +gc () { - if (c == EOF && w == cell_nil) return cell_nil; - if (c == '\n' && w == cell_nil) return readword (getchar (), w, a); - if (c == '\n' && VALUE (car (w)) == '.' && cdr (w) == cell_nil) return cell_dot; - if (c == EOF || c == '\n') return lookup (w, a); - if (c == ' ') return readword ('\n', w, a); - if (c == '"' && w == cell_nil) return read_string (); - if (c == '"') {ungetchar (c); return lookup (w, a);} - if (c == '(' && w == cell_nil) return readlist (a); - if (c == '(') {ungetchar (c); return lookup (w, a);} - if (c == ')' && w == cell_nil) {ungetchar (c); return cell_nil;} - if (c == ')') {ungetchar (c); return lookup (w, a);} - if (c == ',' && peekchar () == '@') {getchar (); return cons (lookup (STRING (cell_symbol_unquote_splicing), a), - cons (readword (getchar (), w, a), - cell_nil));} - if ((c == '\'' - || c == '`' - || c == ',') - && w == cell_nil) {return cons (lookup_char (c, a), - cons (readword (getchar (), w, a), - cell_nil));} - if (c == '#' && peekchar () == ',' && w == cell_nil) { - getchar (); - if (peekchar () == '@'){getchar (); return cons (lookup (STRING (cell_symbol_unsyntax_splicing), a), - cons (readword (getchar (), w, a), - cell_nil));} - return cons (lookup (STRING (cell_symbol_unsyntax), a), cons (readword (getchar (), w, a), cell_nil)); - } - if (c == '#' && (peekchar () == '\'' || peekchar () == '`') && w == cell_nil) { - c = getchar (); - return cons (lookup (cons (make_char ('#'), cons (make_char (c), cell_nil)), a), - cons (readword (getchar (), w, a), cell_nil));} - if (c == ';') {readcomment (c); return readword ('\n', w, a);} - if (c == '#' && peekchar () == 'x') {getchar (); return read_hex ();} - if (c == '#' && peekchar () == '\\') {getchar (); return read_character ();} - if (c == '#' && w == cell_nil && peekchar () == '(') {getchar (); return list_to_vector (readlist (a));} - if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);} - return readword (getchar (), append2 (w, cons (make_char (c), cell_nil)), a); + fprintf (stderr, "***gc[%d]...", g_free.value); + g_free.value = 1; + if (!g_news) + gc_news (); + for (int i=g_free.value; i= '0' && c <= '7' - && peekchar () >= '0' && peekchar () <= '7') { - c = c - '0'; - while (peekchar () >= '0' && peekchar () <= '7') { - c <<= 3; - c += getchar () - '0'; + while (scan < g_free.value) + { + if (NTYPE (scan) == MACRO + || NTYPE (scan) == PAIR + || NTYPE (scan) == REF + || scan == 1 + || ((NTYPE (scan) == SPECIAL && TYPE (NCAR (scan)) == PAIR) + || (NTYPE (scan) == STRING && TYPE (NCAR (scan)) == PAIR) + || (NTYPE (scan) == SYMBOL && TYPE (NCAR (scan)) == PAIR))) + { + SCM car = gc_copy (g_news[scan].car); + gc_relocate_car (scan, car); + } + if ((NTYPE (scan) == MACRO + || NTYPE (scan) == PAIR + || NTYPE (scan) == VALUES) + && g_news[scan].cdr) // allow for 0 terminated list of symbols + { + SCM cdr = gc_copy (g_news[scan].cdr); + gc_relocate_cdr (scan, cdr); + } + scan++; } - } - else if (c >= 'a' && c <= 'z' - && peekchar () >= 'a' && peekchar () <= 'z') { - char buf[10]; - char *p = buf; - *p++ = c; - while (peekchar () >= 'a' && peekchar () <= 'z') { - *p++ = getchar (); + return gc_flip (); +} + +SCM +gc_copy (SCM old) +{ + if (TYPE (old) == BROKEN_HEART) return g_cells[old].car; + SCM new = g_free.value++; + g_news[new] = g_cells[old]; + if (NTYPE (new) == VECTOR) + { + g_news[new].vector = g_free.value; + for (int i=0; i jam[%d]\n", g_free.value); + return stack; +} + +SCM +gc_show () +{ + fprintf (stderr, "cells: "); + scm *t = g_cells; + display_ (stderr, -1); + fprintf (stderr, "\n"); + if (g_news) + { + fprintf (stderr, "news: "); + g_cells = g_news; + display_ (stderr, -1); + fprintf (stderr, "\n"); } - } - return make_char (c); -} - -SCM -read_hex () -{ - int n = 0; - int c = peekchar (); - while ((c >= '0' && c <= '9') - || (c >= 'A' && c <= 'F') - || (c >= 'a' && c <= 'f')) { - n <<= 4; - if (c >= 'a') n += c - 'a' + 10; - else if (c >= 'A') n += c - 'A' + 10; - else n+= c - '0'; - getchar (); - c = peekchar (); - } - return make_number (n); -} - -SCM -append_char (SCM x, int i) -{ - return append2 (x, cons (make_char (i), cell_nil)); -} - -SCM -read_string () -{ - SCM p = cell_nil; - int c = getchar (); - while (true) { - if (c == '"') break; - if (c == '\\' && peekchar () == '"') p = append_char (p, getchar ()); - else if (c == '\\' && peekchar () == 'n') {getchar (); p = append_char (p, '\n');} - else if (c == EOF) assert (!"EOF in string"); - else p = append_char (p, c); - c = getchar (); - } - return make_string (p); -} - -int -eat_whitespace (int c) -{ - while (c == ' ' || c == '\t' || c == '\n') c = getchar (); - if (c == ';') return eat_whitespace (readcomment (c)); - if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());} - return c; -} - -SCM -readlist (SCM a) -{ - int c = getchar (); - c = eat_whitespace (c); - if (c == ')') return cell_nil; - SCM w = readword (c, cell_nil, a); - if (w == cell_dot) - return car (readlist (a)); - return cons (w, readlist (a)); -} - -SCM -read_env (SCM a) -{ - return readword (getchar (), cell_nil, a); + g_cells = t; + return cell_unspecified; } +// Environment setup SCM acons (SCM key, SCM value, SCM alist) { @@ -1490,12 +999,6 @@ add_environment (SCM a, char const *name, SCM x) return acons (make_symbol (cstring_to_list (name)), x, a); } -void -print_f (scm *f) -{ - fprintf (stderr, " g_function=%d; //%s\n", f->function, f->name); -} - SCM mes_symbols () ///((internal)) { @@ -1548,20 +1051,26 @@ mes_builtins (SCM a) { #include "mes.i" +#include "cache.i" #include "define.i" +#include "display.i" #include "lib.i" #include "math.i" #include "posix.i" #include "quasiquote.i" +#include "reader.i" #include "string.i" #include "type.i" +#include "cache.environment.i" #include "define.environment.i" +#include "display.environment.i" #include "lib.environment.i" #include "math.environment.i" #include "mes.environment.i" #include "posix.environment.i" //#include "quasiquote.environment.i" +#include "reader.environment.i" #include "string.environment.i" #include "type.environment.i" @@ -1626,7 +1135,6 @@ read_input_file_env_ (SCM e, SCM a) SCM read_input_file_env (SCM a) { - gc_stack (stack); return read_input_file_env_ (read_env (r0), r0); } @@ -1685,11 +1193,14 @@ bload_env (SCM a) } #include "type.c" +#include "cache.c" #include "define.c" +#include "display.c" #include "lib.c" #include "math.c" #include "posix.c" #include "quasiquote.c" +#include "reader.c" #include "string.c" int diff --git a/module/language/c/parser.mes b/module/language/c/parser.mes index a97b933f..35a49a93 100644 --- a/module/language/c/parser.mes +++ b/module/language/c/parser.mes @@ -55,6 +55,7 @@ (mes-use-module (mes elf)) (mes-use-module (mes libc-i386)))) +(gc) (define c-parser (lalr-parser diff --git a/posix.c b/posix.c index a577806d..5b98cd5e 100644 --- a/posix.c +++ b/posix.c @@ -35,6 +35,15 @@ string_to_cstring (SCM s) return buf; } +SCM +force_output (SCM p) ///((arity . n)) +{ + int fd = 1; + if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = VALUE (car (p)); + FILE *f = fd == 1 ? stdout : stderr; + fflush (f); +} + SCM open_input_file (SCM file_name) { diff --git a/reader.c b/reader.c new file mode 100644 index 00000000..383283e8 --- /dev/null +++ b/reader.c @@ -0,0 +1,287 @@ +/* -*-comment-start: "//";comment-end:""-*- + * Mes --- Maxwell Equations of Software + * Copyright © 2016 Jan Nieuwenhuizen + * + * This file is part of Mes. + * + * Mes 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 3 of the License, or (at + * your option) any later version. + * + * Mes 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 Mes. If not, see . + */ + +SCM +peek_char () +{ + return make_char (peekchar ()); +} + +SCM +read_char () +{ + return make_char (getchar ()); +} + +SCM +unread_char (SCM c) +{ + return ungetchar (VALUE (c)); +} + +SCM +unget_char (SCM c) +{ + assert (TYPE (c) == NUMBER || TYPE (c) == CHAR); + ungetchar (VALUE (c)); + return c; +} +int +read_line_comment (int c) +{ + if (c == '\n') return c; + return read_line_comment (getchar ()); +} + +int +read_block_comment (int c) +{ + if (c == '!' && peekchar () == '#') return getchar (); + return read_block_comment (getchar ()); +} + +SCM lookup_char (int c, SCM a); + +SCM +read_word (int c, SCM w, SCM a) +{ + if (c == EOF && w == cell_nil) return cell_nil; + if (c == '\n' && w == cell_nil) return read_word (getchar (), w, a); + if (c == '\n' && VALUE (car (w)) == '.' && cdr (w) == cell_nil) return cell_dot; + if (c == EOF || c == '\n') return lookup (w, a); + if (c == ' ') return read_word ('\n', w, a); + if (c == '"' && w == cell_nil) return read_string (); + if (c == '"') {ungetchar (c); return lookup (w, a);} + if (c == '(' && w == cell_nil) return read_list (a); + if (c == '(') {ungetchar (c); return lookup (w, a);} + if (c == ')' && w == cell_nil) {ungetchar (c); return cell_nil;} + if (c == ')') {ungetchar (c); return lookup (w, a);} + if (c == ',' && peekchar () == '@') {getchar (); return cons (lookup (STRING (cell_symbol_unquote_splicing), a), + cons (read_word (getchar (), w, a), + cell_nil));} + if ((c == '\'' + || c == '`' + || c == ',') + && w == cell_nil) {return cons (lookup_char (c, a), + cons (read_word (getchar (), w, a), + cell_nil));} + if (c == '#' && peekchar () == ',' && w == cell_nil) { + getchar (); + if (peekchar () == '@'){getchar (); return cons (lookup (STRING (cell_symbol_unsyntax_splicing), a), + cons (read_word (getchar (), w, a), + cell_nil));} + return cons (lookup (STRING (cell_symbol_unsyntax), a), cons (read_word (getchar (), w, a), cell_nil)); + } + if (c == '#' && (peekchar () == '\'' || peekchar () == '`') && w == cell_nil) { + c = getchar (); + return cons (lookup (cons (make_char ('#'), cons (make_char (c), cell_nil)), a), + cons (read_word (getchar (), w, a), cell_nil));} + if (c == ';') {read_line_comment (c); return read_word ('\n', w, a);} + if (c == '#' && peekchar () == 'x') {getchar (); return read_hex ();} + if (c == '#' && peekchar () == '\\') {getchar (); return read_character ();} + if (c == '#' && w == cell_nil && peekchar () == '(') {getchar (); return list_to_vector (read_list (a));} + if (c == '#' && peekchar () == '!') {getchar (); read_block_comment (getchar ()); return read_word (getchar (), w, a);} + return read_word (getchar (), append2 (w, cons (make_char (c), cell_nil)), a); +} + +SCM +read_character () +{ + int c = getchar (); + if (c >= '0' && c <= '7' + && peekchar () >= '0' && peekchar () <= '7') { + c = c - '0'; + while (peekchar () >= '0' && peekchar () <= '7') { + c <<= 3; + c += getchar () - '0'; + } + } + else if (c >= 'a' && c <= 'z' + && peekchar () >= 'a' && peekchar () <= 'z') { + char buf[10]; + char *p = buf; + *p++ = c; + while (peekchar () >= 'a' && peekchar () <= 'z') { + *p++ = getchar (); + } + *p = 0; + if (!strcmp (buf, char_nul.name)) c = char_nul.value; + else if (!strcmp (buf, char_backspace.name)) c = char_backspace.value; + else if (!strcmp (buf, char_tab.name)) c = char_tab.value; + else if (!strcmp (buf, char_newline.name)) c = char_newline.value; + else if (!strcmp (buf, char_vt.name)) c = char_vt.value; + else if (!strcmp (buf, char_page.name)) c = char_page.value; + else if (!strcmp (buf, char_return.name)) c = char_return.value; + else if (!strcmp (buf, char_space.name)) c = char_space.value; + else { + fprintf (stderr, "char not supported: %s\n", buf); + assert (!"char not supported"); + } + } + return make_char (c); +} + +SCM +read_hex () +{ + int n = 0; + int c = peekchar (); + while ((c >= '0' && c <= '9') + || (c >= 'A' && c <= 'F') + || (c >= 'a' && c <= 'f')) { + n <<= 4; + if (c >= 'a') n += c - 'a' + 10; + else if (c >= 'A') n += c - 'A' + 10; + else n+= c - '0'; + getchar (); + c = peekchar (); + } + return make_number (n); +} + +SCM +append_char (SCM x, int i) +{ + return append2 (x, cons (make_char (i), cell_nil)); +} + +SCM +read_string () +{ + SCM p = cell_nil; + int c = getchar (); + while (true) { + if (c == '"') break; + if (c == '\\' && peekchar () == '"') p = append_char (p, getchar ()); + else if (c == '\\' && peekchar () == 'n') {getchar (); p = append_char (p, '\n');} + else if (c == EOF) assert (!"EOF in string"); + else p = append_char (p, c); + c = getchar (); + } + return make_string (p); +} + +int +eat_whitespace (int c) +{ + while (c == ' ' || c == '\t' || c == '\n') c = getchar (); + if (c == ';') return eat_whitespace (read_line_comment (c)); + if (c == '#' && peekchar () == '!') {getchar (); read_block_comment (getchar ()); return eat_whitespace (getchar ());} + return c; +} + +SCM +read_list (SCM a) +{ + int c = getchar (); + c = eat_whitespace (c); + if (c == ')') return cell_nil; + SCM w = read_word (c, cell_nil, a); + if (w == cell_dot) + return car (read_list (a)); + return cons (w, read_list (a)); +} + +SCM +read_env (SCM a) +{ + return read_word (getchar (), cell_nil, a); +} + +SCM +lookup (SCM s, SCM a) +{ + if (isdigit (VALUE (car (s))) || (VALUE (car (s)) == '-' && cdr (s) != cell_nil)) { + SCM p = s; + int sign = 1; + if (VALUE (car (s)) == '-') { + sign = -1; + p = cdr (s); + } + int n = 0; + while (p != cell_nil && isdigit (VALUE (car (p)))) { + n *= 10; + n += VALUE (car (p)) - '0'; + p = cdr (p); + } + if (p == cell_nil) return make_number (n * sign); + } + + SCM x = internal_lookup_symbol (s); + if (x) return x; + + if (cdr (s) == cell_nil) { + if (VALUE (car (s)) == '\'') return cell_symbol_quote; + if (VALUE (car (s)) == '`') return cell_symbol_quasiquote; + if (VALUE (car (s)) == ',') return cell_symbol_unquote; + } + else if (cddr (s) == cell_nil) { + if (VALUE (car (s)) == ',' && VALUE (cadr (s)) == '@') return cell_symbol_unquote_splicing; + if (VALUE (car (s)) == '#' && VALUE (cadr (s)) == '\'') return cell_symbol_syntax; + if (VALUE (car (s)) == '#' && VALUE (cadr (s)) == '`') return cell_symbol_quasisyntax; + if (VALUE (car (s)) == '#' && VALUE (cadr (s)) == ',') return cell_symbol_unsyntax; + } + else if (cdddr (s) == cell_nil) { + if (VALUE (car (s)) == '#' && VALUE (cadr (s)) == ',' && VALUE (caddr (s)) == '@') return cell_symbol_unsyntax_splicing; + if (VALUE (car (s)) == 'E' && VALUE (cadr (s)) == 'O' && VALUE (caddr (s)) == 'F') { + fprintf (stderr, "mes: got EOF\n"); + return cell_nil; // `EOF': eval program, which may read stdin + } + } + + return internal_make_symbol (s); +} + +SCM +lookup_char (int c, SCM a) +{ + return lookup (cons (make_char (c), cell_nil), a); +} + +SCM +list_of_char_equal_p (SCM a, SCM b) +{ + while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) { + assert (TYPE (car (a)) == CHAR); + assert (TYPE (car (b)) == CHAR); + a = cdr (a); + b = cdr (b); + } + return (a == cell_nil && b == cell_nil) ? cell_t : cell_f; +} + +SCM +internal_lookup_symbol (SCM s) +{ + SCM x = symbols; + while (x) { + // .string and .name is the same field; .name is used as a handy + // static field initializer. A string can only be mistaken for a + // cell with type == PAIR for the one character long, zero-padded + // #\etx. + SCM p = STRING (car (x)); + if (p < 0 || p >= g_free.value || TYPE (p) != PAIR) + STRING (car (x)) = cstring_to_list (NAME (car (x))); + if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break; + x = cdr (x); + } + if (x) x = car (x); + return x; +} diff --git a/tests/base.test b/tests/base.test index fffcb778..15ae2d0c 100755 --- a/tests/base.test +++ b/tests/base.test @@ -75,7 +75,7 @@ exit $? (define local-answer 41)) (pass-if-equal "begin 2" 41 (begin local-answer)) -;; (if (not guile?) -;; (pass-if-equal "load" 42 (begin (load "tests/data/load.scm") the-answer))) +(if (not guile?) + (pass-if-equal "load" 42 (begin (load "tests/data/load.scm") the-answer))) (result 'report)