diff --git a/GNUmakefile b/GNUmakefile index 5fc75d7d..bb3eacdc 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -35,6 +35,8 @@ 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: reader.c reader.h reader.i reader.environment.i +mes.o: gc.c gc.h gc.i gc.environment.i +mes.o: vector.c vector.h vector.i vector.environment.i clean: rm -f mes *.o *.environment.i *.symbols.i *.environment.h *.cat a.out diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..d257541d --- /dev/null +++ b/gc.c @@ -0,0 +1,122 @@ +/* -*-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 +gc_up_arena () ///((internal)) +{ + ARENA_SIZE *= 2; + void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(struct scm)); + if (!p) error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list (strerror (errno))), MAKE_NUMBER (g_free))); + g_cells = (struct scm*)p; + g_cells++; + gc_init_news (); +} + +SCM +gc_flip () ///((internal)) +{ + struct scm *cells = g_cells; + g_cells = g_news; + g_news = cells; + if (g_debug) fprintf (stderr, " => jam[%d]\n", g_free); + return g_stack; +} + +SCM +gc_copy (SCM old) ///((internal)) +{ + if (TYPE (old) == TBROKEN_HEART) return g_cells[old].car; + SCM new = g_free++; + g_news[new] = g_cells[old]; + if (NTYPE (new) == TVECTOR) + { + g_news[new].vector = g_free; + for (int i=0; i +;;; Copyright © 2016,2017 Jan Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/lib.c b/lib.c index 5ef86037..ea5eb4f1 100644 --- a/lib.c +++ b/lib.c @@ -18,13 +18,6 @@ * along with Mes. If not, see . */ -SCM -xassq (SCM x, SCM a) ///for speed in core only -{ - while (a != cell_nil && x != CDAR (a)) a = CDR (a); - return a != cell_nil ? CAR (a) : cell_f; -} - //MINI_MES // SCM // length (SCM x) @@ -80,7 +73,7 @@ append (SCM x) ///((arity . n)) // } SCM -assert_defined (SCM x, SCM e) ///(internal) +assert_defined (SCM x, SCM e) ///((internal)) { if (e == cell_undefined) return error (cell_symbol_unbound_variable, x); return e; @@ -102,7 +95,7 @@ check_formals (SCM f, SCM formals, SCM args) ///((internal)) } SCM -check_apply (SCM f, SCM e) +check_apply (SCM f, SCM e) ///((internal)) { char const* type = 0; if (f == cell_f || f == cell_t) type = "bool"; @@ -242,3 +235,25 @@ bload_env (SCM a) ///((internal)) r0 = mes_builtins (r0); return r2; } + +SCM +values (SCM x) ///((arity . n)) +{ + SCM v = cons (0, x); + TYPE (v) = TVALUES; + return v; +} + +SCM +arity_ (SCM x) +{ + assert (TYPE (x) == TFUNCTION); + return MAKE_NUMBER (FUNCTION (x).arity); +} + +SCM +xassq (SCM x, SCM a) ///for speed in core only +{ + while (a != cell_nil && x != CDAR (a)) a = CDR (a); + return a != cell_nil ? CAR (a) : cell_f; +} diff --git a/math.c b/math.c index ee48bbce..11917fa6 100644 --- a/math.c +++ b/math.c @@ -18,34 +18,33 @@ * along with Mes. If not, see . */ -//MINI_MES -// SCM -// greater_p (SCM x) ///((name . ">") (arity . n)) -// { -// int n = INT_MAX; -// while (x != cell_nil) -// { -// assert (TYPE (car (x)) == TNUMBER); -// if (VALUE (car (x)) >= n) return cell_f; -// n = VALUE (car (x)); -// x = cdr (x); -// } -// return cell_t; -// } +SCM +greater_p (SCM x) ///((name . ">") (arity . n)) +{ + int n = INT_MAX; + while (x != cell_nil) + { + assert (TYPE (car (x)) == TNUMBER); + if (VALUE (car (x)) >= n) return cell_f; + n = VALUE (car (x)); + x = cdr (x); + } + return cell_t; +} -// SCM -// less_p (SCM x) ///((name . "<") (arity . n)) -// { -// int n = INT_MIN; -// while (x != cell_nil) -// { -// assert (TYPE (car (x)) == TNUMBER); -// if (VALUE (car (x)) <= n) return cell_f; -// n = VALUE (car (x)); -// x = cdr (x); -// } -// return cell_t; -// } +SCM +less_p (SCM x) ///((name . "<") (arity . n)) +{ + int n = INT_MIN; + while (x != cell_nil) + { + assert (TYPE (car (x)) == TNUMBER); + if (VALUE (car (x)) <= n) return cell_f; + n = VALUE (car (x)); + x = cdr (x); + } + return cell_t; +} SCM is_p (SCM x) ///((name . "=") (arity . n)) diff --git a/mes.c b/mes.c index fa794b87..25c08e2f 100644 --- a/mes.c +++ b/mes.c @@ -158,11 +158,17 @@ struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0}; struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0}; struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0}; +struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0}; +struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0}; + struct scm scm_test = {TSYMBOL, "test",0}; + int g_free = 0; struct scm *g_cells; struct scm *g_news = 0; +SCM g_symbol_max; +bool g_debug = false; #include "mes.symbols.h" @@ -181,11 +187,13 @@ SCM r1 = 0; // param 1 SCM r2 = 0; // save 2+load/dump SCM r3 = 0; // continuation +#include "gc.h" #include "lib.h" #include "math.h" #include "mes.h" #include "posix.h" #include "reader.h" +#include "vector.h" #define CAR(x) g_cells[x].car #define CDR(x) g_cells[x].cdr @@ -362,6 +370,16 @@ error (SCM key, SCM x) assert (!"error"); } +SCM +cstring_to_list (char const* s) +{ + SCM p = cell_nil; + int i = strlen (s); + while (i--) + p = cons (MAKE_CHAR (s[i]), p); + return p; +} + SCM append2 (SCM x, SCM y) { @@ -874,16 +892,6 @@ apply (SCM f, SCM x, SCM a) ///((internal)) return eval_apply (); } -SCM -cstring_to_list (char const* s) -{ - SCM p = cell_nil; - int i = strlen (s); - while (i--) - p = cons (MAKE_CHAR (s[i]), p); - return p; -} - SCM make_symbol_ (SCM s) { @@ -954,325 +962,6 @@ acons (SCM key, SCM value, SCM alist) return cons (cons (key, value), alist); } -// temp MINI_MES lib -//posix.c -FILE *g_stdin; -int -getchar () -{ - return getc (g_stdin); -} - -int -ungetchar (int c) -{ - return ungetc (c, g_stdin); -} - -int -peekchar () -{ - int c = getchar (); - ungetchar (c); - return c; -} - -SCM -peek_byte () -{ - return MAKE_NUMBER (peekchar ()); -} - -SCM -read_byte () -{ - return MAKE_NUMBER (getchar ()); -} - -SCM -unread_byte (SCM i) -{ - ungetchar (VALUE (i)); - return i; -} - -SCM -write_byte (SCM x) ///((arity . n)) -{ - SCM c = car (x); - SCM p = cdr (x); - int fd = 1; - if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p)); - FILE *f = fd == 1 ? stdout : stderr; - assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR); - fputc (VALUE (c), f); - return c; -} - -char const* -string_to_cstring (SCM s) -{ - static char buf[1024]; - char *p = buf; - s = STRING(s); - while (s != cell_nil) - { - *p++ = VALUE (car (s)); - s = cdr (s); - } - *p = 0; - return buf; -} - -int g_depth; - -#define gputs(x) fputs(x, stdout) - -SCM -display_helper (SCM x, int cont, char* sep) -{ - gputs (sep); - if (g_depth == 0) return cell_unspecified; - //FIXME: - //g_depth--; - g_depth = g_depth - 1; - - // eputs ("\n"); - switch (TYPE (x)) - { - case TCHAR: - { - //puts ("\n"); - gputs ("#\\"); - putchar (VALUE (x)); - break; - } - case TFUNCTION: - { - gputs ("#"); - break; - } - case TMACRO: - { - gputs ("#"); - break; - } - case TNUMBER: - { - //gputs ("\n"); - gputs (itoa (VALUE (x))); - break; - } - case TPAIR: - { - if (!cont) gputs ("("); - if (x && x != cell_nil) display_ (CAR (x)); - if (CDR (x) && TYPE (CDR (x)) == TPAIR) - display_helper (CDR (x), 1, " "); - else if (CDR (x) && CDR (x) != cell_nil) - { - if (TYPE (CDR (x)) != TPAIR) - gputs (" . "); - display_ (CDR (x)); - } - if (!cont) gputs (")"); - break; - } - case TSPECIAL: -#if __NYACC__ - // FIXME - //{} - { - SCM t = CAR (x); - while (t && t != cell_nil) - { - putchar (VALUE (CAR (t))); - t = CDR (t); - } - break; - } -#endif - case TSTRING: -#if __NYACC__ - // FIXME - {} -#endif - case TSYMBOL: - { - SCM t = CAR (x); - while (t && t != cell_nil) - { - putchar (VALUE (CAR (t))); - t = CDR (t); - } - break; - } - default: - { - //gputs ("\n"); - gputs ("<"); - gputs (itoa (TYPE (x))); - gputs (":"); - gputs (itoa (x)); - gputs (">"); - break; - } - } - return 0; -} - -SCM -display_ (SCM x) -{ - g_depth = 5; - return display_helper (x, 0, ""); -} - -SCM -stderr_ (SCM x) -{ - SCM write; - if (TYPE (x) == TSTRING) - fprintf (stderr, string_to_cstring (x)); - else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined) - apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0); - else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL) - fprintf (stderr, string_to_cstring (x)); - else if (TYPE (x) == TNUMBER) - fprintf (stderr, "%d", VALUE (x)); - else - fprintf (stderr, "display: undefined\n"); - return cell_unspecified; -} - -//math.c -SCM -greater_p (SCM x) ///((name . ">") (arity . n)) -{ - int n = INT_MAX; - while (x != cell_nil) - { - assert (TYPE (car (x)) == TNUMBER); - if (VALUE (car (x)) >= n) return cell_f; - n = VALUE (car (x)); - x = cdr (x); - } - return cell_t; -} - -SCM -less_p (SCM x) ///((name . "<") (arity . n)) -{ - int n = INT_MIN; - while (x != cell_nil) - { - assert (TYPE (car (x)) == TNUMBER); - if (VALUE (car (x)) <= n) return cell_f; - n = VALUE (car (x)); - x = cdr (x); - } - return cell_t; -} - -// MINI_MES+ -SCM -make_vector (SCM n) -{ - int k = VALUE (n); - g_cells[tmp_num].value = TVECTOR; - SCM v = alloc (k); - SCM x = make_cell (tmp_num, k, v); - for (int i=0; i jam[%d]\n", g_free); - return g_stack; -} - // Environment setup SCM -gc_init_cells () +gc_init_cells () ///((internal)) { g_cells = (struct scm *)malloc (2*ARENA_SIZE*sizeof(struct scm)); g_cells[0].type = TVECTOR; @@ -1405,7 +987,7 @@ gc_init_cells () } SCM -gc_init_news () +gc_init_news () ///((internal)) { g_news = g_cells-1 + ARENA_SIZE; g_news[0].type = TVECTOR; @@ -1445,26 +1027,57 @@ mes_symbols () ///((internal)) a = acons (cell_symbol_begin, cell_begin, a); a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a); a = acons (cell_symbol_sc_expand, cell_f, a); + +#if __GNUC__ + a = acons (cell_symbol_gnuc, cell_t, a); + a = acons (cell_symbol_mesc, cell_f, a); +#else + a = acons (cell_symbol_gnuc, cell_f, a); + a = acons (cell_symbol_mesc, cell_t, a); +#endif + a = acons (cell_closure, a, a); return a; } +#define gputs(x) fputs(x,stdout); + SCM mes_builtins (SCM a) ///((internal)) { #include "mes.i" -#include "lib.i" -#include "math.i" #include "posix.i" +#include "math.i" +#include "lib.i" #include "reader.i" +#include "vector.i" +#include "gc.i" +#include "gc.environment.i" #include "lib.environment.i" #include "math.environment.i" #include "mes.environment.i" #include "posix.environment.i" #include "reader.environment.i" +#include "vector.environment.i" + + if (g_debug) + { + gputs ("functions: "); + gputs (itoa (g_function)); + gputs ("\n"); + for (int i = 0; i < g_function; i++) + { + gputs ("["); + gputs (itoa (i)); + gputs ("]: "); + gputs (g_functions[i].name); + gputs ("\n"); + } + gputs ("\n"); + } return a; } @@ -1488,17 +1101,18 @@ mes_environment () ///((internal)) } FILE *g_stdin; -#include "lib.c" #include "math.c" #include "posix.c" +#include "lib.c" #include "reader.c" +#include "gc.c" +#include "vector.c" int main (int argc, char *argv[]) { #if __GNUC__ g_debug = getenv ("MES_DEBUG"); -#else #endif if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA")); if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes [--dump|--load] < FILE"); diff --git a/mlibc.c b/mlibc.c index e4442dd8..89d1d931 100644 --- a/mlibc.c +++ b/mlibc.c @@ -26,6 +26,7 @@ int open (char const *s, int mode); int read (int fd, void* buf, size_t n); void write (int fd, char const* s, int n); +#define O_RDONLY 0 #define INT_MIN -2147483648 #define INT_MAX 2147483647 @@ -239,6 +240,7 @@ getchar () i = ungetc_buf[ungetc_char--]; if (i < 0) i += 256; + return i; } diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index b715e912..0648bbc8 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -53,11 +53,12 @@ #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:) #:cpp-defs '( "__GNUC__=0" - "__MESCC__=1" - "__NYACC__=1" + "__MESC__=1" + "__NYACC__=1" ;; REMOVEME "STDIN=0" "STDOUT=1" "STDERR=2" + "O_RDONLY=0" "INT_MIN=-2147483648" "INT_MAX=2147483647" diff --git a/module/mes/display.mes b/module/mes/display.mes index 12db70db..31a0c5f8 100644 --- a/module/mes/display.mes +++ b/module/mes/display.mes @@ -94,7 +94,8 @@ (display "#" port)) - ((number? x) (display (number->string x) port)) + ((number? x) + (display (number->string x) port)) ((pair? x) (if (not cont?) (write-char #\( port)) (cond ((eq? (car x) '*circular*) diff --git a/module/mes/libc.mes b/module/mes/libc.mes index 4f575782..1c381805 100644 --- a/module/mes/libc.mes +++ b/module/mes/libc.mes @@ -91,6 +91,13 @@ getchar () ungetc_char = ungetc_char - 1; } if (i < 0) i += 256; + +#if 0 + puts (\"get: \"); + putchar (i); + puts (\"\n\"); +#endif + return i; } " diff --git a/module/mes/read-0-32.mo b/module/mes/read-0-32.mo deleted file mode 100644 index 1efbbfd7..00000000 Binary files a/module/mes/read-0-32.mo and /dev/null differ diff --git a/posix.c b/posix.c index 4e47b855..045eb1c4 100644 --- a/posix.c +++ b/posix.c @@ -18,40 +18,217 @@ * along with Mes. If not, see . */ +#if !MINI_MES #include -//MINI_MES -// SCM -// write_byte (SCM x) ///((arity . n)) -// { -// SCM c = car (x); -// SCM p = cdr (x); -// int fd = 1; -// if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p)); -// FILE *f = fd == 1 ? stdout : stderr; -// assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR); -// fputc (VALUE (c), f); -// return c; -// } +FILE *g_stdin; +int +getchar () +{ + return getc (g_stdin); +} +#endif -char const* string_to_cstring (SCM); +int +ungetchar (int c) +{ + return ungetc (c, g_stdin); +} -// SCM -// stderr_ (SCM x) -// { -// SCM write; -// if (TYPE (x) == TSTRING) -// fprintf (stderr, string_to_cstring (x)); -// else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined) -// apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0); -// else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL) -// fprintf (stderr, string_to_cstring (x)); -// else if (TYPE (x) == TNUMBER) -// fprintf (stderr, "%d", VALUE (x)); -// else -// fprintf (stderr, "display: undefined\n"); -// return cell_unspecified; -// } +int +peekchar () +{ + int c = getchar (); + ungetchar (c); + return c; +} + +SCM +peek_byte () +{ + return MAKE_NUMBER (peekchar ()); +} + +SCM +read_byte () +{ + return MAKE_NUMBER (getchar ()); +} + +SCM +unread_byte (SCM i) +{ + ungetchar (VALUE (i)); + return i; +} + +SCM +write_byte (SCM x) ///((arity . n)) +{ + SCM c = car (x); + SCM p = cdr (x); + int fd = 1; + if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p)); +#if !MES_MINI + FILE *f = fd == 1 ? stdout : stderr; + fputc (VALUE (c), f); +#else + char cc = VALUE (c); + write (1, (char*)&cc, fd); +#endif +#if __GNUC__ + assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR); +#endif + return c; +} + +char const* +string_to_cstring (SCM s) +{ + static char buf[1024]; + char *p = buf; + s = STRING(s); + while (s != cell_nil) + { + *p++ = VALUE (car (s)); + s = cdr (s); + } + *p = 0; + return buf; +} + +int g_depth; + +SCM +display_helper (SCM x, int cont, char* sep) +{ + gputs (sep); + if (g_depth == 0) return cell_unspecified; + //FIXME: + //g_depth--; + g_depth = g_depth - 1; + + // eputs ("\n"); + switch (TYPE (x)) + { + case TCHAR: + { + //gputs ("\n"); + gputs ("#\\"); + putchar (VALUE (x)); + break; + } + case TFUNCTION: + { + gputs ("#"); + break; + } + case TMACRO: + { + gputs ("#"); + break; + } + case TNUMBER: + { + //gputs ("\n"); + gputs (itoa (VALUE (x))); + break; + } + case TPAIR: + { + if (!cont) gputs ("("); + if (x && x != cell_nil) display_ (CAR (x)); + if (CDR (x) && TYPE (CDR (x)) == TPAIR) + display_helper (CDR (x), 1, " "); + else if (CDR (x) && CDR (x) != cell_nil) + { + if (TYPE (CDR (x)) != TPAIR) + gputs (" . "); + display_ (CDR (x)); + } + if (!cont) gputs (")"); + break; + } + case TSPECIAL: +#if __NYACC__ + // FIXME + //{} + { + SCM t = CAR (x); + while (t && t != cell_nil) + { + putchar (VALUE (CAR (t))); + t = CDR (t); + } + break; + } +#endif + case TSTRING: +#if __NYACC__ + // FIXME + {} +#endif + case TSYMBOL: + { + SCM t = CAR (x); + while (t && t != cell_nil) + { + putchar (VALUE (CAR (t))); + t = CDR (t); + } + break; + } + default: + { + //gputs ("\n"); + gputs ("<"); + gputs (itoa (TYPE (x))); + gputs (":"); + gputs (itoa (x)); + gputs (">"); + break; + } + } + return 0; +} + +SCM +display_ (SCM x) +{ + g_depth = 5; + return display_helper (x, 0, ""); +} + +SCM +stderr_ (SCM x) +{ + SCM write; + if (TYPE (x) == TSTRING) + eputs (string_to_cstring (x)); +#if __GNUC__ + else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined) + apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0); +#endif + else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL) + eputs (string_to_cstring (x)); + else if (TYPE (x) == TNUMBER) + eputs (itoa (VALUE (x))); + else + eputs ("core:stderr: display undefined\n"); + return cell_unspecified; +} SCM getenv_ (SCM s) ///((name . "getenv")) @@ -60,56 +237,6 @@ getenv_ (SCM s) ///((name . "getenv")) return p ? MAKE_STRING (cstring_to_list (p)) : cell_f; } -// MINI_MES -// int -// getchar () -// { -// return getc (g_stdin); -// } - -// int -// ungetchar (int c) -// { -// return ungetc (c, g_stdin); -// } - -// int -// peekchar () -// { -// int c = getchar (); -// ungetchar (c); -// return c; -// } - -// SCM -// peek_byte () -// { -// return MAKE_NUMBER (peekchar ()); -// } - -// SCM -// read_byte () -// { -// return MAKE_NUMBER (getchar ()); -// } - -// SCM -// unread_byte (SCM i) -// { -// ungetchar (VALUE (i)); -// return i; -// } - -SCM -force_output (SCM p) ///((arity . n)) -{ - int fd = 1; - if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p)); - FILE *f = fd == 1 ? stdout : stderr; - fflush (f); - return cell_unspecified; -} - SCM open_input_file (SCM file_name) { @@ -128,3 +255,13 @@ set_current_input_port (SCM port) g_stdin = VALUE (port) ? fdopen (VALUE (port), "r") : stdin; return current_input_port (); } + +SCM +force_output (SCM p) ///((arity . n)) +{ + int fd = 1; + if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p)); + FILE *f = fd == 1 ? stdout : stderr; + fflush (f); + return cell_unspecified; +} diff --git a/scaffold/b-0.mes b/scaffold/b-0.mes new file mode 100644 index 00000000..52f2e810 --- /dev/null +++ b/scaffold/b-0.mes @@ -0,0 +1,15 @@ +;;; -*-scheme-*- +(define (newline) (core:display "\n")) +(core:display "b-00\n") +(define save (current-input-port)) +(core:display "save=")(core:display save)(newline) +(core:display "b-0111\n") +(set-current-input-port (open-input-file "scaffold/t-0.mes")) +;;(set-current-input-port (open-input-file "mes/t-0.mes")) +(core:display "ipp=")(core:display (current-input-port))(newline) +(core:display "b-02\n") +(primitive-load) +(core:display "b-03\n") +(set-current-input-port save) +(core:display "b-04\n") +"42\n" diff --git a/scaffold/mini-mes.c b/scaffold/mini-mes.c index def353aa..b2fc0b2a 100644 --- a/scaffold/mini-mes.c +++ b/scaffold/mini-mes.c @@ -23,7 +23,7 @@ #endif #define assert(x) ((x) ? (void)0 : assert_fail (#x)) -#if __MESCC__ +#if __MESC__ //void *g_malloc_base = 0; char *g_malloc_base = 0; // int ungetc_char = -1; @@ -46,7 +46,7 @@ char *g_malloc_base = 0; //int ARENA_SIZE = 4000000; -int ARENA_SIZE = 100000000; +int ARENA_SIZE = 1000000000; char *arena = 0; typedef int SCM; @@ -165,6 +165,9 @@ struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0}; struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0}; struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0}; +struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0}; +struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0}; + struct scm scm_test = {TSYMBOL, "test",0}; #include "mini-mes.symbols.h" @@ -383,6 +386,20 @@ assert_defined (SCM x, SCM e) ///((internal)) return e; } +SCM +cstring_to_list (char const* s) +{ + char *x = s; + SCM p = cell_nil; + int i = strlen (s); + while (i--) + { + p = cons (MAKE_CHAR (s[i]), p); + x++; + } + return p; +} + SCM check_formals (SCM f, SCM formals, SCM args) ///((internal)) { @@ -632,7 +649,7 @@ eval_apply () case cell_vm_eval2: goto eval2; case cell_vm_macro_expand: goto macro_expand; case cell_vm_begin: goto begin; - ///case cell_vm_begin_read_input_file: goto begin_read_input_file; + case cell_vm_begin_read_input_file: goto begin_read_input_file; case cell_vm_begin2: goto begin2; case cell_vm_if: goto vm_if; case cell_vm_if_expr: goto if_expr; @@ -1066,35 +1083,13 @@ lookup_ (SCM s, SCM a) return x ? x : make_symbol_ (s); } -SCM -cstring_to_list (char const* s) -{ - char *x = s; - SCM p = cell_nil; - int i = strlen (s); - while (i--) - { - p = cons (MAKE_CHAR (s[i]), p); - x++; - } - return p; -} - SCM acons (SCM key, SCM value, SCM alist) { return cons (cons (key, value), alist); } - -// MINI_MES: temp-lib - -// int -// getchar () -// { -// return getc (g_stdin); -// } - +// Posix int ungetchar (int c) { @@ -1145,6 +1140,24 @@ write_byte (SCM x) ///((arity . n)) return c; } +char string_to_cstring_buf[1024]; +char const* +string_to_cstring (SCM s) +{ + //static char buf[1024]; + //char *p = buf; + char *p = string_to_cstring_buf; + s = STRING(s); + while (s != cell_nil) + { + *p++ = VALUE (car (s)); + s = cdr (s); + } + *p = 0; + //return buf; + return string_to_cstring_buf; +} + int g_depth; SCM @@ -1226,7 +1239,16 @@ display_helper (SCM x, int cont, char* sep) case TSTRING: #if __NYACC__ // FIXME - {} + //{} + { + SCM t = CAR (x); + while (t && t != cell_nil) + { + putchar (VALUE (CAR (t))); + t = CDR (t); + } + break; + } #endif case TSYMBOL: { @@ -1259,6 +1281,281 @@ display_ (SCM x) return display_helper (x, 0, ""); } +SCM +stderr_ (SCM x) +{ + SCM write; + if (TYPE (x) == TSTRING) + eputs (string_to_cstring (x)); +#if __GNUC__ + else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined) + apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0); +#endif + else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL) + eputs (string_to_cstring (x)); + else if (TYPE (x) == TNUMBER) + eputs (itoa (VALUE (x))); + else + eputs ("core:stderr: display undefined\n"); + return cell_unspecified; +} + +SCM +getenv_ (SCM s) ///((name . "getenv")) +{ +#if 0 + char *p = getenv (string_to_cstring (s)); + return p ? MAKE_STRING (cstring_to_list (p)) : cell_f; +#else + return cell_t; +#endif +} + +SCM +open_input_file (SCM file_name) +{ + return MAKE_NUMBER (open (string_to_cstring (file_name), O_RDONLY)); + // char *s = string_to_cstring (file_name); + // int x = open (s, 0); + // return MAKE_NUMBER (x); +} + +SCM +current_input_port () +{ + return MAKE_NUMBER (g_stdin); +} + +SCM +set_current_input_port (SCM port) +{ + g_stdin = VALUE (port) ? VALUE (port) : STDIN; + return current_input_port (); +} + +SCM +force_output (SCM p) ///((arity . n)) +{ +#if 0 + //FIXME + int fd = 1; + if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p)); + FILE *f = fd == 1 ? stdout : stderr; + fflush (f); +#endif + return cell_unspecified; +} + +// Math +SCM +greater_p (SCM x) ///((name . ">") (arity . n)) +{ + int n = INT_MAX; + while (x != cell_nil) + { + assert (TYPE (car (x)) == TNUMBER); + if (VALUE (car (x)) >= n) return cell_f; + n = VALUE (car (x)); + x = cdr (x); + } + return cell_t; +} + +SCM +less_p (SCM x) ///((name . "<") (arity . n)) +{ + int n = INT_MIN; + while (x != cell_nil) + { + assert (TYPE (car (x)) == TNUMBER); +#if __MESC__ + //FIXME __GNUC__ + if (n == INT_MIN); + else +#endif + if (VALUE (car (x)) <= n) return cell_f; + n = VALUE (car (x)); + x = cdr (x); + } + return cell_t; +} + +SCM +is_p (SCM x) ///((name . "=") (arity . n)) +{ + if (x == cell_nil) return cell_t; + assert (TYPE (car (x)) == TNUMBER); + int n = VALUE (car (x)); + x = cdr (x); + while (x != cell_nil) + { + if (VALUE (car (x)) != n) return cell_f; + x = cdr (x); + } + return cell_t; +} + +SCM +minus (SCM x) ///((name . "-") (arity . n)) +{ + SCM a = car (x); + assert (TYPE (a) == TNUMBER); + int n = VALUE (a); + x = cdr (x); + if (x == cell_nil) + n = -n; + while (x != cell_nil) + { + assert (TYPE (car (x)) == TNUMBER); +#if __GNUC__ + n -= VALUE (car (x)); +#else + n = n - VALUE (car (x)); +#endif + x = cdr (x); + } + return MAKE_NUMBER (n); +} + +SCM +plus (SCM x) ///((name . "+") (arity . n)) +{ + int n = 0; + while (x != cell_nil) + { + assert (TYPE (car (x)) == TNUMBER); +#if __GNUC__ + n += VALUE (car (x)); +#else + n = n + VALUE (car (x)); +#endif + x = cdr (x); + } + return MAKE_NUMBER (n); +} + +SCM +divide (SCM x) ///((name . "/") (arity . n)) +{ + int n = 1; + if (x != cell_nil) { + assert (TYPE (car (x)) == TNUMBER); + n = VALUE (car (x)); + x = cdr (x); + } + while (x != cell_nil) + { + assert (TYPE (car (x)) == TNUMBER); +#if __GNUC__ + n /= VALUE (car (x)); +#else + n = n / VALUE (car (x)); +#endif + x = cdr (x); + } + return MAKE_NUMBER (n); +} + +SCM +modulo (SCM a, SCM b) +{ + assert (TYPE (a) == TNUMBER); + assert (TYPE (b) == TNUMBER); + int x = VALUE (a); + while (x < 0) x += VALUE (b); + return MAKE_NUMBER (x % VALUE (b)); +} + +SCM +multiply (SCM x) ///((name . "*") (arity . n)) +{ + int n = 1; + while (x != cell_nil) + { + assert (TYPE (car (x)) == TNUMBER); +#if __GNUC__ + n *= VALUE (car (x)); +#else + n = n * VALUE (car (x)); +#endif + x = cdr (x); + } + return MAKE_NUMBER (n); +} + +SCM +logior (SCM x) ///((arity . n)) +{ + int n = 0; + while (x != cell_nil) + { + assert (TYPE (car (x)) == TNUMBER); +#if __GNUC__ + n |= VALUE (car (x)); +#else + puts ("FIXME: logior\n"); + //FIXME + //n = n | VALUE (car (x)); +#endif + x = cdr (x); + } + return MAKE_NUMBER (n); +} + +SCM +ash (SCM n, SCM count) +{ + assert (TYPE (n) == TNUMBER); + assert (TYPE (count) == TNUMBER); + int cn = VALUE (n); + int ccount = VALUE (count); +#if __GNUC__ + return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount); +#else + //FIXME + assert (ccount >= 0); + return MAKE_NUMBER (cn << ccount); +#endif +} + +// Lib [rest of] + +SCM +exit_ (SCM x) ///((name . "exit")) +{ + assert (TYPE (x) == TNUMBER); + exit (VALUE (x)); +} + +SCM +append (SCM x) ///((arity . n)) +{ + if (x == cell_nil) return cell_nil; + if (cdr (x) == cell_nil) return car (x); + return append2 (car (x), append (cdr (x))); +} + +SCM +values (SCM x) ///((arity . n)) +{ + SCM v = cons (0, x); + TYPE (v) = TVALUES; + return v; +} + +SCM +arity_ (SCM x) +{ + assert (TYPE (x) == TFUNCTION); + return MAKE_NUMBER (FUNCTION (x).arity); +} + +SCM +xassq (SCM x, SCM a) ///for speed in core only +{ + while (a != cell_nil && x != CDAR (a)) a = CDR (a); + return a != cell_nil ? CAR (a) : cell_f; +} // Jam Collector SCM g_symbol_max; @@ -1319,6 +1616,15 @@ mes_symbols () ///((internal)) a = acons (cell_symbol_begin, cell_begin, a); a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a); a = acons (cell_symbol_sc_expand, cell_f, a); + +#if __GNUC__ + a = acons (cell_symbol_gnuc, cell_t, a); + a = acons (cell_symbol_mesc, cell_f, a); +#else + a = acons (cell_symbol_gnuc, cell_f, a); + a = acons (cell_symbol_mesc, cell_t, a); +#endif + a = acons (cell_closure, a, a); return a; @@ -1377,104 +1683,42 @@ bload_env (SCM a) ///((internal)) g_symbols = r1; g_stdin = STDIN; r0 = mes_builtins (r0); -#if 1 - puts ("symbols: "); - SCM s = g_symbols; - while (s && s != cell_nil) { - display_ (CAR (s)); - puts (" "); - s = CDR (s); - } - puts ("\n"); - puts ("functions: "); - puts (itoa (g_function)); - puts ("\n"); - for (int i = 0; i < g_function; i++) + +#if __GNUC__ + set_env_x (cell_symbol_gnuc, cell_t, r0); + set_env_x (cell_symbol_mesc, cell_f, r0); +#else + set_env_x (cell_symbol_gnuc, cell_f, r0); + set_env_x (cell_symbol_mesc, cell_t, r0); +#endif + + if (g_debug) { - puts ("["); - puts (itoa (i)); - puts ("]: "); - puts (g_functions[i].name); + puts ("symbols: "); + SCM s = g_symbols; + while (s && s != cell_nil) { + display_ (CAR (s)); + puts (" "); + s = CDR (s); + } + puts ("\n"); + puts ("functions: "); + puts (itoa (g_function)); + puts ("\n"); + for (int i = 0; i < g_function; i++) + { + puts ("["); + puts (itoa (i)); + puts ("]: "); + puts (g_functions[i].name); + puts ("\n"); + } + display_ (r0); puts ("\n"); } - display_ (r0); - puts ("\n"); -#endif return r2; } -char string_to_cstring_buf[1024]; -char const* -string_to_cstring (SCM s) -{ - //static char buf[1024]; - //char *p = buf; - char *p = string_to_cstring_buf; - s = STRING(s); - while (s != cell_nil) - { - *p++ = VALUE (car (s)); - s = cdr (s); - } - *p = 0; - //return buf; - return string_to_cstring_buf; -} - -SCM -stderr_ (SCM x) -{ - //SCM write; -#if __NYACC__ || FIXME_NYACC - if (TYPE (x) == TSTRING) -// #else -// if (TYPE (x) == STRING) -#endif - eputs (string_to_cstring (x)); - // else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined) - // apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0); -#if __NYACC__ || FIXME_NYACC - else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL) -// #else -// else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL) -#endif - eputs (string_to_cstring (x)); - else if (TYPE (x) == TNUMBER) - eputs (itoa (VALUE (x))); - else - eputs ("core:stderr: display undefined\n"); - return cell_unspecified; -} - -//math.c -SCM -greater_p (SCM x) ///((name . ">") (arity . n)) -{ - int n = INT_MAX; - while (x != cell_nil) - { - assert (TYPE (car (x)) == TNUMBER); - if (VALUE (car (x)) >= n) return cell_f; - n = VALUE (car (x)); - x = cdr (x); - } - return cell_t; -} - -SCM -less_p (SCM x) ///((name . "<") (arity . n)) -{ - int n = INT_MIN; - while (x != cell_nil) - { - assert (TYPE (car (x)) == TNUMBER); - if (VALUE (car (x)) <= n) return cell_f; - n = VALUE (car (x)); - x = cdr (x); - } - return cell_t; -} - int main (int argc, char *argv[]) { @@ -1502,9 +1746,12 @@ main (int argc, char *argv[]) #endif push_cc (r2, cell_unspecified, r0, cell_unspecified); - eputs ("program: "); - display_ (r1); - eputs ("\n"); + if (g_debug) + { + eputs ("program: "); + display_ (r1); + eputs ("\n"); + } r3 = cell_vm_begin; r1 = eval_apply (); display_ (r1); diff --git a/scaffold/t-0.mes b/scaffold/t-0.mes new file mode 100644 index 00000000..075757f3 --- /dev/null +++ b/scaffold/t-0.mes @@ -0,0 +1,2 @@ +;;; -*-scheme-*- +(core:display "t00\n") diff --git a/scaffold/t.c b/scaffold/t.c index 86ffd739..1fd12f5c 100644 --- a/scaffold/t.c +++ b/scaffold/t.c @@ -184,6 +184,10 @@ math_test () i += 48; putchar (i); puts ("\n"); + + puts ("t: 3*4="); + i = 3 * 4; + if (i!=12) return 1; return read_test (); } diff --git a/vector.c b/vector.c new file mode 100644 index 00000000..abbeba3a --- /dev/null +++ b/vector.c @@ -0,0 +1,90 @@ +/* -*-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 +make_vector (SCM n) +{ + int k = VALUE (n); + g_cells[tmp_num].value = TVECTOR; + SCM v = alloc (k); + SCM x = make_cell (tmp_num, k, v); + for (int i=0; i