From dfe8d3c16cbe4b651fbd9ac1284d1411d878fdd7 Mon Sep 17 00:00:00 2001 From: "Jan (janneke) Nieuwenhuizen" Date: Fri, 17 Jul 2020 14:30:01 +0200 Subject: [PATCH] core: Prepare for M2-Planet: VALUE/TYPE indirections. 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. --- include/mes/m2.h | 3 +- include/mes/macros.h | 3 +- src/builtins.c | 6 +- src/eval-apply.c | 133 ++++++++++++++++++++++++++----------------- src/hash.c | 15 +++-- src/math.c | 67 ++++++++++++++-------- src/posix.c | 12 ++-- src/reader.c | 15 +++-- src/string.c | 10 +++- 9 files changed, 169 insertions(+), 95 deletions(-) diff --git a/include/mes/m2.h b/include/mes/m2.h index 23bb91a4..6d52e7a5 100644 --- a/include/mes/m2.h +++ b/include/mes/m2.h @@ -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 diff --git a/include/mes/macros.h b/include/mes/macros.h index 304b0d45..dc408289 100644 --- a/include/mes/macros.h +++ b/include/mes/macros.h @@ -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 diff --git a/src/builtins.c b/src/builtins.c index 0f02c8b4..46ecc0bb 100644 --- a/src/builtins.c +++ b/src/builtins.c @@ -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 ("# 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; diff --git a/src/hash.c b/src/hash.c index 61d37822..83d49540 100644 --- a/src/hash.c +++ b/src/hash.c @@ -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); diff --git a/src/math.c b/src/math.c index f412965d..4ff117d3 100644 --- a/src/math.c +++ b/src/math.c @@ -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); diff --git a/src/posix.c b/src/posix.c index 03af2a61..69f47115 100644 --- a/src/posix.c +++ b/src/posix.c @@ -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)); } diff --git a/src/reader.c b/src/reader.c index 3e03b351..1722f031 100644 --- a/src/reader.c +++ b/src/reader.c @@ -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; diff --git a/src/string.c b/src/string.c index 639c3c4c..7e7a1ae1 100644 --- a/src/string.c +++ b/src/string.c @@ -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)