#define MES_MINI 0 // 1 for gc-2a.test, gc-3.test
#if MES_FULL
-int ARENA_SIZE = 400000000; // need this much for scripts/mescc.mes
-//int ARENA_SIZE = 300000000; // need this much for tests/match.scm
-//int ARENA_SIZE = 30000000; // need this much for tests/record.scm
-//int ARENA_SIZE = 500000; // enough for tests/scm.test
-//int ARENA_SIZE = 60000; // enough for tests/base.test
+int ARENA_SIZE = 200000000;
int GC_SAFETY = 10000;
int GC_FREE = 20000;
#else
-//int ARENA_SIZE = 500; // MINI
-int ARENA_SIZE = 4000; // MES_MINI, gc-3.test
-//int ARENA_SIZE = 10000; // gc-2a.test
-//int ARENA_SIZE = 18000; // gc-2.test -->KRAK
-//int ARENA_SIZE = 23000; // gc-2.test OK
-// int GC_SAFETY = 1000;
-// int GC_FREE = 1000;
-int GC_SAFETY = 10;
-int GC_FREE = 10;
+int ARENA_SIZE = 15000;
+int GC_SAFETY = 1000;
+int GC_FREE = 100;
#endif
typedef long SCM;
scm scm_symbol_current_module = {SYMBOL, "current-module"};
scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"};
+scm scm_symbol_the_unquoters = {SYMBOL, "*the-unquoters*"};
+
+scm char_eof = {CHAR, .name="*eof*", .value=-1};
scm char_nul = {CHAR, .name="nul", .value=0};
scm char_backspace = {CHAR, .name="backspace", .value=8};
scm char_tab = {CHAR, .name="tab", .value=9};
SCM body = cddr (r1);
SCM p = pairlis (args, r2, r0);
return call_lambda (body, p, p, r0);
- // r2 = p;
- // cache_invalidate_range (r2, g_cells[r0].cdr);
- // SCM r = begin_env (cddr (r1), cons (cons (cell_closure, p), p));
- // cache_invalidate_range (r2, g_cells[r0].cdr);
- // return r;
}
else if (car (r1) == cell_closure) {
SCM args = caddr (r1);
aa = cdr (aa);
SCM p = pairlis (args, r2, aa);
return call_lambda (body, p, aa, r0);
- // r2 = p;
- // r3 = aa;
- // cache_invalidate_range (r2, g_cells[r3].cdr);
- // SCM r = begin_env (body, cons (cons (cell_closure, p), p));
- // cache_invalidate_range (r2, g_cells[r3].cdr);
- // return r;
}
#if BOOT
else if (car (r1) == cell_symbol_label)
if (car (r1) == cell_symbol_define_macro)
return define_env (r1, r0);
if (car (r1) == cell_symbol_primitive_load)
- return load_env (r0);
+ return begin_env (read_input_file_env (r0), r0);
#else
if (car (r1) == cell_symbol_define) {
fprintf (stderr, "C DEFINE: ");
make_function (SCM name, SCM id, SCM arity)
{
g_cells[tmp_num3].value = FUNCTION;
- // function fun_read_byte = {.function0=&read_byte, .arity=0};
- // scm scm_read_byte = {FUNCTION, .name="read-int", .function=&fun_read_byte};
- // SCM cell_read_byte = 93;
function *f = (function*)malloc (sizeof (function));
f->arity = VALUE (arity);
g_cells[tmp_num4].value = (long)f;
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)
{
return cell_unspecified;
}
+SCM
+list_to_vector (SCM x)
+{
+ VALUE (tmp_num) = VALUE (length (x));
+ SCM v = make_vector (tmp_num);
+ SCM p = VECTOR (v);
+ while (x != cell_nil)
+ {
+ g_cells[p++] = g_cells[vector_entry (car (x))];
+ x = cdr (x);
+ }
+ return v;
+}
+
SCM
lookup (SCM s, SCM a)
{
return lookup (cons (make_char (c), cell_nil), a);
}
-SCM
-list_to_vector (SCM x)
-{
- g_cells[tmp_num].value = VALUE (length (x));
- SCM v = make_vector (tmp_num);
- SCM p = VECTOR (v);
- while (x != cell_nil)
- {
- g_cells[p++] = g_cells[vector_entry (car (x))];
- x = cdr (x);
- }
- return v;
-}
-
SCM
force_output (SCM p) ///((arity . n))
{
return c;
}
+SCM
+peek_byte ()
+{
+ return make_number (peekchar ());
+}
+
+SCM
+read_byte ()
+{
+ return make_number (getchar ());
+}
+
+SCM
+unread_byte (SCM i)
+{
+ return ungetchar (VALUE (i));
+}
+
SCM
peek_char ()
{
return make_char (getchar ());
}
+SCM
+unread_char (SCM c)
+{
+ return ungetchar (VALUE (c));
+}
+
SCM
write_char (SCM x) ///((arity . n))
{
return STRING (x);
}
+SCM
+char_to_integer (SCM x)
+{
+ assert (TYPE (x) == CHAR);
+ return make_number (VALUE (x));
+}
+
+SCM
+integer_to_char (SCM x)
+{
+ assert (TYPE (x) == NUMBER);
+ return make_char (VALUE (x));
+}
+
int
readcomment (int c)
{
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 readstring ();
+ 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 == '#' && 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 () == '(') {ungetchar (c); return lookup (w, a);}
if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
return readword (getchar (), append2 (w, cons (make_char (c), cell_nil)), a);
}
-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
read_character ()
{
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)
{
}
SCM
-readstring ()
+read_string ()
{
SCM p = cell_nil;
int c = getchar ();
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_environment () ///((internal))
+mes_symbols () ///((internal))
{
- // setup GC
g_cells = (scm *)malloc (ARENA_SIZE*sizeof(scm));
g_cells[0].type = VECTOR;
- g_cells[0].length = ARENA_SIZE - 1;
- g_cells[0].length = 10;
+ g_cells[0].length = 1000;
g_cells[0].vector = 0;
g_cells++;
- // a = add_environment (a, "%free", &g_free); hihi, gets <3 moved
- // a = add_environment (a, "%the-cells", g_cells);
- // a = add_environment (a, "%new-cells", g_news);
-
-//#include "mes.symbols.i"
g_cells[0].type = CHAR;
g_cells[0].value = 'c';
g_free.value = 1; // 0 is tricky
-#if !MES_MINI
#include "mes.symbols.i"
-#else // MES_MINI
- cell_nil = g_free.value++;
- g_cells[cell_nil] = scm_nil;
- cell_f = g_free.value++;
- g_cells[cell_f] = scm_f;
- cell_t = g_free.value++;
- g_cells[cell_t] = scm_t;
- cell_undefined = g_free.value++;
- g_cells[cell_undefined] = scm_undefined;
- cell_unspecified = g_free.value++;
- g_cells[cell_unspecified] = scm_unspecified;
- cell_closure = g_free.value++;
- g_cells[cell_closure] = scm_closure;
- cell_begin = g_free.value++;
- g_cells[cell_begin] = scm_begin;
-
- cell_symbol_begin = g_free.value++;
- g_cells[cell_symbol_begin] = scm_symbol_begin;
-
- cell_symbol_sc_expander_alist = g_free.value++;
- g_cells[cell_symbol_sc_expander_alist] = scm_symbol_sc_expander_alist;
- cell_symbol_sc_expand = g_free.value++;
- g_cells[cell_symbol_sc_expand] = scm_symbol_sc_expand;
-
- // cell_dot = g_free.value++;
- // g_cells[cell_dot] = scm_dot;
- // cell_circular = g_free.value++;
- // g_cells[cell_circular] = scm_circular;
- // cell_symbol_lambda = g_free.value++;
- // g_cells[cell_symbol_lambda] = scm_symbol_lambda;
- // cell_symbol_if = g_free.value++;
- // g_cells[cell_symbol_if] = scm_symbol_if;
- // cell_symbol_define = g_free.value++;
- // g_cells[cell_symbol_define] = scm_symbol_define;
- // cell_symbol_define_macro = g_free.value++;
- // g_cells[cell_symbol_define_macro] = scm_symbol_define_macro;
-
-#endif // MES_MINI
-
- SCM symbol_max = g_free.value;
-
-#if MES_FULL
-#include "define.i"
-#include "lib.i"
-#include "math.i"
-#include "mes.i"
-#include "posix.i"
-#include "quasiquote.i"
-#include "string.i"
-#include "type.i"
-#else
- cell_cons = g_free.value++;
- cell_display = g_free.value++;
- cell_eq_p = g_free.value++;
- cell_newline = g_free.value++;
-
- g_cells[cell_cons] = scm_cons;
- g_cells[cell_display] = scm_display;
- g_cells[cell_eq_p] = scm_eq_p;
- g_cells[cell_newline] = scm_newline;
-
- cell_make_vector = g_free.value++;
- g_cells[cell_make_vector] = scm_make_vector;
+ SCM symbol_max = g_free.value;
-#endif
-
tmp = g_free.value++;
tmp_num = g_free.value++;
g_cells[tmp_num].type = NUMBER;
tmp_num2 = g_free.value++;
g_cells[tmp_num2].type = NUMBER;
+ tmp_num3 = g_free.value++;
+ g_cells[tmp_num3].type = NUMBER;
+ tmp_num4 = g_free.value++;
+ g_cells[tmp_num4].type = NUMBER;
g_start = g_free.value;
symbols = 0;
for (int i=1; i<symbol_max; i++)
symbols = cons (i, symbols);
-
+
SCM a = cell_nil;
-#if MES_FULL
+#if BOOT
+ a = acons (cell_symbol_label, cell_t, a);
+#endif
+ a = acons (cell_symbol_begin, cell_begin, a);
+ a = add_environment (a, "sc-expand", cell_f);
+ a = acons (cell_closure, a, a);
+
+ internal_lookup_symbol (cell_nil);
+
+ return a;
+}
+
+SCM
+mes_builtins (SCM a)
+{
+#include "mes.i"
+
+#include "define.i"
+#include "lib.i"
+#include "math.i"
+#include "posix.i"
+#include "quasiquote.i"
+#include "string.i"
+#include "type.i"
+
#include "define.environment.i"
#include "lib.environment.i"
#include "math.environment.i"
//#include "quasiquote.environment.i"
#include "string.environment.i"
#include "type.environment.i"
-#else // !MES_FULL
-
- a = add_environment (a, "cons", cell_cons);
- a = add_environment (a, "display", cell_display);
- a = add_environment (a, "eq?", cell_eq_p);
- a = add_environment (a, "newline", cell_newline);
-
- a = add_environment (a, "make-vector", cell_make_vector);
-
-#if !MES_MINI
- a = add_environment (a, "*", cell_multiply);
- a = add_environment (a, "list", cell_list);
- //
- a = add_environment (a, "car", cell_car);
- a = add_environment (a, "cdr", cell_cdr);
- a = add_environment (a, "+", cell_plus);
- a = add_environment (a, "quote", cell_quote);
- a = add_environment (a, "null?", cell_null_p);
- a = add_environment (a, "=", cell_is_p);
-
- // a = add_environment (a, "gc", cell_gc);
- // a = add_environment (a, "apply-env", cell_apply_env);
- // a = add_environment (a, "eval-env", cell_eval_env);
- // a = add_environment (a, "cadr", cell_cadr);
-#endif // !MES_MINI
-#endif // !MES_FULL
-#if BOOT
- ////symbols = cons (cell_symbol_label, symbols);
- a = cons (cons (cell_symbol_label, cell_t), a);
-#endif
- a = cons (cons (cell_symbol_begin, cell_begin), a);
+ SCM cell_unquote = assq_ref_cache (cell_symbol_unquote, a);
+ SCM cell_unquote_splicing = assq_ref_cache (cell_symbol_unquote_splicing, a);
+ SCM the_unquoters = cons (cons (cell_symbol_unquote, cell_unquote),
+ cons (cons (cell_symbol_unquote_splicing, cell_unquote_splicing),
+ cell_nil));
+ a = acons (cell_symbol_the_unquoters, the_unquoters, a);
- a = add_environment (a, "sc-expand", cell_f);
-
- a = cons (cons (cell_closure, a), a);
+ a = add_environment (a, "*foo-bar-baz*", cell_nil); // FIXME: some off-by one?
- internal_lookup_symbol (cell_nil);
+ return a;
+}
+SCM
+mes_stack (SCM a) ///((internal))
+{
r0 = a;
r1 = make_char (0);
r2 = make_char (0);
r3 = make_char (0);
stack = cons (cell_nil, cell_nil);
+ return r0;
+}
- return a;
+SCM
+mes_environment () ///((internal))
+{
+ SCM a = mes_symbols ();
+ return mes_stack (a);
}
SCM
}
SCM
-read_input_file_env (SCM e, SCM a)
+read_input_file_env_ (SCM e, SCM a)
{
if (e == cell_nil) return e;
- return cons (e, read_input_file_env (read_env (a), a));
+ return cons (e, read_input_file_env_ (read_env (a), a));
+}
+
+SCM
+read_input_file_env (SCM a)
+{
+ gc_stack (stack);
+ return read_input_file_env_ (read_env (r0), r0);
}
+bool g_dump_p = false;
+
SCM
load_env (SCM a)
{
- SCM p = read_input_file_env (read_env (a), a);
- return begin_env (p, a);
+ r3 = read_input_file_env (r0);
+ if (g_dump_p && !g_function)
+ {
+ r1 = symbols;
+ SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
+ stack = cons (frame, stack);
+ stack = gc (stack);
+ gc_frame (stack);
+ char *p = (char*)g_cells;
+ fputc ('M', stdout);
+ fputc ('E', stdout);
+ fputc ('S', stdout);
+ fputc (stack >> 8, stdout);
+ fputc (stack % 256, stdout);
+ for (int i=0; i<g_free.value * sizeof(scm); i++)
+ fputc (*p++, stdout);
+ return 0;
+ }
+ if (!g_function)
+ r0 = mes_builtins (r0);
+ return begin_env (r3, r0);
+}
+
+SCM
+bload_env (SCM a)
+{
+ g_stdin = fopen ("read-0.mo", "r");
+ char *p = (char*)g_cells;
+ assert (getchar () == 'M');
+ assert (getchar () == 'E');
+ assert (getchar () == 'S');
+ stack = getchar () << 8;
+ stack += getchar ();
+ int c = getchar ();
+ while (c != EOF)
+ {
+ *p++ = c;
+ c = getchar ();
+ }
+ g_free.value = (p-(char*)g_cells) / sizeof (scm);
+ gc_frame (stack);
+ symbols = r1;
+ g_stdin = stdin;
+
+ r0 = mes_builtins (r0);
+
+ return begin_env (r3, r0);
}
#include "type.c"
int
main (int argc, char *argv[])
{
+ if (argc > 1 && !strcmp (argv[1], "--dump")) g_dump_p = true;
if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes < FILE\n");
if (argc > 1 && !strcmp (argv[1], "--version")) return puts ("Mes 0.2\n");
g_stdin = stdin;
SCM a = mes_environment ();
- display_ (stderr, load_env (a));
+ if (argc > 1 && !strcmp (argv[1], "--load"))
+ display_ (stderr, bload_env (a));
+ else
+ display_ (stderr, load_env (a));
fputs ("", stderr);
+ gc (stack);
fprintf (stderr, "\nstats: [%d]\n", g_free.value);
return 0;
}
--- /dev/null
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; read-0.mes - bootstrap reader from Scheme. Use
+;;; ./mes --dump < module/mes/read-0.mes > read-0.mo
+;;; to read, garbage collect, and dump this reader; then
+;;; ./mes --load < tests/gc-3.test
+;;; to use this reader to read and run the minimal gc-3.test
+;;; TODO: complete this reader, remove reader from C.
+
+;;; Code:
+
+(begin
+
+ ;; (define car (make-function 'car 0))
+ ;; (define cdr (make-function 'cdr 1))
+ ;; (define cons (make-function 'cons 1))
+
+ ;; TODO:
+ ;; * use case/cond, expand
+ ;; * etc int/char?
+ ;; * lookup in Scheme
+ ;; * read characters, quote, strings
+
+ (define (read)
+ (read-word (read-byte) '() (current-module)))
+
+ (define (read-input-file)
+ (define (helper x)
+ (if (null? x) x
+ (cons x (helper (read)))))
+ (helper (read)))
+
+ (define-macro (cond . clauses)
+ (list 'if (null? clauses) *unspecified*
+ (if (null? (cdr clauses))
+ (list 'if (car (car clauses))
+ (list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
+ *unspecified*)
+ (if (eq? (car (cadr clauses)) 'else)
+ (list 'if (car (car clauses))
+ (list (cons 'lambda (cons '() (car clauses))))
+ (list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
+ (list 'if (car (car clauses))
+ (list (cons 'lambda (cons '() (car clauses))))
+ (cons 'cond (cdr clauses)))))))
+
+ (define (eat-whitespace)
+ (cond
+ ((eq? (peek-byte) 9) (read-byte) (eat-whitespace))
+ ((eq? (peek-byte) 10) (read-byte) (eat-whitespace))
+ ((eq? (peek-byte) 13) (read-byte) (eat-whitespace))
+ ((eq? (peek-byte) 32) (read-byte) (eat-whitespace))
+ ((eq? (peek-byte) 59) (begin (read-line-comment (read-byte))
+ (eat-whitespace)))
+ ((eq? (peek-byte) 35) (begin (read-byte)
+ (if (eq? (peek-byte) 33) (begin (read-byte)
+ (read-block-comment (read-byte))
+ (eat-whitespace))
+ (unread-byte 35))))))
+
+ (define (read-block-comment c)
+ (if (eq? c 33) (if (eq? (peek-byte) 35) (read-byte)
+ (read-block-comment (read-byte)))
+ (read-block-comment (read-byte))))
+
+ ;; (define (read-hex c)
+ ;; (if (eq? c 10) c
+ ;; (read-line-comment (read-byte))))
+
+ (define (read-line-comment c)
+ (if (eq? c 10) c
+ (read-line-comment (read-byte))))
+
+ (define (read-list a)
+ (eat-whitespace)
+ (if (eq? (peek-byte) 41) (begin (read-byte) '())
+ ((lambda (w)
+ (if (eq? w '.) (car (read-list a))
+ (cons w (read-list a))))
+ (read-word (read-byte) '() a))))
+
+ ;;(define (read-string))
+
+ (define (lookup-char c a)
+ (lookup (cons (integer->char c) '()) a))
+
+ (define (read-word c w a)
+ (cond
+ ((eq? c -1) '())
+ ((eq? c 10) (if (null? w) (read-word (read-byte) '() a)
+ (lookup w a)))
+ ((eq? c 32) (read-word 10 w a))
+ ((eq? c 34) (if (null? w) (read-string)
+ (begin (unread-byte c) (lookup w a))))
+ ((eq? c 35) (cond
+ ((eq? (peek-byte) 33) (begin (read-byte)
+ (read-block-comment (read-byte))
+ (read-word (read-byte) w a)))
+ ((eq? (peek-byte) 40) (read-byte) (list->vector (read-list a)))
+ ((eq? (peek-byte) 92) (read-byte) (read-character))
+ ((eq? (peek-byte) 120) (read-byte) (read-hex))
+ (else (read-word (read-byte) (append w (cons (integer->char c) '())) a))))
+ ((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) '()) a)
+ (cons (read-word (read-byte) w a) '()))
+ (begin (unread-byte c)) (lookup w a)))
+ ((eq? c 40) (if (null? w) (read-list a)
+ (begin (unread-byte c) (lookup w a))))
+ ((eq? c 41) (if (null? w) (cons (lookup (cons (integer->char c) '()) a)
+ (cons (read-word (read-byte) w a) '()))
+ (begin (unread-byte c) (lookup w a))))
+ ((eq? c 44) (cond
+ ((eq? (peek-byte) 64) (begin (read-byte)
+ (cons
+ (lookup (symbol->list 'unquote-splicing) a)
+ (cons (read-word (read-byte) w a) '()))))
+ (else (cons (lookup-char c a) (cons (read-word (read-byte) w a)
+ '())))))
+ ((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) '())))
+ ((eq? c 59) (read-line-comment c) (read-word 10 w a))
+ (else (read-word (read-byte) (append w (cons (integer->char c) '())) a))))
+
+ ((lambda (p)
+ ;;(display 'program=) (display p) (newline)
+ (begin-env p (current-module)))
+ (read-input-file)))
projects / mes.git / commitdiff