From 3ff1fcb8092fc702a54207db0ae3d41b8f2da361 Mon Sep 17 00:00:00 2001 From: "Jan (janneke) Nieuwenhuizen" Date: Sun, 19 Jul 2020 08:49:23 +0200 Subject: [PATCH] core: Split-out core.c. * src/mes.c (assoc_string, car, cdr, list, null_p, eq_p, values, acons, length__, length, error, append2, append_reverse, reverse_x_, assq, assoc): Move to ... * src/core.c: New file. * build-aux/configure-lib.sh (mes_SOURCES): Add it. * simple.make (MES_SOURCES): Likewise. * build-aux/snarf.sh: Likewise. * include/mes/builtins.h: Update. * src/builtins.c (mes_builtins): Update. --- build-aux/configure-lib.sh | 1 + build-aux/pointer.sh | 1 + build-aux/snarf.sh | 1 + include/mes/builtins.h | 115 ++++++++-------- simple.make | 1 + src/builtins.c | 36 ++--- src/core.c | 267 +++++++++++++++++++++++++++++++++++++ src/lib.c | 24 ++++ src/mes.c | 267 ------------------------------------- 9 files changed, 367 insertions(+), 346 deletions(-) create mode 100644 src/core.c diff --git a/build-aux/configure-lib.sh b/build-aux/configure-lib.sh index 23e7d518..27f1eebe 100644 --- a/build-aux/configure-lib.sh +++ b/build-aux/configure-lib.sh @@ -431,6 +431,7 @@ fi mes_SOURCES=" src/builtins.c +src/core.c src/display.c src/eval-apply.c src/gc.c diff --git a/build-aux/pointer.sh b/build-aux/pointer.sh index 8a7a3c94..9cc6167f 100755 --- a/build-aux/pointer.sh +++ b/build-aux/pointer.sh @@ -47,6 +47,7 @@ sed -ri \ include/mes/symbols.h \ include/mes/builtins.h \ src/builtins.c \ + src/core.c \ src/display.c \ src/eval-apply.c \ src/gc.c \ diff --git a/build-aux/snarf.sh b/build-aux/snarf.sh index a388f174..cc6aa8d8 100755 --- a/build-aux/snarf.sh +++ b/build-aux/snarf.sh @@ -25,6 +25,7 @@ srcdest=${srcdest-./} . ${srcdest}build-aux/trace.sh trace "SNARF$snarf builtins.c" ${srcdest}build-aux/mes-snarf.scm src/builtins.c +trace "SNARF$snarf core.c" ${srcdest}build-aux/mes-snarf.scm src/core.c trace "SNARF$snarf display.c" ${srcdest}build-aux/mes-snarf.scm src/display.c trace "SNARF$snarf eval-apply.c" ${srcdest}build-aux/mes-snarf.scm src/eval-apply.c trace "SNARF$snarf gc.c" ${srcdest}build-aux/mes-snarf.scm src/gc.c diff --git a/include/mes/builtins.h b/include/mes/builtins.h index 38ed1484..7cbba7cd 100644 --- a/include/mes/builtins.h +++ b/include/mes/builtins.h @@ -27,67 +27,7 @@ SCM builtin_name (SCM builtin); SCM builtin_arity (SCM builtin); SCM builtin_p (SCM x); SCM builtin_printer (SCM builtin); -/* src/display.c */ -SCM display_ (SCM x); -SCM display_error_ (SCM x); -SCM display_port_ (SCM x, SCM p); -SCM write_ (SCM x); -SCM write_error_ (SCM x); -SCM write_port_ (SCM x, SCM p); -/* src/eval-apply.c */ -SCM pairlis (SCM x, SCM y, SCM a); -SCM set_car_x (SCM x, SCM e); -SCM set_cdr_x (SCM x, SCM e); -SCM set_env_x (SCM x, SCM e, SCM a); -SCM macro_get_handle (SCM name); -SCM add_formals (SCM formals, SCM x); -SCM eval_apply (); -/* src/gc.c */ -SCM gc_check (); -SCM gc (); -/* src/hash.c */ -SCM hashq (SCM x, SCM size); -SCM hash (SCM x, SCM size); -SCM hashq_get_handle (SCM table, SCM key, SCM dflt); -SCM hashq_ref (SCM table, SCM key, SCM dflt); -SCM hash_ref (SCM table, SCM key, SCM dflt); -SCM hashq_set_x (SCM table, SCM key, SCM value); -SCM hash_set_x (SCM table, SCM key, SCM value); -SCM hash_table_printer (SCM table); -SCM make_hash_table (SCM x); -/* src/lib.c */ -SCM exit_ (SCM x); -SCM frame_printer (SCM frame); -SCM make_stack (SCM stack); -SCM stack_length (SCM stack); -SCM stack_ref (SCM stack, SCM index); -SCM xassq (SCM x, SCM a); -SCM memq (SCM x, SCM a); -SCM equal2_p (SCM a, SCM b); -SCM last_pair (SCM x); -SCM pair_p (SCM x); -SCM char_to_integer (SCM x); -SCM integer_to_char (SCM x); -/* src/math.mes */ -SCM greater_p (SCM x); -SCM less_p (SCM x); -SCM is_p (SCM x); -SCM minus (SCM x); -SCM plus (SCM x); -SCM divide (SCM x); -SCM modulo (SCM a, SCM b); -SCM multiply (SCM x); -SCM logand (SCM x); -SCM logior (SCM x); -SCM lognot (SCM x); -SCM logxor (SCM x); -SCM ash (SCM n, SCM count); -/* src/mes.c */ -SCM make_cell_ (SCM type, SCM car, SCM cdr); -SCM type_ (SCM x); -SCM car_ (SCM x); -SCM cdr_ (SCM x); -SCM cons (SCM x, SCM y); +/* src/core.c */ SCM car (SCM x); SCM cdr (SCM x); SCM list (SCM x); @@ -102,11 +42,64 @@ SCM append_reverse (SCM x, SCM y); SCM reverse_x_ (SCM x, SCM t); SCM assq (SCM x, SCM a); SCM assoc (SCM x, SCM a); +/* src/display.c */ +SCM display_ (SCM x); +SCM display_error_ (SCM x); +SCM display_port_ (SCM x, SCM p); +SCM write_ (SCM x); +SCM write_error_ (SCM x); +SCM write_port_ (SCM x, SCM p); +/* src/eval-apply.c */ +SCM pairlis (SCM x, SCM y, SCM a); SCM set_car_x (SCM x, SCM e); SCM set_cdr_x (SCM x, SCM e); SCM set_env_x (SCM x, SCM e, SCM a); SCM add_formals (SCM formals, SCM x); SCM eval_apply (); +/* src/gc.c */ +SCM cons (SCM x, SCM y); +SCM gc_check (); +SCM gc (); +/* src/hash.c */ +SCM hashq (SCM x, SCM size); +SCM hash (SCM x, SCM size); +SCM hashq_get_handle (SCM table, SCM key, SCM dflt); +SCM hashq_ref (SCM table, SCM key, SCM dflt); +SCM hash_ref (SCM table, SCM key, SCM dflt); +SCM hashq_set_x (SCM table, SCM key, SCM value); +SCM hash_set_x (SCM table, SCM key, SCM value); +SCM hash_table_printer (SCM table); +SCM make_hash_table (SCM x); +/* src/lib.c */ +SCM type_ (SCM x); +SCM car_ (SCM x); +SCM cdr_ (SCM x); +SCM exit_ (SCM x); +SCM frame_printer (SCM frame); +SCM make_stack (SCM stack); +SCM stack_length (SCM stack); +SCM stack_ref (SCM stack, SCM index); +SCM xassq (SCM x, SCM a); +SCM memq (SCM x, SCM a); +SCM equal2_p (SCM a, SCM b); +SCM last_pair (SCM x); +SCM pair_p (SCM x); +SCM char_to_integer (SCM x); +SCM integer_to_char (SCM x); +/* src/math.c */ +SCM greater_p (SCM x); +SCM less_p (SCM x); +SCM is_p (SCM x); +SCM minus (SCM x); +SCM plus (SCM x); +SCM divide (SCM x); +SCM modulo (SCM a, SCM b); +SCM multiply (SCM x); +SCM logand (SCM x); +SCM logior (SCM x); +SCM lognot (SCM x); +SCM logxor (SCM x); +SCM ash (SCM n, SCM count); /* src/module.c */ SCM make_module_type (); SCM module_printer (SCM module); diff --git a/simple.make b/simple.make index 955f5229..542f7b78 100644 --- a/simple.make +++ b/simple.make @@ -48,6 +48,7 @@ CFLAGS:= \ MES_SOURCES = \ src/builtins.c \ + src/core.c \ src/display.c \ src/eval-apply.c \ src/gc.c \ diff --git a/src/builtins.c b/src/builtins.c index 46ecc0bb..98afbe3f 100644 --- a/src/builtins.c +++ b/src/builtins.c @@ -120,6 +120,21 @@ mes_builtins (SCM a) /*:((internal)) */ a = init_builtin (builtin_type, "builtin-arity", 1, &builtin_arity, a); a = init_builtin (builtin_type, "builtin?", 1, &builtin_p, a); a = init_builtin (builtin_type, "builtin-printer", 1, &builtin_printer, a); + /* src/core.c */ + a = init_builtin (builtin_type, "car", 1, &car, a); + a = init_builtin (builtin_type, "cdr", 1, &cdr, a); + a = init_builtin (builtin_type, "list", -1, &list, a); + a = init_builtin (builtin_type, "null?", 1, &null_p, a); + a = init_builtin (builtin_type, "eq?", 2, &eq_p, a); + a = init_builtin (builtin_type, "values", -1, &values, a); + a = init_builtin (builtin_type, "acons", 3, &acons, a); + a = init_builtin (builtin_type, "length", 1, &length, a); + a = init_builtin (builtin_type, "error", 2, &error, a); + a = init_builtin (builtin_type, "append2", 2, &append2, a); + a = init_builtin (builtin_type, "append-reverse", 2, &append_reverse, a); + a = init_builtin (builtin_type, "core:reverse!", 2, &reverse_x_, a); + a = init_builtin (builtin_type, "assq", 2, &assq, a); + a = init_builtin (builtin_type, "assoc", 2, &assoc, a); /* src/display.c */ a = init_builtin (builtin_type, "core:display", 1, &display_, a); a = init_builtin (builtin_type, "core:display-error", 1, &display_error_, a); @@ -149,6 +164,9 @@ mes_builtins (SCM a) /*:((internal)) */ a = init_builtin (builtin_type, "hash-table-printer", 1, &hash_table_printer, a); a = init_builtin (builtin_type, "make-hash-table", 1, &make_hash_table, a); /* src/lib.c */ + a = init_builtin (builtin_type, "core:type", 1, &type_, a); + a = init_builtin (builtin_type, "core:car", 1, &car_, a); + a = init_builtin (builtin_type, "core:cdr", 1, &cdr_, a); a = init_builtin (builtin_type, "exit", 1, &exit_, a); a = init_builtin (builtin_type, "frame-printer", 1, &frame_printer, a); a = init_builtin (builtin_type, "make-stack", -1, &make_stack, a); @@ -175,24 +193,6 @@ mes_builtins (SCM a) /*:((internal)) */ a = init_builtin (builtin_type, "lognot", 1, &lognot, a); a = init_builtin (builtin_type, "logxor", -1, &logxor, a); a = init_builtin (builtin_type, "ash", 2, &ash, a); - /* src/mes.c */ - a = init_builtin (builtin_type, "core:type", 1, &type_, a); - a = init_builtin (builtin_type, "core:car", 1, &car_, a); - a = init_builtin (builtin_type, "core:cdr", 1, &cdr_, a); - a = init_builtin (builtin_type, "car", 1, &car, a); - a = init_builtin (builtin_type, "cdr", 1, &cdr, a); - a = init_builtin (builtin_type, "list", -1, &list, a); - a = init_builtin (builtin_type, "null?", 1, &null_p, a); - a = init_builtin (builtin_type, "eq?", 2, &eq_p, a); - a = init_builtin (builtin_type, "values", -1, &values, a); - a = init_builtin (builtin_type, "acons", 3, &acons, a); - a = init_builtin (builtin_type, "length", 1, &length, a); - a = init_builtin (builtin_type, "error", 2, &error, a); - a = init_builtin (builtin_type, "append2", 2, &append2, a); - a = init_builtin (builtin_type, "append-reverse", 2, &append_reverse, a); - a = init_builtin (builtin_type, "core:reverse!", 2, &reverse_x_, a); - a = init_builtin (builtin_type, "assq", 2, &assq, a); - a = init_builtin (builtin_type, "assoc", 2, &assoc, a); /* src/module.c */ a = init_builtin (builtin_type, "make-module-type", 0, &make_module_type, a); a = init_builtin (builtin_type, "module-printer", 1, &module_printer, a); diff --git a/src/core.c b/src/core.c new file mode 100644 index 00000000..556101c6 --- /dev/null +++ b/src/core.c @@ -0,0 +1,267 @@ +/* -*-comment-start: "//";comment-end:""-*- + * GNU Mes --- Maxwell Equations of Software + * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen + * + * This file is part of GNU Mes. + * + * GNU 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. + * + * GNU 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 GNU Mes. If not, see . + */ + +/** Commentary: + Essential functions, used by the eval/apply core. + */ + +/** Code: */ + +#include "mes/lib.h" +#include "mes/mes.h" + +#include + +SCM +assoc_string (SCM x, SCM a) /*:((internal)) */ +{ + SCM b; + while (a != cell_nil) + { + b = CAR (a); + if (TYPE (CAR (b)) == TSTRING) + if (string_equal_p (x, CAR (b)) == cell_t) + return b; + a = CDR (a); + } + if (a != cell_nil) + return CAR (a); + return cell_f; +} + +SCM +car (SCM x) +{ +#if !__MESC_MES__ + if (TYPE (x) != TPAIR) + error (cell_symbol_not_a_pair, cons (x, cell_symbol_car)); +#endif + return CAR (x); +} + +SCM +cdr (SCM x) +{ +#if !__MESC_MES__ + if (TYPE (x) != TPAIR) + error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr)); +#endif + return CDR (x); +} + +SCM +list (SCM x) /*:((arity . n)) */ +{ + return x; +} + +SCM +null_p (SCM x) +{ + if (x == cell_nil) + return cell_t; + return cell_f; +} + +SCM +eq_p (SCM x, SCM y) +{ + if (x == y) + return cell_t; + int t = TYPE (x); + if (t == TKEYWORD) + { + if (TYPE (y) == TKEYWORD) + return string_equal_p (x, y); + return cell_f; + } + if (t == TCHAR) + { + if (TYPE (y) != TCHAR) + return cell_f; + if (VALUE (x) == VALUE (y)) + return cell_t; + return cell_f; + } + if (t == TNUMBER) + { + if (TYPE (y) != TNUMBER) + return cell_f; + if (VALUE (x) == VALUE (y)) + return cell_t; + return cell_f; + } + return cell_f; +} + +SCM +values (SCM x) /*:((arity . n)) */ +{ + SCM v = cons (0, x); + TYPE (v) = TVALUES; + return v; +} + +SCM +acons (SCM key, SCM value, SCM alist) +{ + return cons (cons (key, value), alist); +} + +long +length__ (SCM x) /*:((internal)) */ +{ + long n = 0; + while (x != cell_nil) + { + n = n + 1; + if (TYPE (x) != TPAIR) + return -1; + x = CDR (x); + } + return n; +} + +SCM +length (SCM x) +{ + return make_number (length__ (x)); +} + +SCM +error (SCM key, SCM x) +{ +#if !__MESC_MES__ && !__M2_PLANET__ + SCM throw = module_ref (R0, cell_symbol_throw); + if (throw != cell_undefined) + return apply (throw, cons (key, cons (x, cell_nil)), R0); +#endif + display_error_ (key); + eputs (": "); + write_error_ (x); + eputs ("\n"); + assert_msg (0, "ERROR"); + exit (1); +} + +SCM +append2 (SCM x, SCM y) +{ + if (x == cell_nil) + return y; + if (TYPE (x) != TPAIR) + error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append2"))); + SCM r = cell_nil; + while (x != cell_nil) + { + r = cons (CAR (x), r); + x = CDR (x); + } + return reverse_x_ (r, y); +} + +SCM +append_reverse (SCM x, SCM y) +{ + if (x == cell_nil) + return y; + if (TYPE (x) != TPAIR) + error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append-reverse"))); + while (x != cell_nil) + { + y = cons (CAR (x), y); + x = CDR (x); + } + return y; +} + +SCM +reverse_x_ (SCM x, SCM t) +{ + if (x != cell_nil && TYPE (x) != TPAIR) + error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("core:reverse!"))); + SCM r = t; + while (x != cell_nil) + { + t = CDR (x); + CDR (x) = r; + r = x; + x = t; + } + return r; +} + +SCM +assq (SCM x, SCM a) +{ + if (TYPE (a) != TPAIR) + return cell_f; + int t = TYPE (x); + + if (t == TSYMBOL || t == TSPECIAL) + while (a != cell_nil) + { + if (x == CAAR (a)) + return CAR (a); + a = CDR (a); + } + else if (t == TCHAR || t == TNUMBER) + { + long v = VALUE (x); + while (a != cell_nil) + { + if (v == VALUE (CAAR (a))) + return CAR (a); + a = CDR (a); + } + } + else if (t == TKEYWORD) + { + while (a != cell_nil) + { + if (string_equal_p (x, CAAR (a)) == cell_t) + return CAR (a); + a = CDR (a); + } + } + else + /* pointer equality, e.g. on strings. */ + while (a != cell_nil) + { + if (x == CAAR (a)) + return CAR (a); + a = CDR (a); + } + return cell_f; +} + +SCM +assoc (SCM x, SCM a) +{ + if (TYPE (x) == TSTRING) + return assoc_string (x, a); + while (a != cell_nil) + { + if (equal2_p (x, CAAR (a)) == cell_t) + return CAR (a); + a = CDR (a); + } + return cell_f; +} diff --git a/src/lib.c b/src/lib.c index 3100a68f..ae0375bd 100644 --- a/src/lib.c +++ b/src/lib.c @@ -24,6 +24,30 @@ #include +SCM +type_ (SCM x) +{ + return make_number (TYPE (x)); +} + +SCM +car_ (SCM x) +{ + SCM a = CAR (x); + if (TYPE (x) == TPAIR) + return a; + return make_number (a); +} + +SCM +cdr_ (SCM x) +{ + SCM d = CDR (x); + if (TYPE (x) == TPAIR || TYPE (x) == TCLOSURE) + return d; + return make_number (d); +} + SCM exit_ (SCM x) /*:((name . "exit")) */ { diff --git a/src/mes.c b/src/mes.c index 317f4bfb..2590f37a 100644 --- a/src/mes.c +++ b/src/mes.c @@ -29,273 +29,6 @@ // char const *MES_PKGDATADIR = "mes"; -SCM -assoc_string (SCM x, SCM a) /*:((internal)) */ -{ - SCM b; - while (a != cell_nil) - { - b = CAR (a); - if (TYPE (CAR (b)) == TSTRING) - if (string_equal_p (x, CAR (b)) == cell_t) - return b; - a = CDR (a); - } - if (a != cell_nil) - return CAR (a); - return cell_f; -} - -SCM -type_ (SCM x) -{ - return make_number (TYPE (x)); -} - -SCM -car_ (SCM x) -{ - if (TYPE (x) != TCONTINUATION && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird - || TYPE (CAR (x)) == TREF - || TYPE (CAR (x)) == TSPECIAL - || TYPE (CAR (x)) == TSYMBOL || TYPE (CAR (x)) == TSTRING)) - return CAR (x); - return make_number (CAR (x)); -} - -SCM -cdr_ (SCM x) -{ - if (TYPE (x) != TCHAR - && TYPE (x) != TNUMBER - && TYPE (x) != TPORT - && (TYPE (CDR (x)) == TPAIR - || TYPE (CDR (x)) == TREF - || TYPE (CDR (x)) == TSPECIAL || TYPE (CDR (x)) == TSYMBOL || TYPE (CDR (x)) == TSTRING)) - return CDR (x); - return make_number (CDR (x)); -} - -SCM -car (SCM x) -{ -#if !__MESC_MES__ - if (TYPE (x) != TPAIR) - error (cell_symbol_not_a_pair, cons (x, cell_symbol_car)); -#endif - return CAR (x); -} - -SCM -cdr (SCM x) -{ -#if !__MESC_MES__ - if (TYPE (x) != TPAIR) - error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr)); -#endif - return CDR (x); -} - -SCM -list (SCM x) /*:((arity . n)) */ -{ - return x; -} - -SCM -null_p (SCM x) -{ - if (x == cell_nil) - return cell_t; - return cell_f; -} - -SCM -eq_p (SCM x, SCM y) -{ - if (x == y) - return cell_t; - int t = TYPE (x); - if (t == TKEYWORD) - { - if (TYPE (y) == TKEYWORD) - return string_equal_p (x, y); - return cell_f; - } - if (t == TCHAR) - { - if (TYPE (y) != TCHAR) - return cell_f; - if (VALUE (x) == VALUE (y)) - return cell_t; - return cell_f; - } - if (t == TNUMBER) - { - if (TYPE (y) != TNUMBER) - return cell_f; - if (VALUE (x) == VALUE (y)) - return cell_t; - return cell_f; - } - return cell_f; -} - -SCM -values (SCM x) /*:((arity . n)) */ -{ - SCM v = cons (0, x); - TYPE (v) = TVALUES; - return v; -} - -SCM -acons (SCM key, SCM value, SCM alist) -{ - return cons (cons (key, value), alist); -} - -long -length__ (SCM x) /*:((internal)) */ -{ - long n = 0; - while (x != cell_nil) - { - n = n + 1; - if (TYPE (x) != TPAIR) - return -1; - x = CDR (x); - } - return n; -} - -SCM -length (SCM x) -{ - return make_number (length__ (x)); -} - -SCM -error (SCM key, SCM x) -{ -#if !__MESC_MES__ && !__M2_PLANET__ - SCM throw = module_ref (R0, cell_symbol_throw); - if (throw != cell_undefined) - return apply (throw, cons (key, cons (x, cell_nil)), R0); -#endif - display_error_ (key); - eputs (": "); - write_error_ (x); - eputs ("\n"); - assert_msg (0, "ERROR"); - exit (1); -} - -SCM -append2 (SCM x, SCM y) -{ - if (x == cell_nil) - return y; - if (TYPE (x) != TPAIR) - error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append2"))); - SCM r = cell_nil; - while (x != cell_nil) - { - r = cons (CAR (x), r); - x = CDR (x); - } - return reverse_x_ (r, y); -} - -SCM -append_reverse (SCM x, SCM y) -{ - if (x == cell_nil) - return y; - if (TYPE (x) != TPAIR) - error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append-reverse"))); - while (x != cell_nil) - { - y = cons (CAR (x), y); - x = CDR (x); - } - return y; -} - -SCM -reverse_x_ (SCM x, SCM t) -{ - if (x != cell_nil && TYPE (x) != TPAIR) - error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("core:reverse!"))); - SCM r = t; - while (x != cell_nil) - { - t = CDR (x); - CDR (x) = r; - r = x; - x = t; - } - return r; -} - -SCM -assq (SCM x, SCM a) -{ - if (TYPE (a) != TPAIR) - return cell_f; - int t = TYPE (x); - - if (t == TSYMBOL || t == TSPECIAL) - while (a != cell_nil) - { - if (x == CAAR (a)) - return CAR (a); - a = CDR (a); - } - else if (t == TCHAR || t == TNUMBER) - { - long v = VALUE (x); - while (a != cell_nil) - { - if (v == VALUE (CAAR (a))) - return CAR (a); - a = CDR (a); - } - } - else if (t == TKEYWORD) - { - while (a != cell_nil) - { - if (string_equal_p (x, CAAR (a)) == cell_t) - return CAR (a); - a = CDR (a); - } - } - else - /* pointer equality, e.g. on strings. */ - while (a != cell_nil) - { - if (x == CAAR (a)) - return CAR (a); - a = CDR (a); - } - return cell_f; -} - -SCM -assoc (SCM x, SCM a) -{ - if (TYPE (x) == TSTRING) - return assoc_string (x, a); - while (a != cell_nil) - { - if (equal2_p (x, CAAR (a)) == cell_t) - return CAR (a); - a = CDR (a); - } - return cell_f; -} - SCM mes_g_stack (SCM a) /*:((internal)) */ {