Back to index

plt-scheme  4.2.1
list.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 #include "schpriv.h"
00027 
00028 /* globals */
00029 Scheme_Object scheme_null[1];
00030 Scheme_Object *scheme_cons_proc;
00031 Scheme_Object *scheme_mcons_proc;
00032 Scheme_Object *scheme_list_proc;
00033 Scheme_Object *scheme_list_star_proc;
00034 Scheme_Object *scheme_box_proc;
00035 
00036 /* locals */
00037 static Scheme_Object *pair_p_prim (int argc, Scheme_Object *argv[]);
00038 static Scheme_Object *mpair_p_prim (int argc, Scheme_Object *argv[]);
00039 static Scheme_Object *cons_prim (int argc, Scheme_Object *argv[]);
00040 static Scheme_Object *mcons_prim (int argc, Scheme_Object *argv[]);
00041 static Scheme_Object *null_p_prim (int argc, Scheme_Object *argv[]);
00042 static Scheme_Object *list_p_prim (int argc, Scheme_Object *argv[]);
00043 static Scheme_Object *list_prim (int argc, Scheme_Object *argv[]);
00044 static Scheme_Object *list_star_prim (int argc, Scheme_Object *argv[]);
00045 static Scheme_Object *immutablep (int argc, Scheme_Object *argv[]);
00046 static Scheme_Object *length_prim (int argc, Scheme_Object *argv[]);
00047 static Scheme_Object *append_prim (int argc, Scheme_Object *argv[]);
00048 static Scheme_Object *reverse_prim (int argc, Scheme_Object *argv[]);
00049 static Scheme_Object *list_tail_prim (int argc, Scheme_Object *argv[]);
00050 static Scheme_Object *list_ref_prim (int argc, Scheme_Object *argv[]);
00051 static Scheme_Object *memv (int argc, Scheme_Object *argv[]);
00052 static Scheme_Object *memq (int argc, Scheme_Object *argv[]);
00053 static Scheme_Object *member (int argc, Scheme_Object *argv[]);
00054 static Scheme_Object *assv (int argc, Scheme_Object *argv[]);
00055 static Scheme_Object *assq (int argc, Scheme_Object *argv[]);
00056 static Scheme_Object *assoc (int argc, Scheme_Object *argv[]);
00057 static Scheme_Object *caaar_prim (int argc, Scheme_Object *argv[]);
00058 static Scheme_Object *caadr_prim (int argc, Scheme_Object *argv[]);
00059 static Scheme_Object *cadar_prim (int argc, Scheme_Object *argv[]);
00060 static Scheme_Object *cdaar_prim (int argc, Scheme_Object *argv[]);
00061 static Scheme_Object *cdadr_prim (int argc, Scheme_Object *argv[]);
00062 static Scheme_Object *cddar_prim (int argc, Scheme_Object *argv[]);
00063 static Scheme_Object *caddr_prim (int argc, Scheme_Object *argv[]);
00064 static Scheme_Object *cdddr_prim (int argc, Scheme_Object *argv[]);
00065 
00066 static Scheme_Object *cddddr_prim (int argc, Scheme_Object *argv[]);
00067 static Scheme_Object *cadddr_prim (int argc, Scheme_Object *argv[]);
00068 static Scheme_Object *cdaddr_prim (int argc, Scheme_Object *argv[]);
00069 static Scheme_Object *cddadr_prim (int argc, Scheme_Object *argv[]);
00070 static Scheme_Object *cdddar_prim (int argc, Scheme_Object *argv[]);
00071 static Scheme_Object *caaddr_prim (int argc, Scheme_Object *argv[]);
00072 static Scheme_Object *cadadr_prim (int argc, Scheme_Object *argv[]);
00073 static Scheme_Object *caddar_prim (int argc, Scheme_Object *argv[]);
00074 static Scheme_Object *cdaadr_prim (int argc, Scheme_Object *argv[]);
00075 static Scheme_Object *cdadar_prim (int argc, Scheme_Object *argv[]);
00076 static Scheme_Object *cddaar_prim (int argc, Scheme_Object *argv[]);
00077 static Scheme_Object *cdaaar_prim (int argc, Scheme_Object *argv[]);
00078 static Scheme_Object *cadaar_prim (int argc, Scheme_Object *argv[]);
00079 static Scheme_Object *caadar_prim (int argc, Scheme_Object *argv[]);
00080 static Scheme_Object *caaadr_prim (int argc, Scheme_Object *argv[]);
00081 static Scheme_Object *caaaar_prim (int argc, Scheme_Object *argv[]);
00082 
00083 static Scheme_Object *box (int argc, Scheme_Object *argv[]);
00084 static Scheme_Object *immutable_box (int argc, Scheme_Object *argv[]);
00085 static Scheme_Object *box_p (int argc, Scheme_Object *argv[]);
00086 static Scheme_Object *unbox (int argc, Scheme_Object *argv[]);
00087 static Scheme_Object *set_box (int argc, Scheme_Object *argv[]);
00088 
00089 static Scheme_Object *make_hash(int argc, Scheme_Object *argv[]);
00090 static Scheme_Object *make_hasheq(int argc, Scheme_Object *argv[]);
00091 static Scheme_Object *make_hasheqv(int argc, Scheme_Object *argv[]);
00092 static Scheme_Object *make_weak_hash(int argc, Scheme_Object *argv[]);
00093 static Scheme_Object *make_weak_hasheq(int argc, Scheme_Object *argv[]);
00094 static Scheme_Object *make_weak_hasheqv(int argc, Scheme_Object *argv[]);
00095 static Scheme_Object *make_immutable_hash(int argc, Scheme_Object *argv[]);
00096 static Scheme_Object *make_immutable_hasheq(int argc, Scheme_Object *argv[]);
00097 static Scheme_Object *make_immutable_hasheqv(int argc, Scheme_Object *argv[]);
00098 static Scheme_Object *hash_table_count(int argc, Scheme_Object *argv[]);
00099 static Scheme_Object *hash_table_copy(int argc, Scheme_Object *argv[]);
00100 static Scheme_Object *hash_p(int argc, Scheme_Object *argv[]);
00101 static Scheme_Object *hash_eq_p(int argc, Scheme_Object *argv[]);
00102 static Scheme_Object *hash_eqv_p(int argc, Scheme_Object *argv[]);
00103 static Scheme_Object *hash_weak_p(int argc, Scheme_Object *argv[]);
00104 static Scheme_Object *hash_table_put_bang(int argc, Scheme_Object *argv[]);
00105 static Scheme_Object *hash_table_put(int argc, Scheme_Object *argv[]);
00106 static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[]);
00107 static Scheme_Object *hash_table_remove_bang(int argc, Scheme_Object *argv[]);
00108 static Scheme_Object *hash_table_remove(int argc, Scheme_Object *argv[]);
00109 static Scheme_Object *hash_table_map(int argc, Scheme_Object *argv[]);
00110 static Scheme_Object *hash_table_for_each(int argc, Scheme_Object *argv[]);
00111 static Scheme_Object *hash_table_iterate_start(int argc, Scheme_Object *argv[]);
00112 static Scheme_Object *hash_table_iterate_next(int argc, Scheme_Object *argv[]);
00113 static Scheme_Object *hash_table_iterate_value(int argc, Scheme_Object *argv[]);
00114 static Scheme_Object *hash_table_iterate_key(int argc, Scheme_Object *argv[]);
00115 static Scheme_Object *eq_hash_code(int argc, Scheme_Object *argv[]);
00116 static Scheme_Object *equal_hash_code(int argc, Scheme_Object *argv[]);
00117 static Scheme_Object *equal_hash2_code(int argc, Scheme_Object *argv[]);
00118 static Scheme_Object *eqv_hash_code(int argc, Scheme_Object *argv[]);
00119 
00120 static Scheme_Object *make_weak_box(int argc, Scheme_Object *argv[]);
00121 static Scheme_Object *weak_box_value(int argc, Scheme_Object *argv[]);
00122 static Scheme_Object *weak_boxp(int argc, Scheme_Object *argv[]);
00123 
00124 static Scheme_Object *make_ephemeron(int argc, Scheme_Object *argv[]);
00125 static Scheme_Object *ephemeron_value(int argc, Scheme_Object *argv[]);
00126 static Scheme_Object *ephemeronp(int argc, Scheme_Object *argv[]);
00127 
00128 static Scheme_Object *make_graph(int argc, Scheme_Object *argv[]);
00129 static Scheme_Object *make_placeholder(int argc, Scheme_Object *argv[]);
00130 static Scheme_Object *placeholder_set(int argc, Scheme_Object *argv[]);
00131 static Scheme_Object *placeholder_get(int argc, Scheme_Object *argv[]);
00132 static Scheme_Object *placeholder_p(int argc, Scheme_Object *argv[]);
00133 static Scheme_Object *make_hash_placeholder(int argc, Scheme_Object *argv[]);
00134 static Scheme_Object *make_hasheq_placeholder(int argc, Scheme_Object *argv[]);
00135 static Scheme_Object *make_hasheqv_placeholder(int argc, Scheme_Object *argv[]);
00136 static Scheme_Object *table_placeholder_p(int argc, Scheme_Object *argv[]);
00137 
00138 #define BOX "box"
00139 #define BOXP "box?"
00140 #define UNBOX "unbox"
00141 #define SETBOX "set-box!"
00142 
00143 static Scheme_Object *weak_symbol, *equal_symbol;
00144 
00145 void
00146 scheme_init_list (Scheme_Env *env)
00147 {
00148   Scheme_Object *p;
00149   
00150   scheme_null->type = scheme_null_type;
00151 
00152   scheme_add_global_constant ("null", scheme_null, env);
00153 
00154   p = scheme_make_folding_prim(pair_p_prim, "pair?", 1, 1, 1);
00155   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00156   scheme_add_global_constant ("pair?", p, env);
00157 
00158   p = scheme_make_folding_prim(mpair_p_prim, "mpair?", 1, 1, 1);
00159   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00160   scheme_add_global_constant ("mpair?", p, env);
00161 
00162   REGISTER_SO(scheme_cons_proc);
00163   p = scheme_make_immed_prim(cons_prim, "cons", 2, 2);
00164   scheme_cons_proc = p;
00165   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00166   scheme_add_global_constant ("cons", p, env);
00167 
00168   p = scheme_make_folding_prim(scheme_checked_car, "car", 1, 1, 1);
00169   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00170   scheme_add_global_constant ("car", p, env);
00171 
00172   p = scheme_make_folding_prim(scheme_checked_cdr, "cdr", 1, 1, 1);
00173   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00174   scheme_add_global_constant ("cdr", p, env);
00175 
00176   REGISTER_SO(scheme_mcons_proc);
00177   p = scheme_make_immed_prim(mcons_prim, "mcons", 2, 2);
00178   scheme_mcons_proc = p;
00179   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00180   scheme_add_global_constant ("mcons", p, env);
00181 
00182   p = scheme_make_immed_prim(scheme_checked_mcar, "mcar", 1, 1);
00183   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00184   scheme_add_global_constant ("mcar", p, env);
00185 
00186   p = scheme_make_immed_prim(scheme_checked_mcdr, "mcdr", 1, 1);
00187   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00188   scheme_add_global_constant ("mcdr", p, env);
00189 
00190   p = scheme_make_immed_prim(scheme_checked_set_mcar, "set-mcar!", 2, 2);
00191   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00192   scheme_add_global_constant ("set-mcar!", p, env);
00193 
00194   p = scheme_make_immed_prim(scheme_checked_set_mcdr, "set-mcdr!", 2, 2);
00195   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00196   scheme_add_global_constant ("set-mcdr!", p, env);
00197 
00198   p = scheme_make_folding_prim(null_p_prim, "null?", 1, 1, 1);
00199   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00200   scheme_add_global_constant ("null?", p, env);
00201 
00202   scheme_add_global_constant ("list?",
00203                            scheme_make_immed_prim(list_p_prim,
00204                                                "list?",
00205                                                1, 1),
00206                            env);
00207 
00208   REGISTER_SO(scheme_list_proc);
00209   p = scheme_make_immed_prim(list_prim, "list", 0, -1);
00210   scheme_list_proc = p;
00211   SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
00212                                 | SCHEME_PRIM_IS_BINARY_INLINED
00213                                 | SCHEME_PRIM_IS_NARY_INLINED);
00214   scheme_add_global_constant ("list", p, env);
00215 
00216   REGISTER_SO(scheme_list_star_proc);
00217   p = scheme_make_immed_prim(list_star_prim, "list*", 1, -1);
00218   scheme_list_star_proc = p;
00219   SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
00220                                 | SCHEME_PRIM_IS_BINARY_INLINED
00221                                 | SCHEME_PRIM_IS_NARY_INLINED);
00222   scheme_add_global_constant ("list*", p, env);
00223 
00224   scheme_add_global_constant("immutable?",
00225                           scheme_make_folding_prim(immutablep,
00226                                                 "immutable?",
00227                                                 1, 1, 1),
00228                           env);
00229   scheme_add_global_constant ("length",
00230                            scheme_make_immed_prim(length_prim,
00231                                                "length",
00232                                                1, 1),
00233                            env);
00234   scheme_add_global_constant ("append",
00235                            scheme_make_immed_prim(append_prim,
00236                                                "append",
00237                                                0, -1),
00238                            env);
00239   scheme_add_global_constant ("reverse",
00240                            scheme_make_immed_prim(reverse_prim,
00241                                                "reverse",
00242                                                1, 1),
00243                            env);
00244   scheme_add_global_constant ("list-tail",
00245                            scheme_make_immed_prim(list_tail_prim,
00246                                                "list-tail",
00247                                                2, 2),
00248                            env);
00249   scheme_add_global_constant ("list-ref",
00250                            scheme_make_immed_prim(list_ref_prim,
00251                                                "list-ref",
00252                                                2, 2),
00253                            env);
00254   scheme_add_global_constant ("memq",
00255                            scheme_make_immed_prim(memq,
00256                                                "memq",
00257                                                2, 2),
00258                            env);
00259   scheme_add_global_constant ("memv",
00260                            scheme_make_immed_prim(memv,
00261                                                "memv",
00262                                                2, 2),
00263                            env);
00264   scheme_add_global_constant ("member",
00265                            scheme_make_immed_prim(member,
00266                                                "member",
00267                                                2, 2),
00268                            env);
00269   scheme_add_global_constant ("assq",
00270                            scheme_make_immed_prim(assq,
00271                                                "assq",
00272                                                2, 2),
00273                            env);
00274   scheme_add_global_constant ("assv",
00275                            scheme_make_immed_prim(assv,
00276                                                "assv",
00277                                                2, 2),
00278                            env);
00279   scheme_add_global_constant ("assoc",
00280                            scheme_make_immed_prim(assoc,
00281                                                "assoc",
00282                                                2, 2),
00283                            env);
00284 
00285   p = scheme_make_folding_prim(scheme_checked_caar, "caar", 1, 1, 1);
00286   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00287   scheme_add_global_constant ("caar", p, env);
00288 
00289   p = scheme_make_folding_prim(scheme_checked_cadr, "cadr", 1, 1, 1);
00290   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00291   scheme_add_global_constant ("cadr", p, env);
00292 
00293   p = scheme_make_folding_prim(scheme_checked_cdar, "cdar", 1, 1, 1);
00294   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00295   scheme_add_global_constant ("cdar", p, env);
00296 
00297   p = scheme_make_folding_prim(scheme_checked_cddr, "cddr", 1, 1, 1);
00298   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00299   scheme_add_global_constant ("cddr", p, env);
00300 
00301   scheme_add_global_constant ("caaar",
00302                            scheme_make_folding_prim(caaar_prim,
00303                                                        "caaar",
00304                                                        1, 1, 1),
00305                            env);
00306   scheme_add_global_constant ("caadr",
00307                            scheme_make_folding_prim(caadr_prim,
00308                                                        "caadr",
00309                                                        1, 1, 1),
00310                            env);
00311   scheme_add_global_constant ("cadar",
00312                            scheme_make_folding_prim(cadar_prim,
00313                                                        "cadar",
00314                                                        1, 1, 1),
00315                            env);
00316   scheme_add_global_constant ("cdaar",
00317                            scheme_make_folding_prim(cdaar_prim,
00318                                                        "cdaar",
00319                                                        1, 1, 1),
00320                            env);
00321   scheme_add_global_constant ("cdadr",
00322                            scheme_make_folding_prim(cdadr_prim,
00323                                                        "cdadr",
00324                                                        1, 1, 1),
00325                            env);
00326   scheme_add_global_constant ("cddar",
00327                            scheme_make_folding_prim(cddar_prim,
00328                                                        "cddar",
00329                                                        1, 1, 1),
00330                            env);
00331   scheme_add_global_constant ("caddr",
00332                            scheme_make_folding_prim(caddr_prim,
00333                                                        "caddr",
00334                                                        1, 1, 1),
00335                            env);
00336   scheme_add_global_constant ("cdddr",
00337                            scheme_make_folding_prim(cdddr_prim,
00338                                                        "cdddr",
00339                                                        1, 1, 1),
00340                            env);
00341   scheme_add_global_constant ("cddddr",
00342                            scheme_make_folding_prim(cddddr_prim,
00343                                                        "cddddr",
00344                                                        1, 1, 1),
00345                            env);
00346 
00347   scheme_add_global_constant ("cadddr",
00348                            scheme_make_folding_prim(cadddr_prim,
00349                                                        "cadddr",
00350                                                        1, 1, 1),
00351                            env);
00352   scheme_add_global_constant ("cdaddr",
00353                            scheme_make_folding_prim(cdaddr_prim,
00354                                                        "cdaddr",
00355                                                        1, 1, 1),
00356                            env);
00357   scheme_add_global_constant ("cddadr",
00358                            scheme_make_folding_prim(cddadr_prim,
00359                                                        "cddadr",
00360                                                        1, 1, 1),
00361                            env);
00362   scheme_add_global_constant ("cdddar",
00363                            scheme_make_folding_prim(cdddar_prim,
00364                                                        "cdddar",
00365                                                        1, 1, 1),
00366                            env);
00367   scheme_add_global_constant ("caaddr",
00368                            scheme_make_folding_prim(caaddr_prim,
00369                                                        "caaddr",
00370                                                        1, 1, 1),
00371                            env);
00372   scheme_add_global_constant ("cadadr",
00373                            scheme_make_folding_prim(cadadr_prim,
00374                                                        "cadadr",
00375                                                        1, 1, 1),
00376                            env);
00377   scheme_add_global_constant ("caddar",
00378                            scheme_make_folding_prim(caddar_prim,
00379                                                        "caddar",
00380                                                        1, 1, 1),
00381                            env);
00382   scheme_add_global_constant ("cdaadr",
00383                            scheme_make_folding_prim(cdaadr_prim,
00384                                                        "cdaadr",
00385                                                        1, 1, 1),
00386                            env);
00387   scheme_add_global_constant ("cdadar",
00388                            scheme_make_folding_prim(cdadar_prim,
00389                                                        "cdadar",
00390                                                        1, 1, 1),
00391                            env);
00392   scheme_add_global_constant ("cddaar",
00393                            scheme_make_folding_prim(cddaar_prim,
00394                                                        "cddaar",
00395                                                        1, 1, 1),
00396                            env);
00397   scheme_add_global_constant ("cdaaar",
00398                            scheme_make_folding_prim(cdaaar_prim,
00399                                                        "cdaaar",
00400                                                        1, 1, 1),
00401                            env);
00402   scheme_add_global_constant ("cadaar",
00403                            scheme_make_folding_prim(cadaar_prim,
00404                                                        "cadaar",
00405                                                        1, 1, 1),
00406                            env);
00407   scheme_add_global_constant ("caadar",
00408                            scheme_make_folding_prim(caadar_prim,
00409                                                        "caadar",
00410                                                        1, 1, 1),
00411                            env);
00412   scheme_add_global_constant ("caaadr",
00413                            scheme_make_folding_prim(caaadr_prim,
00414                                                        "caaadr",
00415                                                        1, 1, 1),
00416                            env);
00417   scheme_add_global_constant ("caaaar",
00418                            scheme_make_folding_prim(caaaar_prim,
00419                                                        "caaaar",
00420                                                        1, 1, 1),
00421                            env);
00422 
00423   REGISTER_SO(scheme_box_proc);
00424   p = scheme_make_immed_prim(box, BOX, 1, 1);
00425   scheme_box_proc = p;
00426   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;  
00427   scheme_add_global_constant(BOX, p, env);
00428 
00429   scheme_add_global_constant("box-immutable",
00430                           scheme_make_immed_prim(immutable_box,
00431                                               "box-immutable",
00432                                               1, 1),
00433                           env);
00434   
00435   p = scheme_make_folding_prim(box_p, BOXP, 1, 1, 1);
00436   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;  
00437   scheme_add_global_constant(BOXP, p, env);
00438 
00439   p = scheme_make_immed_prim(unbox, UNBOX, 1, 1);
00440   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;  
00441   scheme_add_global_constant(UNBOX, p, env);
00442 
00443   scheme_add_global_constant(SETBOX,
00444                           scheme_make_immed_prim(set_box,
00445                                               SETBOX,
00446                                               2, 2),
00447                           env);
00448 
00449   scheme_add_global_constant("make-hash",
00450                           scheme_make_immed_prim(make_hash,
00451                                               "make-hash",
00452                                               0, 0),
00453                           env);
00454   scheme_add_global_constant("make-hasheq",
00455                           scheme_make_immed_prim(make_hasheq,
00456                                               "make-hasheq",
00457                                               0, 0),
00458                           env);
00459   scheme_add_global_constant("make-hasheqv",
00460                           scheme_make_immed_prim(make_hasheqv,
00461                                               "make-hasheqv",
00462                                               0, 0),
00463                           env);
00464   scheme_add_global_constant("make-weak-hash",
00465                           scheme_make_immed_prim(make_weak_hash,
00466                                               "make-weak-hash",
00467                                               0, 0),
00468                           env);
00469   scheme_add_global_constant("make-weak-hasheq",
00470                           scheme_make_immed_prim(make_weak_hasheq,
00471                                               "make-weak-hasheq",
00472                                               0, 0),
00473                           env);
00474   scheme_add_global_constant("make-weak-hasheqv",
00475                           scheme_make_immed_prim(make_weak_hasheqv,
00476                                               "make-weak-hasheqv",
00477                                               0, 0),
00478                           env);
00479   scheme_add_global_constant("make-immutable-hash",
00480                           scheme_make_immed_prim(make_immutable_hash,
00481                                               "make-immutable-hash",
00482                                               1, 1),
00483                           env);
00484   scheme_add_global_constant("make-immutable-hasheq",
00485                           scheme_make_immed_prim(make_immutable_hasheq,
00486                                               "make-immutable-hasheq",
00487                                               1, 1),
00488                           env);
00489   scheme_add_global_constant("make-immutable-hasheqv",
00490                           scheme_make_immed_prim(make_immutable_hasheqv,
00491                                               "make-immutable-hasheqv",
00492                                               1, 1),
00493                           env);
00494   scheme_add_global_constant("hash?",
00495                           scheme_make_folding_prim(hash_p,
00496                                                 "hash?",
00497                                                 1, 1, 1),
00498                           env);
00499   scheme_add_global_constant("hash-eq?",
00500                           scheme_make_folding_prim(hash_eq_p,
00501                                                 "hash-eq?",
00502                                                 1, 1, 1),
00503                           env);
00504   scheme_add_global_constant("hash-eqv?",
00505                           scheme_make_folding_prim(hash_eqv_p,
00506                                                 "hash-eqv?",
00507                                                 1, 1, 1),
00508                           env);
00509   scheme_add_global_constant("hash-weak?",
00510                           scheme_make_folding_prim(hash_weak_p,
00511                                                 "hash-weak?",
00512                                                 1, 1, 1),
00513                           env);
00514   scheme_add_global_constant("hash-count",
00515                           scheme_make_immed_prim(hash_table_count,
00516                                               "hash-count",
00517                                               1, 1),
00518                           env);
00519   scheme_add_global_constant("hash-copy",
00520                           scheme_make_noncm_prim(hash_table_copy,
00521                                               "hash-copy",
00522                                               1, 1),
00523                           env);
00524   scheme_add_global_constant("hash-set!",
00525                           scheme_make_noncm_prim(hash_table_put_bang,
00526                                               "hash-set!",
00527                                               3, 3),
00528                           env);
00529   scheme_add_global_constant("hash-set",
00530                           scheme_make_noncm_prim(hash_table_put,
00531                                               "hash-set",
00532                                               3, 3),
00533                           env);
00534   scheme_add_global_constant("hash-ref",
00535                           scheme_make_prim_w_arity(hash_table_get,
00536                                                 "hash-ref",
00537                                                 2, 3),
00538                           env);
00539   scheme_add_global_constant("hash-remove!",
00540                           scheme_make_noncm_prim(hash_table_remove_bang,
00541                                               "hash-remove!",
00542                                               2, 2),
00543                           env);
00544   scheme_add_global_constant("hash-remove",
00545                           scheme_make_noncm_prim(hash_table_remove,
00546                                               "hash-remove",
00547                                               2, 2),
00548                           env);
00549   scheme_add_global_constant("hash-map",
00550                           scheme_make_noncm_prim(hash_table_map,
00551                                               "hash-map",
00552                                               2, 2),
00553                           env);
00554   scheme_add_global_constant("hash-for-each",
00555                           scheme_make_noncm_prim(hash_table_for_each,
00556                                               "hash-for-each",
00557                                               2, 2),
00558                           env);
00559 
00560   scheme_add_global_constant("hash-iterate-first",
00561                           scheme_make_immed_prim(hash_table_iterate_start,
00562                                               "hash-iterate-first",
00563                                                     1, 1),
00564                           env);
00565   scheme_add_global_constant("hash-iterate-next",
00566                           scheme_make_immed_prim(hash_table_iterate_next,
00567                                               "hash-iterate-next",
00568                                                     2, 2),
00569                           env);
00570   scheme_add_global_constant("hash-iterate-value",
00571                           scheme_make_immed_prim(hash_table_iterate_value,
00572                                               "hash-iterate-value",
00573                                                     2, 2),
00574                           env);
00575   scheme_add_global_constant("hash-iterate-key",
00576                           scheme_make_immed_prim(hash_table_iterate_key,
00577                                               "hash-iterate-key",
00578                                                     2, 2),
00579                           env);
00580 
00581   scheme_add_global_constant("eq-hash-code",
00582                           scheme_make_immed_prim(eq_hash_code,
00583                                               "eq-hash-code",
00584                                               1, 1),
00585                           env);
00586   scheme_add_global_constant("eqv-hash-code",
00587                           scheme_make_immed_prim(eqv_hash_code,
00588                                               "eqv-hash-code",
00589                                               1, 1),
00590                           env);
00591   scheme_add_global_constant("equal-hash-code",
00592                           scheme_make_noncm_prim(equal_hash_code,
00593                                               "equal-hash-code",
00594                                               1, 1),
00595                           env);
00596   scheme_add_global_constant("equal-secondary-hash-code",
00597                           scheme_make_noncm_prim(equal_hash2_code,
00598                                               "equal-secondary-hash-code",
00599                                               1, 1),
00600                           env);
00601 
00602   scheme_add_global_constant("make-weak-box",
00603                           scheme_make_immed_prim(make_weak_box,
00604                                               "make-weak-box",
00605                                               1, 1),
00606                           env);
00607   scheme_add_global_constant("weak-box-value",
00608                           scheme_make_immed_prim(weak_box_value,
00609                                               "weak-box-value",
00610                                               1, 1),
00611                           env);
00612   scheme_add_global_constant("weak-box?",
00613                           scheme_make_folding_prim(weak_boxp,
00614                                                 "weak-box?",
00615                                                 1, 1, 1),
00616                           env);
00617 
00618   scheme_add_global_constant("make-ephemeron",
00619                           scheme_make_immed_prim(make_ephemeron,
00620                                               "make-ephemeron",
00621                                               2, 2),
00622                           env);
00623   scheme_add_global_constant("ephemeron-value",
00624                           scheme_make_immed_prim(ephemeron_value,
00625                                               "ephemeron-value",
00626                                               1, 1),
00627                           env);
00628   scheme_add_global_constant("ephemeron?",
00629                           scheme_make_folding_prim(ephemeronp,
00630                                                 "ephemeron?",
00631                                                 1, 1, 1),
00632                           env);
00633 
00634   scheme_add_global_constant("make-reader-graph",
00635                           scheme_make_prim_w_arity(make_graph,
00636                                                 "make-reader-graph",
00637                                                 1, 1),
00638                           env);
00639   scheme_add_global_constant("make-placeholder",
00640                           scheme_make_prim_w_arity(make_placeholder,
00641                                                 "make-placeholder",
00642                                                 1, 1),
00643                           env);
00644   scheme_add_global_constant("placeholder-get",
00645                           scheme_make_prim_w_arity(placeholder_get,
00646                                                 "placeholder-get",
00647                                                 1, 1),
00648                           env);
00649   scheme_add_global_constant("placeholder-set!",
00650                           scheme_make_prim_w_arity(placeholder_set,
00651                                                 "placeholder-set!",
00652                                                 2, 2),
00653                           env);
00654   scheme_add_global_constant("placeholder?",
00655                           scheme_make_folding_prim(placeholder_p,
00656                                                 "placeholder?",
00657                                                 1, 1, 1),
00658                           env);
00659   scheme_add_global_constant("make-hash-placeholder",
00660                           scheme_make_prim_w_arity(make_hash_placeholder,
00661                                                 "make-hash-placeholder",
00662                                                 1, 1),
00663                           env);
00664   scheme_add_global_constant("make-hasheq-placeholder",
00665                           scheme_make_prim_w_arity(make_hasheq_placeholder,
00666                                                 "make-hasheq-placeholder",
00667                                                 1, 1),
00668                           env);
00669   scheme_add_global_constant("make-hasheqv-placeholder",
00670                           scheme_make_prim_w_arity(make_hasheqv_placeholder,
00671                                                 "make-hasheqv-placeholder",
00672                                                 1, 1),
00673                           env);
00674   scheme_add_global_constant("hash-placeholder?",
00675                           scheme_make_folding_prim(table_placeholder_p,
00676                                                 "hash-placeholder?",
00677                                                 1, 1, 1),
00678                           env);
00679 
00680   REGISTER_SO(weak_symbol);
00681   REGISTER_SO(equal_symbol);
00682 
00683   weak_symbol = scheme_intern_symbol("weak");
00684   equal_symbol = scheme_intern_symbol("equal");
00685 }
00686 
00687 Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr)
00688 {
00689 #ifdef MZ_PRECISE_GC
00690   return GC_malloc_pair(car, cdr);
00691 #else
00692   Scheme_Object *cons;
00693   cons = scheme_alloc_object();
00694   cons->type = scheme_pair_type;
00695   SCHEME_CAR(cons) = car;
00696   SCHEME_CDR(cons) = cdr;
00697   return cons;
00698 #endif
00699 }
00700 
00701 Scheme_Object *scheme_make_mutable_pair(Scheme_Object *car, Scheme_Object *cdr)
00702 {
00703   Scheme_Object *cons;
00704   cons = scheme_alloc_object();
00705   cons->type = scheme_mutable_pair_type;
00706   SCHEME_CAR(cons) = car;
00707   SCHEME_CDR(cons) = cdr;
00708   return cons;
00709 }
00710 
00711 Scheme_Object *scheme_make_raw_pair(Scheme_Object *car, Scheme_Object *cdr)
00712 {
00713   Scheme_Object *cons;
00714 
00715   /* A raw pair is like a pair, but some of our low-level debugging
00716      tools expect pairs to always contain tagged values. A raw pair
00717      contains arbitrary pointers. */
00718 
00719   cons = scheme_alloc_object();
00720   cons->type = scheme_raw_pair_type;
00721   SCHEME_CAR(cons) = car;
00722   SCHEME_CDR(cons) = cdr;
00723   return cons;
00724 }
00725 
00726 # define cons(car, cdr) scheme_make_pair(car, cdr)
00727 
00728 Scheme_Object *scheme_build_list(int size, Scheme_Object **argv)
00729 {
00730   Scheme_Object *pair = scheme_null;
00731   int i;
00732 
00733   for (i = size; i--; ) {
00734     pair = cons(argv[i], pair);
00735   }
00736 
00737   return pair;
00738 }
00739 
00740 Scheme_Object *scheme_build_list_offset(int size, Scheme_Object **argv, int delta)
00741 {
00742   Scheme_Object *pair = scheme_null;
00743   int i;
00744 
00745   for (i = size; i-- > delta; ) {
00746     pair = cons(argv[i], pair);
00747   }
00748 
00749   return pair;
00750 }
00751 
00752 Scheme_Object *scheme_alloc_list(int size)
00753 {
00754   Scheme_Object *pair = scheme_null;
00755   int i;
00756 
00757   for (i = size; i--; ) {
00758     pair = cons(scheme_false, pair);
00759   }
00760 
00761   return pair;
00762 }
00763 
00764 int
00765 scheme_list_length (Scheme_Object *list)
00766 {
00767   int len;
00768 
00769   len = 0;
00770   while (!SCHEME_NULLP(list)) {
00771     len++;
00772     if (SCHEME_PAIRP(list))
00773       list = SCHEME_CDR(list);
00774     else
00775       list = scheme_null;
00776   }
00777 
00778   return len;
00779 }
00780 
00781 int
00782 scheme_proper_list_length (Scheme_Object *list)
00783 {
00784   int len;
00785 
00786   if (!scheme_is_list(list))
00787     return -1;
00788 
00789   len = 0;
00790   while (SCHEME_PAIRP(list)) {
00791     len++;
00792     list = SCHEME_CDR(list);
00793   }
00794 
00795   return len;
00796 }
00797 
00798 Scheme_Object *
00799 scheme_named_map_1(char *name, Scheme_Object *(*fun)(Scheme_Object*, Scheme_Object*),
00800                  Scheme_Object *lst, Scheme_Object *form)
00801 {
00802   Scheme_Object *first = scheme_null, *last = NULL, *pr;
00803 
00804   while (SCHEME_STX_PAIRP(lst)) {
00805     Scheme_Object *v;
00806     v = SCHEME_STX_CAR(lst);
00807     v = fun(v, form);
00808     pr = cons(v, scheme_null);
00809     if (last)
00810       SCHEME_CDR(last) = pr;
00811     else
00812       first = pr;
00813     last = pr;
00814 
00815     lst = SCHEME_STX_CDR(lst);
00816   }
00817 
00818   if (!SCHEME_STX_NULLP(lst))
00819     scheme_wrong_syntax(name, lst, form, "bad syntax (" IMPROPER_LIST_FORM ")");
00820 
00821   return first;
00822 }
00823 
00824 Scheme_Object *
00825 scheme_map_1 (Scheme_Object *(*fun)(Scheme_Object*), Scheme_Object *lst)
00826 {
00827   return scheme_named_map_1("map",
00828                          (Scheme_Object *(*)(Scheme_Object *, Scheme_Object *))fun,
00829                          lst, NULL);
00830 }
00831 
00832 Scheme_Object *
00833 scheme_car (Scheme_Object *pair)
00834 {
00835   return (SCHEME_CAR (pair));
00836 }
00837 
00838 Scheme_Object *
00839 scheme_cdr (Scheme_Object *pair)
00840 {
00841   return (SCHEME_CDR (pair));
00842 }
00843 
00844 Scheme_Object *
00845 scheme_cadr (Scheme_Object *pair)
00846 {
00847   return (SCHEME_CAR (SCHEME_CDR (pair)));
00848 }
00849 
00850 Scheme_Object *
00851 scheme_caddr (Scheme_Object *pair)
00852 {
00853   return (SCHEME_CAR (SCHEME_CDR (SCHEME_CDR (pair))));
00854 }
00855 
00856 Scheme_Object *scheme_copy_list(Scheme_Object *l)
00857 {
00858   return scheme_vector_to_list(scheme_list_to_vector(l));
00859 }
00860 
00861 /* local functions */
00862 
00863 static Scheme_Object *
00864 pair_p_prim (int argc, Scheme_Object *argv[])
00865 {
00866   return (SCHEME_PAIRP(argv[0]) ? scheme_true : scheme_false);
00867 }
00868 
00869 static Scheme_Object *
00870 mpair_p_prim (int argc, Scheme_Object *argv[])
00871 {
00872   return (SCHEME_MUTABLE_PAIRP(argv[0]) ? scheme_true : scheme_false);
00873 }
00874 
00875 static Scheme_Object *
00876 cons_prim (int argc, Scheme_Object *argv[])
00877 {
00878   return cons(argv[0], argv[1]);
00879 }
00880 
00881 static Scheme_Object *
00882 mcons_prim (int argc, Scheme_Object *argv[])
00883 {
00884   return scheme_make_mutable_pair(argv[0], argv[1]);
00885 }
00886 
00887 Scheme_Object *
00888 scheme_checked_car (int argc, Scheme_Object *argv[])
00889 {
00890   if (!SCHEME_PAIRP(argv[0]))
00891     scheme_wrong_type("car", "pair", 0, argc, argv);
00892   return (SCHEME_CAR (argv[0]));
00893 }
00894 
00895 Scheme_Object *
00896 scheme_checked_cdr (int argc, Scheme_Object *argv[])
00897 {
00898   if (!SCHEME_PAIRP(argv[0]))
00899     scheme_wrong_type("cdr", "pair", 0, argc, argv);
00900 
00901   return (SCHEME_CDR (argv[0]));
00902 }
00903 
00904 Scheme_Object *
00905 scheme_checked_mcar (int argc, Scheme_Object *argv[])
00906 {
00907   if (!SCHEME_MPAIRP(argv[0]))
00908     scheme_wrong_type("mcar", "mutable-pair", 0, argc, argv);
00909   return (SCHEME_MCAR (argv[0]));
00910 }
00911 
00912 Scheme_Object *
00913 scheme_checked_mcdr (int argc, Scheme_Object *argv[])
00914 {
00915   if (!SCHEME_MUTABLE_PAIRP(argv[0]))
00916     scheme_wrong_type("mcdr", "mutable-pair", 0, argc, argv);
00917 
00918   return (SCHEME_MCDR (argv[0]));
00919 }
00920 
00921 Scheme_Object *
00922 scheme_checked_set_mcar (int argc, Scheme_Object *argv[])
00923 {
00924   if (!SCHEME_MPAIRP(argv[0]))
00925     scheme_wrong_type("set-mcar!", "mutable-pair", 0, argc, argv);
00926 
00927   SCHEME_MCAR(argv[0]) = argv[1];
00928   return scheme_void;
00929 }
00930 
00931 Scheme_Object *
00932 scheme_checked_set_mcdr (int argc, Scheme_Object *argv[])
00933 {
00934   if (!SCHEME_MPAIRP(argv[0]))
00935     scheme_wrong_type("set-mcdr!", "mutable-pair", 0, argc, argv);
00936 
00937   SCHEME_MCDR(argv[0]) = argv[1];
00938   return scheme_void;
00939 }
00940 
00941 static Scheme_Object *
00942 null_p_prim (int argc, Scheme_Object *argv[])
00943 {
00944   return (SCHEME_NULLP(argv[0]) ? scheme_true : scheme_false);
00945 }
00946 
00947 int scheme_is_list(Scheme_Object *obj1)
00948 {
00949   Scheme_Object *obj2;
00950   int flags;
00951 
00952   if (SCHEME_PAIRP(obj1)) {
00953     flags = SCHEME_PAIR_FLAGS(obj1);
00954     if (flags & PAIR_FLAG_MASK) {
00955       if (flags & PAIR_IS_LIST)
00956         return 1;
00957       else
00958         return 0;
00959     }
00960   } else if (SCHEME_NULLP(obj1))
00961     return 1;
00962   else
00963     return 0;
00964 
00965   obj2 = obj1;
00966 
00967   while (1) {
00968     obj1 = SCHEME_CDR(obj1);
00969 
00970     if (SCHEME_NULLP(obj1)){
00971       flags = PAIR_IS_LIST;
00972       break;
00973     }
00974     if (!SCHEME_PAIRP(obj1)) {
00975       flags = PAIR_IS_NON_LIST;
00976       break;
00977     }
00978 
00979     /* Known list or non-list? */
00980     flags = SCHEME_PAIR_FLAGS(obj1);
00981     if (flags & PAIR_FLAG_MASK)
00982       break;
00983 
00984     obj1 = SCHEME_CDR(obj1);
00985 
00986     if (SCHEME_NULLP(obj1)){
00987       flags = PAIR_IS_LIST;
00988       break;
00989     }
00990     if (!SCHEME_PAIRP(obj1)) {
00991       flags = PAIR_IS_NON_LIST;
00992       break;
00993     }
00994 
00995     /* Known list or non-list? */
00996     flags = SCHEME_PAIR_FLAGS(obj1);
00997     if (flags & PAIR_FLAG_MASK)
00998       break;
00999 
01000     obj2 = SCHEME_CDR(obj2);
01001   }
01002 
01003   /* Propagate info further up the chain. */
01004   SCHEME_PAIR_FLAGS(obj2) |= (flags & PAIR_FLAG_MASK);
01005 
01006   return (flags & PAIR_IS_LIST);
01007 }
01008 
01009 static Scheme_Object *
01010 list_p_prim (int argc, Scheme_Object *argv[])
01011 {
01012   return (scheme_is_list(argv[0])
01013           ? scheme_true
01014           : scheme_false);
01015 }
01016 
01017 #define NORMAL_LIST_INIT() l = scheme_null
01018 #define STAR_LIST_INIT() --argc; l = argv[argc]
01019 
01020 #define LIST_BODY(INIT)                          \
01021   int i;                                         \
01022   GC_CAN_IGNORE Scheme_Object *l;                \
01023   INIT;                                          \
01024   for (i = argc ; i--; ) {                       \
01025     l = cons(argv[i], l);                        \
01026   }                                              \
01027   return l
01028 
01029 static Scheme_Object *
01030 list_prim (int argc, Scheme_Object *argv[])
01031 {
01032   LIST_BODY(NORMAL_LIST_INIT());
01033 }
01034 
01035 static Scheme_Object *
01036 list_star_prim (int argc, Scheme_Object *argv[])
01037 {
01038   LIST_BODY(STAR_LIST_INIT());
01039 }
01040 
01041 static Scheme_Object *
01042 immutablep (int argc, Scheme_Object *argv[])
01043 {
01044   Scheme_Object *v = argv[0];
01045 
01046   return ((!SCHEME_INTP(v)
01047           && ((SCHEME_IMMUTABLEP(v)
01048                 && (SCHEME_VECTORP(v)
01049                     || SCHEME_BYTE_STRINGP(v)
01050                     || SCHEME_CHAR_STRINGP(v)
01051                     || SCHEME_BOXP(v)
01052                     || SCHEME_HASHTP(v)))
01053                || SCHEME_HASHTRP(v)))
01054          ? scheme_true
01055          : scheme_false);
01056 }
01057 
01058 static Scheme_Object *
01059 length_prim (int argc, Scheme_Object *argv[])
01060 {
01061   int l;
01062 
01063   if (!scheme_is_list(argv[0]))
01064     scheme_wrong_type("length", "proper list", 0, argc, argv);
01065 
01066   l = scheme_list_length(argv[0]);
01067 
01068   return scheme_make_integer(l);
01069 }
01070 
01071 Scheme_Object *
01072 scheme_append (Scheme_Object *lst1, Scheme_Object *lst2)
01073 {
01074   Scheme_Object *first, *last, *orig1, *v;
01075 
01076   orig1 = lst1;
01077 
01078   first = last = NULL;
01079   while (SCHEME_PAIRP(lst1)) {
01080     v = cons(SCHEME_CAR(lst1), scheme_null);
01081     if (!first)
01082       first = v;
01083     else
01084       SCHEME_CDR(last) = v;
01085     last = v;
01086     lst1 = SCHEME_CDR(lst1);
01087 
01088     SCHEME_USE_FUEL(1);
01089   }
01090 
01091   if (!SCHEME_NULLP(lst1))
01092     scheme_wrong_type("append", "proper list", -1, 0, &orig1);
01093 
01094   if (!last)
01095     return lst2;
01096 
01097   SCHEME_CDR(last) = lst2;
01098 
01099   return first;
01100 }
01101 
01102 Scheme_Object *scheme_reverse(Scheme_Object *l)
01103 {
01104   Scheme_Object *a[1];
01105   a[0] = l;
01106   return reverse_prim(1, a);
01107 }
01108 
01109 static Scheme_Object *
01110 append_prim (int argc, Scheme_Object *argv[])
01111 {
01112   Scheme_Object *res;
01113   int i;
01114 
01115   if (!argc)
01116     return scheme_null;
01117 
01118   res = argv[argc - 1];
01119   for (i = argc - 1; i--;  ) {
01120     res = scheme_append(argv[i], res);
01121   }
01122 
01123   return res;
01124 }
01125 
01126 static Scheme_Object *
01127 reverse_prim (int argc, Scheme_Object *argv[])
01128 {
01129   Scheme_Object *lst, *last;
01130 
01131   last = scheme_null;
01132   lst = argv[0];
01133   while (!SCHEME_NULLP (lst)) {
01134     if (!SCHEME_PAIRP(lst))
01135       scheme_wrong_type("reverse", "proper list", 0, argc, argv);
01136     last = cons(SCHEME_CAR (lst), last);
01137     lst = SCHEME_CDR (lst);
01138 
01139     SCHEME_USE_FUEL(1);
01140   }
01141   return (last);
01142 }
01143 
01144 #define OCCASIONAL_CHECK ((int)0xFF)
01145 #ifdef PALMOS_STUFF
01146 # define LISTREF_BIGNUM_SLICE 1000
01147 #else
01148 # define LISTREF_BIGNUM_SLICE 1000000
01149 #endif
01150 
01151 static Scheme_Object *
01152 do_list_ref(char *name, int takecar, int argc, Scheme_Object *argv[])
01153 {
01154   long i, k;
01155   Scheme_Object *lst, *index, *bnindex;
01156 
01157   if (SCHEME_BIGNUMP(argv[1])) {
01158     bnindex = argv[1];
01159     k = 0;
01160   } else if (!SCHEME_INTP(argv[1])) {
01161     scheme_wrong_type(name, "non-negative exact integer", 1, argc, argv);
01162     return NULL;
01163   } else {
01164     bnindex = NULL;
01165     k = SCHEME_INT_VAL(argv[1]);
01166   }
01167 
01168   lst = argv[0];
01169   index = argv[1];
01170 
01171   if ((bnindex && !SCHEME_BIGPOS(bnindex))
01172       || (!bnindex && (k < 0))) {
01173     scheme_wrong_type(name, "non-negative exact integer", 1, argc, argv);
01174     return NULL;
01175   }
01176 
01177   do {
01178     if (bnindex) {
01179       if (SCHEME_INTP(bnindex)) {
01180        k = SCHEME_INT_VAL(bnindex);
01181        bnindex = 0;
01182       } else {
01183        k = LISTREF_BIGNUM_SLICE;
01184        bnindex = scheme_bin_minus(bnindex, scheme_make_integer(LISTREF_BIGNUM_SLICE));
01185       }
01186     }
01187 
01188     for (i = 0; i < k; i++) {
01189       if (!SCHEME_PAIRP(lst)) {
01190        char *lstr;
01191        int llen;
01192 
01193        lstr = scheme_make_provided_string(argv[0], 2, &llen);
01194        scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01195                       "%s: index %s too large for list%s: %t", name,
01196                       scheme_make_provided_string(index, 2, NULL),
01197                       SCHEME_NULLP(lst) ? "" : " (not a proper list)",
01198                       lstr, llen);
01199        return NULL;
01200       }
01201       lst = SCHEME_CDR(lst);
01202       if (!(i & OCCASIONAL_CHECK))
01203        SCHEME_USE_FUEL(OCCASIONAL_CHECK);
01204     }
01205   } while(bnindex);
01206 
01207   if (takecar) {
01208     if (!SCHEME_PAIRP(lst)) {
01209       char *lstr;
01210       int llen;
01211 
01212       lstr = scheme_make_provided_string(argv[0], 2, &llen);
01213       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01214                      "%s: index %s too large for list%s: %t", name,
01215                      scheme_make_provided_string(index, 2, NULL),
01216                      SCHEME_NULLP(lst) ? "" : " (not a proper list)",
01217                      lstr, llen);
01218       return NULL;
01219     }
01220 
01221     return SCHEME_CAR(lst);
01222   } else
01223     return lst;
01224 }
01225 
01226 static Scheme_Object *
01227 list_tail_prim(int argc, Scheme_Object *argv[])
01228 {
01229   return do_list_ref("list-tail", 0, argc, argv);
01230 }
01231 
01232 static Scheme_Object *
01233 list_ref_prim(int argc, Scheme_Object *argv[])
01234 {
01235   return do_list_ref("list-ref", 1, argc, argv);
01236 }
01237 
01238 
01239 #define GEN_MEM(name, scheme_name, comp) \
01240 static Scheme_Object * \
01241 name (int argc, Scheme_Object *argv[]) \
01242 { \
01243   Scheme_Object *list, *turtle; \
01244   list = turtle = argv[1]; \
01245   while (SCHEME_PAIRP(list)) \
01246     { \
01247       if (comp (argv[0], SCHEME_CAR (list))) \
01248        { \
01249           return list; \
01250        } \
01251       list = SCHEME_CDR (list); \
01252       if (SCHEME_PAIRP(list)) { \
01253         if (comp (argv[0], SCHEME_CAR (list))) \
01254          { \
01255             return list; \
01256          } \
01257         if (SAME_OBJ(list, turtle)) break; \
01258         list = SCHEME_CDR (list); \
01259         turtle = SCHEME_CDR (turtle); \
01260         SCHEME_USE_FUEL(1); \
01261       } \
01262     } \
01263   if (!SCHEME_NULLP(list)) { \
01264     scheme_raise_exn(MZEXN_FAIL_CONTRACT, \
01265                    "%s: not a proper list: %V", #scheme_name, \
01266                    argv[1]); \
01267   } \
01268   return (scheme_false); \
01269 }
01270 
01271 GEN_MEM(memv, memv, scheme_eqv)
01272 GEN_MEM(memq, memq, SAME_OBJ)
01273 GEN_MEM(member, member, scheme_equal)
01274 
01275 #define GEN_ASS(name, scheme_name, comp) \
01276 static Scheme_Object * \
01277 name (int argc, Scheme_Object *argv[]) \
01278 { \
01279   Scheme_Object *pair, *list, *turtle;                  \
01280   list = turtle = argv[1]; \
01281   while (SCHEME_PAIRP (list)) \
01282     { \
01283       pair = SCHEME_CAR (list); \
01284       if (!SCHEME_PAIRP (pair)) {\
01285         char *npstr, *lstr; \
01286         int nplen, llen; \
01287         npstr = scheme_make_provided_string(pair, 2, &nplen); \
01288         lstr = scheme_make_provided_string(argv[1], 2, &llen); \
01289        scheme_raise_exn(MZEXN_FAIL_CONTRACT, \
01290                       "%s: non-pair found in list: %t in %t", #scheme_name, \
01291                       npstr, nplen, \
01292                       lstr, llen); \
01293        return NULL; \
01294       } \
01295       if (comp (argv[0], SCHEME_CAR (pair))) \
01296        { \
01297           return (pair); \
01298        } \
01299       list = SCHEME_CDR (list); \
01300       if (SCHEME_PAIRP(list)) { \
01301         pair = SCHEME_CAR (list); \
01302         if (SCHEME_PAIRP(pair)) { \
01303           if (comp (argv[0], SCHEME_CAR (pair))) \
01304            return pair; \
01305           list = SCHEME_CDR (list); \
01306           if (SAME_OBJ(list, turtle)) break; \
01307           turtle = SCHEME_CDR (turtle); \
01308           SCHEME_USE_FUEL(1); \
01309         } \
01310       } \
01311     } \
01312   if (!SCHEME_NULLP(list)) {\
01313     scheme_raise_exn(MZEXN_FAIL_CONTRACT, \
01314                    "%s: not a proper list: %V", #scheme_name, \
01315                    argv[1]); \
01316   } \
01317   return (scheme_false); \
01318 }
01319 
01320 GEN_ASS(assv, assv, scheme_eqv)
01321 GEN_ASS(assq, assq, SAME_OBJ)
01322 GEN_ASS(assoc, assoc, scheme_equal)
01323 
01324 #define LISTFUNC2(name, C, D) \
01325 Scheme_Object * \
01326 scheme_checked_ ## name (int argc, Scheme_Object *argv[]) \
01327 { \
01328   if (!(SCHEME_PAIRP(argv[0]) \
01329        && SCHEME_PAIRP(D(argv[0])))) \
01330       scheme_wrong_type(#name, #name "able value", 0, argc, argv); \
01331   return C(D(argv[0])); \
01332 }
01333 
01334 LISTFUNC2(cddr, SCHEME_CDR, SCHEME_CDR)
01335 LISTFUNC2(cadr, SCHEME_CAR, SCHEME_CDR)
01336 LISTFUNC2(cdar, SCHEME_CDR, SCHEME_CAR)
01337 LISTFUNC2(caar, SCHEME_CAR, SCHEME_CAR)
01338 
01339 #define LISTFUNC3(name, B, C, D) \
01340 static Scheme_Object * \
01341 name ## _prim (int argc, Scheme_Object *argv[]) \
01342 { \
01343   if (!((SCHEME_PAIRP(argv[0])) \
01344        && SCHEME_PAIRP(D(argv[0])) \
01345        && SCHEME_PAIRP(C(D(argv[0]))))) \
01346     scheme_wrong_type(#name, #name "able value", 0, argc, argv); \
01347   return B (C (D (argv[0]))); \
01348 }
01349 
01350 LISTFUNC3(cdddr, SCHEME_CDR, SCHEME_CDR, SCHEME_CDR)
01351 
01352 LISTFUNC3(caddr, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR)
01353 LISTFUNC3(cdadr, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR)
01354 LISTFUNC3(cddar, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR)
01355 
01356 LISTFUNC3(cdaar, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR)
01357 LISTFUNC3(cadar, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR)
01358 LISTFUNC3(caadr, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR)
01359 
01360 LISTFUNC3(caaar, SCHEME_CAR, SCHEME_CAR, SCHEME_CAR)
01361 
01362 
01363 #define LISTFUNC4(name, A, B, C, D) \
01364 static Scheme_Object * \
01365 name ## _prim (int argc, Scheme_Object *argv[]) \
01366 { \
01367   if (!(SCHEME_PAIRP(argv[0]) \
01368        && SCHEME_PAIRP(D (argv[0])) \
01369        && SCHEME_PAIRP(C(D(argv[0]))) \
01370        &&SCHEME_PAIRP(B(C(D(argv[0]))))))\
01371     scheme_wrong_type(#name, #name "able value", 0, argc, argv); \
01372   return A(B(C(D(argv[0]))));\
01373 }
01374 
01375 LISTFUNC4(cddddr, SCHEME_CDR, SCHEME_CDR, SCHEME_CDR, SCHEME_CDR)
01376 
01377 LISTFUNC4(cadddr, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR, SCHEME_CDR)
01378 LISTFUNC4(cdaddr, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR)
01379 LISTFUNC4(cddadr, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR)
01380 LISTFUNC4(cdddar, SCHEME_CDR, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR)
01381 
01382 LISTFUNC4(caaddr, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR)
01383 LISTFUNC4(cadadr, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR)
01384 LISTFUNC4(caddar, SCHEME_CAR, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR)
01385 LISTFUNC4(cdaadr, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR)
01386 LISTFUNC4(cdadar, SCHEME_CDR, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR)
01387 LISTFUNC4(cddaar, SCHEME_CDR, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR)
01388 
01389 LISTFUNC4(cdaaar, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR, SCHEME_CAR)
01390 LISTFUNC4(cadaar, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR, SCHEME_CAR)
01391 LISTFUNC4(caadar, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR, SCHEME_CAR)
01392 LISTFUNC4(caaadr, SCHEME_CAR, SCHEME_CAR, SCHEME_CAR, SCHEME_CDR)
01393 
01394 LISTFUNC4(caaaar, SCHEME_CAR, SCHEME_CAR, SCHEME_CAR, SCHEME_CAR)
01395 
01396 Scheme_Object *scheme_box(Scheme_Object *v)
01397 {
01398   Scheme_Object *obj;
01399 
01400   obj = scheme_alloc_small_object();
01401   obj->type = scheme_box_type;
01402   SCHEME_BOX_VAL(obj) = v;
01403 
01404   return obj;
01405 }
01406 
01407 Scheme_Object *scheme_unbox(Scheme_Object *obj)
01408 {
01409   if (!SCHEME_BOXP(obj))
01410       scheme_wrong_type(UNBOX, "box", 0, 1, &obj);
01411   return (Scheme_Object *)SCHEME_BOX_VAL(obj);
01412 }
01413 
01414 void scheme_set_box(Scheme_Object *b, Scheme_Object *v)
01415 {
01416   if (!SCHEME_MUTABLE_BOXP(b))
01417       scheme_wrong_type(SETBOX, "mutable box", 0, 1, &b);
01418   SCHEME_BOX_VAL(b) = v;
01419 }
01420 
01421 static Scheme_Object *box(int c, Scheme_Object *p[])
01422 {
01423   return scheme_box(p[0]);
01424 }
01425 
01426 static Scheme_Object *immutable_box(int c, Scheme_Object *p[])
01427 {
01428   Scheme_Object *obj;
01429 
01430   obj = scheme_box(p[0]);
01431   SCHEME_SET_IMMUTABLE(obj);
01432 
01433   return obj;
01434 }
01435 
01436 static Scheme_Object *box_p(int c, Scheme_Object *p[])
01437 {
01438   return SCHEME_BOXP(p[0]) ? scheme_true : scheme_false;
01439 }
01440 
01441 static Scheme_Object *unbox(int c, Scheme_Object *p[])
01442 {
01443   return scheme_unbox(p[0]);
01444 }
01445 
01446 static Scheme_Object *set_box(int c, Scheme_Object *p[])
01447 {
01448   scheme_set_box(p[0], p[1]);
01449   return scheme_void;
01450 }
01451 
01452 static int compare_equal(void *v1, void *v2)
01453 {
01454   return !scheme_equal((Scheme_Object *)v1, (Scheme_Object *)v2);
01455 }
01456 
01457 static void make_hash_indices_for_equal(void *v, long *_stk_h1, long *_stk_h2)
01458 {
01459   if (_stk_h1)
01460     *_stk_h1 = scheme_equal_hash_key((Scheme_Object *)v);
01461   if (_stk_h2)
01462     *_stk_h2 = scheme_equal_hash_key2((Scheme_Object *)v);
01463 }
01464 
01465 static int compare_eqv(void *v1, void *v2)
01466 {
01467   return !scheme_eqv((Scheme_Object *)v1, (Scheme_Object *)v2);
01468 }
01469 
01470 static void make_hash_indices_for_eqv(void *v, long *_stk_h1, long *_stk_h2)
01471 {
01472   if (_stk_h1)
01473     *_stk_h1 = scheme_eqv_hash_key((Scheme_Object *)v);
01474   if (_stk_h2)
01475     *_stk_h2 = scheme_eqv_hash_key2((Scheme_Object *)v);
01476 }
01477 
01478 Scheme_Bucket_Table *scheme_make_weak_equal_table(void)
01479 {
01480   Scheme_Object *sema;
01481   Scheme_Bucket_Table *t;
01482   
01483   t = scheme_make_bucket_table(20, SCHEME_hash_weak_ptr);
01484   
01485   sema = scheme_make_sema(1);
01486   t->mutex = sema;
01487   t->compare = compare_equal;
01488   t->make_hash_indices = make_hash_indices_for_equal;
01489 
01490   return t;
01491 }
01492 
01493 Scheme_Bucket_Table *scheme_make_weak_eqv_table(void)
01494 {
01495   Scheme_Object *sema;
01496   Scheme_Bucket_Table *t;
01497   
01498   t = scheme_make_bucket_table(20, SCHEME_hash_weak_ptr);
01499   
01500   sema = scheme_make_sema(1);
01501   t->mutex = sema;
01502   t->compare = compare_eqv;
01503   t->make_hash_indices = make_hash_indices_for_eqv;
01504 
01505   return t;
01506 }
01507 
01508 static Scheme_Object *make_hash(int argc, Scheme_Object *argv[])
01509 {
01510   return (Scheme_Object *)scheme_make_hash_table_equal();
01511 }
01512 
01513 static Scheme_Object *make_hasheq(int argc, Scheme_Object *argv[])
01514 {
01515   return (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr);
01516 }
01517 
01518 static Scheme_Object *make_hasheqv(int argc, Scheme_Object *argv[])
01519 {
01520   return (Scheme_Object *)scheme_make_hash_table_eqv();
01521 }
01522 
01523 static Scheme_Object *make_weak_hash(int argc, Scheme_Object *argv[])
01524 {
01525   return (Scheme_Object *)scheme_make_weak_equal_table();
01526 }
01527 
01528 static Scheme_Object *make_weak_hasheq(int argc, Scheme_Object *argv[])
01529 {
01530   return (Scheme_Object *)scheme_make_bucket_table(20, SCHEME_hash_weak_ptr);
01531 }
01532 
01533 static Scheme_Object *make_weak_hasheqv(int argc, Scheme_Object *argv[])
01534 {
01535   return (Scheme_Object *)scheme_make_weak_eqv_table();
01536 }
01537 
01538 static Scheme_Object *make_immutable_table(const char *who, int kind, int argc, Scheme_Object *argv[])
01539 {
01540   Scheme_Object *l = argv[0], *a;
01541   Scheme_Hash_Tree *ht;
01542 
01543   if (scheme_proper_list_length(l) >= 0) {
01544     for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
01545       a = SCHEME_CAR(l);
01546       if (!SCHEME_PAIRP(a))
01547        break;
01548     }
01549   }
01550 
01551   if (!SCHEME_NULLP(l))
01552     scheme_wrong_type("make-immutable-hash", "list of pairs", 0, argc, argv);
01553 
01554   ht = scheme_make_hash_tree(kind);
01555 
01556   for (l = argv[0]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
01557     a = SCHEME_CAR(l);
01558     ht = scheme_hash_tree_set(ht, SCHEME_CAR(a), SCHEME_CDR(a));
01559   }
01560 
01561   return (Scheme_Object *)ht;
01562 }
01563 
01564 static Scheme_Object *make_immutable_hash(int argc, Scheme_Object *argv[])
01565 {
01566   return make_immutable_table("make-immutable-hash", 1, argc, argv);
01567 }
01568 
01569 static Scheme_Object *make_immutable_hasheq(int argc, Scheme_Object *argv[])
01570 {
01571   return make_immutable_table("make-immutable-hasheq", 0, argc, argv);
01572 }
01573 
01574 static Scheme_Object *make_immutable_hasheqv(int argc, Scheme_Object *argv[])
01575 {
01576   return make_immutable_table("make-immutable-hasheqv", 2, argc, argv);
01577 }
01578 
01579 Scheme_Hash_Table *scheme_make_hash_table_equal()
01580 {
01581   Scheme_Hash_Table *t;
01582   Scheme_Object *sema;
01583 
01584   t = scheme_make_hash_table(SCHEME_hash_ptr);
01585 
01586   sema = scheme_make_sema(1);
01587   t->mutex = sema;
01588   t->compare = compare_equal;
01589   t->make_hash_indices = make_hash_indices_for_equal;
01590 
01591   return t;
01592 }
01593 
01594 Scheme_Hash_Table *scheme_make_hash_table_eqv()
01595 {
01596   Scheme_Hash_Table *t;
01597   Scheme_Object *sema;
01598 
01599   t = scheme_make_hash_table(SCHEME_hash_ptr);
01600 
01601   sema = scheme_make_sema(1);
01602   t->mutex = sema;
01603   t->compare = compare_eqv;
01604   t->make_hash_indices = make_hash_indices_for_eqv;
01605 
01606   return t;
01607 }
01608 
01609 static Scheme_Object *hash_table_count(int argc, Scheme_Object *argv[])
01610 {
01611   if (SCHEME_HASHTP(argv[0])) {
01612     Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
01613     return scheme_make_integer(t->count);
01614   } else if (SCHEME_HASHTRP(argv[0])) {
01615     Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)argv[0];
01616     return scheme_make_integer(t->count);
01617   } else if (SCHEME_BUCKTP(argv[0])) {
01618     Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
01619     int count = 0, weak, i;
01620     Scheme_Bucket **buckets, *bucket;
01621     const char *key;
01622 
01623     buckets = t->buckets;
01624     weak = t->weak;
01625 
01626     for (i = t->size; i--; ) {
01627       bucket = buckets[i];
01628       if (bucket) {
01629        if (weak) {
01630          key = (const char *)HT_EXTRACT_WEAK(bucket->key);
01631        } else {
01632          key = bucket->key;
01633        }
01634        if (key)
01635          count++;
01636       }
01637       SCHEME_USE_FUEL(1);
01638     }
01639 
01640     return scheme_make_integer(count);
01641   } else {
01642     scheme_wrong_type("hash-count", "hash", 0, argc, argv);
01643     return NULL;
01644   }
01645 }
01646 
01647 static Scheme_Object *hash_table_copy(int argc, Scheme_Object *argv[])
01648 {
01649   if (SCHEME_HASHTP(argv[0])) {
01650     Scheme_Object *o;
01651     Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
01652     if (t->mutex) scheme_wait_sema(t->mutex,0);
01653     o = (Scheme_Object *)scheme_clone_hash_table(t);
01654     if (t->mutex) scheme_post_sema(t->mutex);
01655     return o;
01656   } else if (SCHEME_BUCKTP(argv[0])) {
01657     Scheme_Object *o;
01658     Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
01659     if (t->mutex) scheme_wait_sema(t->mutex,0);
01660     o = (Scheme_Object *)scheme_clone_bucket_table(t);
01661     if (t->mutex) scheme_post_sema(t->mutex);
01662     return o;
01663   } else if (SCHEME_HASHTRP(argv[0])) {
01664     Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)argv[0];
01665     Scheme_Hash_Table *naya;
01666     int i;
01667     Scheme_Object *k, *v;
01668 
01669     if (scheme_is_hash_tree_equal((Scheme_Object *)t))
01670       naya = scheme_make_hash_table_equal();
01671     else
01672       naya = scheme_make_hash_table(SCHEME_hash_ptr);
01673 
01674     for (i = t->count; i--; ) {
01675       scheme_hash_tree_index(t, i, &k, &v);
01676       scheme_hash_set(naya, k, v);
01677     }
01678 
01679     return (Scheme_Object *)naya;
01680   } else {
01681     scheme_wrong_type("hash-copy", "hash", 0, argc, argv);
01682     return NULL;
01683   }
01684 }
01685 
01686 static Scheme_Object *hash_p(int argc, Scheme_Object *argv[])
01687 {
01688   Scheme_Object *o = argv[0];
01689 
01690   if (SCHEME_HASHTP(o) || SCHEME_HASHTRP(o) || SCHEME_BUCKTP(o))
01691     return scheme_true;
01692   else
01693     return scheme_false;
01694 }
01695 
01696 static Scheme_Object *hash_eq_p(int argc, Scheme_Object *argv[])
01697 {
01698   Scheme_Object *o = argv[0];
01699 
01700   if (SCHEME_HASHTP(o)) {
01701     if ((((Scheme_Hash_Table *)o)->compare != compare_equal)
01702         && (((Scheme_Hash_Table *)o)->compare != compare_eqv))
01703       return scheme_true;
01704   } else if (SCHEME_HASHTRP(o)) {
01705     if (!(SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x3))
01706       return scheme_true;
01707   } else if (SCHEME_BUCKTP(o)) {
01708     if ((((Scheme_Bucket_Table *)o)->compare != compare_equal)
01709         && (((Scheme_Bucket_Table *)o)->compare != compare_eqv))
01710       return scheme_true;
01711   } else {
01712     scheme_wrong_type("hash-eq?", "hash", 0, argc, argv);
01713   }
01714   
01715   return scheme_false;
01716 }
01717 
01718 static Scheme_Object *hash_eqv_p(int argc, Scheme_Object *argv[])
01719 {
01720   Scheme_Object *o = argv[0];
01721 
01722   if (SCHEME_HASHTP(o)) {
01723     if (((Scheme_Hash_Table *)o)->compare == compare_eqv)
01724       return scheme_true;
01725   } else if (SCHEME_HASHTRP(o)) {
01726     if (SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x2)
01727       return scheme_true;
01728   } else if (SCHEME_BUCKTP(o)) {
01729     if (((Scheme_Bucket_Table *)o)->compare == compare_eqv)
01730       return scheme_true;
01731   } else {
01732     scheme_wrong_type("hash-eqv?", "hash", 0, argc, argv);
01733   }
01734   
01735   return scheme_false;
01736 }
01737 
01738 static Scheme_Object *hash_weak_p(int argc, Scheme_Object *argv[])
01739 {
01740   Scheme_Object *o = argv[0];
01741 
01742   if (SCHEME_BUCKTP(o))
01743     return scheme_true;
01744   else if (SCHEME_HASHTP(o) || SCHEME_HASHTRP(o))
01745     return scheme_false;
01746   
01747   scheme_wrong_type("hash-eq?", "hash", 0, argc, argv);
01748    
01749   return NULL;
01750 }
01751 
01752 int scheme_is_hash_table_equal(Scheme_Object *o)
01753 {
01754   return (((Scheme_Hash_Table *)o)->compare == compare_equal);
01755 }
01756 
01757 int scheme_is_hash_table_eqv(Scheme_Object *o)
01758 {
01759   return (((Scheme_Hash_Table *)o)->compare == compare_eqv);
01760 }
01761 
01762 int scheme_is_hash_tree_equal(Scheme_Object *o)
01763 {
01764   return SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x1;
01765 }
01766 
01767 int scheme_is_hash_tree_eqv(Scheme_Object *o)
01768 {
01769   return SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x2;
01770 }
01771 
01772 static Scheme_Object *hash_table_put_bang(int argc, Scheme_Object *argv[])
01773 {
01774   Scheme_Object *v = argv[0];
01775 
01776   if (SCHEME_BUCKTP(v)) {
01777     Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)v;
01778     if (t->mutex) scheme_wait_sema(t->mutex,0);
01779     scheme_add_to_table(t, (char *)argv[1], (void *)argv[2], 0);
01780     if (t->mutex) scheme_post_sema(t->mutex);
01781   } else if (!SCHEME_HASHTP(v) || !SCHEME_MUTABLEP(v)) {
01782     scheme_wrong_type("hash-set!", "mutable table", 0, argc, argv);
01783   } else if (((Scheme_Hash_Table *)v)->mutex) {
01784     Scheme_Hash_Table *t = (Scheme_Hash_Table *)v;
01785     scheme_wait_sema(t->mutex, 0);
01786     scheme_hash_set(t, argv[1], argv[2]);
01787     scheme_post_sema(t->mutex);
01788   } else {
01789     scheme_hash_set((Scheme_Hash_Table *)v, argv[1], argv[2]);
01790   }
01791 
01792   return scheme_void;
01793 }
01794 
01795 static Scheme_Object *hash_table_put(int argc, Scheme_Object *argv[])
01796 {
01797   Scheme_Object *v = argv[0];
01798 
01799   if (!SCHEME_HASHTRP(v)) {
01800     scheme_wrong_type("hash-set", "immutable hash", 0, argc, argv);
01801     return NULL;
01802   }
01803   
01804   return (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)v, argv[1], argv[2]);
01805 }
01806 
01807 static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
01808 {
01809   Scheme_Object *v;
01810 
01811   v = argv[0];
01812 
01813   if (SCHEME_BUCKTP(v)) {
01814     Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)v;
01815     if (t->mutex) scheme_wait_sema(t->mutex, 0);
01816     v = (Scheme_Object *)scheme_lookup_in_table(t, (char *)argv[1]);
01817     if (t->mutex) scheme_post_sema(t->mutex);
01818   } else if (SCHEME_HASHTRP(v)) {
01819     v = scheme_hash_tree_get((Scheme_Hash_Tree *)v, argv[1]);
01820   } else if (!SCHEME_HASHTP(v)) {
01821     scheme_wrong_type("hash-ref", "hash", 0, argc, argv);
01822     return NULL;
01823   } else if (((Scheme_Hash_Table *)v)->mutex) {
01824     Scheme_Hash_Table *t = (Scheme_Hash_Table *)v;
01825     scheme_wait_sema(t->mutex, 0);
01826     v = scheme_hash_get(t, argv[1]);
01827     scheme_post_sema(t->mutex);
01828   } else {
01829     v = scheme_hash_get((Scheme_Hash_Table *)v, argv[1]);
01830   }
01831 
01832   if (v)
01833     return v;
01834   else if (argc == 3) {
01835     v = argv[2];
01836     if (SCHEME_PROCP(v))
01837       return _scheme_tail_apply(v, 0, NULL);
01838     else
01839       return v;
01840   } else {
01841     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01842                    "hash-ref: no value found for key: %V",
01843                    argv[1]);
01844     return scheme_void;
01845   }
01846 }
01847 
01848 static Scheme_Object *hash_table_remove_bang(int argc, Scheme_Object *argv[])
01849 {
01850   if (!(SCHEME_HASHTP(argv[0]) && SCHEME_MUTABLEP(argv[0])) && !SCHEME_BUCKTP(argv[0]))
01851     scheme_wrong_type("hash-remove!", "mutable table", 0, argc, argv);
01852 
01853   if (SCHEME_BUCKTP(argv[0])) {
01854     Scheme_Bucket *b;
01855     Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
01856     if (t->mutex) scheme_wait_sema(t->mutex, 0);
01857     b = scheme_bucket_or_null_from_table((Scheme_Bucket_Table *)argv[0], (char *)argv[1], 0);
01858     if (b) {
01859       HT_EXTRACT_WEAK(b->key) = NULL;
01860       b->val = NULL;
01861     }
01862     if (t->mutex) scheme_post_sema(t->mutex);
01863   } else{
01864     Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
01865     if (t->mutex) scheme_wait_sema(t->mutex, 0);
01866     scheme_hash_set(t, argv[1], NULL);
01867     if (t->mutex) scheme_post_sema(t->mutex);
01868   }
01869 
01870   return scheme_void;
01871 }
01872 
01873 static Scheme_Object *hash_table_remove(int argc, Scheme_Object *argv[])
01874 {
01875   if (!SCHEME_HASHTRP(argv[0]))
01876     scheme_wrong_type("hash-remove", "immutable hash", 0, argc, argv);
01877 
01878   return (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)argv[0], argv[1], NULL);
01879 }
01880 
01881 static Scheme_Object *do_map_hash_table(int argc,
01882                                    Scheme_Object *argv[],
01883                                    char *name,
01884                                    int keep)
01885 {
01886   int i;
01887   Scheme_Object *f;
01888   Scheme_Object *first, *last = NULL, *v, *p[2];
01889 
01890   if (!(SCHEME_HASHTP(argv[0]) || SCHEME_BUCKTP(argv[0]) || SCHEME_HASHTRP(argv[0])))
01891     scheme_wrong_type(name, "hash", 0, argc, argv);
01892   scheme_check_proc_arity(name, 2, 1, argc, argv);
01893 
01894   f = argv[1];
01895 
01896   if (keep)
01897     first = scheme_null;
01898   else
01899     first = scheme_void;
01900 
01901   if (SCHEME_BUCKTP(argv[0])) {
01902     Scheme_Bucket_Table *hash;
01903     Scheme_Bucket *bucket;
01904 
01905     hash = (Scheme_Bucket_Table *)argv[0];
01906 
01907     for (i = hash->size; i--; ) {
01908       bucket = hash->buckets[i];
01909       if (bucket && bucket->val && bucket->key) {
01910        if (hash->weak)
01911          p[0] = (Scheme_Object *)HT_EXTRACT_WEAK(bucket->key);
01912        else
01913          p[0] = (Scheme_Object *)bucket->key;
01914        p[1] = (Scheme_Object *)bucket->val;
01915        if (keep) {
01916          v = _scheme_apply(f, 2, p);
01917          v = cons(v, scheme_null);
01918          if (last)
01919            SCHEME_CDR(last) = v;
01920          else
01921            first = v;
01922          last = v;
01923        } else
01924          _scheme_apply_multi(f, 2, p);
01925       }
01926     }
01927   } else if (SCHEME_HASHTP(argv[0])) {
01928     Scheme_Hash_Table *hash;
01929 
01930     hash = (Scheme_Hash_Table *)argv[0];
01931 
01932     for (i = hash->size; i--; ) {
01933       if (hash->vals[i]) {
01934        p[0] = hash->keys[i];
01935        p[1] = hash->vals[i];
01936        if (keep) {
01937          v = _scheme_apply(f, 2, p);
01938          v = cons(v, scheme_null);
01939          if (last)
01940            SCHEME_CDR(last) = v;
01941          else
01942            first = v;
01943          last = v;
01944        } else
01945          _scheme_apply_multi(f, 2, p);
01946       }
01947     }
01948   } else {
01949     Scheme_Object *ik, *iv;
01950     Scheme_Hash_Tree *hash;
01951     long pos;
01952 
01953     hash = (Scheme_Hash_Tree *)argv[0];
01954 
01955     pos = scheme_hash_tree_next(hash, -1);
01956     while (pos != -1) {
01957       scheme_hash_tree_index(hash, pos, &ik, &iv);
01958       p[0] = ik;
01959       p[1] = iv;
01960       if (keep) {
01961         v = _scheme_apply(f, 2, p);
01962         v = cons(v, scheme_null);
01963         if (last)
01964           SCHEME_CDR(last) = v;
01965         else
01966           first = v;
01967         last = v;
01968       } else
01969         _scheme_apply_multi(f, 2, p);
01970       pos = scheme_hash_tree_next(hash, pos);
01971     }
01972   }
01973 
01974   return first;
01975 }
01976 
01977 static Scheme_Object *hash_table_map(int argc, Scheme_Object *argv[])
01978 {
01979   return do_map_hash_table(argc, argv, "hash-map", 1);
01980 }
01981 
01982 static Scheme_Object *hash_table_for_each(int argc, Scheme_Object *argv[])
01983 {
01984   return do_map_hash_table(argc, argv, "hash-for-each", 0);
01985 }
01986 
01987 static Scheme_Object *hash_table_next(const char *name, int start, int argc, Scheme_Object *argv[])
01988 {
01989   if (SCHEME_HASHTP(argv[0])) {
01990     Scheme_Hash_Table *hash;
01991     int i, sz;
01992 
01993     hash = (Scheme_Hash_Table *)argv[0];
01994 
01995     sz = hash->size;
01996     if (start >= 0) {
01997       if ((start >= sz) || !hash->vals[start])
01998         return NULL;
01999     }
02000     for (i = start + 1; i < sz; i++) {
02001       if (hash->vals[i])
02002         return scheme_make_integer(i);
02003     }
02004 
02005     return scheme_false;
02006   } else if (SCHEME_HASHTRP(argv[0])) {
02007     int v;
02008     v = scheme_hash_tree_next((Scheme_Hash_Tree *)argv[0], start);
02009     if (v == -1)
02010       return scheme_false;
02011     else if (v == -2)
02012       return NULL;
02013     else
02014       return scheme_make_integer(v);
02015   } else if (SCHEME_BUCKTP(argv[0])) {
02016     Scheme_Bucket_Table *hash;
02017     Scheme_Bucket *bucket;
02018     int i, sz;
02019 
02020     hash = (Scheme_Bucket_Table *)argv[0];
02021 
02022     sz = hash->size;
02023     
02024     if (start >= 0) {
02025       bucket = ((start < sz) ? hash->buckets[start] : NULL);
02026       if (!bucket || !bucket->val || !bucket->key) 
02027         return NULL;      
02028     }
02029     for (i = start + 1; i < sz; i++) {
02030       bucket = hash->buckets[i];
02031       if (bucket && bucket->val && bucket->key) {
02032         return scheme_make_integer(i);
02033       }
02034     }
02035 
02036     return scheme_false;
02037   } else {
02038     scheme_wrong_type(name, "hash", 0, argc, argv);
02039     return NULL;
02040   }
02041 }
02042 
02043 static Scheme_Object *hash_table_iterate_start(int argc, Scheme_Object *argv[])
02044 {
02045   return hash_table_next("hash-iterate-first", -1, argc, argv);
02046 }
02047 
02048 static Scheme_Object *hash_table_iterate_next(int argc, Scheme_Object *argv[])
02049 {
02050   Scheme_Object *p = argv[1], *v;
02051   int pos;
02052 
02053   if (SCHEME_INTP(p)) {
02054     pos = SCHEME_INT_VAL(p);
02055     if (pos < 0)
02056       pos = 0x7FFFFFFE;
02057   } else {
02058     pos = 0x7FFFFFFE;
02059   }
02060 
02061   v = hash_table_next("hash-iterate-next", pos, argc, argv);
02062 
02063   if (v)
02064     return v;
02065 
02066   if (SCHEME_INTP(p)) {
02067     if (SCHEME_INT_VAL(p) >= 0)
02068       p = NULL;
02069   } else if (SCHEME_BIGNUMP(p)) {
02070     if (SCHEME_BIGPOS(p))
02071       p = NULL;
02072   }
02073 
02074   if (p)
02075     scheme_wrong_type("hash-iterate-next", "exact non-negative integer", 1, argc, argv);  
02076 
02077   scheme_arg_mismatch("hash-iterate-next", "no element at index: ", argv[1]);
02078 
02079   return NULL;
02080 }
02081 
02082 static Scheme_Object *hash_table_index(const char *name, int argc, Scheme_Object *argv[], int get_val)
02083 {
02084   Scheme_Object *p = argv[1];
02085   int pos, sz;
02086 
02087   if (SCHEME_INTP(p)) {
02088     pos = SCHEME_INT_VAL(p);
02089     if (pos < 0)
02090       pos = 0x7FFFFFFF;
02091   } else {
02092     pos = 0x7FFFFFFF;
02093   }
02094 
02095   if (SCHEME_HASHTP(argv[0])) {
02096     Scheme_Hash_Table *hash;
02097 
02098     hash = (Scheme_Hash_Table *)argv[0];
02099 
02100     sz = hash->size;
02101     if (pos < sz) {
02102       if (hash->vals[pos]) {
02103         if (get_val)
02104           return hash->vals[pos];
02105         else
02106           return hash->keys[pos];
02107       }
02108     }
02109   } else if (SCHEME_HASHTRP(argv[0])) {
02110     Scheme_Object *v, *k;
02111     if (scheme_hash_tree_index((Scheme_Hash_Tree *)argv[0], pos, &k, &v))
02112       return (get_val ? v : k);
02113   } else if (SCHEME_BUCKTP(argv[0])) {
02114     Scheme_Bucket_Table *hash;
02115     int sz;
02116     Scheme_Bucket *bucket;
02117 
02118     hash = (Scheme_Bucket_Table *)argv[0];
02119 
02120     sz = hash->size;
02121     if (pos < sz) {
02122       bucket = hash->buckets[pos];
02123       if (bucket && bucket->val && bucket->key) {
02124         if (get_val)
02125           return (Scheme_Object *)bucket->val;
02126         else {
02127           if (hash->weak)
02128             return (Scheme_Object *)HT_EXTRACT_WEAK(bucket->key);
02129           else
02130             return (Scheme_Object *)bucket->key;
02131         }
02132       }
02133     }
02134   } else {
02135     scheme_wrong_type(name, "hash", 0, argc, argv);
02136     return NULL;
02137   }
02138 
02139   if ((SCHEME_INTP(p)
02140        && (SCHEME_INT_VAL(p) >= 0))
02141       || (SCHEME_BIGNUMP(p)
02142           && SCHEME_BIGPOS(p))) {
02143     scheme_arg_mismatch(name, "no element at index: ", p);
02144     return NULL;
02145   }
02146 
02147   scheme_wrong_type(name, "exact non-negative integer", 1, argc, argv);  
02148   return NULL;
02149 }
02150 
02151 static Scheme_Object *hash_table_iterate_value(int argc, Scheme_Object *argv[])
02152 {
02153   return hash_table_index("hash-iterate-value", argc, argv, 1);
02154 }
02155 
02156 static Scheme_Object *hash_table_iterate_key(int argc, Scheme_Object *argv[])
02157 {
02158   return hash_table_index("hash-iterate-key", argc, argv, 0);
02159 }
02160 
02161 static Scheme_Object *eq_hash_code(int argc, Scheme_Object *argv[])
02162 {
02163   long v;
02164 
02165   if (SCHEME_INTP(argv[0]))
02166     return argv[0];
02167 
02168 #ifdef MZ_PRECISE_GC
02169   v = scheme_hash_key(argv[0]);
02170 #else
02171   v = ((long)argv[0]) >> 2;
02172 #endif
02173 
02174   return scheme_make_integer(v);
02175 }
02176 
02177 static Scheme_Object *equal_hash_code(int argc, Scheme_Object *argv[])
02178 {
02179   long v;
02180 
02181   if (SCHEME_INTP(argv[0]))
02182     return argv[0];
02183 
02184   v = scheme_equal_hash_key(argv[0]);
02185 
02186   return scheme_make_integer(v);
02187 }
02188 
02189 static Scheme_Object *equal_hash2_code(int argc, Scheme_Object *argv[])
02190 {
02191   long v;
02192 
02193   v = scheme_equal_hash_key2(argv[0]);
02194 
02195   return scheme_make_integer(v);
02196 }
02197 
02198 static Scheme_Object *eqv_hash_code(int argc, Scheme_Object *argv[])
02199 {
02200   long v;
02201 
02202   if (SCHEME_INTP(argv[0]))
02203     return argv[0];
02204 
02205   v = scheme_eqv_hash_key(argv[0]);
02206 
02207   return scheme_make_integer(v);
02208 }
02209 
02210 Scheme_Object *scheme_make_weak_box(Scheme_Object *v)
02211 {
02212 #ifdef MZ_PRECISE_GC
02213   return (Scheme_Object *)GC_malloc_weak_box(v, NULL, 0);
02214 #else
02215   Scheme_Small_Object *obj;
02216 
02217   obj = MALLOC_ONE_TAGGED_WEAK(Scheme_Small_Object);
02218 
02219   obj->iso.so.type = scheme_weak_box_type;
02220 
02221   obj->u.ptr_val = v;
02222   scheme_weak_reference((void **)(void *)&obj->u.ptr_val);
02223 
02224   return (Scheme_Object *)obj;
02225 #endif
02226 }
02227 
02228 static Scheme_Object *make_weak_box(int argc, Scheme_Object *argv[])
02229 {
02230   return scheme_make_weak_box(argv[0]);
02231 }
02232 
02233 static Scheme_Object *weak_box_value(int argc, Scheme_Object *argv[])
02234 {
02235   Scheme_Object *o;
02236 
02237   if (!SCHEME_WEAKP(argv[0]))
02238     scheme_wrong_type("weak-box-value", "weak-box", 0, argc, argv);
02239 
02240   o = SCHEME_BOX_VAL(argv[0]);
02241   if (!o)
02242     return scheme_false;
02243   else
02244     return o;
02245 }
02246 
02247 static Scheme_Object *weak_boxp(int argc, Scheme_Object *argv[])
02248 {
02249   return (SCHEME_WEAKP(argv[0]) ? scheme_true : scheme_false);
02250 }
02251 
02252 Scheme_Object * scheme_make_null (void)
02253 {
02254   return scheme_null;
02255 }
02256 
02257 static Scheme_Object *make_graph(int argc, Scheme_Object *argv[])
02258 {
02259   return scheme_resolve_placeholders(argv[0]);
02260 }
02261 
02262 static Scheme_Object *make_placeholder(int argc, Scheme_Object *argv[])
02263 {
02264   Scheme_Object *ph;
02265 
02266   ph = scheme_alloc_small_object();
02267   ph->type = scheme_placeholder_type;
02268   SCHEME_PTR_VAL(ph) = argv[0];
02269 
02270   return ph;
02271 }
02272 
02273 static Scheme_Object *placeholder_set(int argc, Scheme_Object *argv[])
02274 {
02275   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_placeholder_type))
02276     scheme_wrong_type("placeholder-set!", "placeholder", 0, argc, argv);
02277   SCHEME_PTR_VAL(argv[0]) = argv[1];
02278   return scheme_void;
02279 }
02280 
02281 static Scheme_Object *placeholder_get(int argc, Scheme_Object *argv[])
02282 {
02283   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_placeholder_type))
02284     scheme_wrong_type("placeholder-get", "placeholder", 0, argc, argv);
02285   return SCHEME_PTR_VAL(argv[0]);
02286 }
02287 
02288 static Scheme_Object *placeholder_p(int c, Scheme_Object *p[])
02289 {
02290   return (SAME_TYPE(SCHEME_TYPE(p[0]), scheme_placeholder_type)
02291           ? scheme_true 
02292           : scheme_false);
02293 }
02294 
02295 static Scheme_Object *do_make_hash_placeholder(const char *who, int kind, int argc, Scheme_Object *argv[])
02296 {
02297   Scheme_Object *l, *a, *ph;
02298 
02299   for (l = argv[0]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
02300     a = SCHEME_CAR(l);
02301     if (!SCHEME_PAIRP(a))
02302       break;
02303   }
02304 
02305   if (!SCHEME_NULLP(l)) {
02306     scheme_wrong_type(who, "list of pairs", 0, argc, argv);
02307   }
02308 
02309   ph = scheme_alloc_object();
02310   ph->type = scheme_table_placeholder_type;
02311   SCHEME_IPTR_VAL(ph) = argv[0];
02312   SCHEME_PINT_VAL(ph) = kind;
02313 
02314   return ph;
02315 }
02316 
02317 static Scheme_Object *make_hash_placeholder(int argc, Scheme_Object *argv[])
02318 {
02319   return do_make_hash_placeholder("make-hash-placeholder", 1, argc, argv);
02320 }
02321 
02322 static Scheme_Object *make_hasheq_placeholder(int argc, Scheme_Object *argv[])
02323 {
02324   return do_make_hash_placeholder("make-hash-placeholder", 0, argc, argv);
02325 }
02326 
02327 static Scheme_Object *make_hasheqv_placeholder(int argc, Scheme_Object *argv[])
02328 {
02329   return do_make_hash_placeholder("make-hasheqv-placeholder", 2, argc, argv);
02330 }
02331 
02332 static Scheme_Object *table_placeholder_p(int c, Scheme_Object *p[])
02333 {
02334   return (SAME_TYPE(SCHEME_TYPE(p[0]), scheme_table_placeholder_type)
02335           ? scheme_true 
02336           : scheme_false);
02337 }
02338 
02339 
02340 
02341 /************************************************************/
02342 /*                      ephemerons                          */
02343 /************************************************************/
02344 
02345 typedef struct Scheme_Ephemeron {
02346   Scheme_Object so;
02347   Scheme_Object *key, *val;
02348   struct Scheme_Ephemeron *next;
02349 } Scheme_Ephemeron;
02350 
02351 #ifndef MZ_PRECISE_GC
02352 
02353 static Scheme_Ephemeron *ephemerons, *done_ephemerons; /* not registered as a root! */
02354 
02355 #ifdef USE_SENORA_GC
02356 extern void *GC_base(void *d);
02357 # define GC_is_marked(p) GC_base(p)
02358 # define GC_did_mark_stack_overflow() 0
02359 # define GC_mark_overflow_recover(ptr) 
02360 #else
02361 extern MZ_DLLIMPORT void *GC_base(void *);
02362 extern MZ_DLLIMPORT int GC_is_marked(void *);
02363 extern MZ_DLLIMPORT int GC_did_mark_stack_overflow(void);
02364 extern MZ_DLLIMPORT void GC_mark_overflow_recover(void *p);
02365 #endif
02366 extern MZ_DLLIMPORT void GC_push_all_stack(void *, void *);
02367 extern MZ_DLLIMPORT void GC_flush_mark_stack(void);
02368 
02369 #endif
02370 
02371 Scheme_Object *scheme_make_ephemeron(Scheme_Object *key, Scheme_Object *val)
02372 {
02373 #ifdef MZ_PRECISE_GC
02374   return GC_malloc_ephemeron(key, val);
02375 #else
02376   Scheme_Ephemeron *e;
02377   int can_gc = 1;
02378 
02379   if (SCHEME_INTP(val) || !GC_base(val)) 
02380     can_gc = 0;
02381 
02382   if (can_gc) {
02383     e = (Scheme_Ephemeron *)scheme_malloc_atomic(sizeof(Scheme_Ephemeron));
02384   } else {
02385     e = (Scheme_Ephemeron *)scheme_malloc(sizeof(Scheme_Ephemeron));
02386   }
02387   e->so.type = scheme_ephemeron_type;
02388   if (can_gc) {
02389     e->next = ephemerons;
02390     ephemerons = e;
02391   }
02392   e->key = key;
02393   e->val = val;
02394 
02395   return (Scheme_Object *)e;
02396 #endif
02397 }
02398 
02399 Scheme_Object *scheme_ephemeron_value(Scheme_Object *o)
02400 {
02401   return ((Scheme_Ephemeron *)o)->val;
02402 }
02403 
02404 Scheme_Object *scheme_ephemeron_key(Scheme_Object *o)
02405 {
02406   return ((Scheme_Ephemeron *)o)->key;
02407 }
02408 
02409 #ifndef MZ_PRECISE_GC
02410 
02411 static void set_ephemerons(Scheme_Ephemeron *ae, Scheme_Ephemeron *be)
02412 {
02413   if (be) {
02414     Scheme_Ephemeron *e;
02415     for (e = be; e->next; e = e->next) { }
02416     e->next = ae;
02417     ae = be;
02418   }
02419 
02420   ephemerons = ae;
02421 }
02422 
02423 static int mark_ephemerons()
02424 {
02425   Scheme_Ephemeron *e, *ae, *be, *next;
02426   int did_one, mix, ever_done = 0;
02427 
02428   mix = scheme_get_milliseconds();
02429   mix = mix >> 8;
02430 
02431   do {
02432     did_one = 0;
02433     ae = be = NULL;
02434 
02435     for (e = ephemerons; e; e = next) {
02436       next = e->next;
02437 
02438       if (e->key) {      
02439        if (!GC_is_marked(e) || !GC_is_marked(e->key)) {
02440          /* No reason to mark, yet. Randomly put this one back
02441             into one of the keep lists: */
02442          if (mix & 0x1) {
02443            e->next = ae;
02444            ae = e;
02445          } else {
02446            e->next = be;
02447            be = e;
02448          }
02449          mix += ((long)e >> 5) + ((long)e >> 2);
02450        } else {
02451          did_one = 1;
02452          ever_done = 1;
02453          GC_push_all_stack(&e->val, &e->val + 1);
02454          if (GC_did_mark_stack_overflow()) {
02455             GC_mark_overflow_recover(e->val);
02456          } else {
02457            GC_flush_mark_stack();
02458            if (GC_did_mark_stack_overflow()) {
02459               GC_mark_overflow_recover(e->val);
02460            }
02461          }
02462          /* Done with this one: */
02463          e->next = done_ephemerons;
02464          done_ephemerons = e;
02465        }
02466       } else {
02467        /* Ephemeron previously done, so drop it. This case
02468           shouldn't happen, because it should have been
02469           dropped earlier. */
02470       }
02471     }
02472 
02473     /* Combine ae & be back into ephemerons list: */
02474     set_ephemerons(ae, be);
02475   } while (did_one);
02476 
02477   return ever_done;
02478 }
02479 
02480 #endif
02481 
02482 static Scheme_Object *make_ephemeron(int argc, Scheme_Object **argv)
02483 {
02484   return scheme_make_ephemeron(argv[0], argv[1]);
02485 }
02486 
02487 static Scheme_Object *ephemeron_value(int argc, Scheme_Object **argv)
02488 {
02489   Scheme_Object *v;
02490 
02491   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_ephemeron_type))
02492     scheme_wrong_type("ephemeron-value", "ephemeron", 0, argc, argv);
02493   v = scheme_ephemeron_value(argv[0]);
02494 
02495   if (!v)
02496     return scheme_false;
02497   else
02498     return v;
02499 }
02500 
02501 static Scheme_Object *ephemeronp(int argc, Scheme_Object *argv[])
02502 {
02503   return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_ephemeron_type)
02504          ? scheme_true 
02505          : scheme_false);
02506 }
02507 
02508 #ifndef MZ_PRECISE_GC
02509 
02510 int scheme_propagate_ephemeron_marks()
02511 {
02512   return mark_ephemerons();
02513 }
02514 
02515 void scheme_clear_ephemerons()
02516 {
02517   Scheme_Ephemeron *e;
02518 
02519   for (e = ephemerons; e; e = e->next) {
02520     e->val = NULL;
02521     e->key = NULL;
02522   }
02523 
02524   ephemerons = done_ephemerons;
02525   done_ephemerons = NULL;
02526 }
02527 
02528 extern MZ_DLLIMPORT void (*GC_custom_finalize)();
02529 
02530 void scheme_init_ephemerons(void)
02531 {
02532   /* symbol.c will overwrite this, later */
02533   GC_custom_finalize = scheme_clear_ephemerons;
02534 }
02535 
02536 #endif