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

core: Prepare for M2-Planet: VALUE/TYPE indirections.

Browse source 
Rewrite C-constructs not supported by M2-Planet

    VALUE (CAR (foo))           -> SCM a = CAR (foo); VALUE (a)
    TYPE (CAR (foo))            -> SCM t = CAR (foo); TYPE (a)

* src/builtins.c (builtin_function): Use VALUE indirections.
(builtin_printer): Likewise.
* src/eval-apply.c (apply_builtin): Likewise.
(get_macro): Likewise.
(expand_variable_): Likewise.
(eval_apply): Likewise.
* src/hash.c (hashq_get_handle): Likewise.
(hashq_ref): Likewise.
(hash_ref): Likewise.
(hash_set_x): Likewise.
(hash_table_printer): Likewise.
* src/math.c (greater_p): Likewise.
(less_p): Likewise.
(is_p): Likewise.
(minus): Likewise.
(plus): Likewise.
(divide): Likewise.
(multiply): Likewise.
(logand): Likewise.
(logior): Likewise.
(logxor): Likewise.
* src/posix.c (current_input_port): Likewise.
(set_current_output_port): Likewise.
* src/reader.c (reader_read_list): Likewise.
(reader_read_character): Likewise.
(reader_read_string): Likewise.
* src/string.c (list_to_cstring): Likewise.
(read_string): Likewise.
This commit is contained in:
Jan (janneke) Nieuwenhuizen 2020-07-17 14:30:01 +02:00
parent a54f6e9028
commit dfe8d3c16c
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
9 changed files with 169 additions and 95 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
include/mes/m2.h
View file

@ -101,7 +101,8 @@ struct timeval
#define CDDR(x) CDR (CDR (x))
#define CADAR(x) CAR (CDR (CAR (x)))
#define CADDR(x) CAR (CDR (CDR (x)))
#define CDADAR(x) CAR (CDR (CAR (CDR (x))))
#define CDADR(x) CDR (CAR (CDR (x)))
#define CDDAR(x) CDR (CDR (CAR (x)))
#endif

3
include/mes/macros.h
View file

@ -99,6 +99,7 @@
#define CDDR(x) CDR (CDR (x))
#define CADAR(x) CAR (CDR (CAR (x)))
#define CADDR(x) CAR (CDR (CDR (x)))
#define CDADAR(x) CAR (CDR (CAR (CDR (x))))
#define CDADR(x) CDR (CAR (CDR (x)))
#define CDDAR(x) CDR (CDR (CAR (x)))
#endif //__MES_MACROS_H

6
src/builtins.c
View file

@ -60,7 +60,8 @@ builtin_arity (SCM builtin)
FUNCTION
builtin_function (SCM builtin)
{
return VALUE (struct_ref_ (builtin, 5));
SCM x = struct_ref_ (builtin, 5);
return VALUE (x);
}
SCM
@ -78,7 +79,8 @@ builtin_printer (SCM builtin)
fdputs ("#<procedure ", __stdout);
display_ (builtin_name (builtin));
fdputc (' ', __stdout);
int arity = VALUE (builtin_arity (builtin));
SCM x = builtin_arity (builtin);
int arity = VALUE (x);
if (arity == -1)
fdputc ('_', __stdout);
else

133
src/eval-apply.c
View file

@ -167,7 +167,10 @@ get_macro (SCM name) /*:((internal)) */
{
SCM m = macro_get_handle (name);
if (m != cell_f)
return MACRO (CDR (m));
{
SCM d = CDR (m);
return MACRO (d);
}
return cell_f;
}
@ -229,30 +232,31 @@ expand_variable_ (SCM x, SCM formals, int top_p) /*:((internal)) */
{
while (TYPE (x) == TPAIR)
{
if (TYPE (CAR (x)) == TPAIR)
SCM a = CAR (x);
if (TYPE (a) == TPAIR)
{
if (CAAR (x) == cell_symbol_lambda)
if (CAR (a) == cell_symbol_lambda)
{
SCM f = CAR (CDAR (x));
SCM f = CADR (a);
formals = add_formals (formals, f);
}
else if (CAAR (x) == cell_symbol_define || CAAR (x) == cell_symbol_define_macro)
else if (CAR (a) == cell_symbol_define || CAR (a) == cell_symbol_define_macro)
{
SCM f = CAR (CDAR (x));
SCM f = CADR (a);
formals = add_formals (formals, f);
}
if (CAAR (x) != cell_symbol_quote)
expand_variable_ (CAR (x), formals, 0);
if (CAR (a) != cell_symbol_quote)
expand_variable_ (a, formals, 0);
}
else
{
if (CAR (x) == cell_symbol_lambda)
if (a == cell_symbol_lambda)
{
SCM f = CADR (x);
formals = add_formals (formals, f);
x = CDR (x);
}
else if (CAR (x) == cell_symbol_define || CAR (x) == cell_symbol_define_macro)
else if (a == cell_symbol_define || a == cell_symbol_define_macro)
{
SCM f = CADR (x);
if (top_p && TYPE (f) == TPAIR)
@ -260,14 +264,15 @@ expand_variable_ (SCM x, SCM formals, int top_p) /*:((internal)) */
formals = add_formals (formals, f);
x = CDR (x);
}
else if (CAR (x) == cell_symbol_quote)
else if (a == cell_symbol_quote)
return cell_unspecified;
else if (TYPE (CAR (x)) == TSYMBOL
&& CAR (x) != cell_symbol_boot_module
&& CAR (x) != cell_symbol_current_module
&& CAR (x) != cell_symbol_primitive_load && !formal_p (CAR (x), formals))
else if (TYPE (a) == TSYMBOL
&& a != cell_symbol_boot_module
&& a != cell_symbol_current_module
&& a != cell_symbol_primitive_load
&& formal_p (a, formals))
{
SCM v = module_variable (R0, CAR (x));
SCM v = module_variable (R0, a);
if (v != cell_f)
CAR (x) = make_variable_ (v);
}
@ -287,14 +292,22 @@ expand_variable (SCM x, SCM formals) /*:((internal)) */
SCM
apply_builtin (SCM fn, SCM x) /*:((internal)) */
{
int arity = VALUE (builtin_arity (fn));
SCM a = builtin_arity (fn);
int arity = VALUE (a);
if ((arity > 0 || arity == -1) && x != cell_nil)
if (TYPE (CAR (x)) == TVALUES)
x = cons (CADAR (x), CDR (x));
{
SCM a = CAR (x);
if (TYPE (a) == TVALUES)
x = cons (CADR (a), CDR (x));
}
if ((arity > 1 || arity == -1) && x != cell_nil)
if (TYPE (CDR (x)) == TPAIR)
if (TYPE (CADR (x)) == TVALUES)
x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
{
SCM a = CAR (x);
SCM d = CDR (x);
if (TYPE (d) == TPAIR)
if (TYPE (CAR (d)) == TVALUES)
x = cons (a, cons (CADAR (d), d));
}
#if __M2_PLANET__
FUNCTION fp = builtin_function (fn);
@ -305,7 +318,7 @@ apply_builtin (SCM fn, SCM x) /*:((internal)) */
else if (arity == 2)
return fp (CAR (x), CADR (x));
else if (arity == 3)
return fp (CAR (x), CADR (x), CAR (CDDR (x)));
return fp (CAR (x), CADR (x), CADDR (x));
else if (arity == -1)
return fp (x);
#else // !__M2_PLANET__
@ -358,8 +371,11 @@ eval_apply ()
SCM x;
int global_p;
int macro_p;
int t;
SCM a;
SCM c;
SCM d;
int t;
long i;
eval_apply:
if (R3 == cell_vm_evlis2)
@ -450,7 +466,8 @@ evlis3:
apply:
g_stack_array[g_stack + FRAME_PROCEDURE] = CAR (R1);
t = TYPE (CAR (R1));
a = CAR (R1);
t = TYPE (a);
if (t == TSTRUCT && builtin_p (CAR (R1)) == cell_t)
{
check_formals (CAR (R1), builtin_arity (CAR (R1)), CDR (R1));
@ -472,11 +489,12 @@ apply:
}
else if (t == TCONTINUATION)
{
v = CONTINUATION (CAR (R1));
a = CAR (R1);
v = CONTINUATION (a);
if (LENGTH (v) != 0)
{
for (t = 0; t < LENGTH (v); t = t + 1)
g_stack_array[STACK_SIZE - LENGTH (v) + t] = vector_ref_ (v, t);
for (i = 0; i < LENGTH (v); i = i + 1)
g_stack_array[STACK_SIZE - LENGTH (v) + i] = vector_ref_ (v, i);
g_stack = STACK_SIZE - LENGTH (v);
}
x = R1;
@ -532,9 +550,9 @@ apply:
{
if (CAAR (R1) == cell_symbol_lambda)
{
formals = CADR (CAR (R1));
formals = CADAR (R1);
args = CDR (R1);
body = CDDR (CAR (R1));
body = CDDAR (R1);
p = pairlis (formals, CDR (R1), R0);
check_formals (R1, formals, args);
call_lambda (body, p, p, R0);
@ -594,7 +612,7 @@ eval:
}
else if (c == cell_symbol_set_x)
{
push_cc (CAR (CDDR (R1)), R1, R0, cell_vm_eval_set_x);
push_cc (CADDR (R1), R1, R0, cell_vm_eval_set_x);
goto eval;
eval_set_x:
R1 = set_env_x (CADR (R2), R1, R0);
@ -615,12 +633,17 @@ eval:
if (TYPE (R1) == TPAIR)
if (CAR (R1) == cell_symbol_define || CAR (R1) == cell_symbol_define_macro)
{
global_p = CAAR (R0) != cell_closure;
macro_p = CAR (R1) == cell_symbol_define_macro;
global_p = 0;
if (CAAR (R0) != cell_closure)
global_p = 1;
macro_p = 0;
if (CAR (R1) == cell_symbol_define_macro)
macro_p = 1;
if (global_p != 0)
{
name = CADR (R1);
if (TYPE (CADR (R1)) == TPAIR)
aa = CADR (R1);
if (TYPE (aa) == TPAIR)
name = CAR (name);
if (macro_p != 0)
{
@ -636,15 +659,16 @@ eval:
}
}
R2 = R1;
if (TYPE (CADR (R1)) != TPAIR)
aa = CADR (R1);
if (TYPE (aa) != TPAIR)
{
push_cc (CAR (CDDR (R1)), R2, cons (cons (CADR (R1), CADR (R1)), R0), cell_vm_eval_define);
push_cc (CADDR (R1), R2, cons (cons (CADR (R1), CADR (R1)), R0), cell_vm_eval_define);
goto eval;
}
else
{
p = pairlis (CADR (R1), CADR (R1), R0);
formals = CDR (CADR (R1));
formals = CDADR (R1);
body = CDDR (R1);
if (macro_p || global_p)
@ -655,7 +679,8 @@ eval:
}
eval_define:
name = CADR (R2);
if (TYPE (CADR (R2)) == TPAIR)
aa = CADR (R2);
if (TYPE (aa) == TPAIR)
name = CAR (name);
if (macro_p != 0)
{
@ -707,7 +732,8 @@ eval:
}
else if (t == TVARIABLE)
{
R1 = CDR (VARIABLE (R1));
x = VARIABLE (R1);
R1 = CDR (x);
goto vm_return;
}
else if (t == TBROKEN_HEART)
@ -769,7 +795,8 @@ macro_expand:
if (TYPE (R1) == TPAIR)
{
if (TYPE (CAR (R1)) == TSYMBOL && CAR (R1) != cell_symbol_begin)
a = CAR (R1);
if (TYPE (a) == TSYMBOL && a != cell_symbol_begin)
{
macro = macro_get_handle (cell_symbol_portable_macro_expand);
if (macro != cell_f)
@ -830,11 +857,14 @@ begin:
}
if (TYPE (R1) == TPAIR)
if (TYPE (CAR (R1)) == TPAIR)
{
if (CAAR (R1) == cell_symbol_begin)
R1 = append2 (CDAR (R1), CDR (R1));
}
{
a = CAR (R1);
if (TYPE (a) == TPAIR)
{
if (CAR (a) == cell_symbol_begin)
R1 = append2 (CDR (a), CDR (R1));
}
}
if (CDR (R1) == cell_nil)
{
R1 = CAR (R1);
@ -858,12 +888,13 @@ begin_expand:
if (TYPE (R1) == TPAIR)
{
if (TYPE (CAR (R1)) == TPAIR)
a = CAR (R1);
if (TYPE (a) == TPAIR)
if (CAAR (R1) == cell_symbol_begin)
R1 = append2 (CDAR (R1), CDR (R1));
if (CAAR (R1) == cell_symbol_primitive_load)
{
push_cc (CADR (CAR (R1)), R1, R0, cell_vm_begin_expand_primitive_load);
push_cc (CADAR (R1), R1, R0, cell_vm_begin_expand_primitive_load);
goto eval;
begin_expand_primitive_load:
if ((TYPE (R1) == TNUMBER) && VALUE (R1) == 0)
@ -938,16 +969,16 @@ call_with_current_continuation:
x = make_continuation (g_continuations);
g_continuations = g_continuations + 1;
v = make_vector__ (STACK_SIZE - g_stack);
for (t = g_stack; t < STACK_SIZE; t = t + 1)
vector_set_x_ (v, t - g_stack, g_stack_array[t]);
for (i = g_stack; i < STACK_SIZE; i = i + 1)
vector_set_x_ (v, i - g_stack, g_stack_array[i]);
CONTINUATION (x) = v;
gc_pop_frame ();
push_cc (cons (CAR (R1), cons (x, cell_nil)), x, R0, cell_vm_call_with_current_continuation2);
goto apply;
call_with_current_continuation2:
v = make_vector__ (STACK_SIZE - g_stack);
for (t = g_stack; t < STACK_SIZE; t = t + 1)
vector_set_x_ (v, t - g_stack, g_stack_array[t]);
for (i = g_stack; i < STACK_SIZE; i = i + 1)
vector_set_x_ (v, i - g_stack, g_stack_array[i]);
CONTINUATION (R2) = v;
goto vm_return;

15
src/hash.c
View file

@ -72,7 +72,8 @@ hash (SCM x, SCM size)
SCM
hashq_get_handle (SCM table, SCM key, SCM dflt)
{
long size = VALUE (struct_ref_ (table, 3));
SCM s = struct_ref_ (table, 3);
long size = VALUE (s);
unsigned hash = hashq_ (key, size);
SCM buckets = struct_ref_ (table, 4);
SCM bucket = vector_ref_ (buckets, hash);
@ -90,7 +91,8 @@ hashq_ref (SCM table, SCM key, SCM dflt)
#if defined (INLINE)
SCM x = hashq_get_handle (table, key, dflt);
#else
long size = VALUE (struct_ref_ (table, 3));
SCM h = struct_ref_ (table, 3);
long size = VALUE (h);
unsigned hash = hashq_ (key, size);
SCM buckets = struct_ref_ (table, 4);
SCM bucket = vector_ref_ (buckets, hash);
@ -108,7 +110,8 @@ hashq_ref (SCM table, SCM key, SCM dflt)
SCM
hash_ref (SCM table, SCM key, SCM dflt)
{
long size = VALUE (struct_ref_ (table, 3));
SCM s = struct_ref_ (table, 3);
long size = VALUE (s);
unsigned hash = hash_ (key, size);
SCM buckets = struct_ref_ (table, 4);
SCM bucket = vector_ref_ (buckets, hash);
@ -142,7 +145,8 @@ hash_set_x_ (SCM table, unsigned hash, SCM key, SCM value)
SCM
hashq_set_x (SCM table, SCM key, SCM value)
{
long size = VALUE (struct_ref_ (table, 3));
SCM s = struct_ref_ (table, 3);
long size = VALUE (s);
unsigned hash = hashq_ (key, size);
#if defined (INLINE)
return hash_set_x_ (table, hash, key, value);
@ -160,7 +164,8 @@ hashq_set_x (SCM table, SCM key, SCM value)
SCM
hash_set_x (SCM table, SCM key, SCM value)
{
long size = VALUE (struct_ref_ (table, 3));
SCM s = struct_ref_ (table, 3);
long size = VALUE (s);
unsigned hash = hash_ (key, size);
#if defined (INLINE)
return hash_set_x_ (table, hash, key, value);

67
src/math.c
View file

@ -48,9 +48,11 @@ greater_p (SCM x) /*:((name . ">") (arity . n)) */
while (x != cell_nil)
{
assert_number ("greater_p", CAR (x));
if (VALUE (car (x)) >= n)
SCM i = car (x);
long v = VALUE (i);
if (v >= n)
return cell_f;
n = VALUE (car (x));
n = v;
x = cdr (x);
}
return cell_t;
@ -67,9 +69,11 @@ less_p (SCM x) /*:((name . "<") (arity . n)) */
while (x != cell_nil)
{
assert_number ("less_p", CAR (x));
if (VALUE (car (x)) <= n)
SCM i = car (x);
long v = VALUE (i);
if (v <= n)
return cell_f;
n = VALUE (car (x));
n = v;
x = cdr (x);
}
return cell_t;
@ -85,7 +89,9 @@ is_p (SCM x) /*:((name . "=") (arity . n)) */
x = cdr (x);
while (x != cell_nil)
{
if (VALUE (car (x)) != n)
SCM i = car (x);
long v = VALUE (i);
if (v != n)
return cell_f;
x = cdr (x);
}
@ -102,8 +108,10 @@ minus (SCM x) /*:((name . "-") (arity . n)) */
n = -n;
while (x != cell_nil)
{
assert_number ("minus", CAR (x));
n = n - VALUE (car (x));
SCM i = car (x);
assert_number ("minus", i);
long v = VALUE (i);
n = n - v;
x = cdr (x);
}
return make_number (n);
@ -115,8 +123,10 @@ plus (SCM x) /*:((name . "+") (arity . n)) */
long n = 0;
while (x != cell_nil)
{
assert_number ("plus", CAR (x));
n = n + VALUE (car (x));
SCM i = car (x);
assert_number ("plus", i);
long v = VALUE (i);
n = n + v;
x = cdr (x);
}
return make_number (n);
@ -128,19 +138,22 @@ divide (SCM x) /*:((name . "/") (arity . n)) */
long n = 1;
if (x != cell_nil)
{
assert_number ("divide", CAR (x));
n = VALUE (car (x));
SCM i = car (x);
assert_number ("divide", i);
long v = VALUE (i);
n = v;
x = cdr (x);
}
while (x != cell_nil)
{
assert_number ("divide", CAR (x));
long y = VALUE (CAR (x));
if (y == 0)
SCM i = car (x);
assert_number ("divide", i);
long v = VALUE (i);
if (v == 0)
error (cstring_to_symbol ("divide-by-zero"), x);
if (n == 0)
break;
n = n / y;
n = n / v;
x = cdr (x);
}
return make_number (n);
@ -169,8 +182,10 @@ multiply (SCM x) /*:((name . "*") (arity . n)) */
long n = 1;
while (x != cell_nil)
{
assert_number ("multiply", CAR (x));
n = n * VALUE (car (x));
SCM i = car (x);
assert_number ("multiply", i);
long v = VALUE (i);
n = n * v;
x = cdr (x);
}
return make_number (n);
@ -182,8 +197,10 @@ logand (SCM x) /*:((arity . n)) */
long n = -1;
while (x != cell_nil)
{
assert_number ("multiply", CAR (x));
n = n & VALUE (car (x));
SCM i = car (x);
assert_number ("multiply", i);
long v = VALUE (i);
n = n & v;
x = cdr (x);
}
return make_number (n);
@ -195,8 +212,10 @@ logior (SCM x) /*:((arity . n)) */
long n = 0;
while (x != cell_nil)
{
assert_number ("logior", CAR (x));
n = n | VALUE (car (x));
SCM i = car (x);
assert_number ("logior", i);
long v = VALUE (i);
n = n | v;
x = cdr (x);
}
return make_number (n);
@ -216,8 +235,10 @@ logxor (SCM x) /*:((arity . n)) */
long n = 0;
while (x != cell_nil)
{
assert_number ("logxor", CAR (x));
n = n ^ VALUE (car (x));
SCM i = car (x);
assert_number ("logxor", i);
long v = VALUE (i);
n = n ^ v;
x = cdr (x);
}
return make_number (n);

12
src/posix.c
View file

@ -199,8 +199,9 @@ current_input_port ()
SCM x = g_ports;
while (x)
{
if (PORT (CAR (x)) == __stdin)
return CAR (x);
SCM a = CAR (x);
if (PORT (a) == __stdin)
return a;
x = CDR (x);
}
return CAR (x);
@ -259,8 +260,11 @@ open_output_file (SCM x) /*:((arity . n)) */
x = cdr (x);
int mode = S_IRUSR | S_IWUSR;
if (TYPE (x) == TPAIR)
if (TYPE (car (x)) == TNUMBER)
mode = VALUE (car (x));
{
SCM i = car (x);
if (TYPE (i) == TNUMBER)
mode = VALUE (i);
}
return make_number (mes_open (cell_bytes (STRING (file_name)), O_WRONLY | O_CREAT | O_TRUNC, mode));
}

15
src/reader.c
View file

@ -37,8 +37,6 @@ read_input_file_env_ (SCM e, SCM a)
SCM
read_input_file_env (SCM a)
{
//R0 = a;
//return read_input_file_env_ (read_env (R0), R0);
return read_input_file_env_ (read_env (cell_nil), cell_nil);
}
@ -185,7 +183,10 @@ reader_read_list (int c, SCM a)
error (cell_symbol_not_a_pair, make_string0 ("EOF in list"));
SCM s = reader_read_sexp_ (c, a);
if (s == cell_dot)
return CAR (reader_read_list (readchar (), a));
{
s = reader_read_list (readchar (), a);
return CAR (s);
}
return cons (s, reader_read_list (readchar (), a));
}
@ -285,7 +286,8 @@ reader_read_character ()
}
else if (c == 'x' && ((p >= '0' && p <= '9') || (p >= 'a' && p <= 'f') || (p >= 'F' && p <= 'F')))
{
c = VALUE (reader_read_hex ());
SCM n = reader_read_hex ();
c = VALUE (n);
eputs ("reading hex c=");
eputs (itoa (c));
eputs ("\n");
@ -469,7 +471,10 @@ reader_read_string ()
c = '\e'; */
c = 27;
else if (c == 'x')
c = VALUE (reader_read_hex ());
{
SCM n = reader_read_hex ();
c = VALUE (n);
}
}
g_buf[i] = c;
i = i + 1;

10
src/string.c
View file

@ -48,7 +48,8 @@ list_to_cstring (SCM list, size_t *size)
{
if (i > MAX_STRING)
assert_max_string (i, "list_to_string", g_buf);
g_buf[i] = VALUE (car (list));
SCM x = car (list);
g_buf[i] = VALUE (x);
i = i + 1;
list = cdr (list);
}
@ -170,8 +171,11 @@ read_string (SCM port) /*:((arity . n)) */
{
int fd = __stdin;
if (TYPE (port) == TPAIR)
if (TYPE (car (port)) == TNUMBER)
__stdin = VALUE (CAR (port));
{
SCM p = car (port);
if (TYPE (p) == TNUMBER)
__stdin = VALUE (p);
}
int c = readchar ();
size_t i = 0;
while (c != -1)