artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mescc: Run module/base-0.mes.

Browse source 
* 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.
This commit is contained in:
Jan Nieuwenhuizen 2017-03-26 21:13:01 +02:00
parent e460771988
commit 66b53669f8
17 changed files with 942 additions and 684 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
GNUmakefile
View file

@ -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

122
gc.c Normal file
View file

@ -0,0 +1,122 @@
/* -*-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);
}

2
guile/mescc.scm
View file

@ -5,7 +5,7 @@ exec ${GUILE-guile} -L $(pwd)/guile -e '(mescc)' -s "$0" "$@"
!#
;;; 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.
;;;

33
lib.c
View file

@ -18,13 +18,6 @@
* 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)
@ -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;
}

53
math.c
View file

@ -18,34 +18,33 @@
* 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))

498
mes.c
View file

@ -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 ("<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;
}
// 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)
{
@ -1284,116 +973,9 @@ make_tmps (struct scm* cells)
cells[tmp_num2].type = TNUMBER;
}
// 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;
}
// 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");

2
mlibc.c
View file

@ -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;
}

5
module/language/c99/compiler.mes
View file

@ -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"

3
module/mes/display.mes
View file

@ -94,7 +94,8 @@
(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*)

7
module/mes/libc.mes
View file

@ -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;
}
"

BIN
module/mes/read-0-32.mo
View file

Binary file not shown.

297
posix.c
View file

@ -18,40 +18,217 @@
* 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;
// }
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 ("<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"))
@ -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;
}

15
scaffold/b-0.mes Normal file
View file

@ -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"

491
scaffold/mini-mes.c
View file

@ -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);

2
scaffold/t-0.mes Normal file
View file

@ -0,0 +1,2 @@
;;; -*-scheme-*-
(core:display "t00\n")

4
scaffold/t.c
View file

@ -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 ();
}

90
vector.c Normal file
View file

@ -0,0 +1,90 @@
/* -*-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;
}