core: Number based cells.
* 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
parent
25c29ecb6d
commit
61e42e8527
3
.gitignore
vendored
3
.gitignore
vendored
|
|
@ -1,8 +1,9 @@
|
|||
*-
|
||||
*.cat
|
||||
*.environment.h
|
||||
*.environment.i
|
||||
*.go
|
||||
*.h
|
||||
*.i
|
||||
*.o
|
||||
*.symbols.i
|
||||
*~
|
||||
|
|
|
|||
18
GNUmakefile
18
GNUmakefile
|
|
@ -23,14 +23,14 @@ include make/install.make
|
|||
all: mes
|
||||
|
||||
mes.o: mes.c
|
||||
mes.o: mes.c mes.environment.h mes.environment.i mes.symbols.i
|
||||
mes.o: define.c define.environment.h define.environment.i
|
||||
mes.o: lib.c lib.environment.h lib.environment.i
|
||||
mes.o: math.c math.environment.h math.environment.i
|
||||
mes.o: posix.c posix.environment.h posix.environment.i
|
||||
mes.o: quasiquote.c quasiquote.environment.h quasiquote.environment.i
|
||||
mes.o: string.c string.environment.h string.environment.i
|
||||
mes.o: type.c type.environment.h type.environment.i
|
||||
mes.o: mes.c mes.h mes.i mes.environment.i mes.symbols.i
|
||||
mes.o: define.c define.h define.i define.environment.i
|
||||
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: quasiquote.c quasiquote.h quasiquote.i quasiquote.environment.i
|
||||
mes.o: string.c string.h string.i string.environment.i
|
||||
mes.o: type.c type.h type.i type.environment.i
|
||||
|
||||
clean:
|
||||
rm -f mes mes.o *.environment.i *.symbols.i *.environment.h *.cat a.out
|
||||
|
|
@ -38,7 +38,7 @@ clean:
|
|||
distclean: clean
|
||||
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 $<
|
||||
|
||||
check: all guile-check mes-check
|
||||
|
|
|
|||
|
|
@ -62,33 +62,50 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
|
|||
(regexp-replace "_p$" "?"))
|
||||
(.name f))))
|
||||
|
||||
(define %builtin-prefix% "scm_")
|
||||
(define (function-builtin-name f)
|
||||
(string-append %builtin-prefix% (.name f)))
|
||||
|
||||
(define (function->source f)
|
||||
(format #f "a = add_environment (a, ~S, &~a);\n" (function-scm-name f) (function-builtin-name f)))
|
||||
(define %cell-prefix% "cell_")
|
||||
(define (function-cell-name f)
|
||||
(string-append %cell-prefix% (.name f)))
|
||||
|
||||
(define (symbol->source s)
|
||||
(format #f "symbols = cons (&~a, symbols);\n" s))
|
||||
(define (function->source f i)
|
||||
(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->header f)
|
||||
(define (function->environment f i)
|
||||
(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)
|
||||
(if (string-null? (.formals f)) 0
|
||||
(length (string-split (.formals f) #\,)))))
|
||||
(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 "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)
|
||||
(let* ((matches (append (list-matches "\nscm ([a-z_0-9]+) = [{](SCM)," string)
|
||||
(list-matches "\nscm ([a-z_0-9]+) = [{](SYMBOL)," string))))
|
||||
(let* ((matches (append (list-matches "\nscm scm_([a-z_0-9]+) = [{](SPECIAL)," string)
|
||||
(list-matches "\nscm scm_([a-z_0-9]+) = [{](SYMBOL)," string))))
|
||||
(map (cut match:substring <> 1) matches)))
|
||||
|
||||
(define (snarf-functions string)
|
||||
(let* ((matches (list-matches
|
||||
"\nscm [*]\n?([a-z0-9_]+) [(]((scm *[^,)]+|, )*)[)][^\n(]*([^\n]*)"
|
||||
"\nSCM[ \n]?([a-z0-9_]+) [(]((SCM ?[^,)]+|, )*)[)][^\n(]*([^\n]*)"
|
||||
string)))
|
||||
(map (lambda (m)
|
||||
(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))
|
||||
(base-name (basename file-name ".c"))
|
||||
(header (make <file>
|
||||
#:name (string-append base-name ".environment.h")
|
||||
#:content (string-join (map function->header functions) "")))
|
||||
#:name (string-append base-name ".h")
|
||||
#: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>
|
||||
#:name (string-append base-name ".environment.i")
|
||||
#:content (string-join (map function->source (filter (negate no-environment?) functions)) "")))
|
||||
(symbols (make <file>
|
||||
#:content (string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
|
||||
(symbols.h (make <file>
|
||||
#:name (string-append base-name ".symbols.h")
|
||||
#:content (string-join (map symbol->header symbols (iota (length symbols) %start)) "")))
|
||||
(symbols.i (make <file>
|
||||
#:name (string-append base-name ".symbols.i")
|
||||
#:content (string-join (map symbol->source symbols) ""))))
|
||||
(list header environment symbols)))
|
||||
#:content (string-join (map symbol->source symbols (iota (length symbols))) ""))))
|
||||
(list header source environment symbols.h symbols.i)))
|
||||
|
||||
(define (file-write file)
|
||||
(with-output-to-file (.name file) (lambda () (display (.content file)))))
|
||||
|
|
|
|||
32
define.c
32
define.c
|
|
@ -19,42 +19,42 @@
|
|||
*/
|
||||
|
||||
#if !BOOT
|
||||
scm *
|
||||
define_env (scm *e, scm *a)
|
||||
SCM
|
||||
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 ()
|
||||
{
|
||||
scm *x;
|
||||
scm *name = cadr (r1);
|
||||
if (name->type != PAIR)
|
||||
SCM x;
|
||||
SCM name = cadr (r1);
|
||||
if (type (name) != PAIR)
|
||||
x = eval_env (caddr (r1), cons (cons (cadr (r1), cadr (r1)), r0));
|
||||
else {
|
||||
name = car (name);
|
||||
scm *p = pairlis (cadr (r1), cadr (r1), r0);
|
||||
SCM p = pairlis (cadr (r1), cadr (r1), r0);
|
||||
cache_invalidate_range (p, r0);
|
||||
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);
|
||||
|
||||
scm *entry = cons (name, x);
|
||||
scm *aa = cons (entry, &scm_nil);
|
||||
SCM entry = cons (name, x);
|
||||
SCM aa = cons (entry, cell_nil);
|
||||
set_cdr_x (aa, cdr (r0));
|
||||
set_cdr_x (r0, aa);
|
||||
scm *cl = assq (&scm_closure, r0);
|
||||
SCM cl = assq (cell_closure, r0);
|
||||
set_cdr_x (cl, aa);
|
||||
return entry;
|
||||
}
|
||||
#else // BOOT
|
||||
scm*define_env (scm *r1, scm *a){}
|
||||
scm*vm_define_env (scm *r1, scm *a){}
|
||||
SCM define_env (SCM r1, SCM a){}
|
||||
SCM vm_define_env (SCM r1, SCM a){}
|
||||
#endif
|
||||
|
||||
scm *
|
||||
define_macro (scm *r1, scm *a)
|
||||
SCM
|
||||
define_macro (SCM r1, SCM a)
|
||||
{
|
||||
}
|
||||
|
|
|
|||
92
lib.c
92
lib.c
|
|
@ -18,24 +18,24 @@
|
|||
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
scm *caar (scm *x) {return car (car (x));}
|
||||
scm *cadr (scm *x) {return car (cdr (x));}
|
||||
scm *cdar (scm *x) {return cdr (car (x));}
|
||||
scm *cddr (scm *x) {return cdr (cdr (x));}
|
||||
scm *caaar (scm *x) {return car (car (car (x)));}
|
||||
scm *caadr (scm *x) {return car (car (cdr (x)));}
|
||||
scm *caddr (scm *x) {return car (cdr (cdr (x)));}
|
||||
scm *cdadr (scm *x) {return cdr (car (cdr (x)));}
|
||||
scm *cadar (scm *x) {return car (cdr (car (x)));}
|
||||
scm *cddar (scm *x) {return cdr (cdr (car (x)));}
|
||||
scm *cdddr (scm *x) {return cdr (cdr (cdr (x)));}
|
||||
scm *cadddr (scm *x) {return car (cdr (cdr (cdr (x))));}
|
||||
SCM caar (SCM x) {return car (car (x));}
|
||||
SCM cadr (SCM x) {return car (cdr (x));}
|
||||
SCM cdar (SCM x) {return cdr (car (x));}
|
||||
SCM cddr (SCM x) {return cdr (cdr (x));}
|
||||
SCM caaar (SCM x) {return car (car (car (x)));}
|
||||
SCM caadr (SCM x) {return car (car (cdr (x)));}
|
||||
SCM caddr (SCM x) {return car (cdr (cdr (x)));}
|
||||
SCM cdadr (SCM x) {return cdr (car (cdr (x)));}
|
||||
SCM cadar (SCM x) {return car (cdr (car (x)));}
|
||||
SCM cddar (SCM x) {return cdr (cdr (car (x)));}
|
||||
SCM cdddr (SCM x) {return cdr (cdr (cdr (x)));}
|
||||
SCM cadddr (SCM x) {return car (cdr (cdr (cdr (x))));}
|
||||
|
||||
scm *
|
||||
length (scm *x)
|
||||
SCM
|
||||
length (SCM x)
|
||||
{
|
||||
int n = 0;
|
||||
while (x != &scm_nil)
|
||||
while (x != cell_nil)
|
||||
{
|
||||
n++;
|
||||
x = cdr (x);
|
||||
|
|
@ -43,59 +43,59 @@ length (scm *x)
|
|||
return make_number (n);
|
||||
}
|
||||
|
||||
scm *
|
||||
last_pair (scm *x)
|
||||
SCM
|
||||
last_pair (SCM x)
|
||||
{
|
||||
while (x != &scm_nil && cdr (x) != &scm_nil)
|
||||
while (x != cell_nil && cdr (x) != cell_nil)
|
||||
x = cdr (x);
|
||||
return x;
|
||||
}
|
||||
|
||||
scm *
|
||||
list (scm *x) ///((arity . n))
|
||||
SCM
|
||||
list (SCM x) ///((arity . n))
|
||||
{
|
||||
return x;
|
||||
}
|
||||
|
||||
scm *
|
||||
list_ref (scm *x, scm *k)
|
||||
SCM
|
||||
list_ref (SCM x, SCM k)
|
||||
{
|
||||
assert (x->type == PAIR);
|
||||
assert (k->type == NUMBER);
|
||||
int n = k->value;
|
||||
while (n-- && x->cdr != &scm_nil) x = x->cdr;
|
||||
return x != &scm_nil ? x->car : &scm_undefined;
|
||||
assert (type (x) == PAIR);
|
||||
assert (type (k) == NUMBER);
|
||||
int n = value (k);
|
||||
while (n-- && g_cells[x].cdr != cell_nil) x = g_cells[x].cdr;
|
||||
return x != cell_nil ? car (x) : cell_undefined;
|
||||
}
|
||||
|
||||
scm *
|
||||
vector_to_list (scm *v)
|
||||
SCM
|
||||
vector_to_list (SCM v)
|
||||
{
|
||||
scm *x = &scm_nil;
|
||||
for (int i = 0; i < v->length; i++) {
|
||||
scm *e = &v->vector[i];
|
||||
if (e->type == REF) e = e->ref;
|
||||
x = append2 (x, cons (e, &scm_nil));
|
||||
SCM x = cell_nil;
|
||||
for (int i = 0; i < LENGTH (v); i++) {
|
||||
SCM e = VECTOR (v)+i;
|
||||
if (type (e) == REF) e = g_cells[e].ref;
|
||||
x = append2 (x, cons (e, cell_nil));
|
||||
}
|
||||
return x;
|
||||
}
|
||||
|
||||
scm *
|
||||
integer_to_char (scm *x)
|
||||
SCM
|
||||
integer_to_char (SCM x)
|
||||
{
|
||||
assert (x->type == NUMBER);
|
||||
return make_char (x->value);
|
||||
assert (type (x) == NUMBER);
|
||||
return make_char (value (x));
|
||||
}
|
||||
|
||||
scm *
|
||||
char_to_integer (scm *x)
|
||||
SCM
|
||||
char_to_integer (SCM x)
|
||||
{
|
||||
assert (x->type == CHAR);
|
||||
return make_number (x->value);
|
||||
assert (type (x) == CHAR);
|
||||
return make_number (value (x));
|
||||
}
|
||||
|
||||
scm *
|
||||
builtin_exit (scm *x)
|
||||
SCM
|
||||
builtin_exit (SCM x)
|
||||
{
|
||||
assert (x->type == NUMBER);
|
||||
exit (x->value);
|
||||
assert (type (x) == NUMBER);
|
||||
exit (value (x));
|
||||
}
|
||||
|
|
|
|||
118
math.c
118
math.c
|
|
@ -18,127 +18,127 @@
|
|||
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
scm *
|
||||
greater_p (scm *x) ///((name . ">") (arity . n))
|
||||
SCM
|
||||
greater_p (SCM x) ///((name . ">") (arity . n))
|
||||
{
|
||||
int n = INT_MAX;
|
||||
while (x != &scm_nil)
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (x->car->type == NUMBER);
|
||||
if (x->car->value >= n) return &scm_f;
|
||||
n = x->car->value;
|
||||
assert (g_cells[car (x)].type == NUMBER);
|
||||
if (value (car (x)) >= n) return cell_f;
|
||||
n = value (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
return &scm_t;
|
||||
return cell_t;
|
||||
}
|
||||
|
||||
scm *
|
||||
less_p (scm *x) ///((name . "<") (arity . n))
|
||||
SCM
|
||||
less_p (SCM x) ///((name . "<") (arity . n))
|
||||
{
|
||||
int n = INT_MIN;
|
||||
while (x != &scm_nil)
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (x->car->type == NUMBER);
|
||||
if (x->car->value <= n) return &scm_f;
|
||||
n = x->car->value;
|
||||
assert (g_cells[car (x)].type == NUMBER);
|
||||
if (value (car (x)) <= n) return cell_f;
|
||||
n = value (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
return &scm_t;
|
||||
return cell_t;
|
||||
}
|
||||
|
||||
scm *
|
||||
is_p (scm *x) ///((name . "=") (arity . n))
|
||||
SCM
|
||||
is_p (SCM x) ///((name . "=") (arity . n))
|
||||
{
|
||||
if (x == &scm_nil) return &scm_t;
|
||||
assert (x->car->type == NUMBER);
|
||||
int n = x->car->value;
|
||||
if (x == cell_nil) return cell_t;
|
||||
assert (g_cells[car (x)].type == NUMBER);
|
||||
int n = value (car (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);
|
||||
}
|
||||
return &scm_t;
|
||||
return cell_t;
|
||||
}
|
||||
|
||||
scm *
|
||||
minus (scm *x) ///((name . "-") (arity . n))
|
||||
SCM
|
||||
minus (SCM x) ///((name . "-") (arity . n))
|
||||
{
|
||||
scm *a = car (x);
|
||||
assert (a->type == NUMBER);
|
||||
int n = a->value;
|
||||
SCM a = car (x);
|
||||
assert (g_cells[a].type == NUMBER);
|
||||
int n = value (a);
|
||||
x = cdr (x);
|
||||
if (x == &scm_nil)
|
||||
if (x == cell_nil)
|
||||
n = -n;
|
||||
while (x != &scm_nil)
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (x->car->type == NUMBER);
|
||||
n -= x->car->value;
|
||||
assert (g_cells[car (x)].type == NUMBER);
|
||||
n -= value (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
return make_number (n);
|
||||
}
|
||||
|
||||
scm *
|
||||
plus (scm *x) ///((name . "+") (arity . n))
|
||||
SCM
|
||||
plus (SCM x) ///((name . "+") (arity . n))
|
||||
{
|
||||
int n = 0;
|
||||
while (x != &scm_nil)
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (x->car->type == NUMBER);
|
||||
n += x->car->value;
|
||||
assert (g_cells[car (x)].type == NUMBER);
|
||||
n += value (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
return make_number (n);
|
||||
}
|
||||
|
||||
scm *
|
||||
divide (scm *x) ///((name . "/") (arity . n))
|
||||
SCM
|
||||
divide (SCM x) ///((name . "/") (arity . n))
|
||||
{
|
||||
int n = 1;
|
||||
if (x != &scm_nil) {
|
||||
assert (x->car->type == NUMBER);
|
||||
n = x->car->value;
|
||||
if (x != cell_nil) {
|
||||
assert (g_cells[car (x)].type == NUMBER);
|
||||
n = value (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
while (x != &scm_nil)
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (x->car->type == NUMBER);
|
||||
n /= x->car->value;
|
||||
assert (g_cells[car (x)].type == NUMBER);
|
||||
n /= value (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
return make_number (n);
|
||||
}
|
||||
|
||||
scm *
|
||||
modulo (scm *a, scm *b)
|
||||
SCM
|
||||
modulo (SCM a, SCM b)
|
||||
{
|
||||
assert (a->type == NUMBER);
|
||||
assert (b->type == NUMBER);
|
||||
return make_number (a->value % b->value);
|
||||
assert (g_cells[a].type == NUMBER);
|
||||
assert (g_cells[b].type == NUMBER);
|
||||
return make_number (value (a) % value (b));
|
||||
}
|
||||
|
||||
scm *
|
||||
multiply (scm *x) ///((name . "*") (arity . n))
|
||||
SCM
|
||||
multiply (SCM x) ///((name . "*") (arity . n))
|
||||
{
|
||||
int n = 1;
|
||||
while (x != &scm_nil)
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (x->car->type == NUMBER);
|
||||
n *= x->car->value;
|
||||
assert (g_cells[car (x)].type == NUMBER);
|
||||
n *= value (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
return make_number (n);
|
||||
}
|
||||
|
||||
scm *
|
||||
logior (scm *x) ///((arity . n))
|
||||
SCM
|
||||
logior (SCM x) ///((arity . n))
|
||||
{
|
||||
int n = 0;
|
||||
while (x != &scm_nil)
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (x->car->type == NUMBER);
|
||||
n |= x->car->value;
|
||||
assert (g_cells[car (x)].type == NUMBER);
|
||||
n |= value (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
return make_number (n);
|
||||
|
|
|
|||
22
posix.c
22
posix.c
|
|
@ -21,34 +21,34 @@
|
|||
#include <fcntl.h>
|
||||
|
||||
char const*
|
||||
string_to_cstring (scm *s)
|
||||
string_to_cstring (SCM s)
|
||||
{
|
||||
static char buf[1024];
|
||||
char *p = buf;
|
||||
s = s->string;
|
||||
while (s != &scm_nil)
|
||||
s = STRING (s);
|
||||
while (s != cell_nil)
|
||||
{
|
||||
*p++ = s->car->value;
|
||||
s = s->cdr;
|
||||
*p++ = value (car (s));
|
||||
s = cdr (s);
|
||||
}
|
||||
*p = 0;
|
||||
return buf;
|
||||
}
|
||||
|
||||
scm *
|
||||
open_input_file (scm *file_name)
|
||||
SCM
|
||||
open_input_file (SCM file_name)
|
||||
{
|
||||
return make_number (open (string_to_cstring (file_name), O_RDONLY));
|
||||
}
|
||||
|
||||
scm *
|
||||
SCM
|
||||
current_input_port ()
|
||||
{
|
||||
return make_number (fileno (g_stdin));
|
||||
}
|
||||
|
||||
scm *
|
||||
set_current_input_port (scm *port)
|
||||
SCM
|
||||
set_current_input_port (SCM port)
|
||||
{
|
||||
g_stdin = fdopen (port->value, "r");
|
||||
g_stdin = fdopen (value (port), "r");
|
||||
}
|
||||
|
|
|
|||
104
quasiquote.c
104
quasiquote.c
|
|
@ -19,35 +19,35 @@
|
|||
*/
|
||||
|
||||
#if QUASIQUOTE
|
||||
scm *add_environment (scm *a, char const *name, scm *x);
|
||||
SCM add_environment (SCM a, char const *name, SCM x);
|
||||
|
||||
scm *
|
||||
unquote (scm *x) ///((no-environment))
|
||||
SCM
|
||||
unquote (SCM x) ///((no-environment))
|
||||
{
|
||||
return cons (&symbol_unquote, x);
|
||||
return cons (cell_symbol_unquote, x);
|
||||
}
|
||||
|
||||
scm *
|
||||
unquote_splicing (scm *x) ///((no-environment))
|
||||
SCM
|
||||
unquote_splicing (SCM x) ///((no-environment))
|
||||
{
|
||||
return cons (&symbol_unquote_splicing, x);
|
||||
return cons (cell_symbol_unquote_splicing, x);
|
||||
}
|
||||
|
||||
scm *
|
||||
eval_quasiquote (scm *e, scm *a)
|
||||
SCM
|
||||
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 ()
|
||||
{
|
||||
if (r1 == &scm_nil) return r1;
|
||||
else if (atom_p (r1) == &scm_t) return r1;
|
||||
else if (eq_p (car (r1), &symbol_unquote) == &scm_t)
|
||||
if (r1 == cell_nil) return r1;
|
||||
else if (atom_p (r1) == cell_t) return r1;
|
||||
else if (eq_p (car (r1), cell_symbol_unquote) == cell_t)
|
||||
return eval_env (cadr (r1), r0);
|
||||
else if (r1->type == PAIR && r1->car->type == PAIR
|
||||
&& eq_p (caar (r1), &symbol_unquote_splicing) == &scm_t)
|
||||
else if (type (r1) == PAIR && g_cells[car (r1)].type == PAIR
|
||||
&& eq_p (caar (r1), cell_symbol_unquote_splicing) == cell_t)
|
||||
{
|
||||
r2 = eval_env (cadar (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));
|
||||
}
|
||||
|
||||
scm *
|
||||
the_unquoters = &scm_nil;
|
||||
SCM
|
||||
the_unquoters = 0;
|
||||
|
||||
scm *
|
||||
add_unquoters (scm *a)
|
||||
SCM
|
||||
add_unquoters (SCM a)
|
||||
{
|
||||
if (the_unquoters == &scm_nil)
|
||||
the_unquoters = cons (cons (&symbol_unquote, &scm_unquote),
|
||||
cons (cons (&symbol_unquote_splicing, &scm_unquote_splicing),
|
||||
&scm_nil));
|
||||
if (the_unquoters == 0)
|
||||
the_unquoters = cons (cons (cell_symbol_unquote, cell_unquote),
|
||||
cons (cons (cell_symbol_unquote_splicing, cell_unquote_splicing),
|
||||
cell_nil));
|
||||
return append2 (the_unquoters, a);
|
||||
}
|
||||
#else // !QUASIQUOTE
|
||||
|
||||
scm*add_unquoters (scm *a){}
|
||||
scm*eval_quasiquote (scm *e, scm *a){}
|
||||
SCM add_unquoters (SCM a){}
|
||||
SCM eval_quasiquote (SCM e, SCM a){}
|
||||
|
||||
#endif // QUASIQUOTE
|
||||
|
||||
#if QUASISYNTAX
|
||||
scm *
|
||||
syntax (scm *x)
|
||||
SCM
|
||||
syntax (SCM x)
|
||||
{
|
||||
return cons (&symbol_syntax, x);
|
||||
return cons (cell_symbol_syntax, x);
|
||||
}
|
||||
|
||||
scm *
|
||||
unsyntax (scm *x) ///((no-environment))
|
||||
SCM
|
||||
unsyntax (SCM x) ///((no-environment))
|
||||
{
|
||||
return cons (&symbol_unsyntax, x);
|
||||
return cons (cell_symbol_unsyntax, x);
|
||||
}
|
||||
|
||||
scm *
|
||||
unsyntax_splicing (scm *x) ///((no-environment))
|
||||
SCM
|
||||
unsyntax_splicing (SCM x) ///((no-environment))
|
||||
{
|
||||
return cons (&symbol_unsyntax_splicing, x);
|
||||
return cons (cell_symbol_unsyntax_splicing, x);
|
||||
}
|
||||
|
||||
scm *
|
||||
eval_quasisyntax (scm *e, scm *a)
|
||||
SCM
|
||||
eval_quasisyntax (SCM e, SCM a)
|
||||
{
|
||||
if (e == &scm_nil) return e;
|
||||
else if (atom_p (e) == &scm_t) return e;
|
||||
else if (eq_p (car (e), &symbol_unsyntax) == &scm_t)
|
||||
if (e == cell_nil) return e;
|
||||
else if (atom_p (e) == cell_t) return e;
|
||||
else if (eq_p (car (e), cell_symbol_unsyntax) == cell_t)
|
||||
return eval_env (cadr (e), a);
|
||||
else if (e->type == PAIR && e->car->type == PAIR
|
||||
&& eq_p (caar (e), &symbol_unsyntax_splicing) == &scm_t)
|
||||
else if (g_cells[e].type == PAIR && g_cells[car (e)].type == PAIR
|
||||
&& eq_p (caar (e), cell_symbol_unsyntax_splicing) == cell_t)
|
||||
return append2 (eval_env (cadar (e), a), eval_quasisyntax (cdr (e), a));
|
||||
return cons (eval_quasisyntax (car (e), a), eval_quasisyntax (cdr (e), a));
|
||||
}
|
||||
|
||||
scm *
|
||||
add_unsyntaxers (scm *a)
|
||||
SCM
|
||||
add_unsyntaxers (SCM a)
|
||||
{
|
||||
a = cons (cons (&symbol_unsyntax, &scm_unsyntax), a);
|
||||
a = cons (cons (&symbol_unsyntax_splicing, &scm_unsyntax_splicing), a);
|
||||
a = cons (cons (cell_symbol_unsyntax, cell_unsyntax), a);
|
||||
a = cons (cons (cell_symbol_unsyntax_splicing, cell_unsyntax_splicing), a);
|
||||
return a;
|
||||
}
|
||||
|
||||
#else // !QUASISYNTAX
|
||||
scm*syntax (scm *x){}
|
||||
scm*unsyntax (scm *x){}
|
||||
scm*unsyntax_splicing (scm *x){}
|
||||
scm*add_unsyntaxers (scm *a){}
|
||||
scm*eval_unsyntax (scm *e, scm *a){}
|
||||
scm*eval_quasisyntax (scm *e, scm *a){}
|
||||
SCM syntax (SCM x){}
|
||||
SCM unsyntax (SCM x){}
|
||||
SCM unsyntax_splicing (SCM x){}
|
||||
SCM add_unsyntaxers (SCM a){}
|
||||
SCM eval_unsyntax (SCM e, SCM a){}
|
||||
SCM eval_quasisyntax (SCM e, SCM a){}
|
||||
|
||||
#endif // !QUASISYNTAX
|
||||
|
|
|
|||
102
string.c
102
string.c
|
|
@ -18,78 +18,78 @@
|
|||
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
scm *
|
||||
string (scm *x) ///((arity . n))
|
||||
SCM
|
||||
string (SCM x) ///((arity . n))
|
||||
{
|
||||
return make_string (x);
|
||||
}
|
||||
|
||||
scm *
|
||||
string_append (scm *x) ///((arity . n))
|
||||
SCM
|
||||
string_append (SCM x) ///((arity . n))
|
||||
{
|
||||
scm *p = &scm_nil;
|
||||
while (x != &scm_nil)
|
||||
SCM p = cell_nil;
|
||||
while (x != cell_nil)
|
||||
{
|
||||
scm *s = car (x);
|
||||
assert (s->type == STRING);
|
||||
p = append2 (p, s->string);
|
||||
SCM s = car (x);
|
||||
assert (g_cells[s].type == STRING);
|
||||
p = append2 (p, STRING (s));
|
||||
x = cdr (x);
|
||||
}
|
||||
return make_string (p);
|
||||
}
|
||||
|
||||
scm *
|
||||
list_to_string (scm *x)
|
||||
SCM
|
||||
list_to_string (SCM x)
|
||||
{
|
||||
return make_string (x);
|
||||
}
|
||||
|
||||
scm *
|
||||
string_length (scm *x)
|
||||
SCM
|
||||
string_length (SCM x)
|
||||
{
|
||||
assert (x->type == STRING);
|
||||
return make_number (length (x->string)->value);
|
||||
assert (g_cells[x].type == STRING);
|
||||
return make_number (value (length (STRING (x))));
|
||||
}
|
||||
|
||||
scm *
|
||||
string_ref (scm *x, scm *k)
|
||||
SCM
|
||||
string_ref (SCM x, SCM k)
|
||||
{
|
||||
assert (x->type == STRING);
|
||||
assert (k->type == NUMBER);
|
||||
scm n = {NUMBER, .value=k->value};
|
||||
return make_char (list_ref (x->string, &n)->value);
|
||||
assert (g_cells[x].type == STRING);
|
||||
assert (g_cells[k].type == NUMBER);
|
||||
g_cells[tmp_num].value = value (k);
|
||||
return make_char (value (list_ref (STRING (x), tmp_num)));
|
||||
}
|
||||
|
||||
scm *
|
||||
substring (scm *x) ///((arity . n))
|
||||
SCM
|
||||
substring (SCM x) ///((arity . n))
|
||||
{
|
||||
assert (x->type == PAIR);
|
||||
assert (x->car->type == STRING);
|
||||
scm *s = x->car->string;
|
||||
assert (x->cdr->car->type == NUMBER);
|
||||
int start = x->cdr->car->value;
|
||||
int end = length (s)->value;
|
||||
if (x->cdr->cdr->type == PAIR) {
|
||||
assert (x->cdr->cdr->car->type == NUMBER);
|
||||
assert (x->cdr->cdr->car->value <= end);
|
||||
end = x->cdr->cdr->car->value;
|
||||
assert (g_cells[x].type == PAIR);
|
||||
assert (g_cells[car (x)].type == STRING);
|
||||
SCM s = g_cells[car (x)].string;
|
||||
assert (g_cells[cadr (x)].type == NUMBER);
|
||||
int start = g_cells[cadr (x)].value;
|
||||
int end = g_cells[length (s)].value;
|
||||
if (g_cells[cddr (x)].type == PAIR) {
|
||||
assert (g_cells[caddr (x)].type == NUMBER);
|
||||
assert (g_cells[caddr (x)].value <= end);
|
||||
end = g_cells[caddr (x)].value;
|
||||
}
|
||||
int n = end - start;
|
||||
while (start--) s = s->cdr;
|
||||
scm *p = &scm_nil;
|
||||
while (n-- && s != &scm_nil) {
|
||||
p = append2 (p, cons (make_char (s->car->value), &scm_nil));
|
||||
s = s->cdr;
|
||||
while (start--) s = cdr (s);
|
||||
SCM p = cell_nil;
|
||||
while (n-- && s != cell_nil) {
|
||||
p = append2 (p, cons (make_char (g_cells[car (s)].value), cell_nil));
|
||||
s = cdr (s);
|
||||
}
|
||||
return make_string (p);
|
||||
}
|
||||
|
||||
scm *
|
||||
number_to_string (scm *x)
|
||||
SCM
|
||||
number_to_string (SCM x)
|
||||
{
|
||||
assert (x->type == NUMBER);
|
||||
int n = x->value;
|
||||
scm *p = n < 0 ? cons (make_char ('-'), &scm_nil) : &scm_nil;
|
||||
assert (g_cells[x].type == NUMBER);
|
||||
int n = value (x);
|
||||
SCM p = n < 0 ? cons (make_char ('-'), cell_nil) : cell_nil;
|
||||
do {
|
||||
p = cons (make_char (n % 10 + '0'), p);
|
||||
n = n / 10;
|
||||
|
|
@ -97,16 +97,16 @@ number_to_string (scm *x)
|
|||
return make_string (p);
|
||||
}
|
||||
|
||||
scm *
|
||||
string_to_symbol (scm *x)
|
||||
SCM
|
||||
string_to_symbol (SCM x)
|
||||
{
|
||||
assert (x->type == STRING);
|
||||
return make_symbol (x->string);
|
||||
assert (g_cells[x].type == STRING);
|
||||
return make_symbol (STRING (x));
|
||||
}
|
||||
|
||||
scm *
|
||||
symbol_to_string (scm *x)
|
||||
SCM
|
||||
symbol_to_string (SCM x)
|
||||
{
|
||||
assert (x->type == SYMBOL);
|
||||
return make_string (x->string);
|
||||
assert (g_cells[x].type == SYMBOL);
|
||||
return make_string (STRING (x));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#! /bin/sh
|
||||
# -*-scheme-*-
|
||||
set -x
|
||||
echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@"
|
||||
#paredit:||
|
||||
exit $?
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#! /bin/sh
|
||||
# -*-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:||
|
||||
exit $?
|
||||
!#
|
||||
|
|
@ -30,12 +30,68 @@ exit $?
|
|||
(define pair (gc-make-cell 3 zero one))
|
||||
(define zero-list (gc-make-cell 3 zero '()))
|
||||
(define v (gc-make-vector 1))
|
||||
(display v) (newline)
|
||||
(vector-set! v 0 88)
|
||||
(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))
|
||||
(display "list: ") (display list) (newline)
|
||||
(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)
|
||||
(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)
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#! /bin/sh
|
||||
# -*-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:||
|
||||
exit $?
|
||||
!#
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#! /bin/sh
|
||||
# -*-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 $MES_FLAGS "$@"
|
||||
#paredit:||
|
||||
exit $?
|
||||
!#
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#! /bin/sh
|
||||
# -*-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 $MES_FLAGS "$@"
|
||||
#paredit:||
|
||||
exit $?
|
||||
!#
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#! /bin/sh
|
||||
# -*-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 $MES_FLAGS "$@"
|
||||
#paredit:||
|
||||
exit $?
|
||||
!#
|
||||
|
|
@ -33,8 +33,8 @@ exit $?
|
|||
;; (display (eq? *top-begin-define-a* '*top-begin-define-a*))
|
||||
;; (newline)
|
||||
|
||||
(display 'HALLO) (newline)
|
||||
(display 'foo-test:) (newline)
|
||||
;; (display 'HALLO) (newline)
|
||||
;; (display 'foo-test:) (newline)
|
||||
(display 1)(newline)
|
||||
(display 2)(newline)
|
||||
(display 3)(newline)
|
||||
|
|
@ -56,28 +56,28 @@ exit $?
|
|||
(display 18)(newline)
|
||||
(display 19)(newline)
|
||||
|
||||
(display 20)(newline)
|
||||
(display 21)(newline)
|
||||
(display 22)(newline)
|
||||
(display 23)(newline)
|
||||
(display 24)(newline)
|
||||
(display 25)(newline)
|
||||
(display 26)(newline)
|
||||
(display 27)(newline)
|
||||
(display 28)(newline)
|
||||
(display 29)(newline)
|
||||
(display 30)(newline)
|
||||
;; (display 20)(newline)
|
||||
;; (display 21)(newline)
|
||||
;; (display 22)(newline)
|
||||
;; (display 23)(newline)
|
||||
;; (display 24)(newline)
|
||||
;; (display 25)(newline)
|
||||
;; (display 26)(newline)
|
||||
;; (display 27)(newline)
|
||||
;; (display 28)(newline)
|
||||
;; (display 29)(newline)
|
||||
;; (display 30)(newline)
|
||||
|
||||
(display 31)(newline)
|
||||
(display 32)(newline)
|
||||
(display 33)(newline)
|
||||
(display 34)(newline)
|
||||
(display 35)(newline)
|
||||
(display 36)(newline)
|
||||
(display 37)(newline)
|
||||
(display 38)(newline)
|
||||
(display 39)(newline)
|
||||
(display 40)(newline)
|
||||
;; (display 31)(newline)
|
||||
;; (display 32)(newline)
|
||||
;; (display 33)(newline)
|
||||
;; (display 34)(newline)
|
||||
;; (display 35)(newline)
|
||||
;; (display 36)(newline)
|
||||
;; (display 37)(newline)
|
||||
;; (display 38)(newline)
|
||||
;; (display 39)(newline)
|
||||
;; (display 40)(newline)
|
||||
|
||||
;; (display 41)(newline)
|
||||
;; (display 42)(newline)
|
||||
|
|
|
|||
38
tests/gc-4.test
Executable file
38
tests/gc-4.test
Executable 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
37
tests/gc-5.test
Executable 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
47
tests/gc-6.test
Executable 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
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
#! /bin/sh
|
||||
# -*-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:||
|
||||
exit $?
|
||||
!#
|
||||
|
|
|
|||
81
type.c
81
type.c
|
|
@ -20,84 +20,83 @@
|
|||
|
||||
#if !TYPE0
|
||||
|
||||
scm *
|
||||
char_p (scm *x)
|
||||
SCM
|
||||
char_p (SCM x)
|
||||
{
|
||||
return x->type == CHAR ? &scm_t : &scm_f;
|
||||
return type (x) == CHAR ? cell_t : cell_f;
|
||||
}
|
||||
|
||||
scm *
|
||||
macro_p (scm *x)
|
||||
SCM
|
||||
macro_p (SCM x)
|
||||
{
|
||||
return x->type == MACRO ? &scm_t : &scm_f;
|
||||
return type (x) == MACRO ? cell_t : cell_f;
|
||||
}
|
||||
|
||||
scm *
|
||||
number_p (scm *x)
|
||||
SCM
|
||||
number_p (SCM x)
|
||||
{
|
||||
return x->type == NUMBER ? &scm_t : &scm_f;
|
||||
return type (x) == NUMBER ? cell_t : cell_f;
|
||||
}
|
||||
|
||||
scm *
|
||||
pair_p (scm *x)
|
||||
SCM
|
||||
pair_p (SCM x)
|
||||
{
|
||||
return x->type == PAIR ? &scm_t : &scm_f;
|
||||
return type (x) == PAIR ? cell_t : cell_f;
|
||||
}
|
||||
|
||||
scm *
|
||||
ref_p (scm *x)
|
||||
SCM
|
||||
ref_p (SCM x)
|
||||
{
|
||||
return x->type == REF ? &scm_t : &scm_f;
|
||||
return type (x) == REF ? cell_t : cell_f;
|
||||
}
|
||||
|
||||
scm *
|
||||
string_p (scm *x)
|
||||
SCM
|
||||
string_p (SCM x)
|
||||
{
|
||||
return x->type == STRING ? &scm_t : &scm_f;
|
||||
return type (x) == STRING ? cell_t : cell_f;
|
||||
}
|
||||
|
||||
scm *
|
||||
symbol_p (scm *x)
|
||||
SCM
|
||||
symbol_p (SCM x)
|
||||
{
|
||||
return x->type == SYMBOL ? &scm_t : &scm_f;
|
||||
return type (x) == SYMBOL ? cell_t : cell_f;
|
||||
}
|
||||
|
||||
scm *
|
||||
vector_p (scm *x)
|
||||
SCM
|
||||
vector_p (SCM x)
|
||||
{
|
||||
return x->type == VECTOR ? &scm_t : &scm_f;
|
||||
return type (x) == VECTOR ? cell_t : cell_f;
|
||||
}
|
||||
|
||||
scm *
|
||||
builtin_p (scm *x)
|
||||
SCM
|
||||
builtin_p (SCM x)
|
||||
{
|
||||
return x->type == FUNCTION ? &scm_t : &scm_f;
|
||||
return type (x) == FUNCTION ? cell_t : cell_f;
|
||||
}
|
||||
|
||||
// Non-types
|
||||
scm *
|
||||
null_p (scm *x)
|
||||
SCM
|
||||
null_p (SCM x)
|
||||
{
|
||||
return x == &scm_nil ? &scm_t : &scm_f;
|
||||
return x == cell_nil ? cell_t : cell_f;
|
||||
}
|
||||
|
||||
scm *
|
||||
atom_p (scm *x)
|
||||
SCM
|
||||
atom_p (SCM x)
|
||||
{
|
||||
return (x->type == PAIR ? &scm_f : &scm_t);
|
||||
return (type (x) == PAIR ? cell_f : cell_t);
|
||||
}
|
||||
|
||||
scm *
|
||||
boolean_p (scm *x)
|
||||
SCM
|
||||
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
|
||||
|
||||
scm*make_number (int);
|
||||
scm *
|
||||
mes_type_of (scm *x)
|
||||
SCM make_number (int);
|
||||
SCM
|
||||
mes_type_of (SCM x)
|
||||
{
|
||||
return make_number (x->type);
|
||||
return make_number (type (x));
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue