* gc.c: New file.
* vector.c: New file.
* mes.c: Remove vector and gc functions, include vector.c, gc.c.
* GNUmakefile (mes.o): Add gc, vector dependencies.
* scaffold/mini-mes.c (eval_apply): Support primitive-load through
read_input_file.
(getenv_, open_input_file, current_input_port,
set_current_input_port force_output, exit_, values, arity_, xassq,
is_p, minus, plus, divide, modulo multiply, logior, ash): New function.
(mes_symbols): Add symbols %gnuc, %mesc.
* scaffold/mini-mes.c (): New functions.
* scaffold/b-0.mes: New file.
* scaffold/t-0.mes: New file.
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
--- /dev/null
+/* -*-comment-start: "//";comment-end:""-*-
+ * 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/>.
+ */
+
+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<LENGTH (old); i++)
+ g_news[g_free++] = g_cells[VECTOR (old)+i];
+ }
+ g_cells[old].type = TBROKEN_HEART;
+ g_cells[old].car = new;
+ return new;
+}
+
+SCM
+gc_relocate_car (SCM new, SCM car) ///((internal))
+{
+ g_news[new].car = car;
+ return cell_unspecified;
+}
+
+SCM
+gc_relocate_cdr (SCM new, SCM cdr) ///((internal))
+{
+ g_news[new].cdr = cdr;
+ return cell_unspecified;
+}
+
+SCM
+gc_loop (SCM scan) ///((internal))
+{
+ while (scan < g_free)
+ {
+ if (NTYPE (scan) == TCLOSURE
+ || NTYPE (scan) == TCONTINUATION
+ || NTYPE (scan) == TFUNCTION
+ || NTYPE (scan) == TKEYWORD
+ || NTYPE (scan) == TMACRO
+ || NTYPE (scan) == TPAIR
+ || NTYPE (scan) == TREF
+ || scan == 1 // null
+ || NTYPE (scan) == TSPECIAL
+ || NTYPE (scan) == TSTRING
+ || NTYPE (scan) == TSYMBOL)
+ {
+ SCM car = gc_copy (g_news[scan].car);
+ gc_relocate_car (scan, car);
+ }
+ if ((NTYPE (scan) == TCLOSURE
+ || NTYPE (scan) == TCONTINUATION
+ || NTYPE (scan) == TMACRO
+ || NTYPE (scan) == TPAIR
+ || NTYPE (scan) == TVALUES)
+ && 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++;
+ }
+ return gc_flip ();
+}
+
+SCM
+gc ()
+{
+ if (g_debug) fprintf (stderr, "***gc[%d]...", g_free);
+ g_free = 1;
+ if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
+ for (int i=g_free; i<g_symbol_max; i++)
+ gc_copy (i);
+ make_tmps (g_news);
+ g_symbols = gc_copy (g_symbols);
+ SCM new = gc_copy (g_stack);
+ if (g_debug) fprintf (stderr, "new=%d\n", new, g_stack);
+ g_stack = new;
+ return gc_loop (1);
+}
!#
;;; Mes --- The Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
-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)
// }
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;
}
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";
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;
+}
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
-//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))
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"
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
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)
{
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)
{
return cons (cons (key, value), alist);
}
-//\f 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 ("<display>\n");
- switch (TYPE (x))
- {
- case TCHAR:
- {
- //puts ("<char>\n");
- gputs ("#\\");
- putchar (VALUE (x));
- break;
- }
- case TFUNCTION:
- {
- gputs ("#<procedure ");
- ///gputs (FUNCTION (x).name ? FUNCTION (x).name : "?");
- char *p = "?";
- if (FUNCTION (x).name != 0)
- p = FUNCTION (x).name;
- gputs (p);
- gputs ("[");
- gputs (itoa (CDR (x)));
- gputs (",");
- gputs (itoa (x));
- gputs ("]>");
- break;
- }
- case TMACRO:
- {
- gputs ("#<macro ");
- display_helper (cdr (x), cont, "");
- gputs (">");
- break;
- }
- case TNUMBER:
- {
- //gputs ("<number>\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 ("<default>\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;
-}
-
-//\f 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<k; i++) g_cells[v+i] = g_cells[vector_entry (cell_unspecified)];
- return x;
-}
-
-SCM
-arity_ (SCM x)
-{
- assert (TYPE (x) == TFUNCTION);
- return MAKE_NUMBER (FUNCTION (x).arity);
-}
-
-SCM
-values (SCM x) ///((arity . n))
-{
- SCM v = cons (0, x);
- TYPE (v) = TVALUES;
- return v;
-}
-
-SCM
-vector_length (SCM x)
-{
- assert (TYPE (x) == TVECTOR);
- return MAKE_NUMBER (LENGTH (x));
-}
-
-SCM
-vector_ref (SCM x, SCM i)
-{
- assert (TYPE (x) == TVECTOR);
- assert (VALUE (i) < LENGTH (x));
- SCM e = VECTOR (x) + VALUE (i);
- if (TYPE (e) == TREF) e = g_cells[e].ref;
- if (TYPE (e) == TCHAR) e = MAKE_CHAR (VALUE (e));
- if (TYPE (e) == TNUMBER) e = MAKE_NUMBER (VALUE (e));
- return e;
-}
-
-SCM
-vector_entry (SCM x) {
- if (TYPE (x) == TPAIR || TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL || TYPE (x) == TVECTOR) x = MAKE_REF (x);
- return x;
-}
-
-SCM
-vector_set_x (SCM x, SCM i, SCM e)
-{
- assert (TYPE (x) == TVECTOR);
- assert (VALUE (i) < LENGTH (x));
- g_cells[VECTOR (x)+g_cells[i].value] = g_cells[vector_entry (e)];
- 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
-vector_to_list (SCM v)
-{
- SCM x = cell_nil;
- for (int i = 0; i < LENGTH (v); i++) {
- SCM e = VECTOR (v)+i;
- if (TYPE (e) == TREF) e = g_cells[e].ref;
- x = append2 (x, cons (e, cell_nil));
- }
- return x;
-}
-
void
make_tmps (struct scm* cells)
{
cells[tmp_num2].type = TNUMBER;
}
-//\f Jam Collector
-SCM g_symbol_max;
-bool g_debug = false;
-
-SCM
-gc_up_arena ()
-{
- 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 ()
-{
- if (g_debug) fprintf (stderr, "***gc[%d]...", g_free);
- g_free = 1;
- if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
- for (int i=g_free; i<g_symbol_max; i++)
- gc_copy (i);
- make_tmps (g_news);
- g_symbols = gc_copy (g_symbols);
- SCM new = gc_copy (g_stack);
- if (g_debug) fprintf (stderr, "new=%d\n", new, g_stack);
- g_stack = new;
- return gc_loop (1);
-}
-
-SCM
-gc_loop (SCM scan)
-{
- while (scan < g_free)
- {
- if (NTYPE (scan) == TCLOSURE
- || NTYPE (scan) == TCONTINUATION
- || NTYPE (scan) == TFUNCTION
- || NTYPE (scan) == TKEYWORD
- || NTYPE (scan) == TMACRO
- || NTYPE (scan) == TPAIR
- || NTYPE (scan) == TREF
- || scan == 1 // null
- || NTYPE (scan) == TSPECIAL
- || NTYPE (scan) == TSTRING
- || NTYPE (scan) == TSYMBOL)
- {
- SCM car = gc_copy (g_news[scan].car);
- gc_relocate_car (scan, car);
- }
- if ((NTYPE (scan) == TCLOSURE
- || NTYPE (scan) == TCONTINUATION
- || NTYPE (scan) == TMACRO
- || NTYPE (scan) == TPAIR
- || NTYPE (scan) == TVALUES)
- && 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++;
- }
- return gc_flip ();
-}
-
-SCM
-gc_copy (SCM old)
-{
- 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<LENGTH (old); i++)
- g_news[g_free++] = g_cells[VECTOR (old)+i];
- }
- g_cells[old].type = TBROKEN_HEART;
- g_cells[old].car = new;
- return new;
-}
-
-SCM
-gc_relocate_car (SCM new, SCM car)
-{
- g_news[new].car = car;
- return cell_unspecified;
-}
-
-SCM
-gc_relocate_cdr (SCM new, SCM cdr)
-{
- g_news[new].cdr = cdr;
- return cell_unspecified;
-}
-
-SCM
-gc_flip ()
-{
- 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;
-}
-
//\f 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;
}
SCM
-gc_init_news ()
+gc_init_news () ///((internal))
{
g_news = g_cells-1 + ARENA_SIZE;
g_news[0].type = TVECTOR;
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;
}
}
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");
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
i = ungetc_buf[ungetc_char--];
if (i < 0) i += 256;
+
return i;
}
#: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"
(display "#<macro " port)
(display (core:cdr x) port)
(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*)
ungetc_char = ungetc_char - 1;
}
if (i < 0) i += 256;
+
+#if 0
+ puts (\"get: \");
+ putchar (i);
+ puts (\"\n\");
+#endif
+
return i;
}
"
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
+#if !MINI_MES
#include <fcntl.h>
-//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;
-// }
-
-char const* string_to_cstring (SCM);
-
-// 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;
-// }
+FILE *g_stdin;
+int
+getchar ()
+{
+ return getc (g_stdin);
+}
+#endif
+
+int
+ungetchar (int c)
+{
+ return ungetc (c, g_stdin);
+}
+
+int
+peekchar ()
+{
+ int c = getchar ();
+ ungetchar (c);
+ return c;
+}
SCM
-getenv_ (SCM s) ///((name . "getenv"))
+peek_byte ()
{
- char *p = getenv (string_to_cstring (s));
- return p ? MAKE_STRING (cstring_to_list (p)) : cell_f;
+ return MAKE_NUMBER (peekchar ());
}
-// 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
+read_byte ()
+{
+ return MAKE_NUMBER (getchar ());
+}
SCM
-force_output (SCM p) ///((arity . n))
+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;
- fflush (f);
+ 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 ("<display>\n");
+ switch (TYPE (x))
+ {
+ case TCHAR:
+ {
+ //gputs ("<char>\n");
+ gputs ("#\\");
+ putchar (VALUE (x));
+ break;
+ }
+ case TFUNCTION:
+ {
+ gputs ("#<procedure ");
+ ///gputs (FUNCTION (x).name ? FUNCTION (x).name : "?");
+ char *p = "?";
+ if (FUNCTION (x).name != 0)
+ p = FUNCTION (x).name;
+ gputs (p);
+ gputs ("[");
+ gputs (itoa (CDR (x)));
+ gputs (",");
+ gputs (itoa (x));
+ gputs ("]>");
+ break;
+ }
+ case TMACRO:
+ {
+ gputs ("#<macro ");
+ display_helper (cdr (x), cont, "");
+ gputs (">");
+ break;
+ }
+ case TNUMBER:
+ {
+ //gputs ("<number>\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 ("<default>\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"))
+{
+ char *p = getenv (string_to_cstring (s));
+ return p ? MAKE_STRING (cstring_to_list (p)) : cell_f;
+}
+
SCM
open_input_file (SCM file_name)
{
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;
+}
--- /dev/null
+;;; -*-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"
#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;
//int ARENA_SIZE = 4000000;
-int ARENA_SIZE = 100000000;
+int ARENA_SIZE = 1000000000;
char *arena = 0;
typedef int SCM;
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"
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))
{
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;
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);
}
-
-//\f MINI_MES: temp-lib
-
-// int
-// getchar ()
-// {
-// return getc (g_stdin);
-// }
-
+//\f Posix
int
ungetchar (int c)
{
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
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:
{
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;
+}
+
+//\f 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
+}
+
+//\f 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;
+}
//\f Jam Collector
SCM g_symbol_max;
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;
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++)
- {
- puts ("[");
- puts (itoa (i));
- puts ("]: ");
- puts (g_functions[i].name);
- 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)
+#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
- 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)
+ if (g_debug)
{
- assert (TYPE (car (x)) == TNUMBER);
- if (VALUE (car (x)) <= n) return cell_f;
- n = VALUE (car (x));
- x = cdr (x);
+ 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");
}
- return cell_t;
+ return r2;
}
int
#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);
--- /dev/null
+;;; -*-scheme-*-
+(core:display "t00\n")
i += 48;
putchar (i);
puts ("\n");
+
+ puts ("t: 3*4=");
+ i = 3 * 4;
+ if (i!=12) return 1;
return read_test ();
}
--- /dev/null
+/* -*-comment-start: "//";comment-end:""-*-
+ * 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/>.
+ */
+
+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<k; i++) g_cells[v+i] = g_cells[vector_entry (cell_unspecified)];
+ return x;
+}
+
+SCM
+vector_length (SCM x)
+{
+ assert (TYPE (x) == TVECTOR);
+ return MAKE_NUMBER (LENGTH (x));
+}
+
+SCM
+vector_ref (SCM x, SCM i)
+{
+ assert (TYPE (x) == TVECTOR);
+ assert (VALUE (i) < LENGTH (x));
+ SCM e = VECTOR (x) + VALUE (i);
+ if (TYPE (e) == TREF) e = g_cells[e].ref;
+ if (TYPE (e) == TCHAR) e = MAKE_CHAR (VALUE (e));
+ if (TYPE (e) == TNUMBER) e = MAKE_NUMBER (VALUE (e));
+ return e;
+}
+
+SCM
+vector_entry (SCM x) {
+ if (TYPE (x) == TPAIR || TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL || TYPE (x) == TVECTOR) x = MAKE_REF (x);
+ return x;
+}
+
+SCM
+vector_set_x (SCM x, SCM i, SCM e)
+{
+ assert (TYPE (x) == TVECTOR);
+ assert (VALUE (i) < LENGTH (x));
+ g_cells[VECTOR (x)+g_cells[i].value] = g_cells[vector_entry (e)];
+ 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
+vector_to_list (SCM v)
+{
+ SCM x = cell_nil;
+ for (int i = 0; i < LENGTH (v); i++) {
+ SCM e = VECTOR (v)+i;
+ if (TYPE (e) == TREF) e = g_cells[e].ref;
+ x = append2 (x, cons (e, cell_nil));
+ }
+ return x;
+}
projects / mes.git / commitdiff