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

core: Number based cells.

Browse source 
* mes.c (scm_t): Change car, string, ref, cdr, macro, vector into g_cell index
  [WAS]: scm_t pointer.
* define.c: Update.
* lib.c: Update.
* math.c: Update.
* posix.c: Update.
* quasiquote.c: Update.
* string.c: Update.
* type.c: Update.
* build-aux/mes-snarf.mes Update.
* tests/gc-4.test: New test.
* tests/gc-5.test: New test.
* tests/gc-6.test: New test.
This commit is contained in:
Jan Nieuwenhuizen 2016-11-21 09:28:34 +01:00
parent 25c29ecb6d
commit 61e42e8527
21 changed files with 1406 additions and 1060 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
.gitignore vendored
View file

@ -1,8 +1,9 @@
*- *-
*.cat *.cat
*.environment.h *.environment.h
*.environment.i
*.go *.go
*.h
*.i
*.o *.o
*.symbols.i *.symbols.i
*~ *~

18
GNUmakefile
View file

@ -23,14 +23,14 @@ include make/install.make
all: mes all: mes
mes.o: mes.c mes.o: mes.c
mes.o: mes.c mes.environment.h mes.environment.i mes.symbols.i mes.o: mes.c mes.h mes.i mes.environment.i mes.symbols.i
mes.o: define.c define.environment.h define.environment.i mes.o: define.c define.h define.i define.environment.i
mes.o: lib.c lib.environment.h lib.environment.i mes.o: lib.c lib.h lib.i lib.environment.i
mes.o: math.c math.environment.h math.environment.i mes.o: math.c math.h math.i math.environment.i
mes.o: posix.c posix.environment.h posix.environment.i mes.o: posix.c posix.h posix.i posix.environment.i
mes.o: quasiquote.c quasiquote.environment.h quasiquote.environment.i mes.o: quasiquote.c quasiquote.h quasiquote.i quasiquote.environment.i
mes.o: string.c string.environment.h string.environment.i mes.o: string.c string.h string.i string.environment.i
mes.o: type.c type.environment.h type.environment.i mes.o: type.c type.h type.i type.environment.i
clean: clean:
rm -f mes mes.o *.environment.i *.symbols.i *.environment.h *.cat a.out rm -f mes mes.o *.environment.i *.symbols.i *.environment.h *.cat a.out
@ -38,7 +38,7 @@ clean:
distclean: clean distclean: clean
rm -f .config.make rm -f .config.make
%.environment.h %.environment.i %.symbols.i: %.c build-aux/mes-snarf.scm %.h %.i %.environment.i %.symbols.i: %.c build-aux/mes-snarf.scm
build-aux/mes-snarf.scm $< build-aux/mes-snarf.scm $<
check: all guile-check mes-check check: all guile-check mes-check

59
build-aux/mes-snarf.scm
View file

@ -62,33 +62,50 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
(regexp-replace "_p$" "?")) (regexp-replace "_p$" "?"))
(.name f)))) (.name f))))
(define %builtin-prefix% "scm_")
(define (function-builtin-name f) (define (function-builtin-name f)
(string-append %builtin-prefix% (.name f))) (string-append %builtin-prefix% (.name f)))
(define (function->source f) (define %cell-prefix% "cell_")
(format #f "a = add_environment (a, ~S, &~a);\n" (function-scm-name f) (function-builtin-name f))) (define (function-cell-name f)
(string-append %cell-prefix% (.name f)))
(define (symbol->source s) (define (function->source f i)
(format #f "symbols = cons (&~a, symbols);\n" s)) (string-append
(format #f "cell_~a = g_free.value++;\n" (.name f))
(format #f "g_cells[cell_~a] = ~a;\n" (.name f) (function-builtin-name f))))
(define %builtin-prefix% "scm_") (define (function->environment f i)
(define (function->header f) (string-append
(format #f "a = add_environment (a, ~S, ~a);\n" (function-scm-name f) (function-cell-name f))))
(define %start 1)
(define (symbol->header s i)
(format #f "SCM cell_~a;\n" s))
(define (symbol->source s i)
(string-append
(format #f "cell_~a = g_free.value++;\n" s)
(format #f "g_cells[cell_~a] = scm_~a;\n" s s)))
(define (function->header f i)
(let* ((arity (or (assoc-ref (.annotation f) 'arity) (let* ((arity (or (assoc-ref (.annotation f) 'arity)
(if (string-null? (.formals f)) 0 (if (string-null? (.formals f)) 0
(length (string-split (.formals f) #\,))))) (length (string-split (.formals f) #\,)))))
(n (if (eq? arity 'n) -1 arity))) (n (if (eq? arity 'n) -1 arity)))
(string-append (format #f "scm *~a (~a);\n" (.name f) (.formals f)) (string-append (format #f "SCM ~a (~a);\n" (.name f) (.formals f))
(format #f "function fun_~a = {.function~a=&~a, .arity=~a};\n" (.name f) arity (.name f) n) (format #f "function fun_~a = {.function~a=&~a, .arity=~a};\n" (.name f) arity (.name f) n)
(format #f "scm ~a = {FUNCTION, .name=~S, .function=&fun_~a};\n" (function-builtin-name f) (function-scm-name f) (.name f))))) (format #f "scm ~a = {FUNCTION, .name=~S, .function=&fun_~a};\n" (function-builtin-name f) (function-scm-name f) (.name f))
(format #f "SCM cell_~a = ~a;\n" (.name f) i))))
(define (snarf-symbols string) (define (snarf-symbols string)
(let* ((matches (append (list-matches "\nscm ([a-z_0-9]+) = [{](SCM)," string) (let* ((matches (append (list-matches "\nscm scm_([a-z_0-9]+) = [{](SPECIAL)," string)
(list-matches "\nscm ([a-z_0-9]+) = [{](SYMBOL)," string)))) (list-matches "\nscm scm_([a-z_0-9]+) = [{](SYMBOL)," string))))
(map (cut match:substring <> 1) matches))) (map (cut match:substring <> 1) matches)))
(define (snarf-functions string) (define (snarf-functions string)
(let* ((matches (list-matches (let* ((matches (list-matches
"\nscm [*]\n?([a-z0-9_]+) [(]((scm *[^,)]+|, )*)[)][^\n(]*([^\n]*)" "\nSCM[ \n]?([a-z0-9_]+) [(]((SCM ?[^,)]+|, )*)[)][^\n(]*([^\n]*)"
string))) string)))
(map (lambda (m) (map (lambda (m)
(make <function> (make <function>
@ -115,15 +132,21 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
(symbols (snarf-symbols string)) (symbols (snarf-symbols string))
(base-name (basename file-name ".c")) (base-name (basename file-name ".c"))
(header (make <file> (header (make <file>
#:name (string-append base-name ".environment.h") #:name (string-append base-name ".h")
#:content (string-join (map function->header functions) ""))) #:content (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
(source (make <file>
#:name (string-append base-name ".i")
#:content (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
(environment (make <file> (environment (make <file>
#:name (string-append base-name ".environment.i") #:name (string-append base-name ".environment.i")
#:content (string-join (map function->source (filter (negate no-environment?) functions)) ""))) #:content (string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
(symbols (make <file> (symbols.h (make <file>
#:name (string-append base-name ".symbols.i") #:name (string-append base-name ".symbols.h")
#:content (string-join (map symbol->source symbols) "")))) #:content (string-join (map symbol->header symbols (iota (length symbols) %start)) "")))
(list header environment symbols))) (symbols.i (make <file>
#:name (string-append base-name ".symbols.i")
#:content (string-join (map symbol->source symbols (iota (length symbols))) ""))))
(list header source environment symbols.h symbols.i)))
(define (file-write file) (define (file-write file)
(with-output-to-file (.name file) (lambda () (display (.content file))))) (with-output-to-file (.name file) (lambda () (display (.content file)))))

34
define.c
View file

@ -19,42 +19,42 @@
*/ */
#if !BOOT #if !BOOT
scm * SCM
define_env (scm *e, scm *a) define_env (SCM e, SCM a)
{ {
return vm_call (vm_define_env, e, &scm_undefined, a); return vm_call (vm_define_env, e, cell_undefined, a);
} }
scm * SCM
vm_define_env () vm_define_env ()
{ {
scm *x; SCM x;
scm *name = cadr (r1); SCM name = cadr (r1);
if (name->type != PAIR) if (type (name) != PAIR)
x = eval_env (caddr (r1), cons (cons (cadr (r1), cadr (r1)), r0)); x = eval_env (caddr (r1), cons (cons (cadr (r1), cadr (r1)), r0));
else { else {
name = car (name); name = car (name);
scm *p = pairlis (cadr (r1), cadr (r1), r0); SCM p = pairlis (cadr (r1), cadr (r1), r0);
cache_invalidate_range (p, r0); cache_invalidate_range (p, r0);
x = eval_env (make_lambda (cdadr (r1), cddr (r1)), p); x = eval_env (make_lambda (cdadr (r1), cddr (r1)), p);
} }
if (eq_p (car (r1), &symbol_define_macro) == &scm_t) if (eq_p (car (r1), cell_symbol_define_macro) == cell_t)
x = make_macro (name, x); x = make_macro (name, x);
scm *entry = cons (name, x); SCM entry = cons (name, x);
scm *aa = cons (entry, &scm_nil); SCM aa = cons (entry, cell_nil);
set_cdr_x (aa, cdr (r0)); set_cdr_x (aa, cdr (r0));
set_cdr_x (r0, aa); set_cdr_x (r0, aa);
scm *cl = assq (&scm_closure, r0); SCM cl = assq (cell_closure, r0);
set_cdr_x (cl, aa); set_cdr_x (cl, aa);
return entry; return entry;
} }
#else // BOOT #else // BOOT
scm*define_env (scm *r1, scm *a){} SCM define_env (SCM r1, SCM a){}
scm*vm_define_env (scm *r1, scm *a){} SCM vm_define_env (SCM r1, SCM a){}
#endif #endif
scm * SCM
define_macro (scm *r1, scm *a) define_macro (SCM r1, SCM a)
{ {
} }

92
lib.c
View file

@ -18,24 +18,24 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>. * along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/ */
scm *caar (scm *x) {return car (car (x));} SCM caar (SCM x) {return car (car (x));}
scm *cadr (scm *x) {return car (cdr (x));} SCM cadr (SCM x) {return car (cdr (x));}
scm *cdar (scm *x) {return cdr (car (x));} SCM cdar (SCM x) {return cdr (car (x));}
scm *cddr (scm *x) {return cdr (cdr (x));} SCM cddr (SCM x) {return cdr (cdr (x));}
scm *caaar (scm *x) {return car (car (car (x)));} SCM caaar (SCM x) {return car (car (car (x)));}
scm *caadr (scm *x) {return car (car (cdr (x)));} SCM caadr (SCM x) {return car (car (cdr (x)));}
scm *caddr (scm *x) {return car (cdr (cdr (x)));} SCM caddr (SCM x) {return car (cdr (cdr (x)));}
scm *cdadr (scm *x) {return cdr (car (cdr (x)));} SCM cdadr (SCM x) {return cdr (car (cdr (x)));}
scm *cadar (scm *x) {return car (cdr (car (x)));} SCM cadar (SCM x) {return car (cdr (car (x)));}
scm *cddar (scm *x) {return cdr (cdr (car (x)));} SCM cddar (SCM x) {return cdr (cdr (car (x)));}
scm *cdddr (scm *x) {return cdr (cdr (cdr (x)));} SCM cdddr (SCM x) {return cdr (cdr (cdr (x)));}
scm *cadddr (scm *x) {return car (cdr (cdr (cdr (x))));} SCM cadddr (SCM x) {return car (cdr (cdr (cdr (x))));}
scm * SCM
length (scm *x) length (SCM x)
{ {
int n = 0; int n = 0;
while (x != &scm_nil) while (x != cell_nil)
{ {
n++; n++;
x = cdr (x); x = cdr (x);
@ -43,59 +43,59 @@ length (scm *x)
return make_number (n); return make_number (n);
} }
scm * SCM
last_pair (scm *x) last_pair (SCM x)
{ {
while (x != &scm_nil && cdr (x) != &scm_nil) while (x != cell_nil && cdr (x) != cell_nil)
x = cdr (x); x = cdr (x);
return x; return x;
} }
scm * SCM
list (scm *x) ///((arity . n)) list (SCM x) ///((arity . n))
{ {
return x; return x;
} }
scm * SCM
list_ref (scm *x, scm *k) list_ref (SCM x, SCM k)
{ {
assert (x->type == PAIR); assert (type (x) == PAIR);
assert (k->type == NUMBER); assert (type (k) == NUMBER);
int n = k->value; int n = value (k);
while (n-- && x->cdr != &scm_nil) x = x->cdr; while (n-- && g_cells[x].cdr != cell_nil) x = g_cells[x].cdr;
return x != &scm_nil ? x->car : &scm_undefined; return x != cell_nil ? car (x) : cell_undefined;
} }
scm * SCM
vector_to_list (scm *v) vector_to_list (SCM v)
{ {
scm *x = &scm_nil; SCM x = cell_nil;
for (int i = 0; i < v->length; i++) { for (int i = 0; i < LENGTH (v); i++) {
scm *e = &v->vector[i]; SCM e = VECTOR (v)+i;
if (e->type == REF) e = e->ref; if (type (e) == REF) e = g_cells[e].ref;
x = append2 (x, cons (e, &scm_nil)); x = append2 (x, cons (e, cell_nil));
} }
return x; return x;
} }
scm * SCM
integer_to_char (scm *x) integer_to_char (SCM x)
{ {
assert (x->type == NUMBER); assert (type (x) == NUMBER);
return make_char (x->value); return make_char (value (x));
} }
scm * SCM
char_to_integer (scm *x) char_to_integer (SCM x)
{ {
assert (x->type == CHAR); assert (type (x) == CHAR);
return make_number (x->value); return make_number (value (x));
} }
scm * SCM
builtin_exit (scm *x) builtin_exit (SCM x)
{ {
assert (x->type == NUMBER); assert (type (x) == NUMBER);
exit (x->value); exit (value (x));
} }

118
math.c
View file

@ -18,127 +18,127 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>. * along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/ */
scm * SCM
greater_p (scm *x) ///((name . ">") (arity . n)) greater_p (SCM x) ///((name . ">") (arity . n))
{ {
int n = INT_MAX; int n = INT_MAX;
while (x != &scm_nil) while (x != cell_nil)
{ {
assert (x->car->type == NUMBER); assert (g_cells[car (x)].type == NUMBER);
if (x->car->value >= n) return &scm_f; if (value (car (x)) >= n) return cell_f;
n = x->car->value; n = value (car (x));
x = cdr (x); x = cdr (x);
} }
return &scm_t; return cell_t;
} }
scm * SCM
less_p (scm *x) ///((name . "<") (arity . n)) less_p (SCM x) ///((name . "<") (arity . n))
{ {
int n = INT_MIN; int n = INT_MIN;
while (x != &scm_nil) while (x != cell_nil)
{ {
assert (x->car->type == NUMBER); assert (g_cells[car (x)].type == NUMBER);
if (x->car->value <= n) return &scm_f; if (value (car (x)) <= n) return cell_f;
n = x->car->value; n = value (car (x));
x = cdr (x); x = cdr (x);
} }
return &scm_t; return cell_t;
} }
scm * SCM
is_p (scm *x) ///((name . "=") (arity . n)) is_p (SCM x) ///((name . "=") (arity . n))
{ {
if (x == &scm_nil) return &scm_t; if (x == cell_nil) return cell_t;
assert (x->car->type == NUMBER); assert (g_cells[car (x)].type == NUMBER);
int n = x->car->value; int n = value (car (x));
x = cdr (x); x = cdr (x);
while (x != &scm_nil) while (x != cell_nil)
{ {
if (x->car->value != n) return &scm_f; if (value (car (x)) != n) return cell_f;
x = cdr (x); x = cdr (x);
} }
return &scm_t; return cell_t;
} }
scm * SCM
minus (scm *x) ///((name . "-") (arity . n)) minus (SCM x) ///((name . "-") (arity . n))
{ {
scm *a = car (x); SCM a = car (x);
assert (a->type == NUMBER); assert (g_cells[a].type == NUMBER);
int n = a->value; int n = value (a);
x = cdr (x); x = cdr (x);
if (x == &scm_nil) if (x == cell_nil)
n = -n; n = -n;
while (x != &scm_nil) while (x != cell_nil)
{ {
assert (x->car->type == NUMBER); assert (g_cells[car (x)].type == NUMBER);
n -= x->car->value; n -= value (car (x));
x = cdr (x); x = cdr (x);
} }
return make_number (n); return make_number (n);
} }
scm * SCM
plus (scm *x) ///((name . "+") (arity . n)) plus (SCM x) ///((name . "+") (arity . n))
{ {
int n = 0; int n = 0;
while (x != &scm_nil) while (x != cell_nil)
{ {
assert (x->car->type == NUMBER); assert (g_cells[car (x)].type == NUMBER);
n += x->car->value; n += value (car (x));
x = cdr (x); x = cdr (x);
} }
return make_number (n); return make_number (n);
} }
scm * SCM
divide (scm *x) ///((name . "/") (arity . n)) divide (SCM x) ///((name . "/") (arity . n))
{ {
int n = 1; int n = 1;
if (x != &scm_nil) { if (x != cell_nil) {
assert (x->car->type == NUMBER); assert (g_cells[car (x)].type == NUMBER);
n = x->car->value; n = value (car (x));
x = cdr (x); x = cdr (x);
} }
while (x != &scm_nil) while (x != cell_nil)
{ {
assert (x->car->type == NUMBER); assert (g_cells[car (x)].type == NUMBER);
n /= x->car->value; n /= value (car (x));
x = cdr (x); x = cdr (x);
} }
return make_number (n); return make_number (n);
} }
scm * SCM
modulo (scm *a, scm *b) modulo (SCM a, SCM b)
{ {
assert (a->type == NUMBER); assert (g_cells[a].type == NUMBER);
assert (b->type == NUMBER); assert (g_cells[b].type == NUMBER);
return make_number (a->value % b->value); return make_number (value (a) % value (b));
} }
scm * SCM
multiply (scm *x) ///((name . "*") (arity . n)) multiply (SCM x) ///((name . "*") (arity . n))
{ {
int n = 1; int n = 1;
while (x != &scm_nil) while (x != cell_nil)
{ {
assert (x->car->type == NUMBER); assert (g_cells[car (x)].type == NUMBER);
n *= x->car->value; n *= value (car (x));
x = cdr (x); x = cdr (x);
} }
return make_number (n); return make_number (n);
} }
scm * SCM
logior (scm *x) ///((arity . n)) logior (SCM x) ///((arity . n))
{ {
int n = 0; int n = 0;
while (x != &scm_nil) while (x != cell_nil)
{ {
assert (x->car->type == NUMBER); assert (g_cells[car (x)].type == NUMBER);
n |= x->car->value; n |= value (car (x));
x = cdr (x); x = cdr (x);
} }
return make_number (n); return make_number (n);

1586
mes.c
View file

File diff suppressed because it is too large Load diff

22
posix.c
View file

@ -21,34 +21,34 @@
#include <fcntl.h> #include <fcntl.h>
char const* char const*
string_to_cstring (scm *s) string_to_cstring (SCM s)
{ {
static char buf[1024]; static char buf[1024];
char *p = buf; char *p = buf;
s = s->string; s = STRING (s);
while (s != &scm_nil) while (s != cell_nil)
{ {
*p++ = s->car->value; *p++ = value (car (s));
s = s->cdr; s = cdr (s);
} }
*p = 0; *p = 0;
return buf; return buf;
} }
scm * SCM
open_input_file (scm *file_name) open_input_file (SCM file_name)
{ {
return make_number (open (string_to_cstring (file_name), O_RDONLY)); return make_number (open (string_to_cstring (file_name), O_RDONLY));
} }
scm * SCM
current_input_port () current_input_port ()
{ {
return make_number (fileno (g_stdin)); return make_number (fileno (g_stdin));
} }
scm * SCM
set_current_input_port (scm *port) set_current_input_port (SCM port)
{ {
g_stdin = fdopen (port->value, "r"); g_stdin = fdopen (value (port), "r");
} }

104
quasiquote.c
View file

@ -19,35 +19,35 @@
*/ */
#if QUASIQUOTE #if QUASIQUOTE
scm *add_environment (scm *a, char const *name, scm *x); SCM add_environment (SCM a, char const *name, SCM x);
scm * SCM
unquote (scm *x) ///((no-environment)) unquote (SCM x) ///((no-environment))
{ {
return cons (&symbol_unquote, x); return cons (cell_symbol_unquote, x);
} }
scm * SCM
unquote_splicing (scm *x) ///((no-environment)) unquote_splicing (SCM x) ///((no-environment))
{ {
return cons (&symbol_unquote_splicing, x); return cons (cell_symbol_unquote_splicing, x);
} }
scm * SCM
eval_quasiquote (scm *e, scm *a) eval_quasiquote (SCM e, SCM a)
{ {
return vm_call (vm_eval_quasiquote, e, &scm_undefined, a); return vm_call (vm_eval_quasiquote, e, cell_undefined, a);
} }
scm * SCM
vm_eval_quasiquote () vm_eval_quasiquote ()
{ {
if (r1 == &scm_nil) return r1; if (r1 == cell_nil) return r1;
else if (atom_p (r1) == &scm_t) return r1; else if (atom_p (r1) == cell_t) return r1;
else if (eq_p (car (r1), &symbol_unquote) == &scm_t) else if (eq_p (car (r1), cell_symbol_unquote) == cell_t)
return eval_env (cadr (r1), r0); return eval_env (cadr (r1), r0);
else if (r1->type == PAIR && r1->car->type == PAIR else if (type (r1) == PAIR && g_cells[car (r1)].type == PAIR
&& eq_p (caar (r1), &symbol_unquote_splicing) == &scm_t) && eq_p (caar (r1), cell_symbol_unquote_splicing) == cell_t)
{ {
r2 = eval_env (cadar (r1), r0); r2 = eval_env (cadar (r1), r0);
return append2 (r2, eval_quasiquote (cdr (r1), r0)); return append2 (r2, eval_quasiquote (cdr (r1), r0));
@ -56,71 +56,71 @@ vm_eval_quasiquote ()
return cons (r2, eval_quasiquote (cdr (r1), r0)); return cons (r2, eval_quasiquote (cdr (r1), r0));
} }
scm * SCM
the_unquoters = &scm_nil; the_unquoters = 0;
scm * SCM
add_unquoters (scm *a) add_unquoters (SCM a)
{ {
if (the_unquoters == &scm_nil) if (the_unquoters == 0)
the_unquoters = cons (cons (&symbol_unquote, &scm_unquote), the_unquoters = cons (cons (cell_symbol_unquote, cell_unquote),
cons (cons (&symbol_unquote_splicing, &scm_unquote_splicing), cons (cons (cell_symbol_unquote_splicing, cell_unquote_splicing),
&scm_nil)); cell_nil));
return append2 (the_unquoters, a); return append2 (the_unquoters, a);
} }
#else // !QUASIQUOTE #else // !QUASIQUOTE
scm*add_unquoters (scm *a){} SCM add_unquoters (SCM a){}
scm*eval_quasiquote (scm *e, scm *a){} SCM eval_quasiquote (SCM e, SCM a){}
#endif // QUASIQUOTE #endif // QUASIQUOTE
#if QUASISYNTAX #if QUASISYNTAX
scm * SCM
syntax (scm *x) syntax (SCM x)
{ {
return cons (&symbol_syntax, x); return cons (cell_symbol_syntax, x);
} }
scm * SCM
unsyntax (scm *x) ///((no-environment)) unsyntax (SCM x) ///((no-environment))
{ {
return cons (&symbol_unsyntax, x); return cons (cell_symbol_unsyntax, x);
} }
scm * SCM
unsyntax_splicing (scm *x) ///((no-environment)) unsyntax_splicing (SCM x) ///((no-environment))
{ {
return cons (&symbol_unsyntax_splicing, x); return cons (cell_symbol_unsyntax_splicing, x);
} }
scm * SCM
eval_quasisyntax (scm *e, scm *a) eval_quasisyntax (SCM e, SCM a)
{ {
if (e == &scm_nil) return e; if (e == cell_nil) return e;
else if (atom_p (e) == &scm_t) return e; else if (atom_p (e) == cell_t) return e;
else if (eq_p (car (e), &symbol_unsyntax) == &scm_t) else if (eq_p (car (e), cell_symbol_unsyntax) == cell_t)
return eval_env (cadr (e), a); return eval_env (cadr (e), a);
else if (e->type == PAIR && e->car->type == PAIR else if (g_cells[e].type == PAIR && g_cells[car (e)].type == PAIR
&& eq_p (caar (e), &symbol_unsyntax_splicing) == &scm_t) && eq_p (caar (e), cell_symbol_unsyntax_splicing) == cell_t)
return append2 (eval_env (cadar (e), a), eval_quasisyntax (cdr (e), a)); return append2 (eval_env (cadar (e), a), eval_quasisyntax (cdr (e), a));
return cons (eval_quasisyntax (car (e), a), eval_quasisyntax (cdr (e), a)); return cons (eval_quasisyntax (car (e), a), eval_quasisyntax (cdr (e), a));
} }
scm * SCM
add_unsyntaxers (scm *a) add_unsyntaxers (SCM a)
{ {
a = cons (cons (&symbol_unsyntax, &scm_unsyntax), a); a = cons (cons (cell_symbol_unsyntax, cell_unsyntax), a);
a = cons (cons (&symbol_unsyntax_splicing, &scm_unsyntax_splicing), a); a = cons (cons (cell_symbol_unsyntax_splicing, cell_unsyntax_splicing), a);
return a; return a;
} }
#else // !QUASISYNTAX #else // !QUASISYNTAX
scm*syntax (scm *x){} SCM syntax (SCM x){}
scm*unsyntax (scm *x){} SCM unsyntax (SCM x){}
scm*unsyntax_splicing (scm *x){} SCM unsyntax_splicing (SCM x){}
scm*add_unsyntaxers (scm *a){} SCM add_unsyntaxers (SCM a){}
scm*eval_unsyntax (scm *e, scm *a){} SCM eval_unsyntax (SCM e, SCM a){}
scm*eval_quasisyntax (scm *e, scm *a){} SCM eval_quasisyntax (SCM e, SCM a){}
#endif // !QUASISYNTAX #endif // !QUASISYNTAX

102
string.c
View file

@ -18,78 +18,78 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>. * along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/ */
scm * SCM
string (scm *x) ///((arity . n)) string (SCM x) ///((arity . n))
{ {
return make_string (x); return make_string (x);
} }
scm * SCM
string_append (scm *x) ///((arity . n)) string_append (SCM x) ///((arity . n))
{ {
scm *p = &scm_nil; SCM p = cell_nil;
while (x != &scm_nil) while (x != cell_nil)
{ {
scm *s = car (x); SCM s = car (x);
assert (s->type == STRING); assert (g_cells[s].type == STRING);
p = append2 (p, s->string); p = append2 (p, STRING (s));
x = cdr (x); x = cdr (x);
} }
return make_string (p); return make_string (p);
} }
scm * SCM
list_to_string (scm *x) list_to_string (SCM x)
{ {
return make_string (x); return make_string (x);
} }
scm * SCM
string_length (scm *x) string_length (SCM x)
{ {
assert (x->type == STRING); assert (g_cells[x].type == STRING);
return make_number (length (x->string)->value); return make_number (value (length (STRING (x))));
} }
scm * SCM
string_ref (scm *x, scm *k) string_ref (SCM x, SCM k)
{ {
assert (x->type == STRING); assert (g_cells[x].type == STRING);
assert (k->type == NUMBER); assert (g_cells[k].type == NUMBER);
scm n = {NUMBER, .value=k->value}; g_cells[tmp_num].value = value (k);
return make_char (list_ref (x->string, &n)->value); return make_char (value (list_ref (STRING (x), tmp_num)));
} }
scm * SCM
substring (scm *x) ///((arity . n)) substring (SCM x) ///((arity . n))
{ {
assert (x->type == PAIR); assert (g_cells[x].type == PAIR);
assert (x->car->type == STRING); assert (g_cells[car (x)].type == STRING);
scm *s = x->car->string; SCM s = g_cells[car (x)].string;
assert (x->cdr->car->type == NUMBER); assert (g_cells[cadr (x)].type == NUMBER);
int start = x->cdr->car->value; int start = g_cells[cadr (x)].value;
int end = length (s)->value; int end = g_cells[length (s)].value;
if (x->cdr->cdr->type == PAIR) { if (g_cells[cddr (x)].type == PAIR) {
assert (x->cdr->cdr->car->type == NUMBER); assert (g_cells[caddr (x)].type == NUMBER);
assert (x->cdr->cdr->car->value <= end); assert (g_cells[caddr (x)].value <= end);
end = x->cdr->cdr->car->value; end = g_cells[caddr (x)].value;
} }
int n = end - start; int n = end - start;
while (start--) s = s->cdr; while (start--) s = cdr (s);
scm *p = &scm_nil; SCM p = cell_nil;
while (n-- && s != &scm_nil) { while (n-- && s != cell_nil) {
p = append2 (p, cons (make_char (s->car->value), &scm_nil)); p = append2 (p, cons (make_char (g_cells[car (s)].value), cell_nil));
s = s->cdr; s = cdr (s);
} }
return make_string (p); return make_string (p);
} }
scm * SCM
number_to_string (scm *x) number_to_string (SCM x)
{ {
assert (x->type == NUMBER); assert (g_cells[x].type == NUMBER);
int n = x->value; int n = value (x);
scm *p = n < 0 ? cons (make_char ('-'), &scm_nil) : &scm_nil; SCM p = n < 0 ? cons (make_char ('-'), cell_nil) : cell_nil;
do { do {
p = cons (make_char (n % 10 + '0'), p); p = cons (make_char (n % 10 + '0'), p);
n = n / 10; n = n / 10;
@ -97,16 +97,16 @@ number_to_string (scm *x)
return make_string (p); return make_string (p);
} }
scm * SCM
string_to_symbol (scm *x) string_to_symbol (SCM x)
{ {
assert (x->type == STRING); assert (g_cells[x].type == STRING);
return make_symbol (x->string); return make_symbol (STRING (x));
} }
scm * SCM
symbol_to_string (scm *x) symbol_to_string (SCM x)
{ {
assert (x->type == SYMBOL); assert (g_cells[x].type == SYMBOL);
return make_string (x->string); return make_string (STRING (x));
} }

1
tests/base.test
View file

@ -1,5 +1,6 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-scheme-*-
set -x
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@" echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@"
#paredit:|| #paredit:||
exit $? exit $?

68
tests/gc-0.test
View file

@ -1,6 +1,6 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-scheme-*-
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@" echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/..//mes "$@"
#paredit:|| #paredit:||
exit $? exit $?
!# !#
@ -30,12 +30,68 @@ exit $?
(define pair (gc-make-cell 3 zero one)) (define pair (gc-make-cell 3 zero one))
(define zero-list (gc-make-cell 3 zero '())) (define zero-list (gc-make-cell 3 zero '()))
(define v (gc-make-vector 1)) (define v (gc-make-vector 1))
(display v) (newline)
(vector-set! v 0 88) (vector-set! v 0 88)
(define zero-v-list (gc-make-cell 3 v zero-list)) (define zero-v-list (gc-make-cell 3 v zero-list))
(define list (gc-make-cell 3 (gc-make-cell 3 zero one) zero-v-list)) (define list (gc-make-cell 3 (gc-make-cell 3 zero one) zero-v-list))
(display "list: ") (display list) (newline) (display "list: ") (display list) (newline)
(display "cells:") (display %the-cells) (newline) (display "v: ") (display v) (newline)
(gc list) (gc)
(display "gc done\n") (display "list: ") (display list) (newline)
(display "scm old:") (display %new-cells) (newline) (display "v: ") (display v) (newline)
(display "scm cells:") (display %the-cells) (newline) (gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
(gc)
(display "list: ") (display list) (newline)
(display "v: ") (display v) (newline)
;; (display "list: ") (display list) (newline)
;; (display "v: ") (display v) (newline)
;;(gc-show)
;;(display "cells:") (display %the-cells) (newline)
;;(gc list)
;; (display "gc done\n")
;; (display "scm old:") (display %new-cells) (newline)
;; (display "scm cells:") (display %the-cells) (newline)

2
tests/gc-1.test
View file

@ -1,6 +1,6 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-scheme-*-
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@" echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@"
#paredit:|| #paredit:||
exit $? exit $?
!# !#

2
tests/gc-2.test
View file

@ -1,7 +1,7 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-scheme-*-
set -x set -x
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@" echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@"
#paredit:|| #paredit:||
exit $? exit $?
!# !#

2
tests/gc-2a.test
View file

@ -1,7 +1,7 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-scheme-*-
set -x set -x
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@" echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@"
#paredit:|| #paredit:||
exit $? exit $?
!# !#

48
tests/gc-3.test
View file

@ -1,7 +1,7 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-scheme-*-
set -x set -x
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@" echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@"
#paredit:|| #paredit:||
exit $? exit $?
!# !#
@ -33,8 +33,8 @@ exit $?
;; (display (eq? *top-begin-define-a* '*top-begin-define-a*)) ;; (display (eq? *top-begin-define-a* '*top-begin-define-a*))
;; (newline) ;; (newline)
(display 'HALLO) (newline) ;; (display 'HALLO) (newline)
(display 'foo-test:) (newline) ;; (display 'foo-test:) (newline)
(display 1)(newline) (display 1)(newline)
(display 2)(newline) (display 2)(newline)
(display 3)(newline) (display 3)(newline)
@ -56,28 +56,28 @@ exit $?
(display 18)(newline) (display 18)(newline)
(display 19)(newline) (display 19)(newline)
(display 20)(newline) ;; (display 20)(newline)
(display 21)(newline) ;; (display 21)(newline)
(display 22)(newline) ;; (display 22)(newline)
(display 23)(newline) ;; (display 23)(newline)
(display 24)(newline) ;; (display 24)(newline)
(display 25)(newline) ;; (display 25)(newline)
(display 26)(newline) ;; (display 26)(newline)
(display 27)(newline) ;; (display 27)(newline)
(display 28)(newline) ;; (display 28)(newline)
(display 29)(newline) ;; (display 29)(newline)
(display 30)(newline) ;; (display 30)(newline)
(display 31)(newline) ;; (display 31)(newline)
(display 32)(newline) ;; (display 32)(newline)
(display 33)(newline) ;; (display 33)(newline)
(display 34)(newline) ;; (display 34)(newline)
(display 35)(newline) ;; (display 35)(newline)
(display 36)(newline) ;; (display 36)(newline)
(display 37)(newline) ;; (display 37)(newline)
(display 38)(newline) ;; (display 38)(newline)
(display 39)(newline) ;; (display 39)(newline)
(display 40)(newline) ;; (display 40)(newline)
;; (display 41)(newline) ;; (display 41)(newline)
;; (display 42)(newline) ;; (display 42)(newline)

38
tests/gc-4.test Executable file
View file

@ -0,0 +1,38 @@
#! /bin/sh
# -*-scheme-*-
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/..//mes "$@"
#paredit:||
exit $?
!#
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(define v #(0 1 2))
(display "v: ") (display v) (newline)
(gc)
(display "v: ") (display v) (newline)
(gc)
(display "v: ") (display v) (newline)
(gc)
(display "v: ") (display v) (newline)
(gc)
(display "v: ") (display v) (newline)

37
tests/gc-5.test Executable file
View file

@ -0,0 +1,37 @@
#! /bin/sh
# -*-scheme-*-
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/..//mes "$@"
#paredit:||
exit $?
!#
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(define v (values 0 1 2))
(display "v: ") (display v) (newline)
(gc)
(display "v: ") (display v) (newline)
(gc)
(display "v: ") (display v) (newline)
(gc)
(display "v: ") (display v) (newline)
(gc)
(display "v: ") (display v) (newline)

47
tests/gc-6.test Executable file
View file

@ -0,0 +1,47 @@
#! /bin/sh
# -*-scheme-*-
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/..//mes "$@"
#paredit:||
exit $?
!#
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(define (cwv)
(display "cwvf=") (display call-with-values-env) (newline)
(call-with-values (lambda () (values 1 2 3))
(lambda (a b c) (+ a b c))))
(display "cwv:") (display cwv) (newline)
(display "cdr cwv:") (display (cdr cwv)) (newline)
(display "(cwv):") (display (cwv)) (newline)
;;(display "current-module:") (display (current-module)) (newline)
(gc)
(display "cwv:") (display cwv) (newline)
(display "cdr cwv:") (display (cdr cwv)) (newline)
;;(display "current-module:") (display (current-module)) (newline)
(display "(cwv):") (display (cwv)) (newline)
(gc)
(display "cwv:") (display cwv) (newline)
(display "cdr cwv:") (display (cdr cwv)) (newline)
(display "(cwv):") (display (cwv call-with-values-env)) (newline)
(gc)
'dun

2
tests/gc.test
View file

@ -1,6 +1,6 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-scheme-*-
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@" echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@"
#paredit:|| #paredit:||
exit $? exit $?
!# !#

81
type.c
View file

@ -20,84 +20,83 @@
#if !TYPE0 #if !TYPE0
scm * SCM
char_p (scm *x) char_p (SCM x)
{ {
return x->type == CHAR ? &scm_t : &scm_f; return type (x) == CHAR ? cell_t : cell_f;
} }
scm * SCM
macro_p (scm *x) macro_p (SCM x)
{ {
return x->type == MACRO ? &scm_t : &scm_f; return type (x) == MACRO ? cell_t : cell_f;
} }
scm * SCM
number_p (scm *x) number_p (SCM x)
{ {
return x->type == NUMBER ? &scm_t : &scm_f; return type (x) == NUMBER ? cell_t : cell_f;
} }
scm * SCM
pair_p (scm *x) pair_p (SCM x)
{ {
return x->type == PAIR ? &scm_t : &scm_f; return type (x) == PAIR ? cell_t : cell_f;
} }
scm * SCM
ref_p (scm *x) ref_p (SCM x)
{ {
return x->type == REF ? &scm_t : &scm_f; return type (x) == REF ? cell_t : cell_f;
} }
scm * SCM
string_p (scm *x) string_p (SCM x)
{ {
return x->type == STRING ? &scm_t : &scm_f; return type (x) == STRING ? cell_t : cell_f;
} }
scm * SCM
symbol_p (scm *x) symbol_p (SCM x)
{ {
return x->type == SYMBOL ? &scm_t : &scm_f; return type (x) == SYMBOL ? cell_t : cell_f;
} }
scm * SCM
vector_p (scm *x) vector_p (SCM x)
{ {
return x->type == VECTOR ? &scm_t : &scm_f; return type (x) == VECTOR ? cell_t : cell_f;
} }
scm * SCM
builtin_p (scm *x) builtin_p (SCM x)
{ {
return x->type == FUNCTION ? &scm_t : &scm_f; return type (x) == FUNCTION ? cell_t : cell_f;
} }
// Non-types // Non-types
scm * SCM
null_p (scm *x) null_p (SCM x)
{ {
return x == &scm_nil ? &scm_t : &scm_f; return x == cell_nil ? cell_t : cell_f;
} }
scm * SCM
atom_p (scm *x) atom_p (SCM x)
{ {
return (x->type == PAIR ? &scm_f : &scm_t); return (type (x) == PAIR ? cell_f : cell_t);
} }
scm * SCM
boolean_p (scm *x) boolean_p (SCM x)
{ {
return (x == &scm_t || x == &scm_f) ? &scm_t : &scm_f; return (x == cell_t || x == cell_f) ? cell_t : cell_f;
} }
#endif #endif
scm*make_number (int); SCM make_number (int);
scm * SCM
mes_type_of (scm *x) mes_type_of (SCM x)
{ {
return make_number (x->type); return make_number (type (x));
} }