Back to index

plt-scheme  4.2.1
fun.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 /* This file is a hodge-podge of various aspects of application and
00027    continuations.  It includes primitives like `call/cc' and
00028    `procedure-arity', which have no better home, as well as parts of
00029    closure compilation and wrappers for evaluation to handle stack
00030    overflow and continuation-jump limits. */
00031 
00032 #include "schpriv.h"
00033 #include "schexpobs.h"
00034 
00035 /* The implementations of the time primitives, such as
00036    `current-seconds', vary a lot from platform to platform. */
00037 #ifdef TIME_SYNTAX
00038 # ifdef USE_MACTIME
00039 #  include <OSUtils.h>
00040 #  include <Timer.h>
00041 # else
00042 #  ifndef USE_PALMTIME
00043 #   if defined(OSKIT) && !defined(OSKIT_TEST)
00044     /* Get FreeBSD version, not oskit/time.h version */
00045 #    include <freebsd/time.h>
00046 #   endif
00047 #   include <time.h>
00048 #   ifdef USE_FTIME
00049 #    include <sys/timeb.h>
00050 #   else
00051 #    include <sys/time.h>
00052 #   endif /* USE_FTIME */
00053 #   ifdef USE_GETRUSAGE
00054 #    include <sys/types.h>
00055 #    include <sys/time.h>
00056 #    include <sys/resource.h>
00057 #    include <errno.h>
00058 #   endif /* USE_GETRUSAGE */
00059 #   ifdef USE_SYSCALL_GETRUSAGE
00060 #    include <sys/syscall.h>
00061 #    define getrusage(a, b)  syscall(SYS_GETRUSAGE, a, b)
00062 #    define USE_GETRUSAGE
00063 #   endif /* USE_SYSCALL_GETRUSAGE */
00064 #   ifdef WINDOWS_GET_PROCESS_TIMES
00065 #    include <Windows.h>
00066 #   endif
00067 #  endif /* USE_PALMTIME */
00068 # endif /* USE_MACTIME */
00069 #endif /* TIME_SYNTAX */
00070 
00071 static void ASSERT_SUSPEND_BREAK_ZERO() {
00072 #if 0
00073   if (scheme_current_thread->suspend_break)
00074     abort();
00075 #endif
00076 }
00077 
00078 /* globals */
00079 int scheme_defining_primitives; /* set to 1 during start-up */
00080 
00081 Scheme_Object scheme_void[1]; /* the void constant */
00082 Scheme_Object *scheme_values_func; /* the function bound to `values' */
00083 Scheme_Object *scheme_procedure_p_proc;
00084 Scheme_Object *scheme_procedure_arity_includes_proc;
00085 Scheme_Object *scheme_void_proc;
00086 Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
00087 Scheme_Object *scheme_reduced_procedure_struct;
00088 Scheme_Object *scheme_tail_call_waiting;
00089 Scheme_Object *scheme_inferred_name_symbol;
00090 Scheme_Object *scheme_default_prompt_tag;
00091 
00092 int scheme_cont_capture_count;
00093 int scheme_prompt_capture_count;
00094 
00095 
00096 /* locals */
00097 static Scheme_Object *procedure_p (int argc, Scheme_Object *argv[]);
00098 static Scheme_Object *apply (int argc, Scheme_Object *argv[]);
00099 static Scheme_Object *map (int argc, Scheme_Object *argv[]);
00100 static Scheme_Object *for_each (int argc, Scheme_Object *argv[]);
00101 static Scheme_Object *andmap (int argc, Scheme_Object *argv[]);
00102 static Scheme_Object *ormap (int argc, Scheme_Object *argv[]);
00103 static Scheme_Object *call_cc (int argc, Scheme_Object *argv[]);
00104 static Scheme_Object *internal_call_cc (int argc, Scheme_Object *argv[]);
00105 static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[]);
00106 static Scheme_Object *call_with_continuation_barrier (int argc, Scheme_Object *argv[]);
00107 static Scheme_Object *call_with_prompt (int argc, Scheme_Object *argv[]);
00108 static Scheme_Object *call_with_control (int argc, Scheme_Object *argv[]);
00109 static Scheme_Object *make_prompt_tag (int argc, Scheme_Object *argv[]);
00110 static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[]);
00111 static Scheme_Object *continuation_prompt_available(int argc, Scheme_Object *argv[]);
00112 static Scheme_Object *get_default_prompt_tag (int argc, Scheme_Object *argv[]);
00113 static Scheme_Object *prompt_tag_p (int argc, Scheme_Object *argv[]);
00114 static Scheme_Object *call_with_sema (int argc, Scheme_Object *argv[]);
00115 static Scheme_Object *call_with_sema_enable_break (int argc, Scheme_Object *argv[]);
00116 static Scheme_Object *cc_marks (int argc, Scheme_Object *argv[]);
00117 static Scheme_Object *cont_marks (int argc, Scheme_Object *argv[]);
00118 static Scheme_Object *cc_marks_p (int argc, Scheme_Object *argv[]);
00119 static Scheme_Object *extract_cc_marks (int argc, Scheme_Object *argv[]);
00120 static Scheme_Object *extract_cc_markses (int argc, Scheme_Object *argv[]);
00121 static Scheme_Object *extract_cc_proc_marks (int argc, Scheme_Object *argv[]);
00122 static Scheme_Object *extract_one_cc_mark (int argc, Scheme_Object *argv[]);
00123 static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv[]);
00124 static Scheme_Object *void_func (int argc, Scheme_Object *argv[]);
00125 static Scheme_Object *void_p (int argc, Scheme_Object *argv[]);
00126 static Scheme_Object *dynamic_wind (int argc, Scheme_Object *argv[]);
00127 #ifdef TIME_SYNTAX
00128 static Scheme_Object *time_apply(int argc, Scheme_Object *argv[]);
00129 static Scheme_Object *current_milliseconds(int argc, Scheme_Object **argv);
00130 static Scheme_Object *current_inexact_milliseconds(int argc, Scheme_Object **argv);
00131 static Scheme_Object *current_process_milliseconds(int argc, Scheme_Object **argv);
00132 static Scheme_Object *current_gc_milliseconds(int argc, Scheme_Object **argv);
00133 static Scheme_Object *current_seconds(int argc, Scheme_Object **argv);
00134 static Scheme_Object *seconds_to_date(int argc, Scheme_Object **argv);
00135 #endif
00136 static Scheme_Object *object_name(int argc, Scheme_Object *argv[]);
00137 static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[]);
00138 static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[]);
00139 static Scheme_Object *procedure_arity_includes(int argc, Scheme_Object *argv[]);
00140 static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]);
00141 static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]);
00142 static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]);
00143 static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]);
00144 static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]);
00145 static Scheme_Object *primitive_result_arity (int argc, Scheme_Object *argv[]);
00146 static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[]);
00147 Scheme_Object *scheme_values(int argc, Scheme_Object *argv[]);
00148 static Scheme_Object *current_print(int argc, Scheme_Object **argv);
00149 static Scheme_Object *current_prompt_read(int, Scheme_Object **);
00150 
00151 static Scheme_Object *write_compiled_closure(Scheme_Object *obj);
00152 static Scheme_Object *read_compiled_closure(Scheme_Object *obj);
00153 
00154 /* READ ONLY SHARABLE GLOBALS */
00155 static Scheme_Prompt *original_default_prompt; /* for escapes, represents the implicit initial prompt */
00156 
00157 static Scheme_Object *certify_mode_symbol;
00158 static Scheme_Object *transparent_symbol;
00159 static Scheme_Object *transparent_binding_symbol;
00160 static Scheme_Object *opaque_symbol;
00161 
00162 static Scheme_Object *cont_key; /* uninterned */
00163 static Scheme_Object *barrier_prompt_key; /* uninterned */
00164 
00165 static Scheme_Object *is_method_symbol;
00166 
00167 static Scheme_Object *call_with_prompt_proc;
00168 static Scheme_Object *abort_continuation_proc;
00169 
00170 static Scheme_Object *internal_call_cc_prim;
00171 
00172 /* CACHES NEED TO BE THREAD LOCAL */
00173 static THREAD_LOCAL Scheme_Prompt *available_prompt;
00174 static THREAD_LOCAL Scheme_Prompt *available_cws_prompt;
00175 static THREAD_LOCAL Scheme_Prompt *available_regular_prompt;
00176 static THREAD_LOCAL Scheme_Dynamic_Wind *available_prompt_dw;
00177 static THREAD_LOCAL Scheme_Meta_Continuation *available_prompt_mc;
00178 static THREAD_LOCAL Scheme_Object *cached_beg_stx;
00179 static THREAD_LOCAL Scheme_Object *cached_dv_stx;
00180 static THREAD_LOCAL Scheme_Object *cached_ds_stx;
00181 static THREAD_LOCAL int cached_stx_phase;
00182 
00183 /* NEED TO BE THREAD LOCAL */
00184 static Scheme_Cont *offstack_cont;
00185 static Scheme_Overflow *offstack_overflow;
00186 
00187 
00188 typedef void (*DW_PrePost_Proc)(void *);
00189 
00190 #define CONS(a,b) scheme_make_pair(a,b)
00191 
00192 #ifdef MZ_PRECISE_GC
00193 static void register_traversers(void);
00194 #endif
00195 
00196 
00197 /* See call_cc: */
00198 typedef struct Scheme_Dynamic_Wind_List {
00199   MZTAG_IF_REQUIRED
00200   Scheme_Dynamic_Wind *dw;
00201   int meta_depth;
00202   struct Scheme_Dynamic_Wind_List *next;
00203 } Scheme_Dynamic_Wind_List;
00204 
00205 /*========================================================================*/
00206 /*                             initialization                             */
00207 /*========================================================================*/
00208 
00209 void
00210 scheme_init_fun (Scheme_Env *env)
00211 {
00212   Scheme_Object *o;
00213 
00214 #ifdef MZ_PRECISE_GC
00215   register_traversers();
00216 #endif
00217 
00218 #ifdef MZ_APPLY_WAITING_CONSTANT
00219   scheme_tail_call_waiting = MZ_APPLY_WAITING_CONSTANT;
00220 #else
00221   REGISTER_SO(scheme_tail_call_waiting);
00222   scheme_tail_call_waiting = scheme_alloc_eternal_object();
00223   scheme_tail_call_waiting->type = scheme_tail_call_waiting_type;
00224 #endif
00225 
00226   REGISTER_SO(cached_beg_stx);
00227   REGISTER_SO(cached_dv_stx);
00228   REGISTER_SO(cached_ds_stx);
00229   REGISTER_SO(scheme_procedure_p_proc);
00230   REGISTER_SO(scheme_procedure_arity_includes_proc);
00231 
00232   REGISTER_SO(offstack_cont);
00233   REGISTER_SO(offstack_overflow);
00234 
00235   o = scheme_make_folding_prim(procedure_p, "procedure?", 1, 1, 1);
00236   SCHEME_PRIM_PROC_FLAGS(o) |= SCHEME_PRIM_IS_UNARY_INLINED;
00237   scheme_add_global_constant("procedure?", o, env);
00238 
00239   scheme_procedure_p_proc = o;
00240 
00241   scheme_add_global_constant("apply",
00242                           scheme_make_prim_w_arity2(apply,
00243                                                  "apply",
00244                                                  2, -1,
00245                                                  0, -1),
00246                           env);
00247   scheme_add_global_constant("map",
00248                           scheme_make_noncm_prim(map,
00249                                                     "map",
00250                                                     2, -1),
00251                           env);
00252   scheme_add_global_constant("for-each",
00253                           scheme_make_noncm_prim(for_each,
00254                                                     "for-each",
00255                                                     2, -1),
00256                           env);
00257   scheme_add_global_constant("andmap",
00258                           scheme_make_prim_w_arity(andmap,
00259                                                 "andmap",
00260                                                 2, -1),
00261                           env);
00262   scheme_add_global_constant("ormap",
00263                           scheme_make_prim_w_arity(ormap,
00264                                                 "ormap",
00265                                                 2, -1),
00266                           env);
00267 
00268   REGISTER_SO(scheme_call_with_values_proc);
00269   scheme_call_with_values_proc = scheme_make_prim_w_arity2(call_with_values,
00270                                                            "call-with-values",
00271                                                            2, 2,
00272                                                            0, -1);
00273   scheme_add_global_constant("call-with-values",
00274                           scheme_call_with_values_proc,
00275                           env);
00276 
00277   REGISTER_SO(scheme_values_func);
00278   scheme_values_func = scheme_make_prim_w_arity2(scheme_values,
00279                                            "values",
00280                                            0, -1,
00281                                            0, -1);
00282   scheme_add_global_constant("values",
00283                           scheme_values_func,
00284                           env);
00285 
00286   o = scheme_make_prim_w_arity2(scheme_call_ec,
00287                             "call-with-escape-continuation",
00288                             1, 1,
00289                             0, -1);
00290   scheme_add_global_constant("call-with-escape-continuation", o, env);
00291   scheme_add_global_constant("call/ec", o, env);
00292 
00293   REGISTER_SO(internal_call_cc_prim);
00294   internal_call_cc_prim = scheme_make_prim_w_arity2(internal_call_cc,
00295                                               "call-with-current-continuation",
00296                                               1, 3,
00297                                               0, -1);
00298 
00299   o = scheme_make_prim_w_arity2(call_cc,
00300                             "call-with-current-continuation",
00301                             1, 2,
00302                             0, -1);
00303 
00304   scheme_add_global_constant("call-with-current-continuation", o, env);
00305   scheme_add_global_constant("call/cc", o, env);
00306 
00307   scheme_add_global_constant("continuation?",
00308                              scheme_make_folding_prim(continuation_p,
00309                                                 "continuation?",
00310                                                 1, 1, 1),
00311                              env);
00312 
00313   scheme_add_global_constant("call-with-continuation-barrier",
00314                           scheme_make_prim_w_arity2(call_with_continuation_barrier,
00315                                                  "call-with-continuation-barrier",
00316                                                  1, 1,
00317                                                  0, -1), 
00318                           env);
00319 
00320   REGISTER_SO(call_with_prompt_proc);
00321   call_with_prompt_proc = scheme_make_prim_w_arity2(call_with_prompt,
00322                                                     "call-with-continuation-prompt",
00323                                                     1, -1,
00324                                                     0, -1);
00325   scheme_add_global_constant("call-with-continuation-prompt",
00326                           call_with_prompt_proc, 
00327                           env);
00328 
00329   scheme_add_global_constant("call-with-composable-continuation",
00330                           scheme_make_prim_w_arity2(call_with_control,
00331                                                        "call-with-composable-continuation",
00332                                                        1, 2,
00333                                                        0, -1), 
00334                           env);
00335 
00336   REGISTER_SO(abort_continuation_proc);
00337   abort_continuation_proc = scheme_make_prim_w_arity(abort_continuation,
00338                                                      "abort-current-continuation",
00339                                                      1, -1);
00340   scheme_add_global_constant("abort-current-continuation",
00341                           abort_continuation_proc, 
00342                           env);
00343 
00344   scheme_add_global_constant("continuation-prompt-available?",
00345                           scheme_make_prim_w_arity(continuation_prompt_available,
00346                                                       "continuation-prompt-available?",
00347                                                       1, 2), 
00348                           env);
00349 
00350   scheme_add_global_constant("make-continuation-prompt-tag",
00351                           scheme_make_prim_w_arity(make_prompt_tag,
00352                                                       "make-continuation-prompt-tag",
00353                                                       0, 1), 
00354                           env);
00355 
00356   scheme_add_global_constant("default-continuation-prompt-tag",
00357                              scheme_make_prim_w_arity(get_default_prompt_tag,
00358                                                       "default-continuation-prompt-tag",
00359                                                       0, 0), 
00360                           env);
00361   scheme_add_global_constant("continuation-prompt-tag?",
00362                              scheme_make_folding_prim(prompt_tag_p,
00363                                                 "continuation-prompt-tag?",
00364                                                 1, 1, 1),
00365                              env);
00366 
00367   scheme_add_global_constant("call-with-semaphore",
00368                           scheme_make_prim_w_arity2(call_with_sema,
00369                                                  "call-with-semaphore",
00370                                                  2, -1,
00371                                                  0, -1), 
00372                           env);
00373   scheme_add_global_constant("call-with-semaphore/enable-break",
00374                           scheme_make_prim_w_arity2(call_with_sema_enable_break,
00375                                                  "call-with-semaphore/enable-break",
00376                                                  2, -1,
00377                                                  0, -1),
00378                           env);
00379 
00380   scheme_add_global_constant("current-continuation-marks",
00381                           scheme_make_prim_w_arity(cc_marks,
00382                                                 "current-continuation-marks",
00383                                                 0, 1),
00384                           env);
00385   scheme_add_global_constant("continuation-marks",
00386                           scheme_make_prim_w_arity(cont_marks,
00387                                                 "continuation-marks",
00388                                                 1, 2),
00389                           env);
00390   scheme_add_global_constant("continuation-mark-set->list",
00391                           scheme_make_prim_w_arity(extract_cc_marks,
00392                                                 "continuation-mark-set->list",
00393                                                 2, 3),
00394                           env);
00395   scheme_add_global_constant("continuation-mark-set->list*",
00396                           scheme_make_prim_w_arity(extract_cc_markses,
00397                                                 "continuation-mark-set->list*",
00398                                                 2, 4),
00399                           env);
00400   scheme_add_global_constant("continuation-mark-set-first",
00401                           scheme_make_prim_w_arity(extract_one_cc_mark,
00402                                                 "continuation-mark-set-first",
00403                                                 2, 4),
00404                           env);
00405   scheme_add_global_constant("call-with-immediate-continuation-mark",
00406                           scheme_make_prim_w_arity2(call_with_immediate_cc_mark,
00407                                                        "call-with-immediate-continuation-mark",
00408                                                        2, 3,
00409                                                        0, -1),
00410                           env);
00411   scheme_add_global_constant("continuation-mark-set?",
00412                           scheme_make_prim_w_arity(cc_marks_p,
00413                                                 "continuation-mark-set?",
00414                                                 1, 1),
00415                           env);
00416   scheme_add_global_constant("continuation-mark-set->context",
00417                           scheme_make_prim_w_arity(extract_cc_proc_marks,
00418                                                 "continuation-mark-set->context",
00419                                                 1, 1),
00420                           env);
00421 
00422   REGISTER_SO(scheme_void_proc);
00423   scheme_void_proc = scheme_make_folding_prim(void_func,
00424                                          "void",
00425                                          0, -1, 1);
00426   scheme_add_global_constant("void", scheme_void_proc, env);
00427   scheme_add_global_constant("void?",
00428                           scheme_make_folding_prim(void_p,
00429                                                 "void?",
00430                                                 1, 1, 1),
00431                           env);
00432 #ifdef TIME_SYNTAX
00433   scheme_add_global_constant("time-apply",
00434                           scheme_make_prim_w_arity2(time_apply,
00435                                                  "time-apply",
00436                                                  2, 2,
00437                                                  4, 4),
00438                           env);
00439   scheme_add_global_constant("current-milliseconds",
00440                           scheme_make_prim_w_arity(current_milliseconds,
00441                                                 "current-milliseconds",
00442                                                 0, 0),
00443                           env);
00444   scheme_add_global_constant("current-inexact-milliseconds",
00445                           scheme_make_prim_w_arity(current_inexact_milliseconds,
00446                                                 "current-inexact-milliseconds",
00447                                                 0, 0),
00448                           env);
00449   scheme_add_global_constant("current-process-milliseconds",
00450                           scheme_make_prim_w_arity(current_process_milliseconds,
00451                                                 "current-process-milliseconds",
00452                                                 0, 1),
00453                           env);
00454   scheme_add_global_constant("current-gc-milliseconds",
00455                           scheme_make_prim_w_arity(current_gc_milliseconds,
00456                                                 "current-gc-milliseconds",
00457                                                 0, 0),
00458                           env);
00459   scheme_add_global_constant("current-seconds",
00460                           scheme_make_prim_w_arity(current_seconds,
00461                                                 "current-seconds",
00462                                                 0, 0),
00463                           env);
00464   scheme_add_global_constant("seconds->date",
00465                           scheme_make_prim_w_arity(seconds_to_date,
00466                                                 "seconds->date",
00467                                                 1, 1),
00468                           env);
00469 #endif
00470 
00471   scheme_add_global_constant("dynamic-wind",
00472                           scheme_make_prim_w_arity(dynamic_wind,
00473                                                 "dynamic-wind",
00474                                                 3, 3),
00475                           env);
00476 
00477   scheme_add_global_constant("object-name",
00478                           scheme_make_folding_prim(object_name,
00479                                                 "object-name",
00480                                                 1, 1, 1),
00481                           env);
00482 
00483   scheme_add_global_constant("procedure-arity",
00484                           scheme_make_folding_prim(procedure_arity,
00485                                                 "procedure-arity",
00486                                                 1, 1, 1),
00487                           env);
00488   scheme_add_global_constant("procedure-arity?",
00489                           scheme_make_folding_prim(procedure_arity_p,
00490                                                 "procedure-arity?",
00491                                                 1, 1, 1),
00492                           env);
00493 
00494   scheme_procedure_arity_includes_proc = scheme_make_folding_prim(procedure_arity_includes,
00495                                                                   "procedure-arity-includes?",
00496                                                                   2, 2, 1);
00497   scheme_add_global_constant("procedure-arity-includes?",
00498                           scheme_procedure_arity_includes_proc,
00499                           env);
00500 
00501   scheme_add_global_constant("procedure-reduce-arity",
00502                           scheme_make_prim_w_arity(procedure_reduce_arity,
00503                                                 "procedure-reduce-arity",
00504                                                 2, 2),
00505                           env);
00506   scheme_add_global_constant("procedure-rename",
00507                           scheme_make_prim_w_arity(procedure_rename,
00508                                                 "procedure-rename",
00509                                                 2, 2),
00510                           env);
00511   scheme_add_global_constant("procedure-closure-contents-eq?",
00512                           scheme_make_folding_prim(procedure_equal_closure_p,
00513                                                 "procedure-closure-contents-eq?",
00514                                                 2, 2, 1),
00515                           env);
00516 
00517   scheme_add_global_constant("primitive?",
00518                           scheme_make_folding_prim(primitive_p,
00519                                                 "primitive?",
00520                                                 1, 1, 1),
00521                           env);
00522   scheme_add_global_constant("primitive-closure?",
00523                           scheme_make_folding_prim(primitive_closure_p,
00524                                                 "primitive-closure?",
00525                                                 1, 1, 1),
00526                           env);
00527 
00528   scheme_add_global_constant("primitive-result-arity",
00529                           scheme_make_folding_prim(primitive_result_arity,
00530                                                 "primitive-result-arity",
00531                                                 1, 1, 1),
00532                           env);
00533 
00534   scheme_add_global_constant("current-print",
00535                           scheme_register_parameter(current_print,
00536                                                  "current-print",
00537                                                  MZCONFIG_PRINT_HANDLER),
00538                           env);
00539   scheme_add_global_constant("current-prompt-read",
00540                           scheme_register_parameter(current_prompt_read,
00541                                                  "current-prompt-read",
00542                                                  MZCONFIG_PROMPT_READ_HANDLER),
00543                           env);
00544 
00545   scheme_install_type_writer(scheme_unclosed_procedure_type,
00546                           write_compiled_closure);
00547   scheme_install_type_reader(scheme_unclosed_procedure_type,
00548                           read_compiled_closure);
00549 
00550   REGISTER_SO(is_method_symbol);
00551   REGISTER_SO(scheme_inferred_name_symbol);
00552   REGISTER_SO(cont_key);
00553   is_method_symbol = scheme_intern_symbol("method-arity-error");
00554   scheme_inferred_name_symbol = scheme_intern_symbol("inferred-name");
00555   cont_key = scheme_make_symbol("k"); /* uninterned */
00556   
00557   REGISTER_SO(scheme_default_prompt_tag);
00558   {
00559     Scheme_Object *a[1];
00560     a[0] = scheme_intern_symbol("default");
00561     scheme_default_prompt_tag = make_prompt_tag(1, a);
00562   }
00563 
00564   REGISTER_SO(original_default_prompt);
00565   original_default_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
00566   original_default_prompt->so.type = scheme_prompt_type;
00567   original_default_prompt->tag = scheme_default_prompt_tag;
00568 }
00569 
00570 Scheme_Object *
00571 scheme_make_void (void)
00572 {
00573   return scheme_void;
00574 }
00575 
00576 /*========================================================================*/
00577 /*                          primitive procedures                          */
00578 /*========================================================================*/
00579 
00580 static Scheme_Object *
00581 make_prim_closure(Scheme_Prim *fun, int eternal,
00582                 const char *name,
00583                 mzshort mina, mzshort maxa,
00584                 int flags,
00585                 mzshort minr, mzshort maxr,
00586                 int closed, int count, Scheme_Object **vals)
00587 {
00588   Scheme_Primitive_Proc *prim;
00589   int hasr, size;
00590 
00591   hasr = ((minr != 1) || (maxr != 1));
00592   size = (hasr 
00593          ? sizeof(Scheme_Prim_W_Result_Arity) 
00594          : (closed
00595             ? (sizeof(Scheme_Primitive_Closure)
00596               + ((count - 1) * sizeof(Scheme_Object *)))
00597             : sizeof(Scheme_Primitive_Proc)));
00598 
00599   if (eternal && scheme_starting_up && !closed)
00600     prim = (Scheme_Primitive_Proc *)scheme_malloc_eternal_tagged(size);
00601   else
00602     prim = (Scheme_Primitive_Proc *)scheme_malloc_tagged(size);
00603   prim->pp.so.type = scheme_prim_type;
00604   prim->prim_val = (Scheme_Primitive_Closure_Proc *)fun;
00605   prim->name = name;
00606   prim->mina = mina;
00607   if (maxa < 0)
00608     maxa = SCHEME_MAX_ARGS + 1;
00609   prim->mu.maxa = maxa;
00610   prim->pp.flags = (flags
00611                   | (scheme_defining_primitives ? SCHEME_PRIM_IS_PRIMITIVE : 0)
00612                   | (hasr ? SCHEME_PRIM_IS_MULTI_RESULT : 0)
00613                   | (closed ? SCHEME_PRIM_IS_CLOSURE : 0));
00614 
00615   if (hasr) {
00616     ((Scheme_Prim_W_Result_Arity *)prim)->minr = minr;
00617     ((Scheme_Prim_W_Result_Arity *)prim)->maxr = maxr;
00618   }
00619   if (closed) {
00620 #ifdef MZ_PRECISE_GC
00621     ((Scheme_Primitive_Closure *)prim)->count = count;
00622 #endif
00623     memcpy(((Scheme_Primitive_Closure *)prim)->val,
00624           vals,
00625           count * sizeof(Scheme_Object *));
00626   }
00627 
00628   return (Scheme_Object *)prim;
00629 }
00630 
00631 Scheme_Object *
00632 scheme_make_prim_w_everything(Scheme_Prim *fun, int eternal,
00633                            const char *name,
00634                            mzshort mina, mzshort maxa,
00635                            int flags,
00636                            mzshort minr, mzshort maxr)
00637 {
00638   return make_prim_closure(fun, eternal,
00639                         name,
00640                         mina, maxa,
00641                         flags,
00642                         minr, maxr,
00643                         0, 0, NULL);
00644 }
00645 
00646 Scheme_Object *scheme_make_prim(Scheme_Prim *fun)
00647 {
00648   return make_prim_closure(fun, 1, NULL, 0, -1, 0, 1, 1,
00649                         0, 0, NULL);
00650 }
00651 
00652 Scheme_Object *
00653 scheme_make_noneternal_prim (Scheme_Prim *fun)
00654 {
00655   return make_prim_closure(fun, 0, NULL, 0, -1, 0, 1, 1,
00656                         0, 0, NULL);
00657 }
00658 
00659 Scheme_Object *
00660 scheme_make_prim_w_arity(Scheme_Prim *fun, const char *name,
00661                       mzshort mina, mzshort maxa)
00662 {
00663   return make_prim_closure(fun, 1, name, mina, maxa, 0, 1, 1,
00664                         0, 0, NULL);
00665 }
00666 
00667 Scheme_Object *
00668 scheme_make_folding_prim(Scheme_Prim *fun, const char *name,
00669                       mzshort mina, mzshort maxa,
00670                       short folding)
00671 {
00672   return make_prim_closure(fun, 1, name, mina, maxa,
00673                         (folding 
00674                          ? SCHEME_PRIM_OPT_FOLDING
00675                          : 0),
00676                         1, 1,
00677                         0, 0, NULL);
00678 }
00679 
00680 Scheme_Object *
00681 scheme_make_noncm_prim(Scheme_Prim *fun, const char *name,
00682                      mzshort mina, mzshort maxa)
00683 {
00684   /* A non-cm primitive leaves the mark stack unchanged when it returns,
00685      it can't return multiple values or a tail call, and it cannot
00686      use its third argument (i.e., the closure pointer). */
00687   return make_prim_closure(fun, 1, name, mina, maxa,
00688                         SCHEME_PRIM_OPT_NONCM,
00689                         1, 1,
00690                         0, 0, NULL);
00691 }
00692 
00693 Scheme_Object *
00694 scheme_make_immed_prim(Scheme_Prim *fun, const char *name,
00695                      mzshort mina, mzshort maxa)
00696 {
00697   /* An immediate primitive is a non-cm primitive, and it doesn't
00698      extend the continuation in a way that interacts with space safety, except
00699      maybe to raise an exception. */
00700   return make_prim_closure(fun, 1, name, mina, maxa,
00701                         SCHEME_PRIM_OPT_IMMEDIATE,
00702                         1, 1,
00703                         0, 0, NULL);
00704 }
00705 
00706 Scheme_Object *
00707 scheme_make_noneternal_prim_w_arity(Scheme_Prim *fun, const char *name,
00708                                 mzshort mina, mzshort maxa)
00709 {
00710   return make_prim_closure(fun, 0, name, mina, maxa, 0, 1, 1,
00711                         0, 0, NULL);
00712 }
00713 
00714 Scheme_Object *scheme_make_prim_closure_w_arity(Scheme_Primitive_Closure_Proc *prim,
00715                                           int size, Scheme_Object **vals,
00716                                           const char *name,
00717                                           mzshort mina, mzshort maxa)
00718 {
00719   return make_prim_closure((Scheme_Prim *)prim, 1, name, mina, maxa, 0, 1, 1,
00720                         1, size, vals);
00721 
00722 }
00723 
00724 Scheme_Object *scheme_make_folding_prim_closure(Scheme_Primitive_Closure_Proc *prim,
00725                                           int size, Scheme_Object **vals,
00726                                           const char *name,
00727                                           mzshort mina, mzshort maxa,
00728                                           short functional)
00729 {
00730   return make_prim_closure((Scheme_Prim *)prim, 1, name, mina, maxa,
00731                         (functional
00732                          ? SCHEME_PRIM_OPT_FOLDING
00733                          : 0),
00734                         1, 1,
00735                         1, size, vals);
00736 }
00737 
00738 Scheme_Object *
00739 scheme_make_closed_prim_w_everything(Scheme_Closed_Prim *fun,
00740                                  void *data,
00741                                  const char *name,
00742                                  mzshort mina, mzshort maxa,
00743                                  short folding,
00744                                  mzshort minr, mzshort maxr)
00745 {
00746   Scheme_Closed_Primitive_Proc *prim;
00747   int hasr, size;
00748 
00749   hasr = ((minr != 1) || (maxr != 1));
00750   size = hasr ? sizeof(Scheme_Closed_Prim_W_Result_Arity) : sizeof(Scheme_Closed_Primitive_Proc);
00751 
00752   prim = (Scheme_Closed_Primitive_Proc *)scheme_malloc_tagged(size);
00753 
00754   prim->pp.so.type = scheme_closed_prim_type;
00755   SCHEME_CLSD_PRIM(prim) = fun;
00756   SCHEME_CLSD_PRIM_DATA(prim) = data;
00757   prim->name = name;
00758   prim->mina = mina;
00759   prim->maxa = maxa;
00760   prim->pp.flags = ((folding ? SCHEME_PRIM_OPT_FOLDING : 0)
00761                   | (scheme_defining_primitives ? SCHEME_PRIM_IS_PRIMITIVE : 0)
00762                   | (hasr ? SCHEME_PRIM_IS_MULTI_RESULT : 0));
00763 
00764   if (hasr) {
00765     ((Scheme_Closed_Prim_W_Result_Arity *)prim)->minr = minr;
00766     ((Scheme_Closed_Prim_W_Result_Arity *)prim)->maxr = maxr;
00767   }
00768 
00769   return (Scheme_Object *)prim;
00770 }
00771 
00772 Scheme_Object *
00773 scheme_make_folding_closed_prim(Scheme_Closed_Prim *fun,
00774                             void *data,
00775                             const char *name,
00776                             mzshort mina, mzshort maxa,
00777                             short folding)
00778 {
00779   return scheme_make_closed_prim_w_everything(fun, data, name, mina, maxa, folding, 1, 1);
00780 }
00781 
00782 Scheme_Object *
00783 scheme_make_closed_prim_w_arity(Scheme_Closed_Prim *fun, void *data,
00784                             const char *name, mzshort mina, mzshort maxa)
00785 {
00786   return scheme_make_closed_prim_w_everything(fun, data, name, mina, maxa, 0, 1, 1);
00787 }
00788 
00789 Scheme_Object *
00790 scheme_make_closed_prim(Scheme_Closed_Prim *fun, void *data)
00791 {
00792   return scheme_make_closed_prim_w_everything(fun, data, NULL, 0, -1, 0, 1, 1);
00793 }
00794 
00795 void scheme_prim_is_method(Scheme_Object *o)
00796 {
00797   if (SCHEME_CLSD_PRIMP(o))
00798     ((Scheme_Closed_Primitive_Proc *)o)->pp.flags |= SCHEME_PRIM_IS_METHOD;
00799   else
00800     ((Scheme_Primitive_Proc *)o)->pp.flags |= SCHEME_PRIM_IS_METHOD;
00801 }
00802 
00803 int scheme_has_method_property(Scheme_Object *code)
00804 {
00805   return SCHEME_TRUEP(scheme_stx_property(code, is_method_symbol, NULL));
00806 }
00807 
00808 /*========================================================================*/
00809 /*                  closures (run time and compilation)                   */
00810 /*========================================================================*/
00811 
00812 Scheme_Object *
00813 scheme_make_closure(Scheme_Thread *p, Scheme_Object *code, int close)
00814      /* Creates a closure at run-time (or an empty closure at compile
00815         time; note that the byte-code marshaller in print.c can handle
00816         empty closures for that reason). */
00817 {
00818   Scheme_Closure_Data *data;
00819   Scheme_Closure *closure;
00820   GC_CAN_IGNORE Scheme_Object **runstack;
00821   GC_CAN_IGNORE Scheme_Object **dest;
00822   GC_CAN_IGNORE mzshort *map;
00823   int i;
00824 
00825   data = (Scheme_Closure_Data *)code;
00826   
00827 #ifdef MZ_USE_JIT
00828   if (data->u.native_code) {
00829     Scheme_Object *nc;
00830 
00831     nc = scheme_make_native_closure(data->u.native_code);
00832 
00833     if (close) {
00834       runstack = MZ_RUNSTACK;
00835       dest = ((Scheme_Native_Closure *)nc)->vals;
00836       map = data->closure_map;
00837       i = data->closure_size;
00838       
00839       /* Copy data into the closure: */
00840       while (i--) {
00841        dest[i] = runstack[map[i]];
00842       }
00843     }
00844 
00845     return nc;
00846   }
00847 #endif
00848 
00849   i = data->closure_size;
00850 
00851   closure = (Scheme_Closure *)
00852     scheme_malloc_tagged(sizeof(Scheme_Closure)
00853                       + (i - 1) * sizeof(Scheme_Object *));
00854 
00855   closure->so.type = scheme_closure_type;
00856   SCHEME_COMPILED_CLOS_CODE(closure) = data;
00857 
00858   if (!close || !i)
00859     return (Scheme_Object *)closure;
00860 
00861   runstack = MZ_RUNSTACK;
00862   dest = closure->vals;
00863   map = data->closure_map;
00864 
00865   /* Copy data into the closure: */
00866   while (i--) {
00867     dest[i] = runstack[map[i]];
00868   }
00869 
00870   return (Scheme_Object *)closure;
00871 }
00872 
00873 Scheme_Closure *scheme_malloc_empty_closure()
00874 {
00875   Scheme_Closure *cl;
00876 
00877   cl = (Scheme_Closure *)scheme_malloc_tagged(sizeof(Scheme_Closure) - sizeof(Scheme_Object *));
00878   cl->so.type = scheme_closure_type;
00879 
00880   return cl;
00881 }
00882 
00883 Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Object *context)
00884   /* If lr is supplied as a letrec binding this closure, it may be used
00885      for JIT compilation. */
00886 {
00887 #ifdef MZ_USE_JIT
00888   Scheme_Closure_Data *data = (Scheme_Closure_Data *)code, *data2;
00889 
00890   /* We need to cache clones to support multiple references
00891      to a zero-sized closure in bytecode. We need either a clone
00892      or native code, and context determines which field is releveant,
00893      so we put the two possibilities in a union `u'. */
00894 
00895   if (!context)
00896     data2 = data->u.jit_clone;
00897   else
00898     data2 = NULL;
00899 
00900   if (!data2) {
00901     Scheme_Native_Closure_Data *ndata;
00902     
00903     data2 = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
00904     memcpy(data2, code, sizeof(Scheme_Closure_Data));
00905 
00906     data2->context = context;
00907 
00908     ndata = scheme_generate_lambda(data2, 1, NULL);
00909     data2->u.native_code = ndata;
00910 
00911     if (!context)
00912       data->u.jit_clone = data2;
00913   }      
00914     
00915   /* If it's zero-sized, then create closure now */
00916   if (!data2->closure_size)
00917     return scheme_make_native_closure(data2->u.native_code);
00918 
00919   return (Scheme_Object *)data2;
00920 #endif
00921 
00922   return code;
00923 }
00924 
00925 void scheme_delay_load_closure(Scheme_Closure_Data *data)
00926 {
00927   if (SCHEME_RPAIRP(data->code)) {
00928     Scheme_Object *v, *vinfo = NULL;
00929 
00930     v = SCHEME_CAR(data->code);
00931     if (SCHEME_VECTORP(v)) {
00932       /* Has info for delayed validation */
00933       vinfo = v;
00934       v = SCHEME_VEC_ELS(vinfo)[0];
00935     }
00936     v = scheme_load_delayed_code(SCHEME_INT_VAL(v), 
00937                                  (struct Scheme_Load_Delay *)SCHEME_CDR(data->code));
00938     data->code = v;
00939     
00940     if (vinfo) {
00941       scheme_validate_closure(NULL, 
00942                               (Scheme_Object *)data,
00943                               (char *)SCHEME_VEC_ELS(vinfo)[1], 
00944                               (Validate_TLS)SCHEME_VEC_ELS(vinfo)[2], 
00945                               SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[3]),
00946                               SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[4]),
00947                               SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[5]),
00948                               SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[6]));
00949     }
00950   }
00951 }
00952 
00953 /* Closure_Info is used to store extra closure information
00954    before a closure mapping is resolved. */
00955 typedef struct {
00956   MZTAG_IF_REQUIRED
00957   int *local_flags;
00958   mzshort base_closure_size; /* doesn't include top-level (if any) */
00959   mzshort *base_closure_map;
00960   short has_tl, body_size;
00961 } Closure_Info;
00962 
00963 Scheme_Object *
00964 scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info)
00965 {
00966   Scheme_Closure_Data *data;
00967   Scheme_Object *code, *ctx;
00968   Closure_Info *cl;
00969   mzshort dcs, *dcm;
00970   int i;
00971 
00972   data = (Scheme_Closure_Data *)_data;
00973 
00974   info->single_result = 1;
00975   info->preserves_marks = 1;
00976 
00977   info = scheme_optimize_info_add_frame(info, data->num_params, data->num_params,
00978                                    SCHEME_LAMBDA_FRAME);
00979 
00980   /* For reporting warnings: */
00981   if (info->context && SCHEME_PAIRP(info->context))
00982     ctx = scheme_make_pair((Scheme_Object *)data,
00983                            SCHEME_CDR(info->context));
00984   else if (info->context)
00985     ctx = scheme_make_pair((Scheme_Object *)data, info->context);
00986   else
00987     ctx = (Scheme_Object *)data;
00988   info->context = ctx;
00989 
00990   cl = (Closure_Info *)data->closure_map;
00991   for (i = 0; i < data->num_params; i++) {
00992     if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED)
00993       scheme_optimize_mutated(info, i);
00994   }
00995 
00996   code = scheme_optimize_expr(data->code, info);
00997 
00998   if (info->single_result)
00999     SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SINGLE_RESULT;
01000   else if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT)
01001     SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_SINGLE_RESULT;
01002 
01003   if (info->preserves_marks)
01004     SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_PRESERVES_MARKS;
01005   else if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_PRESERVES_MARKS)
01006     SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_PRESERVES_MARKS;
01007 
01008   if ((info->single_result > 0) && (info->preserves_marks > 0)
01009       && (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE))
01010     SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_RESULT_TENTATIVE;
01011 
01012   data->code = code;
01013 
01014   /* Remembers positions of used vars (and unsets usage for this level) */
01015   scheme_env_make_closure_map(info, &dcs, &dcm);
01016   cl->base_closure_size = dcs;
01017   cl->base_closure_map = dcm;
01018   if (scheme_env_uses_toplevel(info))
01019     cl->has_tl = 1;
01020   else
01021     cl->has_tl = 0;
01022   cl->body_size = info->size;
01023 
01024   info->size++;
01025   info->inline_fuel++;
01026 
01027   data->closure_size = (cl->base_closure_size
01028                      + (cl->has_tl ? 1 : 0));
01029 
01030   scheme_optimize_info_done(info);
01031 
01032   return (Scheme_Object *)data;
01033 }
01034 
01035 Scheme_Object *scheme_clone_closure_compilation(int dup_ok, Scheme_Object *_data, Optimize_Info *info, int delta, int closure_depth)
01036 {
01037   Scheme_Closure_Data *data, *data2;
01038   Scheme_Object *body;
01039   Closure_Info *cl;
01040   int *flags, sz;
01041 
01042   data = (Scheme_Closure_Data *)_data;
01043 
01044   body = scheme_optimize_clone(dup_ok, data->code, info, delta, closure_depth + data->num_params);
01045   if (!body) return NULL;
01046 
01047   data2 = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
01048   memcpy(data2, data, sizeof(Scheme_Closure_Data));
01049 
01050   data2->code = body;
01051 
01052   cl = MALLOC_ONE_RT(Closure_Info);
01053   memcpy(cl, data->closure_map, sizeof(Closure_Info));
01054   data2->closure_map = (mzshort *)cl;
01055 
01056   /* We don't have to update base_closure_map, because
01057      it will get re-computed as the closure is re-optimized. */
01058 
01059   sz = sizeof(int) * data2->num_params;
01060   flags = (int *)scheme_malloc_atomic(sz);
01061   memcpy(flags, cl->local_flags, sz);
01062   cl->local_flags = flags;
01063 
01064   return (Scheme_Object *)data2;
01065 }
01066 
01067 Scheme_Object *scheme_shift_closure_compilation(Scheme_Object *_data, int delta, int after_depth)
01068 {
01069   Scheme_Object *expr;
01070   Scheme_Closure_Data *data = (Scheme_Closure_Data *)_data;
01071 
01072   expr = scheme_optimize_shift(data->code, delta, after_depth + data->num_params);
01073   data->code = expr;
01074 
01075   return _data;
01076 }
01077 
01078 Scheme_Object *scheme_sfs_closure(Scheme_Object *expr, SFS_Info *info, int self_pos)
01079 {
01080   Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr;
01081   Scheme_Object *code;
01082   int i, size, has_tl = 0;
01083 
01084   size = data->closure_size;
01085   if (size) {
01086     if (info->stackpos + data->closure_map[size - 1] == info->tlpos) {
01087       has_tl = 1;
01088       --size;
01089     }
01090   }
01091 
01092   if (!info->pass) {
01093     for (i = size; i--; ) {
01094       scheme_sfs_used(info, data->closure_map[i]);
01095     }
01096   } else {
01097     /* Check whether we need to zero out any stack positions
01098        after capturing them in a closure: */
01099     Scheme_Object *clears = scheme_null;
01100 
01101     if (info->ip < info->max_nontail) {
01102       int pos, ip;
01103       for (i = size; i--; ) {
01104         pos = data->closure_map[i] + info->stackpos;
01105         if (pos < info->depth) {
01106           ip = info->max_used[pos];
01107           if ((ip == info->ip)
01108               && (ip < info->max_calls[pos])) {
01109             pos -= info->stackpos;
01110             clears = scheme_make_pair(scheme_make_integer(pos),
01111                                       clears);
01112           }
01113         }
01114       }
01115     }
01116 
01117     return scheme_sfs_add_clears(expr, clears, 0);
01118   }
01119 
01120   if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SFS)) {
01121     SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SFS;
01122     info = scheme_new_sfs_info(data->max_let_depth);
01123     scheme_sfs_push(info, data->closure_size + data->num_params, 1);
01124 
01125     if (has_tl)
01126       info->tlpos = info->stackpos + data->closure_size - 1;
01127 
01128     if (self_pos >= 0) {
01129       for (i = size; i--; ) {
01130         if (data->closure_map[i] == self_pos) {
01131           info->selfpos = info->stackpos + i;
01132           info->selfstart = info->stackpos;
01133           info->selflen = data->closure_size;
01134           break;
01135         }
01136       }
01137     }
01138 
01139     code = scheme_sfs(data->code, info, data->max_let_depth);
01140 
01141     /* If any arguments go unused, and if there's a non-tail,
01142        non-immediate call in the body, then we flush the
01143        unused arguments at the start of the body. We assume that
01144        the closure values are used (otherwise they wouldn't
01145        be in the closure). */
01146     if (info->max_nontail) {
01147       int i, pos, cnt;
01148       Scheme_Object *clears = scheme_null;
01149 
01150       cnt = data->num_params;
01151       for (i = 0; i < cnt; i++) {
01152         pos = data->max_let_depth - (cnt - i);
01153         if (!info->max_used[pos]) {
01154           pos = i + data->closure_size;
01155           clears = scheme_make_pair(scheme_make_integer(pos),
01156                                     clears);
01157         }
01158       }
01159       
01160       if (SCHEME_PAIRP(clears))
01161         code = scheme_sfs_add_clears(code, clears, 1);
01162     }
01163 
01164     data->code = code;
01165   }
01166 
01167   return expr;
01168 }
01169 
01170 int scheme_closure_body_size(Scheme_Closure_Data *data, int check_assign)
01171 {
01172   int i;
01173   Closure_Info *cl;
01174 
01175   cl = (Closure_Info *)data->closure_map;
01176 
01177   if (check_assign) {
01178     /* Don't try to inline if there's a rest arg: */
01179     if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
01180       return -1;
01181     
01182     /* Don't try to inline if any arguments are mutated: */
01183     for (i = data->num_params; i--; ) {
01184       if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED)
01185        return -1;
01186     }
01187   }
01188 
01189   return cl->body_size;
01190 }
01191 
01192 int scheme_closure_has_top_level(Scheme_Closure_Data *data)
01193 {
01194   Closure_Info *cl;
01195 
01196   cl = (Closure_Info *)data->closure_map;
01197 
01198   return cl->has_tl;
01199 }
01200 
01201 int scheme_closure_argument_flags(Scheme_Closure_Data *data, int i)
01202 {
01203   return ((Closure_Info *)data->closure_map)->local_flags[i];
01204 }
01205 
01206 XFORM_NONGCING static int boxmap_size(int n)
01207 {
01208   return (n + (BITS_PER_MZSHORT - 1)) / BITS_PER_MZSHORT;
01209 }
01210 
01211 static mzshort *allocate_boxmap(int n)
01212 {
01213   mzshort *boxmap;
01214   int size;
01215 
01216   size = boxmap_size(n);
01217   boxmap = MALLOC_N_ATOMIC(mzshort, size);
01218   memset(boxmap, 0, size * sizeof(mzshort));
01219 
01220   return boxmap;
01221 }
01222 
01223 XFORM_NONGCING static void boxmap_set(mzshort *boxmap, int j)
01224 {
01225   boxmap[j / BITS_PER_MZSHORT] |= ((mzshort)1 << (j & (BITS_PER_MZSHORT - 1)));
01226 }
01227 
01228 XFORM_NONGCING static int boxmap_get(mzshort *boxmap, int j)
01229 {
01230   if (boxmap[j / BITS_PER_MZSHORT] & ((mzshort)1 << (j & (BITS_PER_MZSHORT - 1))))
01231     return 1;
01232   else
01233     return 0;
01234 }
01235 
01236 Scheme_Object *
01237 scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, 
01238                                    int can_lift, int convert, int just_compute_lift,
01239                                    Scheme_Object *precomputed_lift)
01240 {
01241   Scheme_Closure_Data *data;
01242   int i, closure_size, offset, np, num_params;
01243   int has_tl, convert_size, need_lift;
01244   mzshort *oldpos, *closure_map;
01245   Closure_Info *cl;
01246   Resolve_Info *new_info;
01247   Scheme_Object *lifted, *result, *lifteds = NULL;
01248   Scheme_Hash_Table *captured = NULL;
01249   mzshort *convert_map, *convert_boxes = NULL;
01250 
01251   data = (Scheme_Closure_Data *)_data;
01252   cl = (Closure_Info *)data->closure_map;
01253   if (!just_compute_lift)
01254     data->iso.so.type = scheme_unclosed_procedure_type;
01255 
01256   if (convert || can_lift) {
01257     if (!convert && !scheme_resolving_in_procedure(info))
01258       can_lift = 0; /* no point in lifting when outside of a lambda or letrec */
01259     if (!info->lifts)
01260       can_lift = 0;
01261   }
01262 
01263   /* We have to perform a small bit of constant propagation here.
01264      Procedures closed only over top-level bindings are lifted during
01265      this pass. Some of the captured bindings from this phase may
01266      refer to a lifted procedure. In that case, we can replace the
01267      lexical reference with a direct reference to the top-level
01268      binding, which means that we can drop the binding from the
01269      closure. */
01270 
01271   closure_size = data->closure_size;
01272   closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * closure_size);
01273 
01274   has_tl = cl->has_tl;
01275   if (has_tl && !can_lift)
01276     convert = 0;
01277 
01278   /* Locals in closure are first: */
01279   oldpos = cl->base_closure_map;
01280   offset = 0;
01281   for (i = 0; i < cl->base_closure_size; i++) {
01282     int li, flags;
01283     li = scheme_resolve_info_lookup(info, oldpos[i], &flags, &lifted, 0);
01284     if (lifted) {
01285       /* Drop lifted binding from closure. */
01286       if (SAME_TYPE(SCHEME_TYPE(lifted), scheme_toplevel_type)
01287           || SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(lifted)), scheme_toplevel_type)) {
01288         has_tl = 1;
01289         if (!can_lift)
01290           convert = 0;
01291       }
01292       /* If the lifted binding is for a converted closure,
01293          we may need to add more bindings to this closure. */
01294       if (SCHEME_RPAIRP(lifted)) {
01295         lifteds = scheme_make_raw_pair(lifted, lifteds);
01296       }
01297     } else {
01298       closure_map[offset] = li;
01299       if (convert && (flags & SCHEME_INFO_BOXED)) {
01300         /* The only problem with a boxed variable is that
01301            it's more difficult to validate. We have to track
01302            which arguments are boxes. And the resulting procedure
01303            must be used only in application positions. */
01304         if (!convert_boxes)
01305           convert_boxes = allocate_boxmap(cl->base_closure_size);
01306         boxmap_set(convert_boxes, offset);
01307       }
01308       offset++;
01309     }
01310   }
01311 
01312   /* Add bindings introduced by closure conversion. The `captured'
01313      table maps old positions to new positions. */
01314   while (lifteds) {
01315     int j, cnt, boxed;
01316     Scheme_Object *vec, *loc;
01317 
01318     if (!captured) {
01319       captured = scheme_make_hash_table(SCHEME_hash_ptr);
01320       for (i = 0; i < offset; i++) {
01321         int cp;
01322         cp = i;
01323         if (convert_boxes && boxmap_get(convert_boxes, i))
01324           cp = -(cp + 1);
01325         scheme_hash_set(captured, scheme_make_integer(closure_map[i]), scheme_make_integer(cp));
01326       }
01327     }
01328 
01329     lifted = SCHEME_CAR(lifteds);
01330     vec = SCHEME_CDR(lifted);
01331     cnt = SCHEME_VEC_SIZE(vec);
01332     --cnt;
01333     for (j = 0; j < cnt; j++) {
01334       loc = SCHEME_VEC_ELS(vec)[j+1];
01335       if (SCHEME_BOXP(loc)) {
01336         loc = SCHEME_BOX_VAL(loc);
01337         boxed = 1;
01338       } else
01339         boxed = 0;
01340       i = SCHEME_LOCAL_POS(loc);
01341       if (!scheme_hash_get(captured, scheme_make_integer(i))) {
01342         /* Need to capture an extra binding: */
01343         int cp;
01344         cp = captured->count;
01345         if (boxed)
01346           cp = -(cp + 1);
01347         scheme_hash_set(captured, scheme_make_integer(i), scheme_make_integer(cp));
01348       }
01349     }
01350 
01351     lifteds = SCHEME_CDR(lifteds);
01352   }
01353 
01354   if (captured && (captured->count > offset)) {
01355     /* We need to extend the closure map.  All the info
01356        is in captured, so just build it from scratch. */
01357     int old_pos, j;
01358     closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * (captured->count + (has_tl ? 1 : 0)));
01359     offset = captured->count;
01360     convert_boxes = NULL;
01361     for (j = captured->size; j--; ) {
01362       if (captured->vals[j]) {
01363         int cp;
01364         cp = SCHEME_INT_VAL(captured->vals[j]);
01365         old_pos = SCHEME_INT_VAL(captured->keys[j]);
01366         if (cp < 0) {
01367           /* Boxed */
01368           cp = -(cp + 1);
01369           if (!convert_boxes)
01370             convert_boxes = allocate_boxmap(offset);
01371           boxmap_set(convert_boxes, cp);
01372         }
01373         closure_map[cp] = old_pos;
01374       }
01375     }
01376   }
01377 
01378   if (convert
01379       && (offset || !has_tl) /* either need args, or treat as convert becasue it's fully closed */
01380       ) {
01381     /* Take over closure_map to be the convert map, instead. */
01382     int new_boxes_size;
01383 
01384     convert_map = closure_map;
01385     convert_size = offset;
01386 
01387     if (convert_boxes)
01388       new_boxes_size = boxmap_size(convert_size + data->num_params);
01389     else
01390       new_boxes_size = 0;
01391 
01392     if (has_tl || convert_boxes) {
01393       int sz;
01394       sz = ((has_tl ? sizeof(mzshort) : 0) + new_boxes_size * sizeof(mzshort));
01395       closure_map = (mzshort *)scheme_malloc_atomic(sz);
01396       memset(closure_map, 0, sz);
01397       if (convert_boxes) {
01398         int bsz;
01399         bsz = boxmap_size(convert_size);
01400         memcpy(closure_map XFORM_OK_PLUS (has_tl ? 1 : 0), 
01401                convert_boxes, 
01402                bsz * sizeof(mzshort));
01403       }
01404     } else
01405       closure_map = NULL;
01406     offset = 0;
01407   } else {
01408     convert = 0;
01409     convert_map = NULL;
01410     convert_size = 0;
01411     convert_boxes = NULL;
01412   }
01413 
01414   /* Then the pointer to globals, if any: */
01415   if (has_tl) {
01416     /* GLOBAL ASSUMPTION: jit.c assumes that the array
01417        of globals is the last item in the closure; grep
01418        for "GLOBAL ASSUMPTION" in jit.c */
01419     int li;
01420     li = scheme_resolve_toplevel_pos(info);
01421     closure_map[offset] = li;
01422     offset++;
01423   }
01424 
01425   /* Reset closure_size, in case a lifted variable was removed: */
01426   closure_size = offset;
01427   if (!just_compute_lift) {
01428     data->closure_size = closure_size;
01429     if (convert && convert_boxes)
01430       SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_HAS_REF_ARGS;
01431   }
01432 
01433   /* Set up environment mapping, initialized for arguments: */
01434 
01435   np = num_params = data->num_params;
01436   if ((data->num_params == 1)
01437       && (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
01438       && !(cl->local_flags[0] & SCHEME_WAS_USED)
01439       && !convert) {
01440     /* (lambda args E) where args is not in E => drop the argument */
01441     new_info = scheme_resolve_info_extend(info, 0, 1, cl->base_closure_size);
01442     num_params = 0;
01443     if (!just_compute_lift)
01444       data->num_params = 0;
01445   } else {
01446     new_info = scheme_resolve_info_extend(info, data->num_params, data->num_params,
01447                                      cl->base_closure_size + data->num_params);
01448     for (i = 0; i < data->num_params; i++) {
01449       scheme_resolve_info_add_mapping(new_info, i, i + closure_size + convert_size,
01450                                       ((cl->local_flags[i] & SCHEME_WAS_SET_BANGED)
01451                                        ? SCHEME_INFO_BOXED
01452                                        : 0),
01453                                       NULL);
01454     }
01455   }
01456 
01457   /* Extend mapping to go from old locations on the stack (as if bodies were
01458      evaluated immediately) to new locations (where closures
01459      effectively shift and compact values on the stack). 
01460 
01461      We don't have to include bindings added because an oiriginal
01462      binding was lifted (i.e., the extra bindings in `captured'),
01463      because they don't appear in the body. Instead, they are
01464      introduced directly in resolved form through the `lifted' info.
01465      That means, though, that we need to transform the `lifted'
01466      mapping. */
01467   if (has_tl && convert) {
01468     /* Skip handle for globals */
01469     offset = 1;
01470   } else {
01471     offset = 0;
01472   }
01473   for (i = 0; i < cl->base_closure_size; i++) {
01474     int p = oldpos[i], flags;
01475 
01476     if (p < 0)
01477       p -= np;
01478     else
01479       p += np;
01480 
01481     flags = scheme_resolve_info_flags(info, oldpos[i], &lifted);
01482 
01483     if (lifted && SCHEME_RPAIRP(lifted)) {
01484       /* Convert from a vector of local references to an array of
01485          positions. */
01486       Scheme_Object *vec, *loc, **ca;
01487       mzshort *cmap, *boxmap = NULL;
01488       int sz, j, cp;
01489 
01490       vec = SCHEME_CDR(lifted);
01491       sz = SCHEME_VEC_SIZE(vec);
01492       --sz;
01493       cmap = MALLOC_N_ATOMIC(mzshort, sz);
01494       for (j = 0; j < sz; j++) {
01495         loc = SCHEME_VEC_ELS(vec)[j+1];
01496         if (SCHEME_BOXP(loc)) {
01497           if (!boxmap)
01498             boxmap = allocate_boxmap(sz);
01499           boxmap_set(boxmap, j);
01500           loc = SCHEME_BOX_VAL(loc);
01501         }
01502         loc = scheme_hash_get(captured, scheme_make_integer(SCHEME_LOCAL_POS(loc)));
01503         cp = SCHEME_INT_VAL(loc);
01504         if (cp < 0)
01505           cp = -(cp + 1);
01506         cmap[j] = cp + (has_tl && convert ? 1 : 0);
01507       }
01508 
01509       ca = MALLOC_N(Scheme_Object *, 4);
01510       ca[0] = scheme_make_integer(sz);
01511       ca[1] = (Scheme_Object *)cmap;
01512       ca[2] = SCHEME_VEC_ELS(vec)[0];
01513       ca[3] = (Scheme_Object *)boxmap;
01514       
01515       lifted = scheme_make_raw_pair(SCHEME_CAR(lifted), (Scheme_Object *)ca);
01516     }
01517 
01518     scheme_resolve_info_add_mapping(new_info, p, lifted ? 0 : offset++, flags, lifted);
01519   }
01520   if (has_tl) {
01521     if (convert)
01522       offset = 0; /* other closure elements converted to arguments */
01523     else
01524       offset = closure_size - 1;
01525     scheme_resolve_info_set_toplevel_pos(new_info, offset);
01526   }
01527 
01528   if (!just_compute_lift)
01529     data->closure_map = closure_map;
01530 
01531   new_info->in_proc = 1;
01532 
01533   if (!just_compute_lift) {
01534     Scheme_Object *code;
01535     code = scheme_resolve_expr(data->code, new_info);
01536     data->code = code;
01537 
01538     data->max_let_depth = (new_info->max_let_depth
01539                            + num_params
01540                            + closure_size
01541                            + convert_size
01542                            + SCHEME_TAIL_COPY_THRESHOLD);
01543 
01544     /* Add code to box set!ed argument variables: */
01545     for (i = 0; i < num_params; i++) {
01546       if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED) {
01547         int j = i + closure_size + convert_size;
01548         Scheme_Object *bcode;
01549         
01550         bcode = scheme_make_syntax_resolved(BOXENV_EXPD,
01551                                             scheme_make_pair(scheme_make_integer(j),
01552                                                              data->code));
01553         data->code = bcode;
01554       }
01555     }
01556   }
01557 
01558   if ((closure_size == 1)
01559       && can_lift
01560       && has_tl
01561       && info->lifts) {
01562     need_lift = 1;
01563   } else
01564     need_lift = 0;
01565 
01566   if (convert) {
01567     num_params += convert_size;
01568     if (!just_compute_lift)
01569       data->num_params = num_params;
01570   }
01571 
01572   /* If the closure is empty, create the closure now */
01573   if (!closure_size) {
01574     if (precomputed_lift) {
01575       result = SCHEME_CAR(precomputed_lift);
01576       if (!just_compute_lift)
01577         ((Scheme_Closure *)result)->code = data;
01578     } else {
01579       if (just_compute_lift)
01580         result = (Scheme_Object *)scheme_malloc_empty_closure();
01581       else
01582         result = scheme_make_closure(NULL, (Scheme_Object *)data, 0);
01583     }
01584   } else
01585     result = (Scheme_Object *)data;
01586   
01587   if (need_lift) {
01588     if (just_compute_lift) {
01589       if (just_compute_lift > 1)
01590         result = scheme_resolve_invent_toplevel(info);
01591       else
01592         result = scheme_resolve_generate_stub_lift();
01593     } else {
01594       Scheme_Object *tl, *defn_tl;
01595       if (precomputed_lift) {
01596         tl = precomputed_lift;
01597         if (SCHEME_RPAIRP(tl))
01598           tl = SCHEME_CAR(tl);
01599       } else {
01600         tl = scheme_resolve_invent_toplevel(info);
01601       }
01602       defn_tl = scheme_resolve_invented_toplevel_to_defn(info, tl);
01603       scheme_resolve_lift_definition(info, defn_tl, result);
01604       if (has_tl)
01605         closure_map[0] = 0; /* globals for closure creation will be at 0 after lifting */
01606       result = tl;
01607     }
01608   }
01609   
01610   if (convert) {
01611     Scheme_Object **ca, *arity;
01612 
01613     if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)) {
01614       arity = scheme_box(scheme_make_integer(num_params - convert_size - 1));
01615     } else {
01616       arity = scheme_make_integer(num_params - convert_size);
01617     }
01618 
01619     ca = MALLOC_N(Scheme_Object *, 4);
01620     ca[0] = scheme_make_integer(convert_size);
01621     ca[1] = (Scheme_Object *)convert_map;
01622     ca[2] = arity;
01623     ca[3] = (Scheme_Object *)convert_boxes;
01624 
01625     if (precomputed_lift) {
01626       SCHEME_CAR(precomputed_lift) = result;
01627       SCHEME_CDR(precomputed_lift) = (Scheme_Object *)ca;
01628       result = precomputed_lift;
01629     } else 
01630       result = scheme_make_raw_pair(result, (Scheme_Object *)ca);
01631   }
01632 
01633   return result;
01634 }
01635 
01636 Scheme_Object *scheme_source_to_name(Scheme_Object *code)
01637      /* Makes up a procedure name when there's not a good one in the source: */
01638 {
01639   Scheme_Stx *cstx = (Scheme_Stx *)code;
01640   if ((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0)) {
01641     char buf[50], src[20];
01642     Scheme_Object *name;
01643 
01644     if (cstx->srcloc->src && SCHEME_PATHP(cstx->srcloc->src)) {
01645       if (SCHEME_BYTE_STRLEN_VAL(cstx->srcloc->src) < 20)
01646        memcpy(src, SCHEME_BYTE_STR_VAL(cstx->srcloc->src), SCHEME_BYTE_STRLEN_VAL(cstx->srcloc->src) + 1);
01647       else {
01648        memcpy(src, SCHEME_BYTE_STR_VAL(cstx->srcloc->src) + SCHEME_BYTE_STRLEN_VAL(cstx->srcloc->src) - 19, 20);
01649        src[0] = '.';
01650        src[1] = '.';
01651        src[2] = '.';
01652       }
01653     } else {
01654       return NULL;
01655     }
01656 
01657     if (cstx->srcloc->line >= 0) {
01658       sprintf(buf, "%s%s%ld:%ld",
01659              src, (src[0] ? ":" : ""), cstx->srcloc->line, cstx->srcloc->col - 1);
01660     } else {
01661       sprintf(buf, "%s%s%ld",
01662              src, (src[0] ? "::" : ""), cstx->srcloc->pos);
01663     }
01664 
01665     name = scheme_intern_exact_symbol(buf, strlen(buf));
01666     return name;
01667   }
01668 
01669   return NULL;
01670 }
01671 
01672 Scheme_Object *combine_name_with_srcloc(Scheme_Object *name, Scheme_Object *code, int src_based_name)
01673 {
01674   Scheme_Stx *cstx = (Scheme_Stx *)code;
01675 
01676   if (((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0))
01677       && cstx->srcloc->src) {
01678     Scheme_Object *vec;
01679     vec = scheme_make_vector(7, NULL);
01680     SCHEME_VEC_ELS(vec)[0] = name;
01681     SCHEME_VEC_ELS(vec)[1] = cstx->srcloc->src;
01682     if (cstx->srcloc->line >= 0) {
01683       SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(cstx->srcloc->line);
01684       SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(cstx->srcloc->col-1);
01685     } else {
01686       SCHEME_VEC_ELS(vec)[2] = scheme_false;
01687       SCHEME_VEC_ELS(vec)[3] = scheme_false;
01688     }
01689     if (cstx->srcloc->pos >= 0)
01690       SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(cstx->srcloc->pos);
01691     else
01692       SCHEME_VEC_ELS(vec)[4] = scheme_false;
01693     if (cstx->srcloc->span >= 0)
01694       SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(cstx->srcloc->span);
01695     else
01696       SCHEME_VEC_ELS(vec)[5] = scheme_false;
01697     SCHEME_VEC_ELS(vec)[6] = (src_based_name ? scheme_true : scheme_false);
01698     
01699     return vec;
01700   }
01701 
01702   return name;
01703 }
01704 
01705 Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Info *rec, int drec)
01706 {
01707   Scheme_Object *name;
01708 
01709   name = scheme_stx_property(code, scheme_inferred_name_symbol, NULL);
01710   if (name && SCHEME_SYMBOLP(name)) {
01711     name = combine_name_with_srcloc(name, code, 0);
01712   } else {
01713     name = rec[drec].value_name;
01714     if (!name || SCHEME_FALSEP(name)) {
01715       name = scheme_source_to_name(code);
01716       if (name)
01717        name = combine_name_with_srcloc(name, code, 1);
01718     } else {
01719       name = combine_name_with_srcloc(name, code, 0);
01720     }
01721   }
01722   return name;
01723 }
01724 
01725 Scheme_Object *
01726 scheme_make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code,
01727                             Scheme_Compile_Info *rec, int drec)
01728      /* Compiles a `lambda' expression */
01729 {
01730   Scheme_Object *allparams, *params, *forms, *param, *name;
01731   Scheme_Closure_Data *data;
01732   Scheme_Compile_Info lam;
01733   Scheme_Comp_Env *frame;
01734   int i;
01735   long num_params;
01736   Closure_Info *cl;
01737 
01738   data  = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
01739 
01740   data->iso.so.type = scheme_compiled_unclosed_procedure_type;
01741 
01742   params = SCHEME_STX_CDR(code);
01743   params = SCHEME_STX_CAR(params);
01744   allparams = params;
01745 
01746   num_params = 0;
01747   for (; SCHEME_STX_PAIRP(params); params = SCHEME_STX_CDR(params)) {
01748     num_params++;
01749   }
01750   SCHEME_CLOSURE_DATA_FLAGS(data) = 0;
01751   if (!SCHEME_STX_NULLP(params)) {
01752     SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_HAS_REST;
01753     num_params++;
01754   }
01755   data->num_params = num_params;
01756   if ((data->num_params > 0) && scheme_has_method_property(code))
01757     SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_IS_METHOD;
01758 
01759   forms = SCHEME_STX_CDR(code);
01760   forms = SCHEME_STX_CDR(forms);
01761 
01762   frame = scheme_new_compilation_frame(data->num_params, SCHEME_LAMBDA_FRAME, env, rec[drec].certs);
01763   params = allparams;
01764   for (i = 0; i < data->num_params; i++) {
01765     if (!SCHEME_STX_PAIRP(params))
01766       param = params;
01767     else
01768       param = SCHEME_STX_CAR(params);
01769     scheme_add_compilation_binding(i, param, frame);
01770     if (SCHEME_STX_PAIRP(params))
01771       params = SCHEME_STX_CDR (params);
01772   }
01773 
01774   if (SCHEME_STX_NULLP(forms))
01775     scheme_wrong_syntax(NULL, NULL, code, "bad syntax (empty body)");
01776 
01777   forms = scheme_datum_to_syntax(forms, code, code, 0, 0);
01778   forms = scheme_add_env_renames(forms, frame, env);
01779 
01780   name = scheme_build_closure_name(code, rec, drec);
01781   data->name = name;
01782 
01783   scheme_compile_rec_done_local(rec, drec);
01784 
01785   scheme_init_lambda_rec(rec, drec, &lam, 0);
01786 
01787   {
01788     Scheme_Object *datacode;
01789     datacode = scheme_compile_sequence(forms,
01790                                    scheme_no_defines(frame),
01791                                    &lam, 0);
01792     data->code = datacode;
01793   }
01794 
01795   scheme_merge_lambda_rec(rec, drec, &lam, 0);
01796 
01797   cl = MALLOC_ONE_RT(Closure_Info);
01798 #ifdef MZTAG_REQUIRED
01799   cl->type = scheme_rt_closure_info;
01800 #endif
01801   {
01802     int *local_flags;
01803     local_flags = scheme_env_get_flags(frame, 0, data->num_params);
01804     cl->local_flags = local_flags;
01805   }
01806   data->closure_map = (mzshort *)cl;
01807 
01808   return (Scheme_Object *)data;
01809 }
01810 
01811 
01812 /*========================================================================*/
01813 /*                            prompt helpers                              */
01814 /*========================================================================*/
01815 
01816 static void initialize_prompt(Scheme_Thread *p, Scheme_Prompt *prompt, void *stack_boundary)
01817 {
01818   prompt->is_barrier = 0;
01819   prompt->stack_boundary = stack_boundary;
01820   prompt->runstack_boundary_start = MZ_RUNSTACK_START;
01821   prompt->runstack_boundary_offset = (MZ_RUNSTACK - MZ_RUNSTACK_START);
01822   prompt->mark_boundary = MZ_CONT_MARK_STACK;
01823   prompt->boundary_mark_pos = MZ_CONT_MARK_POS;
01824 }
01825 
01826 /*========================================================================*/
01827 /*                         stack-overflow wrapper                         */
01828 /*========================================================================*/
01829 
01830 typedef Scheme_Object *(*Overflow_K_Proc)(void);
01831 
01832 THREAD_LOCAL Scheme_Overflow_Jmp *scheme_overflow_jmp;
01833 THREAD_LOCAL void *scheme_overflow_stack_start;
01834 
01835 MZ_DO_NOT_INLINE(void scheme_really_create_overflow(void *stack_base));
01836 
01837 void scheme_really_create_overflow(void *stack_base)
01838 {
01839   Scheme_Overflow_Jmp *jmp;
01840 
01841   if (scheme_overflow_jmp)
01842     return;
01843 
01844   scheme_overflow_stack_start = stack_base;
01845 
01846   jmp = MALLOC_ONE_RT(Scheme_Overflow_Jmp);
01847 #ifdef MZTAG_REQUIRED
01848   jmp->type = scheme_rt_overflow_jmp;
01849 #endif
01850 
01851   scheme_init_jmpup_buf(&jmp->cont);
01852   if (scheme_setjmpup(&jmp->cont, jmp, stack_base)) {
01853     /* A jump into here is a request to handle overflow.
01854        The way to continue is in p->overflow_k.
01855        When we get back, put the result into
01856        scheme_overflow_reply. The route to return is
01857        in the thread's `overflow' field. */
01858     Scheme_Thread * volatile p;
01859     Scheme_Overflow * volatile overflow;
01860     mz_jmp_buf nestedbuf;
01861 
01862     p = scheme_current_thread;
01863     overflow = p->overflow;
01864 
01865     overflow->jmp->savebuf = p->error_buf;
01866     p->error_buf = &nestedbuf;
01867     if (scheme_setjmp(nestedbuf)) {
01868       /* there was an escape from the overflow */
01869       p = scheme_current_thread;
01870       p->overflow_reply = NULL; /* means "continue the error" */
01871     } else {
01872       void *p1, *p2, *p3, *p4, *p5;
01873       long i1, i2, i3, i4;
01874       Overflow_K_Proc f = p->overflow_k;
01875       Scheme_Object *reply;
01876 
01877       p1 = p->ku.k.p1;
01878       p2 = p->ku.k.p2;
01879       p3 = p->ku.k.p3;
01880       p4 = p->ku.k.p4;
01881       p5 = p->ku.k.p5;
01882       i1 = p->ku.k.i1;
01883       i2 = p->ku.k.i2;
01884       i3 = p->ku.k.i3;
01885       i4 = p->ku.k.i4;
01886 
01887       /* stack overflow is a lot of work; force a sleep */
01888       scheme_thread_block(0);
01889       p->ran_some = 1;
01890 
01891       p->ku.k.p1 = p1;
01892       p->ku.k.p2 = p2;
01893       p->ku.k.p3 = p3;
01894       p->ku.k.p4 = p4;
01895       p->ku.k.p5 = p5;
01896       p->ku.k.i1 = i1;
01897       p->ku.k.i2 = i2;
01898       p->ku.k.i3 = i3;
01899       p->ku.k.i4 = i4;
01900 
01901       reply = f();
01902       scheme_overflow_reply = reply;
01903     }
01904 
01905     p = scheme_current_thread;
01906     overflow = p->overflow;
01907     p->stack_start = overflow->stack_start;
01908 
01909     /* Reset overflow buffer and continue */
01910     scheme_longjmpup(&overflow->jmp->cont);
01911   }
01912 
01913   if (scheme_overflow_jmp) {
01914     scheme_signal_error("shouldn't get here!");
01915   }
01916 
01917   scheme_overflow_jmp = jmp;
01918 }
01919 
01920 void scheme_create_overflow(void)
01921 {
01922   void *stack_marker;
01923   scheme_really_create_overflow(PROMPT_STACK(stack_marker));
01924   stack_marker = NULL; /* to ensure that we get __gc_var_stack__ in 3m */
01925 }
01926 
01927 void scheme_init_overflow(void)
01928 {
01929   REGISTER_SO(scheme_overflow_jmp);
01930 }
01931 
01932 void scheme_reset_overflow(void)
01933 {
01934   scheme_overflow_jmp = NULL;
01935 }
01936 
01937 /*========================================================================*/
01938 /*                       entry continuation barrier                       */
01939 /*========================================================================*/
01940 
01941 static Scheme_Prompt *allocate_prompt(Scheme_Prompt **cached_prompt) {
01942   Scheme_Prompt *prompt;
01943   if (*cached_prompt) {
01944     prompt = *cached_prompt;
01945     *cached_prompt = NULL;
01946   } else  {
01947     prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
01948     prompt->so.type = scheme_prompt_type;
01949   }
01950   return prompt;
01951 }
01952 
01953 static void save_dynamic_state(Scheme_Thread *thread, Scheme_Dynamic_State *state) {
01954     state->current_local_env = thread->current_local_env;
01955     state->mark              = thread->current_local_mark;
01956     state->name              = thread->current_local_name;
01957     state->certs             = thread->current_local_certs;
01958     state->modidx            = thread->current_local_modidx;
01959     state->menv              = thread->current_local_menv;
01960 }
01961 
01962 static void restore_dynamic_state(Scheme_Dynamic_State *state, Scheme_Thread *thread) {
01963     thread->current_local_env     = state->current_local_env;
01964     thread->current_local_mark    = state->mark;
01965     thread->current_local_name    = state->name;
01966     thread->current_local_certs   = state->certs;
01967     thread->current_local_modidx  = state->modidx;
01968     thread->current_local_menv    = state->menv;
01969 }
01970 
01971 void scheme_set_dynamic_state(Scheme_Dynamic_State *state, Scheme_Comp_Env *env, Scheme_Object *mark, 
01972                      Scheme_Object *name, 
01973                      Scheme_Object *certs, 
01974                      Scheme_Env *menv,
01975                      Scheme_Object *modidx)
01976 {
01977   state->current_local_env = env;
01978   state->mark              = mark;
01979   state->name              = name;
01980   state->certs             = certs;
01981   state->modidx            = modidx;
01982   state->menv              = menv;
01983 }
01984 
01985 void *scheme_top_level_do(void *(*k)(void), int eb) {
01986     return scheme_top_level_do_worker(k, eb, 0, NULL);
01987 }
01988 
01989 void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread, Scheme_Dynamic_State *dyn_state)
01990 {
01991   /* Wraps a function `k' with a handler for stack overflows and
01992      barriers to full-continuation jumps. No barrier if !eb. */
01993   
01994   void * v;
01995   Scheme_Prompt * volatile prompt = NULL;
01996   mz_jmp_buf *save;
01997   mz_jmp_buf newbuf;
01998   Scheme_Stack_State envss;
01999 
02000   Scheme_Dynamic_State save_dyn_state;
02001 
02002   Scheme_Thread * volatile p = scheme_current_thread;
02003   volatile int old_pcc = scheme_prompt_capture_count;
02004   Scheme_Cont_Frame_Data cframe;
02005 
02006 #ifdef MZ_PRECISE_GC
02007   void *external_stack;
02008 #endif
02009 
02010 
02011   if (scheme_active_but_sleeping)
02012     scheme_wake_up();
02013 
02014   if (eb) {
02015     prompt = allocate_prompt(&available_prompt);
02016     initialize_prompt(p, prompt, PROMPT_STACK(prompt));
02017       
02018     if (!new_thread) {
02019       prompt->is_barrier = 1;
02020     }
02021 
02022     if (!barrier_prompt_key) {
02023       REGISTER_SO(barrier_prompt_key);
02024       barrier_prompt_key = scheme_make_symbol("bar"); /* uninterned */
02025     }
02026   }
02027 
02028 #ifdef MZ_PRECISE_GC
02029   if (scheme_get_external_stack_val)
02030     external_stack = scheme_get_external_stack_val();
02031   else
02032     external_stack = NULL;
02033 #endif
02034 
02035   scheme_save_env_stack_w_thread(envss, p);
02036   save_dynamic_state(p, &save_dyn_state);
02037 
02038   if (dyn_state) {
02039     restore_dynamic_state(dyn_state, p);
02040     dyn_state = NULL;
02041   }
02042 
02043   scheme_create_overflow(); /* needed even if scheme_overflow_jmp is already set */
02044 
02045   if (prompt) {
02046     scheme_push_continuation_frame(&cframe);
02047     scheme_set_cont_mark(barrier_prompt_key, (Scheme_Object *)prompt);
02048   }
02049 
02050   save = p->error_buf;
02051   p->error_buf = &newbuf;
02052 
02053   if (scheme_setjmp(newbuf)) {
02054     if (!new_thread) {
02055       p = scheme_current_thread;
02056       scheme_restore_env_stack_w_thread(envss, p);
02057 #ifdef MZ_PRECISE_GC
02058       if (scheme_set_external_stack_val)
02059         scheme_set_external_stack_val(external_stack);
02060 #endif
02061       if (prompt) {
02062         scheme_pop_continuation_frame(&cframe);
02063         if (old_pcc == scheme_prompt_capture_count) {
02064           /* It wasn't used */
02065           available_prompt = prompt;
02066         }
02067       }
02068       restore_dynamic_state(&save_dyn_state, p);
02069     }
02070     scheme_longjmp(*save, 1);
02071   }
02072 
02073   if (new_thread) {
02074     /* check for initial break before we do anything */
02075     scheme_check_break_now();
02076   }
02077 
02078   v = k();
02079 
02080   /* IMPORTANT: no GCs from here to return, since v
02081      may refer to multiple values, and we don't want the
02082      multiple-value array cleared. */
02083 
02084   if (!new_thread) {
02085     p = scheme_current_thread;
02086 
02087     restore_dynamic_state(&save_dyn_state, p);
02088 
02089     p->error_buf = save;
02090   }
02091 
02092   if (prompt) {
02093     scheme_pop_continuation_frame(&cframe);
02094     if (old_pcc == scheme_prompt_capture_count) {
02095       /* It wasn't used */
02096       available_prompt = prompt;
02097     }
02098   }
02099 
02100   if (scheme_active_but_sleeping)
02101     scheme_wake_up();
02102 
02103   return (Scheme_Object *)v;
02104 }
02105 
02106 
02107 void scheme_clear_prompt_cache()
02108 {
02109   available_prompt = NULL;
02110   available_cws_prompt = NULL;
02111   available_regular_prompt = NULL;
02112   available_prompt_dw = NULL;
02113   available_prompt_mc = NULL;
02114 }
02115 
02116 static void ensure_overflow_id(Scheme_Overflow *overflow)
02117 {
02118   void *id;
02119   if (!overflow->id) {
02120     if (overflow->jmp) {
02121       overflow->id = overflow->jmp;
02122     } else {
02123       id = scheme_malloc_atomic(4);
02124       overflow->id = id;
02125     }
02126   }
02127 }
02128 
02129 void scheme_ensure_dw_id(Scheme_Dynamic_Wind *dw)
02130 {
02131   void *id;
02132   if (!dw->id) {
02133     id = scheme_malloc_atomic(4);
02134     dw->id = id;
02135   }
02136 }
02137 
02138 /*========================================================================*/
02139 /*                  procedure application evaluation                      */
02140 /*========================================================================*/
02141 
02142 static Scheme_Object *
02143 force_values(Scheme_Object *obj, int multi_ok)
02144   /* Called where _scheme_apply() or _scheme_value() might return a
02145      a tail-call-waiting trampoline token.  */
02146 {
02147   if (SAME_OBJ(obj, SCHEME_TAIL_CALL_WAITING)) {
02148     Scheme_Thread *p = scheme_current_thread;
02149     GC_CAN_IGNORE Scheme_Object *rator;
02150     GC_CAN_IGNORE Scheme_Object **rands;
02151       
02152     /* Watch out for use of tail buffer: */
02153     if (p->ku.apply.tail_rands == p->tail_buffer) {
02154       GC_CAN_IGNORE Scheme_Object **tb;
02155       p->tail_buffer = NULL; /* so args aren't zeroed */
02156       tb = MALLOC_N(Scheme_Object *, p->tail_buffer_size);
02157       p->tail_buffer = tb;
02158     }
02159 
02160     rator = p->ku.apply.tail_rator;
02161     rands = p->ku.apply.tail_rands;
02162     p->ku.apply.tail_rator = NULL;
02163     p->ku.apply.tail_rands = NULL;
02164       
02165     if (multi_ok) {
02166       return _scheme_apply_multi(rator,
02167                              p->ku.apply.tail_num_rands,
02168                              rands);
02169     } else {
02170       return _scheme_apply(rator,
02171                         p->ku.apply.tail_num_rands,
02172                         rands);
02173     }
02174   } else if (SAME_OBJ(obj, SCHEME_EVAL_WAITING)) {
02175     Scheme_Thread *p = scheme_current_thread;
02176     if (multi_ok)
02177       return _scheme_eval_linked_expr_multi(p->ku.eval.wait_expr);
02178     else
02179       return _scheme_eval_linked_expr(p->ku.eval.wait_expr);
02180   } else if (obj)
02181     return obj;
02182   else
02183     return scheme_void;
02184 }
02185 
02186 Scheme_Object *
02187 scheme_force_value(Scheme_Object *obj)
02188 {
02189   return force_values(obj, 1);
02190 }
02191 
02192 Scheme_Object *
02193 scheme_force_one_value(Scheme_Object *obj)
02194 {
02195   return force_values(obj, 0);
02196 }
02197 
02198 Scheme_Object *
02199 scheme_force_value_same_mark(Scheme_Object *obj)
02200 {
02201   Scheme_Object *v;
02202   
02203   MZ_CONT_MARK_POS -= 2;
02204   v = force_values(obj, 1);
02205   MZ_CONT_MARK_POS += 2;
02206 
02207   return v;
02208 }
02209 
02210 Scheme_Object *
02211 scheme_force_one_value_same_mark(Scheme_Object *obj)
02212 {
02213   Scheme_Object *v;
02214   
02215   MZ_CONT_MARK_POS -= 2;
02216   v = force_values(obj, 0);
02217   MZ_CONT_MARK_POS += 2;
02218 
02219   return v;
02220 }
02221 
02222 static void *apply_k(void)
02223 {
02224   Scheme_Thread *p = scheme_current_thread;
02225   Scheme_Object *rator;
02226   int num_rands;
02227   Scheme_Object **rands;
02228 
02229   rator = (Scheme_Object *)p->ku.k.p1;
02230   rands = (Scheme_Object **)p->ku.k.p2;
02231   num_rands = p->ku.k.i1;
02232 
02233   p->ku.k.p1 = NULL;
02234   p->ku.k.p2 = NULL;
02235 
02236   if (p->ku.k.i2)
02237     return (void *)_scheme_apply_multi_wp(rator, num_rands, rands, p);
02238   else
02239     return (void *)_scheme_apply_wp(rator, num_rands, rands, p);
02240 }
02241 
02242 static Scheme_Object *
02243 _apply(Scheme_Object *rator, int num_rands, Scheme_Object **rands, int multi, int eb)
02244 {
02245   Scheme_Thread *p = scheme_current_thread;
02246 
02247   p->ku.k.p1 = rator;
02248   p->ku.k.p2 = rands;
02249   p->ku.k.i1 = num_rands;
02250   p->ku.k.i2 = multi;
02251 
02252   return (Scheme_Object *)scheme_top_level_do(apply_k, eb);
02253 }
02254 
02255 Scheme_Object *
02256 scheme_apply(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
02257 {
02258   return _apply(rator, num_rands, rands, 0, 1);
02259 }
02260 
02261 Scheme_Object *
02262 scheme_apply_multi(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
02263 {
02264   return _apply(rator, num_rands, rands, 1, 1);
02265 }
02266 
02267 Scheme_Object *
02268 scheme_apply_thread_thunk(Scheme_Object *rator)
02269 {
02270   Scheme_Thread *p = scheme_current_thread;
02271 
02272   p->ku.k.p1 = rator;
02273   p->ku.k.p2 = NULL;
02274   p->ku.k.i1 = 0;
02275   p->ku.k.i2 = 1;
02276 
02277   return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 1, NULL);
02278 }
02279 
02280 Scheme_Object *
02281 scheme_apply_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state)
02282 {
02283   Scheme_Thread *p = scheme_current_thread;
02284 
02285   p->ku.k.p1 = rator;
02286   p->ku.k.p2 = rands;
02287   p->ku.k.i1 = num_rands;
02288   p->ku.k.i2 = 0;
02289 
02290   return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 0, dyn_state);
02291 }
02292 
02293 Scheme_Object *
02294 scheme_apply_multi_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state)
02295 {
02296   Scheme_Thread *p = scheme_current_thread;
02297 
02298   p->ku.k.p1 = rator;
02299   p->ku.k.p2 = rands;
02300   p->ku.k.i1 = num_rands;
02301   p->ku.k.i2 = 1;
02302 
02303   return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 0, dyn_state);
02304 }
02305 
02306 Scheme_Object *
02307 scheme_apply_no_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
02308 {
02309   return _apply(rator, num_rands, rands, 0, 0);
02310 }
02311 
02312 Scheme_Object *
02313 scheme_apply_multi_no_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
02314 {
02315   return _apply(rator, num_rands, rands, 1, 0);
02316 }
02317 
02318 static Scheme_Object *
02319 finish_apply_with_prompt(void *_data, int argc, Scheme_Object **argv)
02320 {
02321   void **data = (void **)_data;
02322   Scheme_Object *rator, *is_multi;
02323 
02324   argv = (Scheme_Object **)_data;
02325   for (argc = 0; data[argc]; argc++) { }
02326 
02327   rator = (Scheme_Object *)data[argc+1];
02328   is_multi = (Scheme_Object *)data[argc+2];
02329 
02330   if (SCHEME_TRUEP(is_multi))
02331     return _scheme_apply_multi(rator, argc, argv);
02332   else
02333     return _scheme_apply(rator, argc, argv);
02334 }
02335 
02336 static Scheme_Object *
02337 do_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands, int multi, int top_level)
02338 {
02339   void **a;
02340   int i;
02341 
02342   a = MALLOC_N(void*, 3 + num_rands);
02343 
02344   for (i = 0; i < num_rands; i++) {
02345     a[i] = rands[i];
02346   }
02347   a[num_rands] = NULL;
02348   a[num_rands + 1] = rator;
02349   a[num_rands + 2] = (multi ? scheme_true : scheme_false);
02350 
02351   if (top_level) {
02352     if (multi)
02353       return scheme_call_with_prompt_multi(finish_apply_with_prompt, a);
02354     else
02355       return scheme_call_with_prompt(finish_apply_with_prompt, a);
02356   } else {
02357     if (multi)
02358       return _scheme_call_with_prompt_multi(finish_apply_with_prompt, a);
02359     else
02360       return _scheme_call_with_prompt(finish_apply_with_prompt, a);
02361   }
02362 }
02363 
02364 Scheme_Object *
02365 scheme_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
02366 {
02367   return do_apply_with_prompt(rator, num_rands, rands, 0, 1);
02368 }
02369 
02370 Scheme_Object *
02371 scheme_apply_multi_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
02372 {
02373   return do_apply_with_prompt(rator, num_rands, rands, 1, 1);
02374 }
02375 
02376 Scheme_Object *
02377 _scheme_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
02378 {
02379   return do_apply_with_prompt(rator, num_rands, rands, 0, 0);
02380 }
02381 
02382 Scheme_Object *_scheme_apply_multi_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
02383 {
02384   return do_apply_with_prompt(rator, num_rands, rands, 1, 0);
02385 }
02386 
02387 
02388 Scheme_Object *
02389 scheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
02390 {
02391   /* NOTE: apply_values_execute (in syntax.c) and
02392      tail_call_with_values_from_multiple_result (in jit.c)
02393      assume that this function won't allocate when 
02394      num_rands <= p->tail_buffer_size. */
02395   int i;
02396   Scheme_Thread *p = scheme_current_thread;
02397 
02398   p->ku.apply.tail_rator = rator;
02399   p->ku.apply.tail_num_rands = num_rands;
02400 
02401   if (num_rands) {
02402     Scheme_Object **a;
02403     if (num_rands > p->tail_buffer_size) {
02404       {
02405        Scheme_Object **tb;
02406        tb = MALLOC_N(Scheme_Object *, num_rands);
02407        p->tail_buffer = tb;
02408        p->tail_buffer_size = num_rands;
02409       }
02410     }
02411     a = p->tail_buffer;
02412     p->ku.apply.tail_rands = a;
02413     for (i = num_rands; i--; ) {
02414       a[i] = rands[i];
02415     }
02416   } else
02417     p->ku.apply.tail_rands = NULL;
02418 
02419   return SCHEME_TAIL_CALL_WAITING;
02420 }
02421 
02422 Scheme_Object *
02423 scheme_tail_apply_no_copy (Scheme_Object *rator, int num_rands,
02424                         Scheme_Object **rands)
02425 {
02426   Scheme_Thread *p = scheme_current_thread;
02427 
02428   p->ku.apply.tail_rator = rator;
02429   p->ku.apply.tail_num_rands = num_rands;
02430   p->ku.apply.tail_rands = rands;
02431 
02432   return SCHEME_TAIL_CALL_WAITING;
02433 }
02434 
02435 static
02436 Scheme_Object *
02437 X_scheme_apply_to_list(Scheme_Object *rator, Scheme_Object *rands, int force,
02438                      int top_level)
02439 {
02440   int num_rands, i;
02441   Scheme_Object **rands_vec;
02442 
02443   num_rands = scheme_list_length(rands);
02444   rands_vec = MALLOC_N(Scheme_Object *, num_rands);
02445 
02446   for (i = 0; i < num_rands ; i++) {
02447     if (!SCHEME_PAIRP(rands)) {
02448       scheme_signal_error("bad application form");
02449     }
02450     rands_vec[i] = SCHEME_CAR(rands);
02451     rands = SCHEME_CDR(rands);
02452   }
02453 
02454   if (top_level)  {
02455     if (force)
02456       return scheme_apply(rator, num_rands, rands_vec);
02457     else
02458       return scheme_tail_apply(rator, num_rands, rands_vec);
02459   } else {
02460     if (force)
02461       return _scheme_apply(rator, num_rands, rands_vec);
02462     else
02463       return _scheme_tail_apply(rator, num_rands, rands_vec);
02464   }
02465 }
02466 
02467 Scheme_Object *
02468 scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
02469 {
02470   return X_scheme_apply_to_list(rator, rands, 1, 1);
02471 }
02472 
02473 Scheme_Object *
02474 scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
02475 {
02476   return X_scheme_apply_to_list(rator, rands, 0, 1);
02477 }
02478 
02479 Scheme_Object *
02480 _scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
02481 {
02482   return X_scheme_apply_to_list(rator, rands, 1, 0);
02483 }
02484 
02485 Scheme_Object *
02486 _scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
02487 {
02488   return X_scheme_apply_to_list(rator, rands, 0, 0);
02489 }
02490 
02491 static Scheme_Object *
02492 cert_with_specials(Scheme_Object *code, Scheme_Object *mark, Scheme_Env *menv, 
02493                  Scheme_Object *orig_code, Scheme_Object *closest_code,
02494                    Scheme_Comp_Env *cenv, int phase, 
02495                  int deflt, int cadr_deflt)
02496 {
02497   Scheme_Object *prop;
02498   int next_cadr_deflt = 0;
02499 
02500   if (!certify_mode_symbol) {
02501     REGISTER_SO(certify_mode_symbol);
02502     REGISTER_SO(transparent_symbol);
02503     REGISTER_SO(transparent_binding_symbol);
02504     REGISTER_SO(opaque_symbol);
02505     certify_mode_symbol = scheme_intern_symbol("certify-mode");
02506     transparent_symbol = scheme_intern_symbol("transparent");
02507     transparent_binding_symbol = scheme_intern_symbol("transparent-binding");
02508     opaque_symbol = scheme_intern_symbol("opaque");
02509   }
02510 
02511   if (SCHEME_STXP(code)) {
02512     prop = scheme_stx_property(code, certify_mode_symbol, NULL);
02513     if (SAME_OBJ(prop, opaque_symbol)) {
02514       return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1);
02515     } else if (SAME_OBJ(prop, transparent_symbol)) {
02516       cadr_deflt = 0;
02517       /* fall through */
02518     } else if (SAME_OBJ(prop, transparent_binding_symbol)) {
02519       cadr_deflt = 0;
02520       next_cadr_deflt = 1;
02521       /* fall through */
02522     } else {
02523       /* Default transparency depends on module-identifier=? comparison
02524         to `begin', `define-values', and `define-syntaxes'. */
02525       int trans = deflt;
02526       if (SCHEME_TRUEP(prop))
02527         scheme_log(NULL,
02528                    SCHEME_LOG_WARNING,
02529                    0,
02530                    "warning: unrecognized 'certify-mode property value: %V",
02531                    prop);
02532       if (SCHEME_STX_PAIRP(code)) {
02533        Scheme_Object *name;
02534        name = SCHEME_STX_CAR(code);
02535        if (SCHEME_STX_SYMBOLP(name)) {
02536          Scheme_Object *beg_stx, *dv_stx, *ds_stx;
02537 
02538          if (!phase) {
02539            beg_stx = scheme_begin_stx;
02540            dv_stx = scheme_define_values_stx;
02541            ds_stx = scheme_define_syntaxes_stx;
02542          } else if (phase == cached_stx_phase) {
02543            beg_stx = cached_beg_stx;
02544            dv_stx = cached_dv_stx;
02545            ds_stx = cached_ds_stx;
02546          } else {
02547            beg_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_begin_stx), scheme_false, 
02548                                         scheme_sys_wraps(cenv), 0, 0);
02549            dv_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_define_values_stx), scheme_false, 
02550                                        scheme_sys_wraps(cenv), 0, 0);
02551            ds_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_define_syntaxes_stx), scheme_false, 
02552                                        scheme_sys_wraps(cenv), 0, 0);
02553            cached_beg_stx = beg_stx;
02554            cached_dv_stx = dv_stx;
02555            cached_ds_stx = ds_stx;
02556            cached_stx_phase = phase;
02557          }
02558 
02559          if (scheme_stx_module_eq(beg_stx, name, phase)) {
02560            trans = 1;
02561            next_cadr_deflt = 0;
02562          } else if (scheme_stx_module_eq(dv_stx, name, phase)
02563                    || scheme_stx_module_eq(ds_stx, name, phase)) {
02564            trans = 1;
02565            next_cadr_deflt = 1;
02566          }
02567        }
02568       }
02569       
02570       if (!trans)
02571        return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1);
02572     }
02573   }
02574 
02575   if (SCHEME_STX_PAIRP(code)) {
02576     Scheme_Object *a, *d, *v;
02577     
02578     if (SCHEME_STXP(code))
02579       closest_code = code;
02580 
02581     a = SCHEME_STX_CAR(code);
02582     a = scheme_stx_propagate_inactive_certs(a, closest_code);
02583     a = cert_with_specials(a, mark, menv, orig_code, closest_code, cenv, phase, cadr_deflt, 0);
02584     d = SCHEME_STX_CDR(code);
02585     if (SCHEME_STXP(d))
02586       d = scheme_stx_propagate_inactive_certs(d, closest_code);
02587     d = cert_with_specials(d, mark, menv, orig_code, closest_code, cenv, phase, 1, next_cadr_deflt);
02588 
02589     v = scheme_make_pair(a, d);
02590 
02591     if (SCHEME_PAIRP(code))
02592       return v;
02593 
02594     return scheme_datum_to_syntax(v, code, code, 0, 2);
02595   } else if (SCHEME_STX_NULLP(code))
02596     return code;
02597 
02598   return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1);
02599 }
02600 
02601 Scheme_Object *
02602 scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
02603                  Scheme_Object *rator, Scheme_Object *code,
02604                  Scheme_Comp_Env *env, Scheme_Object *boundname,
02605                    Scheme_Compile_Expand_Info *rec, int drec,
02606                  int for_set)
02607 {
02608   Scheme_Object *orig_code = code;
02609   Scheme_Object *certs;
02610   certs = rec[drec].certs;
02611 
02612   if (scheme_is_rename_transformer(rator)) {
02613     Scheme_Object *mark;
02614    
02615     rator = scheme_rename_transformer_id(rator);
02616     /* rator is now an identifier */
02617 
02618     /* and it's introduced by this expression: */
02619     mark = scheme_new_mark();
02620     rator = scheme_add_remove_mark(rator, mark);
02621 
02622     if (for_set) {
02623       Scheme_Object *tail, *setkw;
02624 
02625       tail = SCHEME_STX_CDR(code);
02626       setkw = SCHEME_STX_CAR(code);
02627       tail = SCHEME_STX_CDR(tail);
02628       code = scheme_make_pair(setkw, scheme_make_pair(rator, tail));
02629       code = scheme_datum_to_syntax(code, orig_code, orig_code, 0, 0);
02630     } else if (SCHEME_SYMBOLP(SCHEME_STX_VAL(code)))
02631       code = rator;
02632     else {
02633       code = SCHEME_STX_CDR(code);
02634       code = scheme_make_pair(rator, code);
02635       code = scheme_datum_to_syntax(code, orig_code, scheme_sys_wraps(env), 0, 0);
02636     }
02637 
02638     code = cert_with_specials(code, mark, menv, orig_code, orig_code, env, env->genv->phase, 0, 0);
02639 
02640     code = scheme_stx_track(code, orig_code, name);
02641 
02642     return code;
02643   } else {
02644     Scheme_Object *mark, *rands_vec[1];
02645 
02646     certs = scheme_stx_extract_certs(code, certs);
02647  
02648     if (scheme_is_set_transformer(rator))
02649       rator = scheme_set_transformer_proc(rator);
02650 
02651     mark = scheme_new_mark();
02652     code = scheme_add_remove_mark(code, mark);
02653 
02654     SCHEME_EXPAND_OBSERVE_MACRO_PRE_X(rec[drec].observer, code);
02655 
02656     {
02657       Scheme_Dynamic_State dyn_state;
02658       Scheme_Cont_Frame_Data cframe;
02659       Scheme_Config *config;
02660 
02661       scheme_prepare_exp_env(env->genv);
02662       config = scheme_extend_config(scheme_current_config(),
02663                                     MZCONFIG_ENV,
02664                                     (Scheme_Object *)env->genv->exp_env);
02665       scheme_push_continuation_frame(&cframe);
02666       scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
02667 
02668       scheme_set_dynamic_state(&dyn_state, env, mark, boundname, certs, 
02669           menv, menv ? menv->link_midx : env->genv->link_midx);
02670 
02671       rands_vec[0] = code;
02672       code = scheme_apply_with_dynamic_state(rator, 1, rands_vec, &dyn_state);
02673 
02674       scheme_pop_continuation_frame(&cframe);
02675     }
02676 
02677     SCHEME_EXPAND_OBSERVE_MACRO_POST_X(rec[drec].observer, code);
02678 
02679     if (!SCHEME_STXP(code)) {
02680       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
02681                        "%S: return value from syntax expander was not syntax: %V",
02682                        SCHEME_STX_SYM(name),
02683                        code);
02684     }
02685 
02686     code = scheme_add_remove_mark(code, mark);
02687 
02688     code = cert_with_specials(code, mark, menv, orig_code, orig_code, env, env->genv->phase, 0, 0);
02689 
02690     code = scheme_stx_track(code, orig_code, name);
02691 
02692     return code;
02693   }
02694 }
02695 
02696 /*========================================================================*/
02697 /*                                   arity                                */
02698 /*========================================================================*/
02699 
02700 Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa)
02701 {
02702   if (mina == maxa)
02703     return scheme_make_integer(mina);
02704   else if (maxa == -1) {
02705     Scheme_Object *p[1];
02706     p[0] = scheme_make_integer(mina);
02707     return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
02708   } else {
02709     int i;
02710     Scheme_Object *l = scheme_null;
02711 
02712     for (i = maxa; i >= mina; --i) {
02713       l = scheme_make_pair(scheme_make_integer(i), l);
02714     }
02715 
02716     return l;
02717   }
02718 }
02719 
02720 static Scheme_Object *clone_arity(Scheme_Object *a)
02721 {
02722   if (SCHEME_PAIRP(a)) {
02723     Scheme_Object *m, *l;
02724     m = scheme_copy_list(a);
02725     for (l = m; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
02726       a = clone_arity(SCHEME_CAR(l));
02727       SCHEME_CAR(l) = a;
02728     }
02729     return m;
02730   } else if (SCHEME_STRUCTP(a)) {
02731     Scheme_Object *p[1];
02732     p[0] = ((Scheme_Structure *)a)->slots[0];
02733     return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
02734   } else
02735     return a;
02736 }
02737 
02738 static Scheme_Object *get_or_check_arity(Scheme_Object *p, long a, Scheme_Object *bign)
02739 /* a == -1 => get arity
02740    a == -2 => check for allowing bignum */
02741 {
02742   Scheme_Type type;
02743   mzshort mina, maxa;
02744   int drop = 0, cases_count = 0;
02745   mzshort *cases = NULL;
02746 
02747  top:
02748 
02749   type = SCHEME_TYPE(p);
02750   if (type == scheme_prim_type) {
02751     mina = ((Scheme_Primitive_Proc *)p)->mina;
02752     maxa = ((Scheme_Primitive_Proc *)p)->mu.maxa;
02753     if (mina < 0) {
02754       cases = ((Scheme_Primitive_Proc *)p)->mu.cases;
02755       cases_count = -(mina + 1);
02756     } else {
02757       if (maxa > SCHEME_MAX_ARGS)
02758        maxa = -1;
02759     }
02760   } else if (type == scheme_closed_prim_type) {
02761     mina = ((Scheme_Closed_Primitive_Proc *)p)->mina;
02762     maxa = ((Scheme_Closed_Primitive_Proc *)p)->maxa;
02763     if (mina == -2) {
02764       cases_count = -maxa;
02765       cases = ((Scheme_Closed_Case_Primitive_Proc *)p)->cases;
02766     }
02767   } else if (type == scheme_cont_type || type == scheme_escaping_cont_type) {
02768     mina = 0;
02769     maxa = -1;
02770   } else if (type == scheme_case_closure_type) {
02771     Scheme_Case_Lambda *seq;
02772     Scheme_Closure_Data *data;
02773     int i;
02774     Scheme_Object *first, *last = NULL, *v;
02775 
02776     if (a == -1)
02777       first = scheme_null;
02778     else
02779       first = scheme_false;
02780 
02781     seq = (Scheme_Case_Lambda *)p;
02782     for (i = 0; i < seq->count; i++) {
02783       data = SCHEME_COMPILED_CLOS_CODE(seq->array[i]);
02784       mina = maxa = data->num_params;
02785       if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
02786        if (mina)
02787          --mina;
02788        maxa = -1;
02789       }
02790 
02791       if (a >= 0) {
02792        if ((a + drop) >= mina && (maxa < 0 || (a + drop) <= maxa))
02793          return scheme_true;
02794       } else if (a == -2) {
02795        if (maxa < 0)
02796          return scheme_true;
02797       } else {
02798        if (mina >= drop) {
02799          mina -= drop;
02800          if (maxa > 0)
02801            maxa -= drop;
02802 
02803          v = scheme_make_pair(scheme_make_arity(mina, maxa), scheme_null);
02804          if (!last)
02805            first = v;
02806          else
02807            SCHEME_CDR(last) = v;
02808          last = v;
02809        }
02810       }
02811     }
02812 
02813     return first;
02814   } else if (type == scheme_proc_struct_type) {
02815     int is_method;
02816     if (scheme_reduced_procedure_struct
02817         && scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
02818       if (a >= 0)
02819         bign = scheme_make_integer(a);
02820       if (a == -1)
02821         return clone_arity(((Scheme_Structure *)p)->slots[1]);
02822       else {
02823         /* Check arity (or for varargs) */
02824         Scheme_Object *v;
02825         v = ((Scheme_Structure *)p)->slots[1];
02826         if (SCHEME_STRUCTP(v)) {
02827           v = ((Scheme_Structure *)v)->slots[0];
02828           return (scheme_bin_lt_eq(v, bign)
02829                   ? scheme_true
02830                   : scheme_false);
02831         } else if (SCHEME_PAIRP(v)) {
02832           Scheme_Object *x;
02833           while (!SCHEME_NULLP(v)) {
02834             x = SCHEME_CAR(v);
02835             if (SCHEME_STRUCTP(x)) {
02836               x = ((Scheme_Structure *)x)->slots[0];  
02837               if (scheme_bin_lt_eq(x, bign))
02838                 return scheme_true;
02839             } else {
02840               if (scheme_bin_eq(x, bign))
02841                 return scheme_true;
02842             }
02843             v = SCHEME_CDR(v);
02844           }
02845           return scheme_false;
02846         } else if (SCHEME_NULLP(v)) {
02847           return scheme_false;
02848         } else {
02849           return (scheme_bin_eq(v, bign)
02850                   ? scheme_true
02851                   : scheme_false);
02852         }
02853       }
02854     } else {
02855       p = scheme_extract_struct_procedure(p, -1, NULL, &is_method);
02856       if (!SCHEME_PROCP(p)) {
02857         if (a == -1)
02858           return scheme_null;
02859         else
02860           return scheme_false;
02861       }
02862       if (is_method)
02863         drop++;
02864     }
02865     SCHEME_USE_FUEL(1);
02866     goto top;
02867 #ifdef MZ_USE_JIT
02868   } else if (type == scheme_native_closure_type) {
02869     if (a < 0) {
02870       Scheme_Object *pa;
02871 
02872       pa = scheme_get_native_arity(p);
02873 
02874       if (SCHEME_BOXP(pa)) {
02875        /* Is a method; pa already corrects for it */
02876        pa = SCHEME_BOX_VAL(pa);
02877       }
02878 
02879       if (SCHEME_STRUCTP(pa)) {
02880        /* This happens when a non-case-lambda is not yet JITted.
02881           It's an arity-at-least record. Convert it to the
02882           negative-int encoding. */
02883        int v;
02884        pa = ((Scheme_Structure *)pa)->slots[0];
02885        v = -(SCHEME_INT_VAL(pa) + 1);
02886        pa = scheme_make_integer(v);
02887       }
02888 
02889       if (SCHEME_INTP(pa)) {
02890        mina = SCHEME_INT_VAL(pa);
02891        if (mina < 0) {
02892          if (a == -2) {
02893            /* Yes, varargs */
02894            return scheme_true;
02895          }
02896          mina = (-mina) - 1;
02897          maxa = -1;
02898        } else {
02899          if (a == -2) {
02900            /* No varargs */
02901            return scheme_false;
02902          }
02903          maxa = mina;
02904        }
02905       } else {
02906        if (a == -2) {
02907          /* Check for varargs */
02908          Scheme_Object *a;
02909          while (!SCHEME_NULLP(pa)) {
02910            a = SCHEME_CAR(pa);
02911            if (SCHEME_STRUCTP(a))
02912              return scheme_true;
02913            pa = SCHEME_CDR(pa);
02914          }
02915          return scheme_false;
02916        } else {
02917          if (drop) {
02918            /* Need to adjust elements (e.g., because this
02919               procedure is a struct's apply handler) */
02920            Scheme_Object *first = scheme_null, *last = NULL, *a;
02921            int v;
02922            while (SCHEME_PAIRP(pa)) {
02923              a = SCHEME_CAR(pa);
02924              if (SCHEME_INTP(a)) {
02925               v = SCHEME_INT_VAL(a);
02926               if (v < drop)
02927                 a = NULL;
02928               else {
02929                 v -= drop;
02930                 a = scheme_make_integer(v);
02931               }
02932              } else {
02933               /* arity-at-least */
02934               a = ((Scheme_Structure *)a)->slots[0];
02935               v = SCHEME_INT_VAL(a);
02936               if (v >= drop) {
02937                 a = scheme_make_arity(v - drop, -1);
02938               } else {
02939                 a = scheme_make_arity(0, -1);
02940               }
02941              }
02942              if (a) {
02943               a = scheme_make_pair(a, scheme_null);
02944               if (last)
02945                 SCHEME_CDR(last) = a;
02946               else
02947                 first = a;
02948               last = a;
02949              }
02950              pa = SCHEME_CDR(pa);
02951            }
02952            return first;
02953          }
02954          return pa;
02955        }
02956       }
02957     } else {
02958       if (scheme_native_arity_check(p, a + drop))
02959        return scheme_true;
02960       else
02961        return scheme_false;
02962     }
02963 #endif
02964   } else {
02965     Scheme_Closure_Data *data;
02966 
02967     data = SCHEME_COMPILED_CLOS_CODE(p);
02968     mina = maxa = data->num_params;
02969     if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
02970       if (mina)
02971        --mina;
02972       maxa = -1;
02973     }
02974   }
02975 
02976   if (cases) {
02977     int count = cases_count, i;
02978 
02979     if (a == -1) {
02980       Scheme_Object *arity, *a, *last = NULL;
02981 
02982       arity = scheme_alloc_list(count);
02983 
02984       for (i = 0, a = arity; i < count; i++) {
02985        Scheme_Object *av;
02986        int mn, mx;
02987        mn = cases[2 * i];
02988        mx = cases[(2 * i) + 1];
02989 
02990        if (mn >= drop) {
02991          mn -= drop;
02992          if (mx > 0)
02993            mx -= drop;
02994 
02995          av = scheme_make_arity(mn, mx);
02996 
02997          SCHEME_CAR(a) = av;
02998          last = a;
02999          a = SCHEME_CDR(a);
03000        }
03001       }
03002 
03003       /* If drop > 0, might have found no matches */
03004       if (!SCHEME_NULLP(a)) {
03005        if (last)
03006          SCHEME_CDR(last) = scheme_null;
03007        else
03008          arity = scheme_null;
03009       }
03010 
03011       return arity;
03012     }
03013 
03014     if (a == -2) {
03015       for (i = 0; i < count; i++) {
03016        if (cases[(2 * i) + 1] < 0)
03017          return scheme_true;
03018       }
03019 
03020       return scheme_false;
03021     }
03022 
03023     a += drop;
03024 
03025     for (i = 0; i < count; i++) {
03026       int na, xa;
03027       na = cases[2 * i];
03028       xa = cases[(2 * i) + 1];
03029       if ((a >= na) && ((xa < 0) || (a <= xa)))
03030        return scheme_true;
03031     }
03032 
03033     return scheme_false;
03034   }
03035 
03036   if (a == -1) {
03037     if (mina < drop)
03038       return scheme_null;
03039     else
03040       mina -= drop;
03041     if (maxa > 0)
03042       maxa -= drop;
03043 
03044     return scheme_make_arity(mina, maxa);
03045   }
03046 
03047   if (a == -2)
03048     return (maxa < 0) ? scheme_true : scheme_false;
03049 
03050   a += drop;
03051 
03052   if (a < mina || (maxa >= 0 && a > maxa))
03053     return scheme_false;
03054 
03055   return scheme_true;
03056 }
03057 
03058 Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, long a)
03059 {
03060   return get_or_check_arity(p, a, NULL);
03061 }
03062 
03063 int scheme_check_proc_arity2(const char *where, int a,
03064                           int which, int argc, Scheme_Object **argv,
03065                           int false_ok)
03066 {
03067   Scheme_Object *p;
03068 
03069   if (which < 0)
03070     p = argv[0];
03071   else
03072     p = argv[which];
03073 
03074   if (false_ok && SCHEME_FALSEP(p))
03075     return 1;
03076 
03077   if (!SCHEME_PROCP(p) || SCHEME_FALSEP(get_or_check_arity(p, a, NULL))) {
03078     if (where) {
03079       char buffer[60];
03080 
03081       sprintf(buffer, "procedure (arity %d)%s", 
03082              a,
03083              false_ok ? " or #f" : "");
03084 
03085       scheme_wrong_type(where, buffer, which, argc, argv);
03086     } else
03087       return 0;
03088   }
03089 
03090   return 1;
03091 }
03092 
03093 int scheme_check_proc_arity(const char *where, int a,
03094                          int which, int argc, Scheme_Object **argv)
03095 {
03096   return scheme_check_proc_arity2(where, a, which, argc, argv, 0);
03097 }
03098 
03099 /*========================================================================*/
03100 /*                        basic function primitives                       */
03101 /*========================================================================*/
03102 
03103 static Scheme_Object *
03104 void_func (int argc, Scheme_Object *argv[])
03105 {
03106   return scheme_void;
03107 }
03108 
03109 static Scheme_Object *
03110 void_p (int argc, Scheme_Object *argv[])
03111 {
03112   return SAME_OBJ(argv[0], scheme_void) ? scheme_true : scheme_false;
03113 }
03114 
03115 static Scheme_Object *
03116 procedure_p (int argc, Scheme_Object *argv[])
03117 {
03118   return (SCHEME_PROCP(argv[0]) ? scheme_true : scheme_false);
03119 }
03120 
03121 static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[])
03122 {
03123   int isprim;
03124 
03125   if (SCHEME_PRIMP(argv[0]))
03126     isprim = (((Scheme_Primitive_Proc *)argv[0])->pp.flags & SCHEME_PRIM_IS_PRIMITIVE);
03127   else if (SCHEME_CLSD_PRIMP(argv[0]))
03128     isprim = (((Scheme_Closed_Primitive_Proc *)argv[0])->pp.flags & SCHEME_PRIM_IS_PRIMITIVE);
03129   else
03130     isprim = 0;
03131 
03132   return isprim ? scheme_true : scheme_false;
03133 }
03134 
03135 static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[])
03136 {
03137   int isprim;
03138 
03139   if (SCHEME_CLSD_PRIMP(argv[0]))
03140     isprim = (((Scheme_Closed_Primitive_Proc *)argv[0])->pp.flags & SCHEME_PRIM_IS_PRIMITIVE);
03141   else
03142     isprim = 0;
03143 
03144   return isprim ? scheme_true : scheme_false;
03145 }
03146 
03147 Scheme_Object *scheme_proc_struct_name_source(Scheme_Object *a)
03148 {
03149   Scheme_Object *b;
03150 
03151   while (SCHEME_PROC_STRUCTP(a)) {
03152     if (scheme_reduced_procedure_struct
03153         && scheme_is_struct_instance(scheme_reduced_procedure_struct, a)
03154         && SCHEME_TRUEP(((Scheme_Structure *)a)->slots[2])) {
03155       return a;
03156     } else {
03157       /* Either use struct name, or extract proc, depending
03158          whether it's method-style */
03159       int is_method;
03160       b = scheme_extract_struct_procedure(a, -1, NULL, &is_method);
03161       if (!is_method && SCHEME_PROCP(b)) {
03162         a = b;
03163         SCHEME_USE_FUEL(1);
03164       } else
03165         break;
03166     }
03167   }
03168 
03169   return a;
03170 }
03171 
03172 const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error)
03173      /* for_error > 0 => get name for an error message;
03174        for_error < 0 => symbol result ok set *len to -1 */
03175 {
03176   Scheme_Type type;
03177   int dummy;
03178   char *s;
03179 
03180   if (!len)
03181     len = &dummy;
03182 
03183  top:
03184 
03185   type = SCHEME_TYPE(p);
03186   if (type == scheme_prim_type) {
03187     if (((Scheme_Primitive_Proc *)p)->name)
03188       *len = strlen(((Scheme_Primitive_Proc *)p)->name);
03189     return ((Scheme_Primitive_Proc *)p)->name;
03190   } else if (type == scheme_closed_prim_type) {
03191     if (((Scheme_Closed_Primitive_Proc *)p)->name)
03192       *len = strlen(((Scheme_Closed_Primitive_Proc *)p)->name);
03193     return ((Scheme_Closed_Primitive_Proc *)p)->name;
03194   } else if (type == scheme_cont_type || type == scheme_escaping_cont_type) {
03195     return NULL;
03196   } else if (type == scheme_case_closure_type) {
03197     Scheme_Object *n;
03198 
03199     n = ((Scheme_Case_Lambda *)p)->name;
03200     if (n) {
03201       if (SCHEME_BOXP(n)) {
03202        /* See note in schpriv.h about the IS_METHOD hack */
03203        n = SCHEME_BOX_VAL(n);
03204        if (SCHEME_FALSEP(n))
03205          return NULL;
03206       }
03207 
03208       if (SCHEME_VECTORP(n))
03209        n = SCHEME_VEC_ELS(n)[0];
03210 
03211       if (for_error < 0) {
03212        s = (char *)n;
03213        *len = -1;
03214       } else {
03215        *len = SCHEME_SYM_LEN(n);
03216        s = scheme_symbol_val(n);
03217       }
03218     } else
03219       return NULL;
03220   } else if (type == scheme_proc_struct_type) {
03221     /* Assert: the request is for an error. */
03222     Scheme_Object *other;
03223     other = scheme_proc_struct_name_source(p);
03224     if (SAME_OBJ(other, p)) {
03225       if (scheme_reduced_procedure_struct
03226           && scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
03227         /* It must have a name: */
03228         Scheme_Object *sym = ((Scheme_Structure *)p)->slots[2];
03229         if (for_error < 0) {
03230           s = (char *)sym;
03231           *len = -1;
03232         } else {
03233           *len = SCHEME_SYM_LEN(sym);
03234           s = scheme_symbol_val(sym);
03235         }
03236       } else {
03237         Scheme_Object *sym;
03238         sym = SCHEME_STRUCT_NAME_SYM(p);
03239         *len = SCHEME_SYM_LEN(sym);
03240         s = (char *)scheme_malloc_atomic((*len) + 8);
03241         memcpy(s, "struct ", 7);
03242         memcpy(s + 7, scheme_symbol_val(sym), *len);
03243         (*len) += 7;
03244         s[*len] = 0;
03245         return s;
03246       }
03247     } else {
03248       p = other;
03249       goto top;
03250     }
03251   } else {
03252     Scheme_Object *name;
03253 
03254     if (type == scheme_compiled_unclosed_procedure_type) {
03255       name = ((Scheme_Closure_Data *)p)->name;
03256     } else if (type == scheme_closure_type) {
03257       name = SCHEME_COMPILED_CLOS_CODE(p)->name;
03258     } else {
03259       /* Native closure: */
03260       name = ((Scheme_Native_Closure *)p)->code->u2.name;
03261       if (name && SAME_TYPE(SCHEME_TYPE(name), scheme_unclosed_procedure_type)) {
03262        /* Not yet jitted. Use `name' as the other alternaive of 
03263           the union: */
03264        name = ((Scheme_Closure_Data *)name)->name;
03265       }
03266     }
03267 
03268     if (name) {
03269       if (SCHEME_VECTORP(name))
03270        name = SCHEME_VEC_ELS(name)[0];
03271       if (for_error < 0) {
03272        s = (char *)name;
03273        *len = -1;
03274       } else {
03275        *len = SCHEME_SYM_LEN(name);
03276        s = scheme_symbol_val(name);
03277       }
03278     } else
03279       return NULL;
03280   }
03281 
03282   if (for_error > 0) {
03283     char *r;
03284 
03285     r = (char *)scheme_malloc_atomic((*len) + 11);
03286     memcpy(r, "procedure ", 10);
03287     memcpy(r + 10, s, *len + 1);
03288     *len += 10;
03289 
03290     return r;
03291   }
03292 
03293   return s;
03294 }
03295 
03296 static Scheme_Object *primitive_result_arity(int argc, Scheme_Object *argv[])
03297 {
03298   Scheme_Object *o;
03299 
03300   o = argv[0];
03301 
03302   if (SCHEME_PRIMP(o)
03303       && (((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_PRIMITIVE)) {
03304     if (((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT) {
03305       Scheme_Prim_W_Result_Arity *p = (Scheme_Prim_W_Result_Arity *)o;
03306       return scheme_make_arity(p->minr, p->maxr);
03307     }
03308   } else if (SCHEME_CLSD_PRIMP(o)
03309             && (((Scheme_Closed_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_PRIMITIVE)) {
03310     if (((Scheme_Closed_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT) {
03311       Scheme_Closed_Prim_W_Result_Arity *p = (Scheme_Closed_Prim_W_Result_Arity *)o;
03312       return scheme_make_arity(p->minr, p->maxr);
03313     }
03314   } else {
03315     scheme_wrong_type("primitive-result_arity", "primitive", 0, argc, argv);
03316     return NULL;
03317   }
03318 
03319   return scheme_make_integer(1);
03320 }
03321 
03322 static Scheme_Object *object_name(int argc, Scheme_Object **argv)
03323 {
03324   Scheme_Object *a = argv[0];
03325 
03326   if (SCHEME_PROC_STRUCTP(a)) {
03327     a = scheme_proc_struct_name_source(a);
03328     
03329     if (SCHEME_STRUCTP(a)
03330         && scheme_reduced_procedure_struct
03331         && scheme_is_struct_instance(scheme_reduced_procedure_struct, a)) {
03332       /* It must have a name: */
03333       return ((Scheme_Structure *)a)->slots[2];
03334     }
03335   }
03336 
03337   if (SCHEME_STRUCTP(a)) {
03338     return SCHEME_STRUCT_NAME_SYM(a);
03339   } else if (SCHEME_PROCP(a)) {
03340     const char *s;
03341     int len;
03342 
03343     s = scheme_get_proc_name(a, &len, -1);
03344     if (s) {
03345       if (len < 0)
03346        return (Scheme_Object *)s;
03347       else
03348        return scheme_intern_exact_symbol(s, len);
03349     }
03350   } else if (SCHEME_STRUCT_TYPEP(a)) {
03351     return ((Scheme_Struct_Type *)a)->name;
03352   } else if (SAME_TYPE(SCHEME_TYPE(a), scheme_struct_property_type)) {
03353     return ((Scheme_Struct_Property *)a)->name;
03354   } else if (SAME_TYPE(SCHEME_TYPE(a), scheme_regexp_type)) {
03355     Scheme_Object *s;
03356     s = scheme_regexp_source(a);
03357     if (s)
03358       return s;
03359   } else if (SCHEME_INPUT_PORTP(a)) {
03360     Scheme_Input_Port *ip;
03361     ip = scheme_input_port_record(a);
03362     return ip->name;
03363   } else if (SCHEME_OUTPUT_PORTP(a)) {
03364     Scheme_Output_Port *op;
03365     op = scheme_output_port_record(a);
03366     return op->name;
03367   } else if (SCHEME_THREADP(a)) {
03368     Scheme_Thread *t = (Scheme_Thread *)a;
03369     if (t->name) {
03370       return t->name;
03371     }
03372   }
03373 
03374   return scheme_false;
03375 }
03376 
03377 Scheme_Object *scheme_arity(Scheme_Object *p)
03378 {
03379   return get_or_check_arity(p, -1, NULL);
03380 }
03381 
03382 static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[])
03383 {
03384   if (!SCHEME_PROCP(argv[0]))
03385     scheme_wrong_type("procedure-arity", "procedure", 0, argc, argv);
03386 
03387   return get_or_check_arity(argv[0], -1, NULL);
03388 }
03389 
03390 static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[])
03391 {
03392   Scheme_Object *a = argv[0], *v;
03393 
03394   if (SCHEME_INTP(a)) {
03395     return ((SCHEME_INT_VAL(a) >= 0) ? scheme_true : scheme_false);
03396   } else if (SCHEME_BIGNUMP(a)) {
03397     return (SCHEME_BIGPOS(a) ? scheme_true : scheme_false);
03398   } else if (SCHEME_NULLP(a)) {
03399     return scheme_true;
03400   } else if (SCHEME_PAIRP(a)) {
03401     while (SCHEME_PAIRP(a)) {
03402       v = SCHEME_CAR(a);
03403       if (SCHEME_INTP(v)) {
03404         if (SCHEME_INT_VAL(v) < 0)
03405           return scheme_false;
03406       } else if (SCHEME_BIGNUMP(v)) {
03407         if (!SCHEME_BIGPOS(v))
03408           return scheme_false;
03409       } else if (!SCHEME_STRUCTP(v)
03410                  || !scheme_is_struct_instance(scheme_arity_at_least, v)) {
03411         return scheme_false;
03412       }
03413       a = SCHEME_CDR(a);
03414     }
03415     return SCHEME_NULLP(a) ? scheme_true : scheme_false;
03416   } else if (SCHEME_STRUCTP(a)
03417              && scheme_is_struct_instance(scheme_arity_at_least, a)) {
03418     return scheme_true;
03419   } else
03420     return scheme_false;
03421 }
03422 
03423 static Scheme_Object *procedure_arity_includes(int argc, Scheme_Object *argv[])
03424 {
03425   long n;
03426 
03427   if (!SCHEME_PROCP(argv[0]))
03428     scheme_wrong_type("procedure-arity-includes?", "procedure", 0, argc, argv);
03429 
03430   n = scheme_extract_index("procedure-arity-includes?", 1, argc, argv, -2, 0);
03431   /* -2 means a bignum */
03432 
03433   return get_or_check_arity(argv[0], n, argv[1]);
03434 }
03435 
03436 static int is_arity(Scheme_Object *a, int at_least_ok, int list_ok)
03437 {
03438   if (SCHEME_INTP(a)) {
03439     return (SCHEME_INT_VAL(a) >= 0);
03440   } else if (SCHEME_BIGNUMP(a)) {
03441     return SCHEME_BIGPOS(a);
03442   } else if (at_least_ok
03443              && SCHEME_STRUCTP(a)
03444              && scheme_is_struct_instance(scheme_arity_at_least, a)) {
03445     a = ((Scheme_Structure *)a)->slots[0];
03446     return is_arity(a, 0, 0);
03447   }
03448 
03449   if (!list_ok)
03450     return 0;
03451 
03452   while (SCHEME_PAIRP(a)) {
03453     if (!is_arity(SCHEME_CAR(a), 1, 0))
03454       return 0;
03455     a = SCHEME_CDR(a);
03456   }
03457 
03458   if (SCHEME_NULLP(a))
03459     return 1;
03460   return 0;
03461 }
03462 
03463 void scheme_init_reduced_proc_struct(Scheme_Env *env)
03464 {
03465   if (!scheme_reduced_procedure_struct) {
03466     Scheme_Object *pr;
03467 
03468     REGISTER_SO(scheme_reduced_procedure_struct);
03469     pr = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
03470     while (((Scheme_Inspector *)pr)->superior->superior) {
03471       pr = (Scheme_Object *)((Scheme_Inspector *)pr)->superior;
03472     }
03473     scheme_reduced_procedure_struct = scheme_make_proc_struct_type(NULL,
03474                                                                    NULL,
03475                                                                    pr,
03476                                                                    3, 0,
03477                                                                    scheme_false,
03478                                                                    scheme_make_integer(0),
03479                                                                    NULL);
03480   }
03481 }
03482 
03483 static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty, Scheme_Object *name)
03484 {
03485   Scheme_Object *a[3];
03486   
03487   if (SCHEME_STRUCTP(proc)
03488       && scheme_is_struct_instance(scheme_reduced_procedure_struct, proc)) {
03489     /* Don't need the intermediate layer */
03490     if (!name)
03491       name = ((Scheme_Structure *)proc)->slots[2];
03492     proc = ((Scheme_Structure *)proc)->slots[0];
03493   }
03494 
03495   a[0] = proc;
03496   a[1] = aty;
03497   a[2] = (name ? name : scheme_false);
03498 
03499   return scheme_make_struct_instance(scheme_reduced_procedure_struct, 3, a);
03500 }
03501 
03502 static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
03503 {
03504   Scheme_Object *orig, *req, *aty, *oa, *ra, *ol, *lra, *ara, *prev, *pr, *tmp;
03505 
03506   if (!SCHEME_PROCP(argv[0]))
03507     scheme_wrong_type("procedure-reduce-arity", "procedure", 0, argc, argv);
03508 
03509   if (!is_arity(argv[1], 1, 1)) {
03510     scheme_wrong_type("procedure-reduce-arity", "arity", 1, argc, argv);
03511   }
03512 
03513   /* Check whether current arity covers the requested arity.  This is
03514      a bit complicated, because both the source and target can be
03515      lists that include arity-at-least records. */
03516 
03517   orig = get_or_check_arity(argv[0], -1, NULL);
03518   aty = clone_arity(argv[1]);
03519   req = aty;
03520 
03521   if (!SCHEME_PAIRP(orig) && !SCHEME_NULLP(orig))
03522     orig = scheme_make_pair(orig, scheme_null);
03523   if (!SCHEME_PAIRP(req) && !SCHEME_NULLP(req))
03524     req = scheme_make_pair(req, scheme_null);
03525 
03526   while (!SCHEME_NULLP(req)) {
03527     ra = SCHEME_CAR(req);
03528     if (SCHEME_STRUCTP(ra)
03529         && scheme_is_struct_instance(scheme_arity_at_least, ra)) {
03530       /* Convert to a sequence of range pairs, where the
03531          last one can be (min, #f); we'll iterate through the 
03532          original arity to knock out ranges until (if it matches)
03533          we end up with an empty list of ranges. */
03534       ra = scheme_make_pair(scheme_make_pair(((Scheme_Structure *)ra)->slots[0],
03535                                              scheme_false),
03536                             scheme_null);
03537     }
03538 
03539     for (ol = orig; !SCHEME_NULLP(ol); ol = SCHEME_CDR(ol)) {
03540       oa = SCHEME_CAR(ol);
03541       if (SCHEME_INTP(ra) || SCHEME_BIGNUMP(ra)) {
03542         if (SCHEME_INTP(oa) || SCHEME_BIGNUMP(oa)) {
03543           if (scheme_equal(ra, oa))
03544             break;
03545         } else {
03546           /* orig is arity-at-least */
03547           oa = ((Scheme_Structure *)oa)->slots[0];
03548           if (scheme_bin_lt_eq(oa, ra))
03549             break;
03550         }
03551       } else {
03552         /* requested is arity-at-least */
03553         int at_least;
03554         if (SCHEME_INTP(oa) || SCHEME_BIGNUMP(oa)) {
03555           at_least = 0;
03556         } else {
03557           /* orig is arity-at-least */
03558           at_least = 1;
03559           oa = ((Scheme_Structure *)oa)->slots[0];
03560         }
03561 
03562         lra = ra;
03563         prev = NULL;
03564         while (!SCHEME_NULLP(lra)) {
03565           /* check [lo, hi] vs oa: */
03566           ara = SCHEME_CAR(lra);
03567           if (SCHEME_FALSEP(SCHEME_CDR(ara))
03568               || scheme_bin_lt_eq(oa, SCHEME_CDR(ara))) {
03569             if (scheme_bin_gt_eq(oa, SCHEME_CAR(ara))) {
03570               /* oa is in the range [lo, hi]: */
03571               if (scheme_equal(oa, SCHEME_CAR(ara))) {
03572                 /* the range is [oa, hi] */
03573                 if (at_least) {
03574                   /* oa is arity-at least, so drop from here */
03575                   if (prev)
03576                     SCHEME_CDR(prev) = scheme_null;
03577                   else
03578                     ra = scheme_null;
03579                 } else {
03580                   if (scheme_equal(oa, SCHEME_CDR(ara))) {
03581                     /* the range is [oa, oa], so drop it */
03582                     if (prev)
03583                       SCHEME_CDR(prev) = SCHEME_CDR(lra);
03584                     else
03585                       ra = SCHEME_CDR(lra);
03586                   } else {
03587                     /* change range to [ao+1, hi] */
03588                     tmp = scheme_bin_plus(oa, scheme_make_integer(1));
03589                     SCHEME_CAR(ara) = tmp;
03590                   }
03591                 }
03592               } else if (scheme_equal(oa, SCHEME_CAR(ara))) {
03593                 /* the range is [lo, oa], where lo < oa */
03594                 tmp = scheme_bin_minus(oa, scheme_make_integer(1));
03595                 SCHEME_CDR(ara) = tmp;
03596                 if (at_least) 
03597                   SCHEME_CDR(lra) = scheme_null;
03598               } else {
03599                 /* split the range */
03600                 if (at_least) {
03601                   tmp = scheme_bin_minus(oa, scheme_make_integer(1));
03602                   SCHEME_CDR(ara) = tmp;
03603                   SCHEME_CDR(lra) = scheme_null;
03604                 } else {
03605                   pr = scheme_make_pair(scheme_make_pair(scheme_bin_plus(oa, scheme_make_integer(1)),
03606                                                          SCHEME_CDR(ara)),
03607                                         SCHEME_CDR(lra));
03608                   tmp = scheme_bin_minus(oa, scheme_make_integer(1));
03609                   SCHEME_CDR(ara) = tmp;
03610                   SCHEME_CDR(lra) = pr;
03611                 }
03612               }
03613               break;
03614             } else if (at_least) {
03615               /* oa is less than lo, so truncate */
03616               if (prev)
03617                 SCHEME_CDR(prev) = scheme_null;
03618               else
03619                 ra = scheme_null;
03620               break;
03621             }
03622           }
03623           prev = lra;
03624           lra = SCHEME_CDR(lra);
03625         }
03626         if (SCHEME_NULLP(ra))
03627           break;
03628       }
03629     }
03630 
03631     if (SCHEME_NULLP(ol)) {
03632       scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
03633                        "procedure-reduce-arity: arity of procedure: %V"
03634                        " does not include requested arity: %V",
03635                        argv[0],
03636                        argv[1]);
03637       return NULL;
03638     }
03639 
03640     req = SCHEME_CDR(req);
03641   }
03642 
03643   /* Construct a procedure that has the given arity. */
03644   return make_reduced_proc(argv[0], aty, NULL);
03645 }
03646 
03647 static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[])
03648 {
03649   Scheme_Object *aty;
03650 
03651   if (!SCHEME_PROCP(argv[0]))
03652     scheme_wrong_type("procedure-rename", "procedure", 0, argc, argv);
03653   if (!SCHEME_SYMBOLP(argv[1]))
03654     scheme_wrong_type("procedure-rename", "symbol", 1, argc, argv);
03655 
03656   aty = get_or_check_arity(argv[0], -1, NULL);  
03657 
03658   return make_reduced_proc(argv[0], aty, argv[1]);
03659 }
03660 
03661 static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])
03662 {
03663   Scheme_Object *v1 = argv[0], *v2 = argv[1];
03664 
03665   if (!SCHEME_PROCP(v1))
03666     scheme_wrong_type("procedure-closure-contents-eq?", "procedure", 0, argc, argv);
03667   if (!SCHEME_PROCP(v2))
03668     scheme_wrong_type("procedure-closure-contents-eq?", "procedure", 1, argc, argv);
03669 
03670   if (SAME_OBJ(v1, v2))
03671     return scheme_true;
03672 
03673   if (!SAME_TYPE(SCHEME_TYPE(v1), SCHEME_TYPE(v2)))
03674     return scheme_false;
03675 
03676   switch (SCHEME_TYPE(v1)) {
03677   case scheme_prim_type:
03678     {
03679       Scheme_Primitive_Proc *p1 = (Scheme_Primitive_Proc *)v1;
03680       Scheme_Primitive_Proc *p2 = (Scheme_Primitive_Proc *)v2;
03681 
03682       if (p1->prim_val == p2->prim_val) {
03683        if (p1->pp.flags & SCHEME_PRIM_IS_CLOSURE) {
03684          if (!(p2->pp.flags & SCHEME_PRIM_IS_CLOSURE))
03685            return scheme_false;
03686 
03687          /* They both are closures, but we don't know how 
03688             many fields in each, except in 3m mode. So
03689             give up. */
03690          return scheme_false;
03691        } else if (!(p2->pp.flags & SCHEME_PRIM_IS_CLOSURE))
03692          return scheme_true;
03693       }
03694     }
03695     break;
03696   case scheme_closure_type:
03697     {
03698       Scheme_Closure *c1 = (Scheme_Closure *)v1;
03699       Scheme_Closure *c2 = (Scheme_Closure *)v2;
03700 
03701       if (SAME_OBJ(c1->code, c2->code)) {
03702        int i;
03703        for (i = c1->code->closure_size; i--; ) {
03704          if (!SAME_OBJ(c1->vals[i], c2->vals[i]))
03705            return scheme_false;
03706        }
03707        return scheme_true;
03708       }
03709     }
03710     break;
03711   case scheme_native_closure_type:
03712     {
03713       Scheme_Native_Closure *c1 = (Scheme_Native_Closure *)v1;
03714       Scheme_Native_Closure *c2 = (Scheme_Native_Closure *)v2;
03715 
03716       if (SAME_OBJ(c1->code, c2->code)) {
03717        int i;
03718        i = c1->code->closure_size;
03719        if (i < 0) {
03720          /* A case closure */
03721          Scheme_Native_Closure *sc1, *sc2;
03722          int j;
03723          i = -(i + 1);
03724          while (i--) {
03725            sc1 = (Scheme_Native_Closure *)c1->vals[i];
03726            sc2 = (Scheme_Native_Closure *)c2->vals[i];
03727            j = sc1->code->closure_size;
03728            while (j--) {
03729              if (!SAME_OBJ(sc1->vals[j], sc2->vals[j]))
03730               return scheme_false;
03731            }
03732          }
03733        } else {
03734          /* Normal closure: */
03735          while (i--) {
03736            if (!SAME_OBJ(c1->vals[i], c2->vals[i]))
03737              return scheme_false;
03738          }
03739        }
03740        return scheme_true;
03741       }
03742     }
03743     break;
03744   case scheme_case_closure_type:
03745     {
03746       Scheme_Case_Lambda *c1 = (Scheme_Case_Lambda *)v1;
03747       Scheme_Case_Lambda *c2 = (Scheme_Case_Lambda *)v2;
03748       if (c1->count == c2->count) {
03749        Scheme_Closure *sc1, *sc2;
03750        int i, j;
03751        for (i = c1->count; i--; ) {
03752          sc1 = (Scheme_Closure *)c1->array[i];
03753          sc2 = (Scheme_Closure *)c2->array[i];
03754          if (!SAME_OBJ(sc1->code, sc2->code))
03755            return scheme_false;
03756          for (j = sc1->code->closure_size; j--; ) {
03757            if (!SAME_OBJ(sc1->vals[j], sc2->vals[j]))
03758              return scheme_false;
03759          }
03760        }
03761        return scheme_true;
03762       }
03763     }
03764     break;
03765   }
03766 
03767   return scheme_false;
03768 }
03769 
03770 static Scheme_Object *
03771 apply(int argc, Scheme_Object *argv[])
03772 {
03773   Scheme_Object *rands;
03774   Scheme_Object **rand_vec;
03775   int i, num_rands;
03776   Scheme_Thread *p = scheme_current_thread;
03777 
03778   if (!SCHEME_PROCP(argv[0])) {
03779     scheme_wrong_type("apply", "procedure", 0, argc, argv);
03780     return NULL;
03781   }
03782 
03783   rands = argv[argc-1];
03784 
03785   num_rands = scheme_proper_list_length(rands);
03786   if (num_rands < 0) {
03787     scheme_wrong_type("apply", "proper list", argc - 1, argc, argv);
03788     return NULL;
03789   }
03790   num_rands += (argc - 2);
03791 
03792   if (num_rands > p->tail_buffer_size) {
03793     rand_vec = MALLOC_N(Scheme_Object *, num_rands);
03794     /* num_rands might be very big, so don't install it as the tail buffer */
03795   } else
03796     rand_vec = p->tail_buffer;
03797 
03798   for (i = argc - 2; i--; ) {
03799     rand_vec[i] = argv[i + 1];
03800   }
03801 
03802   for (i = argc - 2; SCHEME_PAIRP(rands); i++, rands = SCHEME_CDR(rands)) {
03803     rand_vec[i] = SCHEME_CAR(rands);
03804   }
03805 
03806   p->ku.apply.tail_rator = argv[0];
03807   p->ku.apply.tail_rands = rand_vec;
03808   p->ku.apply.tail_num_rands = num_rands;
03809 
03810   return SCHEME_TAIL_CALL_WAITING;
03811 }
03812 
03813 #define DO_MAP map
03814 #define MAP_NAME "map"
03815 #define MAP_MODE
03816 #include "schmap.inc"
03817 #undef MAP_MODE
03818 #undef MAP_NAME
03819 #undef DO_MAP
03820 
03821 #define DO_MAP for_each
03822 #define MAP_NAME "for-each"
03823 #define FOR_EACH_MODE
03824 #include "schmap.inc"
03825 #undef FOR_EACH_MODE
03826 #undef MAP_NAME
03827 #undef DO_MAP
03828 
03829 #define DO_MAP andmap
03830 #define MAP_NAME "andmap"
03831 #define AND_MODE
03832 #include "schmap.inc"
03833 #undef AND_MODE
03834 #undef MAP_NAME
03835 #undef DO_MAP
03836 
03837 #define DO_MAP ormap
03838 #define MAP_NAME "ormap"
03839 #define OR_MODE
03840 #include "schmap.inc"
03841 #undef OR_MODE
03842 #undef MAP_NAME
03843 #undef DO_MAP
03844 
03845 static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[])
03846 {
03847   Scheme_Thread *p;
03848   Scheme_Object *v;
03849 
03850   scheme_check_proc_arity("call-with-values", 0, 0, argc, argv);
03851   if (!SCHEME_PROCP(argv[1]))
03852     scheme_wrong_type("call-with-values", "procedure", 1, argc, argv);
03853 
03854   v = _scheme_apply_multi(argv[0], 0, NULL);
03855   p = scheme_current_thread;
03856   if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
03857     int n;
03858     Scheme_Object **a;
03859     if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
03860       p->values_buffer = NULL;
03861     /* Beware: the fields overlap! */
03862     n = p->ku.multiple.count;
03863     a = p->ku.multiple.array;
03864     p->ku.apply.tail_num_rands = n;
03865     p->ku.apply.tail_rands = a;
03866   } else {
03867     p->ku.apply.tail_num_rands = 1;
03868     p->ku.apply.tail_rands = p->tail_buffer;
03869     p->ku.apply.tail_rands[0] = v;
03870   }
03871 
03872   p->ku.apply.tail_rator = argv[1];
03873 
03874   return SCHEME_TAIL_CALL_WAITING;
03875 }
03876 
03877 static MZ_INLINE Scheme_Object *values_slow(int argc, Scheme_Object *argv[])
03878 {
03879   Scheme_Thread *p = scheme_current_thread;
03880   Scheme_Object **a;
03881   int i;
03882 
03883   a = MALLOC_N(Scheme_Object *, argc);
03884   p->values_buffer = a;
03885   p->values_buffer_size = argc;
03886 
03887   p->ku.multiple.array = a;
03888 
03889   for (i = 0; i < argc; i++) {
03890     a[i] = argv[i];
03891   }
03892 
03893   return SCHEME_MULTIPLE_VALUES;
03894 }
03895 
03896 Scheme_Object *scheme_values(int argc, Scheme_Object *argv[])
03897 {
03898   Scheme_Thread *p;
03899   int i;
03900   Scheme_Object **a;
03901 
03902   if (argc == 1)
03903     return argv[0];
03904 
03905   p = scheme_current_thread;
03906   p->ku.multiple.count = argc;
03907   if (p->values_buffer && (p->values_buffer_size >= argc)) {
03908     a = p->values_buffer;
03909   } else {
03910     return values_slow(argc, argv);
03911   }
03912 
03913   p->ku.multiple.array = a;
03914 
03915   for (i = 0; i < argc; i++) {
03916     a[i] = argv[i];
03917   }
03918 
03919   return SCHEME_MULTIPLE_VALUES;
03920 }
03921 
03922 void scheme_detach_multple_array(Scheme_Object **values)
03923 {
03924   Scheme_Thread *t = scheme_current_thread;
03925 
03926   if (SAME_OBJ(values, t->values_buffer))
03927     t->values_buffer = NULL;
03928 }
03929 
03930 /*========================================================================*/
03931 /*                             continuations                              */
03932 /*========================================================================*/
03933 
03934 static void reset_cjs(Scheme_Continuation_Jump_State *a)
03935 {
03936   a->jumping_to_continuation = NULL;
03937   a->val = NULL;
03938   a->num_vals = 0;
03939   a->is_kill = 0;
03940   a->is_escape = 0;
03941 }
03942 
03943 void scheme_clear_escape(void)
03944 {
03945   Scheme_Thread *p = scheme_current_thread;
03946 
03947   reset_cjs(&p->cjs);
03948   p->suspend_break = 0;
03949 }
03950 
03951 static void copy_cjs(Scheme_Continuation_Jump_State *a, Scheme_Continuation_Jump_State *b)
03952 {
03953   a->jumping_to_continuation = b->jumping_to_continuation;
03954   a->val = b->val;
03955   a->num_vals = b->num_vals;
03956   a->is_kill = b->is_kill;
03957   a->is_escape = b->is_escape;
03958 }
03959 
03960 Scheme_Object *
03961 scheme_call_ec (int argc, Scheme_Object *argv[])
03962 {
03963   mz_jmp_buf newbuf;
03964   Scheme_Escaping_Cont * volatile cont;
03965   Scheme_Thread *p1 = scheme_current_thread;
03966   Scheme_Object * volatile v;
03967   Scheme_Object *a[1];
03968   Scheme_Cont_Frame_Data cframe;
03969   Scheme_Prompt *barrier_prompt;
03970 
03971   scheme_check_proc_arity("call-with-escape-continuation", 1,
03972                        0, argc, argv);
03973 
03974   cont = MALLOC_ONE_TAGGED(Scheme_Escaping_Cont);
03975   cont->so.type = scheme_escaping_cont_type;
03976   ASSERT_SUSPEND_BREAK_ZERO();
03977 
03978   cont->saveerr = p1->error_buf;
03979   p1->error_buf = &newbuf;
03980 
03981   scheme_save_env_stack_w_thread(cont->envss, p1);
03982 
03983   barrier_prompt = scheme_get_barrier_prompt(NULL, NULL);
03984   cont->barrier_prompt = barrier_prompt;
03985 
03986   scheme_prompt_capture_count++;
03987 
03988   scheme_push_continuation_frame(&cframe);
03989   scheme_set_cont_mark((Scheme_Object *)cont, scheme_true);
03990 
03991   if (scheme_setjmp(newbuf)) {
03992     Scheme_Thread *p2 = scheme_current_thread;
03993     if (p2->cjs.jumping_to_continuation
03994        && SAME_OBJ(p2->cjs.jumping_to_continuation, (Scheme_Object *)cont)) {
03995       int n = p2->cjs.num_vals;
03996       v = p2->cjs.val;
03997       reset_cjs(&p2->cjs);
03998       scheme_restore_env_stack_w_thread(cont->envss, p2);
03999       p2->suspend_break = 0;
04000       if (n != 1)
04001         v = scheme_values(n, (Scheme_Object **)v);
04002     } else {
04003       scheme_longjmp(*cont->saveerr, 1);
04004     }
04005   } else {
04006     a[0] = (Scheme_Object *)cont;
04007     v = _scheme_apply_multi(argv[0], 1, a);
04008   }
04009 
04010   p1 = scheme_current_thread;
04011 
04012   p1->error_buf = cont->saveerr;
04013   scheme_pop_continuation_frame(&cframe);
04014 
04015   return v;
04016 }
04017 
04018 int scheme_escape_continuation_ok(Scheme_Object *ec)
04019 {
04020   Scheme_Escaping_Cont *cont = (Scheme_Escaping_Cont *)ec;
04021 
04022   if (scheme_extract_one_cc_mark(NULL, (Scheme_Object *)cont))
04023     return 1;
04024   else
04025     return 0;
04026 }
04027 
04028 static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv[])
04029 {
04030   Scheme_Thread *p = scheme_current_thread;
04031   long findpos, bottom;
04032   Scheme_Object *a[1], *key;
04033 
04034   scheme_check_proc_arity("call-with-immediate-continuation-mark", 1, 1, argc, argv);
04035 
04036   key = argv[0];
04037   if (argc > 2)
04038     a[0] = argv[2];
04039   else
04040     a[0] = scheme_false;
04041 
04042   if (p->cont_mark_stack_segments) {
04043     findpos = (long)MZ_CONT_MARK_STACK;
04044     bottom = (long)p->cont_mark_stack_bottom;
04045     while (findpos-- > bottom) {
04046       Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
04047       long pos = findpos & SCHEME_MARK_SEGMENT_MASK;
04048       Scheme_Cont_Mark *find = seg + pos;
04049 
04050       if ((long)find->pos < (long)MZ_CONT_MARK_POS) {
04051         break;
04052       } else {
04053         if (find->key == key) {
04054           a[0] = find->val;
04055           break;
04056         }
04057       }
04058     }
04059   }
04060 
04061   return scheme_tail_apply(argv[1], 1, a);
04062 }
04063 
04064 static Scheme_Object *
04065 do_call_with_sema(const char *who, int enable_break, int argc, Scheme_Object *argv[])
04066 {
04067   mz_jmp_buf newbuf, * volatile savebuf;
04068   Scheme_Prompt * volatile prompt;
04069   int i, just_try;
04070   int volatile extra;
04071   Scheme_Object * volatile sema;
04072   Scheme_Object *v, *quick_args[4], **extra_args;
04073   Scheme_Cont_Frame_Data cframe;
04074   int old_pcc = scheme_prompt_capture_count;
04075 
04076   if (!SCHEME_SEMAP(argv[0])) {
04077     scheme_wrong_type(who, "semaphore", 0, argc, argv);
04078     return NULL;
04079   }
04080   if (argc > 2)
04081     extra = argc - 3;
04082   else
04083     extra = 0;
04084   if (!scheme_check_proc_arity(NULL, extra, 1, argc, argv)) {
04085     scheme_wrong_type(who, "procedure (arity matching extra args)", 1, argc, argv);
04086     return NULL;
04087   }
04088   if ((argc > 2) && SCHEME_TRUEP(argv[2])) {
04089     if (!scheme_check_proc_arity(NULL, 0, 2, argc, argv)) {
04090       scheme_wrong_type(who, "procedure (arity 0) or #f", 1, argc, argv);
04091       return NULL;
04092     }
04093     just_try = 1;
04094   } else
04095     just_try = 0;
04096 
04097   sema = argv[0];
04098 
04099   if (just_try && enable_break && scheme_current_thread->external_break) {
04100     /* Check for a break before polling the semaphore */
04101     Scheme_Cont_Frame_Data bcframe;
04102     scheme_push_break_enable(&bcframe, 1, 1);
04103     scheme_check_break_now();
04104     scheme_pop_break_enable(&bcframe, 0);
04105   }
04106 
04107   if (!scheme_wait_sema(sema, just_try ? 1 : (enable_break ? -1 : 0))) {
04108     return _scheme_tail_apply(argv[2], 0, NULL);
04109   }
04110 
04111   savebuf = scheme_current_thread->error_buf;
04112   scheme_current_thread->error_buf = &newbuf;
04113 
04114   if (available_cws_prompt) {
04115     prompt = available_cws_prompt;
04116     available_cws_prompt = NULL;
04117   } else {
04118     prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
04119     prompt->so.type = scheme_prompt_type;
04120   }
04121 
04122   scheme_push_continuation_frame(&cframe);
04123   scheme_set_cont_mark(barrier_prompt_key, (Scheme_Object *)prompt);
04124 
04125   if (scheme_setjmp(newbuf)) {
04126     v = NULL;
04127   } else {
04128     if (extra > 4)
04129       extra_args = MALLOC_N(Scheme_Object *, extra);
04130     else
04131       extra_args = quick_args;
04132     for (i = 3; i < argc; i++) {
04133       extra_args[i - 3] = argv[i];
04134     }
04135 
04136     v = _scheme_apply_multi(argv[1], extra, extra_args);
04137   }
04138 
04139   scheme_pop_continuation_frame(&cframe);
04140 
04141   scheme_post_sema(sema); /* FIXME: what if we reach the max count? */
04142 
04143   if (old_pcc != scheme_prompt_capture_count)
04144     available_cws_prompt = prompt;
04145 
04146   if (!v)
04147     scheme_longjmp(*savebuf, 1);
04148 
04149   scheme_current_thread->error_buf = savebuf;
04150 
04151   return v;
04152 }
04153 
04154 static Scheme_Object *
04155 call_with_sema(int argc, Scheme_Object *argv[])
04156 {
04157   return do_call_with_sema("call-with-semaphore", 0, argc, argv);
04158 }
04159 
04160 static Scheme_Object *
04161 call_with_sema_enable_break(int argc, Scheme_Object *argv[])
04162 {
04163   return do_call_with_sema("call-with-semaphore/enable-break", 1, argc, argv);
04164 }
04165 
04166 static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
04167                                         Scheme_Object **runstack,
04168                                         Scheme_Object **runstack_start,
04169                                         Scheme_Cont *share_from,
04170                                         Scheme_Prompt *effective_prompt)
04171 {
04172   Scheme_Saved_Stack *saved, *isaved, *csaved, *share_saved, *share_csaved, *ss;
04173   Scheme_Object **start;
04174   long size;
04175   int done;
04176 
04177   /* Copy out current runstack: */
04178   saved = MALLOC_ONE_RT(Scheme_Saved_Stack);
04179 #ifdef MZTAG_REQUIRED
04180   saved->type = scheme_rt_saved_stack;
04181 #endif
04182   if (share_from && (share_from->runstack_start == runstack_start)) {
04183     /* Copy just the difference between share_from's runstack and current runstack... */
04184     size = (share_from->ss.runstack_offset - (runstack XFORM_OK_MINUS runstack_start));
04185     /* But add one, because call/cc takes one argument. If there's not one
04186        move value on the stack, then call/cc must have received its argument
04187        from elsewhere. */
04188     if (share_from->ss.runstack_offset < p->runstack_size)
04189       size++;
04190   } else if (effective_prompt && (effective_prompt->runstack_boundary_start == runstack_start)) {
04191     /* Copy only up to the prompt */
04192     size = effective_prompt->runstack_boundary_offset - (runstack XFORM_OK_MINUS runstack_start);
04193   } else {
04194     size = p->runstack_size - (runstack XFORM_OK_MINUS runstack_start);
04195   }
04196 
04197   saved->runstack_size = size;
04198   start = MALLOC_N(Scheme_Object*, size);
04199   saved->runstack_start = start;
04200   memcpy(saved->runstack_start, runstack, size * sizeof(Scheme_Object *));
04201   saved->runstack_offset = (runstack XFORM_OK_MINUS runstack_start);
04202 
04203   if (!effective_prompt || (effective_prompt->runstack_boundary_start != runstack_start)) {
04204 
04205     /* Copy saved runstacks: */
04206     if (share_from) {
04207       /* We can share all saved runstacks */
04208       share_csaved = share_from->runstack_saved;
04209       share_saved = share_from->runstack_copied->prev;
04210     } else {
04211       share_saved = NULL;
04212       share_csaved = NULL;
04213     }
04214     isaved = saved;
04215     for (csaved = p->runstack_saved; csaved; csaved = csaved->prev) {
04216       if (share_csaved && (csaved->runstack_start == share_csaved->runstack_start)) {
04217        /* Share */
04218        isaved->prev = share_saved;
04219        break;
04220       }
04221     
04222       ss = MALLOC_ONE_RT(Scheme_Saved_Stack);
04223 #ifdef MZTAG_REQUIRED
04224       ss->type = scheme_rt_saved_stack;
04225 #endif
04226       isaved->prev = ss;
04227       isaved = ss;
04228 
04229       if (effective_prompt && (effective_prompt->runstack_boundary_start == csaved->runstack_start)) {
04230        size = effective_prompt->runstack_boundary_offset - csaved->runstack_offset;
04231        done = 1;
04232       } else {
04233        size = csaved->runstack_size - csaved->runstack_offset;
04234        done = 0;
04235       }
04236 
04237       isaved->runstack_size = size;
04238       
04239       start = MALLOC_N(Scheme_Object*, size);
04240       isaved->runstack_start = start;
04241       memcpy(isaved->runstack_start, 
04242             csaved->runstack_start XFORM_OK_PLUS csaved->runstack_offset, 
04243             size * sizeof(Scheme_Object *));
04244       isaved->runstack_offset = csaved->runstack_offset;
04245 
04246       if (done) break;
04247     }
04248   }
04249 
04250   return saved;
04251 }
04252 
04253 static Scheme_Cont_Mark *copy_out_mark_stack(Scheme_Thread *p, 
04254                                         MZ_MARK_STACK_TYPE pos,
04255                                         Scheme_Cont *sub_cont,
04256                                         long *_offset,
04257                                         Scheme_Prompt *effective_prompt,
04258                                              int clear_caches)
04259 {
04260   long cmcount, offset = 0, sub_count = 0;
04261   Scheme_Cont_Mark *cont_mark_stack_copied;
04262 
04263   /* Copy cont mark stack: */
04264   cmcount = (long)pos;
04265   offset = 0;
04266 
04267   if (sub_cont) {
04268     /* Rely on copy of marks in a tail of this continuation. */
04269     sub_count = sub_cont->cont_mark_total - sub_cont->cont_mark_nonshare;
04270     if (sub_count < 0)
04271       sub_count = 0;
04272   } else if (effective_prompt) {
04273     /* Copy only marks since the prompt. */
04274     sub_count = effective_prompt->mark_boundary;
04275   }
04276   cmcount -= sub_count;
04277   offset += sub_count; 
04278 
04279   if (_offset) *_offset = offset;
04280 
04281   if (cmcount) {
04282     cont_mark_stack_copied = MALLOC_N(Scheme_Cont_Mark, cmcount);
04283     while (cmcount--) {
04284       int cms = cmcount + offset;
04285       Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[cms >> SCHEME_LOG_MARK_SEGMENT_SIZE];
04286       long pos = cms & SCHEME_MARK_SEGMENT_MASK;
04287       Scheme_Cont_Mark *cm = seg + pos;
04288       
04289       memcpy(cont_mark_stack_copied + cmcount, cm, sizeof(Scheme_Cont_Mark));
04290       if (clear_caches)
04291         cont_mark_stack_copied[cmcount].cache = NULL;
04292     }
04293     
04294     return cont_mark_stack_copied;
04295   } else
04296     return NULL;
04297 }
04298 
04299 static void copy_in_runstack(Scheme_Thread *p, Scheme_Saved_Stack *isaved, int set_runstack)
04300 {
04301   Scheme_Saved_Stack *csaved;
04302   long size;
04303 
04304   size = isaved->runstack_size;
04305   if (set_runstack) {
04306     MZ_RUNSTACK = MZ_RUNSTACK_START + (p->runstack_size - size);
04307   }
04308   memcpy(MZ_RUNSTACK, isaved->runstack_start, size * sizeof(Scheme_Object *));
04309   for (csaved = p->runstack_saved; csaved; csaved = csaved->prev) {
04310     isaved = isaved->prev;
04311     if (!isaved) {
04312       /* The saved stack can be shorter than the current stack if
04313          there's a barrier prompt, or if we're in shortcut mode. */
04314       break;
04315     }
04316     size = isaved->runstack_size;
04317     csaved->runstack_offset = isaved->runstack_offset;
04318     memcpy(csaved->runstack_start XFORM_OK_PLUS csaved->runstack_offset, 
04319           isaved->runstack_start, 
04320           size * sizeof(Scheme_Object *));
04321   }
04322 }
04323 
04324 static void copy_in_mark_stack(Scheme_Thread *p, Scheme_Cont_Mark *cont_mark_stack_copied,
04325                             MZ_MARK_STACK_TYPE cms, MZ_MARK_STACK_TYPE base_cms,
04326                             long copied_offset, Scheme_Object **_sub_conts,
04327                                int clear_caches)
04328      /* Copies in the mark stack up to depth cms, but assumes that the
04329        stack up to depth base_cms is already in place (probably in
04330        place for a dynamic-wind context in an continuation
04331        restoration.) */
04332 {
04333   long cmcount, base_cmcount, cmoffset;
04334   Scheme_Cont_Mark *cm_src;
04335   Scheme_Cont *sub_cont = NULL;
04336 
04337   cmcount = (long)cms;
04338   base_cmcount = (long)base_cms;
04339 
04340   if (cmcount) {
04341     /* First, make sure we have enough segments */
04342     long needed = ((cmcount - 1) >> SCHEME_LOG_MARK_SEGMENT_SIZE) + 1;
04343 
04344     if (needed > p->cont_mark_seg_count) {
04345       Scheme_Cont_Mark **segs, **old_segs = p->cont_mark_stack_segments;
04346       int newcount = needed, oldcount = p->cont_mark_seg_count, npos;
04347 
04348       /* Note: we perform allocations before changing p to avoid GC trouble,
04349         since MzScheme adjusts a thread's cont_mark_stack_segments on GC. */
04350       segs = MALLOC_N(Scheme_Cont_Mark *, needed);
04351 
04352       for (npos = needed; npos--; ) {
04353        if (npos < oldcount)
04354          segs[npos] = old_segs[npos]; /* might be NULL due to GC! */
04355        else
04356          segs[npos] = NULL;
04357 
04358        if (!segs[npos]) {
04359          Scheme_Cont_Mark *cm;
04360          cm = scheme_malloc_allow_interior(sizeof(Scheme_Cont_Mark) * SCHEME_MARK_SEGMENT_SIZE);
04361          segs[npos] = cm;
04362        }
04363       }
04364 
04365       p->cont_mark_seg_count = newcount;
04366       p->cont_mark_stack_segments = segs;
04367     }
04368   }
04369 
04370   if (_sub_conts) {
04371     if (*_sub_conts) {
04372       sub_cont = (Scheme_Cont *)SCHEME_CAR(*_sub_conts);
04373     }
04374   }
04375 
04376   while (base_cmcount < cmcount) {
04377     Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[base_cmcount >> SCHEME_LOG_MARK_SEGMENT_SIZE];
04378     long pos = base_cmcount & SCHEME_MARK_SEGMENT_MASK;
04379     GC_CAN_IGNORE Scheme_Cont_Mark *cm = seg + pos;
04380     
04381     cm_src = cont_mark_stack_copied;
04382     cmoffset = base_cmcount - copied_offset;
04383 
04384     if (sub_cont) {
04385       while (base_cmcount >= (sub_cont->cont_mark_total - sub_cont->cont_mark_nonshare)) {
04386        *_sub_conts = SCHEME_CDR(*_sub_conts);
04387        if (*_sub_conts) {
04388          sub_cont = (Scheme_Cont *)SCHEME_CAR(*_sub_conts);
04389        } else {
04390          sub_cont = NULL;
04391          break;
04392        }
04393       }
04394       if (sub_cont) {
04395        cm_src = sub_cont->cont_mark_stack_copied;
04396        cmoffset = base_cmcount - sub_cont->cont_mark_offset;
04397       }
04398     }
04399 
04400     memcpy(cm, cm_src + cmoffset, sizeof(Scheme_Cont_Mark));
04401     if (clear_caches) {
04402       cm->cache = NULL;
04403     }
04404 
04405     base_cmcount++;
04406   }
04407 }
04408 
04409 static MZ_MARK_STACK_TYPE find_shareable_marks()
04410 {
04411   Scheme_Thread *p = scheme_current_thread;
04412   long cmcount, delta = 0;
04413 
04414   cmcount = (long)MZ_CONT_MARK_STACK;
04415 
04416   while (cmcount--) {
04417     Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[cmcount >> SCHEME_LOG_MARK_SEGMENT_SIZE];
04418     long pos = cmcount & SCHEME_MARK_SEGMENT_MASK;
04419 
04420     if (seg[pos].pos < MZ_CONT_MARK_POS)
04421       break;
04422     if (SAME_OBJ(seg[pos].key, cont_key))
04423       delta = 1;
04424     else
04425       delta = 0;
04426   }
04427 
04428   return cmcount + 1 + delta;
04429 }
04430 
04431 static Scheme_Overflow *clone_overflows(Scheme_Overflow *overflow, void *limit, Scheme_Overflow *tail)
04432 {
04433   Scheme_Overflow *naya, *first = NULL, *prev = NULL;
04434 
04435   for (; overflow && (!limit || (overflow->id != limit)); overflow = overflow->prev) {
04436     naya = MALLOC_ONE_RT(Scheme_Overflow);
04437     memcpy(naya, overflow, sizeof(Scheme_Overflow));
04438     if (prev)
04439       prev->prev = naya;
04440     else
04441       first = naya;
04442     prev = naya;
04443   }
04444 
04445   if (first) {
04446     prev->prev = tail;
04447     return first;
04448   } else
04449     return tail;
04450 }
04451 
04452 static Scheme_Dynamic_Wind *clone_dyn_wind(Scheme_Dynamic_Wind *dw, 
04453                                            Scheme_Object *limit_prompt_tag, int limit_depth,
04454                                            Scheme_Dynamic_Wind *tail, 
04455                                            int keep_tail, int composable)
04456 {
04457   Scheme_Dynamic_Wind *naya, *first = NULL, *prev = NULL;
04458   int cnt = 0;
04459 
04460   for (; dw; dw = dw->prev) {
04461     if (dw->depth == limit_depth)
04462       break;
04463     if (composable && limit_prompt_tag && (dw->prompt_tag == limit_prompt_tag))
04464       break;
04465     scheme_ensure_dw_id(dw);
04466     naya = MALLOC_ONE_RT(Scheme_Dynamic_Wind);
04467     memcpy(naya, dw, sizeof(Scheme_Dynamic_Wind));
04468     if (prev)
04469       prev->prev = naya;
04470     else
04471       first = naya;
04472     prev = naya;
04473     cnt++;
04474     if (limit_prompt_tag && (dw->prompt_tag == limit_prompt_tag)) {
04475       dw = dw->prev; /* in case keep_tail is true */
04476       break;
04477     }
04478   }
04479   if (keep_tail)
04480     tail = dw;
04481   if (first) {
04482     prev->prev = tail;
04483     if (tail)
04484       cnt += tail->depth + 1;
04485     for (dw = first; dw != tail; dw = dw->prev) {
04486       dw->depth = --cnt;
04487     }
04488     return first;
04489   } else
04490     return tail;
04491 }
04492 
04493 static void clear_cm_copy_caches(Scheme_Cont_Mark *cp, int cnt)
04494 {
04495   int i;
04496   for (i = 0; i < cnt; i++) {
04497     cp[i].cache = NULL;
04498   }
04499 }
04500 
04501 static Scheme_Saved_Stack *clone_runstack_saved(Scheme_Saved_Stack *saved, Scheme_Object **boundary_start,
04502                                                 Scheme_Saved_Stack *last)
04503 {
04504   Scheme_Saved_Stack *naya, *first = last, *prev = NULL;
04505 
04506   while (saved) {
04507     naya = MALLOC_ONE_RT(Scheme_Saved_Stack);
04508     memcpy(naya, saved, sizeof(Scheme_Saved_Stack));
04509     if (prev)
04510       prev->prev = naya;
04511     else
04512       first = naya;
04513     prev = naya;
04514     if (saved->runstack_start == boundary_start)
04515       break;
04516     saved = saved->prev;
04517   }
04518   if (prev)
04519     prev->prev = last;
04520   
04521   return first;
04522 }
04523 
04524 static Scheme_Saved_Stack *clone_runstack_copied(Scheme_Saved_Stack *copied, 
04525                                                  Scheme_Object **copied_start,
04526                                                  Scheme_Saved_Stack *saved, 
04527                                                  Scheme_Object **boundary_start,
04528                                                  long boundary_offset)
04529 {
04530   Scheme_Saved_Stack *naya, *first = NULL, *prev = NULL, *s;
04531 
04532   if (copied_start == boundary_start) {
04533     naya = copied;
04534   } else {
04535     for (naya = copied->prev, s = saved; 
04536          s->runstack_start != boundary_start; 
04537          naya = naya->prev, s = s->prev) {
04538     }
04539   }
04540   if ((naya->runstack_offset + naya->runstack_size == boundary_offset)
04541       && !naya->prev) {
04542     /* no need to prune anything */
04543     return copied;
04544   }
04545 
04546   s = NULL;
04547   while (copied) {
04548     naya = MALLOC_ONE_RT(Scheme_Saved_Stack);
04549     memcpy(naya, copied, sizeof(Scheme_Saved_Stack));
04550     naya->prev = NULL;
04551     if (prev)
04552       prev->prev = naya;
04553     else
04554       first = naya;
04555     prev = naya;
04556     if ((!s && copied_start == boundary_start)
04557         || (s && (s->runstack_start == boundary_start))) {
04558       long size;
04559       Scheme_Object **a;
04560       size = boundary_offset - naya->runstack_offset;
04561       if (size < 0)
04562         scheme_signal_error("negative stack-copy size while pruning");
04563       if (size > naya->runstack_size)
04564         scheme_signal_error("bigger stack-copy size while pruning: %d vs. %d", size, naya->runstack_size);
04565       a = MALLOC_N(Scheme_Object *, size);
04566       memcpy(a, naya->runstack_start, size * sizeof(Scheme_Object *));
04567       naya->runstack_start = a;
04568       naya->runstack_size = size;
04569       break;
04570     }
04571 
04572     copied = copied->prev;
04573     if (!s)
04574       s = saved;
04575     else
04576       s = s->prev;
04577   }
04578   
04579   return first;
04580 }
04581 
04582 static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc,
04583                                                  Scheme_Object *limit_tag, int limit_depth,
04584                                                  Scheme_Meta_Continuation *prompt_cont,
04585                                                  Scheme_Prompt *prompt,
04586                                                  Scheme_Meta_Continuation *tail,
04587                                                  int for_composable)
04588 {
04589   Scheme_Meta_Continuation *naya, *first = NULL, *prev = NULL;
04590   int cnt = 0, depth;
04591 
04592   for (; mc; mc = mc->next) {
04593     if (!limit_depth--)
04594       break;
04595     if (!mc->pseudo && SAME_OBJ(mc->prompt_tag, limit_tag))
04596       break;
04597     if (for_composable && mc->pseudo && mc->empty_to_next && mc->next
04598         && SAME_OBJ(mc->next->prompt_tag, limit_tag)) {
04599       /* We don't need to keep the compose-introduced
04600          meta-continuation, because it represents an empty
04601          continuation relative to the prompt. */
04602       break;
04603     }
04604     
04605     naya = MALLOC_ONE_RT(Scheme_Meta_Continuation);
04606     cnt++;
04607     memcpy(naya, mc, sizeof(Scheme_Meta_Continuation));
04608     if (SAME_OBJ(mc, prompt_cont)) {
04609       /* Need only part of this meta-continuation's marks. */
04610       long delta;
04611       void *stack_boundary;
04612 
04613       delta = prompt->mark_boundary - naya->cont_mark_offset;
04614       if (delta) {
04615         naya->cont_mark_total -= delta;
04616         naya->cont_mark_offset += delta;
04617         if (naya->cont_mark_total) {
04618           Scheme_Cont_Mark *cp;
04619           cp = MALLOC_N(Scheme_Cont_Mark, naya->cont_mark_total);
04620           memcpy(cp, mc->cont_mark_stack_copied + delta, naya->cont_mark_total * sizeof(Scheme_Cont_Mark));
04621           if (mc->cm_caches) {
04622             clear_cm_copy_caches(cp, naya->cont_mark_total);
04623           }
04624           naya->cont_mark_stack_copied = cp;
04625           naya->cm_caches = 0;
04626           naya->cm_shared = 0;
04627         } else
04628           naya->cont_mark_stack_copied = NULL;
04629       }
04630       naya->cont_mark_pos_bottom = prompt->boundary_mark_pos;
04631 
04632       if ((prompt->boundary_overflow_id && (prompt->boundary_overflow_id == naya->overflow->id))
04633           || (!prompt->boundary_overflow_id && !naya->overflow->prev)) {
04634         stack_boundary = prompt->stack_boundary;
04635       } else {
04636         stack_boundary = naya->overflow->stack_start;
04637       }
04638 
04639       if (naya->cont) {
04640         Scheme_Cont *cnaya;
04641         Scheme_Saved_Stack *saved;
04642 
04643         cnaya = MALLOC_ONE_TAGGED(Scheme_Cont);
04644         memcpy(cnaya, naya->cont, sizeof(Scheme_Cont));
04645 
04646         naya->cont = cnaya;
04647 
04648         cnaya->cont_mark_total = naya->cont_mark_total;
04649         cnaya->cont_mark_offset = naya->cont_mark_offset;
04650         cnaya->cont_mark_pos_bottom = naya->cont_mark_pos_bottom;
04651         cnaya->cont_mark_stack_copied = naya->cont_mark_stack_copied;
04652 
04653         cnaya->prompt_stack_start = stack_boundary;
04654 
04655         /* Prune unneeded runstack data */
04656         saved = clone_runstack_copied(cnaya->runstack_copied, 
04657                                       cnaya->runstack_start,
04658                                       cnaya->runstack_saved, 
04659                                       prompt->runstack_boundary_start,
04660                                       prompt->runstack_boundary_offset);
04661         cnaya->runstack_copied = saved;
04662 
04663         /* Prune unneeded buffers */
04664         if (prompt->runstack_boundary_start == cnaya->runstack_start)
04665           saved = NULL;
04666         else
04667           saved = clone_runstack_saved(cnaya->runstack_saved, 
04668                                        prompt->runstack_boundary_start,
04669                                        NULL);
04670         cnaya->runstack_saved = saved;
04671 
04672         cnaya->need_meta_prompt = 1;
04673       }
04674       if (naya->overflow && !naya->overflow->eot) {
04675         /* Prune unneeded C-stack data */
04676         Scheme_Overflow *onaya;
04677         Scheme_Overflow_Jmp *jmp;
04678         jmp = scheme_prune_jmpup(naya->overflow->jmp, stack_boundary);
04679         if (jmp) {
04680           onaya = MALLOC_ONE_RT(Scheme_Overflow);
04681           memcpy(onaya, naya->overflow, sizeof(Scheme_Overflow));
04682           naya->overflow = onaya;
04683           onaya->jmp = jmp;
04684           onaya->stack_start = stack_boundary;
04685         }
04686       }
04687     } else {
04688       if (!mc->cm_caches) {
04689         mc->cm_shared = 1;
04690         naya->cm_shared = 1;
04691       } else {
04692         Scheme_Cont_Mark *cp;
04693         cp = MALLOC_N(Scheme_Cont_Mark, naya->cont_mark_total);
04694         memcpy(cp, mc->cont_mark_stack_copied, naya->cont_mark_total * sizeof(Scheme_Cont_Mark));
04695         clear_cm_copy_caches(cp, naya->cont_mark_total);
04696         naya->cont_mark_stack_copied = cp;
04697         naya->cm_caches = 0;
04698         naya->cm_shared = 0;
04699       }
04700     }
04701     if (prev)
04702       prev->next = naya;
04703     else
04704       first = naya;
04705     prev = naya;
04706   }
04707 
04708   if (first) {
04709     prev->next = tail;
04710   } else
04711     first = tail;
04712 
04713   /* Set depth for newly prefixed meta-conts: */
04714   if (tail)
04715     depth = tail->depth + 1;
04716   else
04717     depth = 0;
04718   for (naya = first; cnt--; naya = naya->next) {
04719     naya->depth = depth + cnt;
04720   }
04721 
04722   return first;
04723 }
04724 
04725 static void sync_meta_cont(Scheme_Meta_Continuation *resume_mc)
04726 {
04727   Scheme_Cont *cnaya;
04728 
04729   if (!resume_mc->cont)
04730     return;
04731 
04732   cnaya = MALLOC_ONE_TAGGED(Scheme_Cont);
04733   memcpy(cnaya, resume_mc->cont, sizeof(Scheme_Cont));
04734     
04735   resume_mc->cont = cnaya;
04736     
04737   cnaya->ss.cont_mark_stack += (resume_mc->cont_mark_total - cnaya->cont_mark_total);
04738 
04739   cnaya->cont_mark_total = resume_mc->cont_mark_total;
04740   cnaya->cont_mark_offset = resume_mc->cont_mark_offset;
04741   cnaya->cont_mark_pos_bottom = resume_mc->cont_mark_pos_bottom;
04742   cnaya->cont_mark_stack_copied = resume_mc->cont_mark_stack_copied;
04743 }
04744 
04745 void prune_cont_marks(Scheme_Meta_Continuation *resume_mc, Scheme_Cont *cont, Scheme_Object *extra_marks)
04746 {
04747   Scheme_Object *val;
04748   Scheme_Hash_Table *ht;
04749   long pos, num_overlap, num_coverlap, new_overlap, base, i;
04750   Scheme_Cont_Mark *cp;
04751   
04752   for (pos = resume_mc->cont_mark_total, num_overlap = 0;
04753        pos--;
04754        num_overlap++) {
04755     if (resume_mc->cont_mark_stack_copied[pos].pos != resume_mc->cont_mark_pos)
04756       break;
04757   }
04758 
04759   if (!num_overlap && (!extra_marks || !SCHEME_VEC_SIZE(extra_marks))) {
04760     /* No pruning (nothing to prune) or addition needed. */
04761     return;
04762   }
04763 
04764   for (pos = cont->cont_mark_total, num_coverlap = 0;
04765        pos--;
04766        num_coverlap++) {
04767     if (cont->cont_mark_stack_copied[pos].pos != (cont->cont_mark_pos_bottom + 2))
04768       break;
04769   }
04770 
04771   if (!num_coverlap && (!extra_marks || !SCHEME_VEC_SIZE(extra_marks))) {
04772     /* No pruning (nothing to compare against) or addition needed. */
04773     return;
04774   }
04775 
04776   /* Compute the new set to have in the meta-continuation. */
04777   ht = scheme_make_hash_table(SCHEME_hash_ptr);
04778   
04779   for (pos = resume_mc->cont_mark_total - 1, i = 0; i < num_overlap; i++, pos--) {
04780     val = resume_mc->cont_mark_stack_copied[pos].val;
04781     if (!val)
04782       val = cont_key;
04783     scheme_hash_set(ht, 
04784                     resume_mc->cont_mark_stack_copied[pos].key,
04785                     val);
04786   }
04787   if (extra_marks) {
04788     for (i = 0; i < SCHEME_VEC_SIZE(extra_marks); i += 2) {
04789       val = SCHEME_VEC_ELS(extra_marks)[i+1];
04790       if (!val)
04791         val = cont_key;
04792       scheme_hash_set(ht, SCHEME_VEC_ELS(extra_marks)[i], val);
04793     }
04794   }
04795   for (pos = cont->cont_mark_total - 1, i = 0; i < num_coverlap; i++, pos--) {
04796     scheme_hash_set(ht, 
04797                     cont->cont_mark_stack_copied[pos].key,
04798                     NULL);
04799   }
04800 
04801   new_overlap = ht->count;
04802 
04803   /* Install changes: */
04804   base = resume_mc->cont_mark_total - num_overlap;
04805   cp = MALLOC_N(Scheme_Cont_Mark, base + new_overlap);
04806   memcpy(cp, resume_mc->cont_mark_stack_copied, base * sizeof(Scheme_Cont_Mark));
04807   resume_mc->cont_mark_stack_copied = cp;
04808   resume_mc->cont_mark_total = base + new_overlap;
04809   resume_mc->cm_shared = 0;
04810   resume_mc->cont_mark_stack += (new_overlap - num_overlap);
04811   for (i = 0; i < ht->size; i++) {
04812     if (ht->vals[i]) {
04813       cp[base].key = ht->keys[i];
04814       val = ht->vals[i];
04815       if (SAME_OBJ(val, cont_key))
04816         val = NULL;
04817       cp[base].val = val;
04818       cp[base].pos = resume_mc->cont_mark_pos;
04819       cp[base].cache = NULL;
04820       base++;
04821     }
04822   }
04823 
04824   sync_meta_cont(resume_mc);
04825 }
04826 
04827 static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl,
04828                                              int dwl_len,
04829                                              Scheme_Cont *cont,
04830                                              MZ_MARK_STACK_TYPE copied_cms,
04831                                              int clear_cm_caches,
04832                                              Scheme_Object **_sub_conts)
04833 {
04834   Scheme_Thread *p = scheme_current_thread;
04835   int old_cac = scheme_continuation_application_count;
04836 
04837   for (; dwl; dwl = dwl->next) {
04838     if (dwl->dw->pre) {
04839       p->dw = dwl->dw->prev;
04840       p->next_meta = dwl->meta_depth + dwl->dw->next_meta;
04841       if (dwl->meta_depth > 0) {
04842         scheme_apply_dw_in_meta(dwl->dw, 0, dwl->meta_depth, cont);
04843       } else {
04844         /* Restore the needed part of the mark stack for this
04845            dynamic-wind context. Clear cached info on restore
04846            if there's a prompt. */
04847         DW_PrePost_Proc pre = dwl->dw->pre;
04848         MZ_CONT_MARK_POS = dwl->dw->envss.cont_mark_pos;
04849         MZ_CONT_MARK_STACK = dwl->dw->envss.cont_mark_stack;
04850         copy_in_mark_stack(p, cont->cont_mark_stack_copied, 
04851                            MZ_CONT_MARK_STACK, copied_cms,
04852                            cont->cont_mark_offset, _sub_conts,
04853                            clear_cm_caches);
04854         copied_cms = MZ_CONT_MARK_STACK;
04855 
04856         pre(dwl->dw->data);
04857 
04858         if (scheme_continuation_application_count != old_cac) {
04859           old_cac = scheme_continuation_application_count;
04860           scheme_recheck_prompt_and_barrier(cont);
04861         }
04862       }
04863       p = scheme_current_thread;
04864     }
04865   }
04866   return copied_cms;
04867 }
04868 
04869 static Scheme_Object *
04870 call_cc (int argc, Scheme_Object *argv[])
04871 {
04872   scheme_check_proc_arity("call-with-current-continuation", 1,
04873                        0, argc, argv);
04874   if (argc > 1) {
04875     if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) {
04876       scheme_wrong_type("call-with-current-continuation", "continuation-prompt-tag",
04877                         1, argc, argv);
04878     }
04879   }
04880 
04881   /* Trampoline to internal_call_cc. This trampoline ensures that
04882      the runstack is flushed before we try to grab the continuation. */
04883   return _scheme_tail_apply(internal_call_cc_prim, argc, argv);
04884 }
04885 
04886 static Scheme_Cont *grab_continuation(Scheme_Thread *p, int for_prompt, int composable,
04887                                       Scheme_Object *prompt_tag,
04888                                       Scheme_Cont *sub_cont, Scheme_Prompt *prompt,
04889                                       Scheme_Meta_Continuation *prompt_cont, MZ_MARK_POS_TYPE prompt_pos,
04890                                       Scheme_Prompt *barrier_prompt, Scheme_Prompt *effective_barrier_prompt,
04891                                       Scheme_Meta_Continuation *barrier_cont, MZ_MARK_POS_TYPE barrier_pos)
04892 {
04893   Scheme_Cont *cont;
04894   
04895   cont = MALLOC_ONE_TAGGED(Scheme_Cont);
04896   cont->so.type = scheme_cont_type;
04897 
04898   if (!for_prompt && !composable) {
04899     /* Set cont_key mark before capturing marks: */
04900     scheme_set_cont_mark(cont_key, (Scheme_Object *)cont);
04901   }
04902 
04903   if (composable)
04904     cont->composable = 1;
04905 
04906   scheme_init_jmpup_buf(&cont->buf);
04907   cont->prompt_tag = prompt_tag;
04908   if (for_prompt)
04909     cont->dw = NULL;
04910   else if (prompt) {
04911     Scheme_Dynamic_Wind *dw;
04912     if (p->dw) {
04913       dw = clone_dyn_wind(p->dw, prompt_tag, -1, NULL, 0, composable);
04914       cont->dw = dw;
04915       cont->next_meta = p->next_meta;
04916     } else
04917       cont->dw = NULL;
04918   } else {
04919     cont->dw = p->dw;
04920     cont->next_meta = p->next_meta;
04921   }
04922   if (!for_prompt)
04923     ASSERT_SUSPEND_BREAK_ZERO();
04924   copy_cjs(&cont->cjs, &p->cjs);
04925   cont->save_overflow = p->overflow;
04926   scheme_save_env_stack_w_thread(cont->ss, p);
04927   cont->runstack_size = p->runstack_size;
04928   cont->runstack_start = MZ_RUNSTACK_START;
04929   cont->runstack_saved = p->runstack_saved;
04930   cont->meta_tail_pos = (prompt ? prompt->boundary_mark_pos + 2 : 0);
04931   cont->init_config = p->init_config;
04932   cont->init_break_cell = p->init_break_cell;
04933   if (for_prompt) {
04934     cont->meta_continuation = NULL;
04935   } else if (prompt) {
04936     Scheme_Meta_Continuation *mc;
04937     Scheme_Object *id;
04938     mc = clone_meta_cont(p->meta_continuation, prompt_tag, -1, prompt_cont, prompt, NULL, composable);
04939     cont->meta_continuation = mc;
04940     if (!prompt_cont) {
04941       /* Remember the prompt id, so we can maybe take a shortcut on 
04942          invocation. (The shortcut only works within a meta-continuation.) */
04943       if (!prompt->id) {
04944         id = scheme_make_pair(scheme_false, scheme_false);
04945         prompt->id = id;
04946       }
04947       cont->prompt_id = prompt->id;
04948     }
04949     cont->has_prompt_dw = 1;
04950   } else
04951     cont->meta_continuation = p->meta_continuation;
04952 
04953   if (effective_barrier_prompt) {
04954     cont->barrier_prompt = effective_barrier_prompt;
04955     scheme_prompt_capture_count++;
04956   }
04957 
04958   if (p->meta_prompt && prompt_cont) /* prompt_cont => meta-prompt is shallower than prompt */
04959     prompt = p->meta_prompt;
04960 
04961   {
04962     Scheme_Overflow *overflow;
04963     /* Mark overflows as captured: */
04964     for (overflow = p->overflow; overflow; overflow = overflow->prev) {
04965       overflow->jmp->captured = 1;
04966     }
04967     /* If prompt, then clone overflow records up to the prompt. */
04968     if (prompt) {
04969       overflow = clone_overflows(p->overflow, prompt->boundary_overflow_id, NULL);
04970       cont->save_overflow = overflow;
04971     }
04972   }
04973   scheme_cont_capture_count++;
04974 
04975   if (!effective_barrier_prompt || !effective_barrier_prompt->is_barrier) {
04976     /* This continuation can be used by other threads,
04977        so we need to track ownership of the runstack */
04978     if (!p->runstack_owner) {
04979       Scheme_Thread **owner;
04980       owner = MALLOC_N(Scheme_Thread *, 1);
04981       p->runstack_owner = owner;
04982       *owner = p;
04983     }
04984     if (p->cont_mark_stack && !p->cont_mark_stack_owner) {
04985       Scheme_Thread **owner;
04986       owner = MALLOC_N(Scheme_Thread *, 1);
04987       p->cont_mark_stack_owner = owner;
04988       *owner = p;
04989     }
04990   }
04991 
04992 #ifdef MZ_USE_JIT
04993   {
04994     Scheme_Object *tr;
04995     tr = scheme_native_stack_trace();
04996     cont->native_trace = tr;
04997   }
04998 #endif
04999 
05000   {
05001     Scheme_Saved_Stack *saved;
05002     saved = copy_out_runstack(p, MZ_RUNSTACK, MZ_RUNSTACK_START, sub_cont, 
05003                               (for_prompt ? p->meta_prompt : prompt));
05004     cont->runstack_copied = saved;
05005     if (!for_prompt && prompt) {
05006       /* Prune cont->runstack_saved to drop unneeded saves.
05007          (Note that this is different than runstack_copied; 
05008           runstack_saved keeps the shared runstack buffers, 
05009           not the content.) */
05010       if (SAME_OBJ(prompt->runstack_boundary_start, MZ_RUNSTACK_START))
05011         saved = NULL;
05012       else
05013         saved = clone_runstack_saved(cont->runstack_saved, 
05014                                      prompt->runstack_boundary_start,
05015                                      NULL);
05016       cont->runstack_saved = saved;
05017     }
05018   }
05019 
05020   {
05021     Scheme_Prompt *effective_prompt;
05022     Scheme_Cont_Mark *msaved;
05023     long offset;
05024     effective_prompt = (for_prompt ? p->meta_prompt : prompt);
05025     msaved = copy_out_mark_stack(p, cont->ss.cont_mark_stack, sub_cont, &offset, 
05026                                  effective_prompt,
05027                                  /* If there's a prompt, then clear caches in the mark stack,
05028                                     since any cached values are wrong for the delimited
05029                                     continuation. Otherwise, leave the cache in place
05030                                     for operations directly on the continuation; the caches
05031                                     will be cleared on restore if the continuation is appended
05032                                     to another on invocation. */
05033                                  !!prompt);
05034     cont->cont_mark_stack_copied = msaved;
05035     cont->cont_mark_offset = offset;
05036     if (effective_prompt)
05037       cont->cont_mark_total = cont->ss.cont_mark_stack - effective_prompt->mark_boundary;
05038     else
05039       cont->cont_mark_total = cont->ss.cont_mark_stack;
05040     offset = find_shareable_marks();
05041     cont->cont_mark_nonshare = cont->ss.cont_mark_stack - offset;
05042     /* Need to remember the pos key for the bottom, 
05043        at least for composable continuations, so 
05044        we can splice the captured continuation marks
05045        with a meta continuation's marks. */
05046     cont->cont_mark_pos_bottom = (effective_prompt
05047                                   ? effective_prompt->boundary_mark_pos
05048                                   : 1);
05049   }
05050 
05051   cont->runstack_owner = p->runstack_owner;
05052   cont->cont_mark_stack_owner = p->cont_mark_stack_owner;
05053 
05054   cont->stack_start = p->stack_start;
05055 
05056   cont->savebuf = p->error_buf;
05057 
05058   if (prompt)
05059     cont->prompt_buf = prompt->prompt_buf;
05060 
05061   return cont;
05062 }
05063 
05064 static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_prompt,
05065                                  Scheme_Object *result, 
05066                                  Scheme_Overflow *resume, int empty_to_next_mc,
05067                                  Scheme_Object *prompt_tag, Scheme_Cont *sub_cont,
05068                                  Scheme_Dynamic_Wind *common_dw, int common_next_meta, 
05069                                  Scheme_Prompt *shortcut_prompt,
05070                                  int clear_cm_caches, int do_reset_cjs,
05071                                  Scheme_Cont *cm_cont, Scheme_Object *extra_marks)
05072 {
05073   MZ_MARK_STACK_TYPE copied_cms = 0;
05074   Scheme_Object **mv, *sub_conts = NULL;
05075   int mc;
05076 
05077   if (SAME_OBJ(result, SCHEME_MULTIPLE_VALUES)) {
05078     /* Get values out before GC */
05079     mv = p->ku.multiple.array;
05080     mc = p->ku.multiple.count;
05081     if (SAME_OBJ(mv, p->values_buffer))
05082       p->values_buffer = NULL;
05083   } else {
05084     mv = NULL;
05085     mc = 0;
05086   }
05087 
05088   p->error_buf = cont->savebuf;
05089 
05090   p->init_config = cont->init_config;
05091   p->init_break_cell = cont->init_break_cell;
05092 
05093   if (do_reset_cjs)
05094     copy_cjs(&p->cjs, &cont->cjs);
05095   if (shortcut_prompt) {
05096     Scheme_Overflow *overflow;
05097     overflow = clone_overflows(cont->save_overflow, NULL, p->overflow);
05098     p->overflow = overflow;
05099   } else {
05100     p->overflow = cont->save_overflow;
05101   }
05102   if (for_prompt) {
05103     if (p->meta_prompt)
05104       cont->need_meta_prompt = 1;
05105   } else {
05106     Scheme_Meta_Continuation *mc, *resume_mc;
05107     if (resume) {
05108       resume_mc = MALLOC_ONE_RT(Scheme_Meta_Continuation);
05109 #ifdef MZTAG_REQUIRED
05110       resume_mc->type = scheme_rt_meta_cont;
05111 #endif
05112       resume_mc->overflow = resume;
05113 
05114       resume_mc->prompt_tag = prompt_tag;
05115       resume_mc->pseudo = cont->composable;
05116       resume_mc->empty_to_next = empty_to_next_mc;
05117       resume_mc->meta_tail_pos = cont->meta_tail_pos;
05118 
05119       if (!cm_cont) {
05120         /* resume must correspond to the implicit prompt at
05121            the thread's beginning. */
05122       } else {
05123         resume_mc->cont_mark_stack = cm_cont->ss.cont_mark_stack;
05124         resume_mc->cont_mark_pos = cm_cont->ss.cont_mark_pos;
05125         resume_mc->cont_mark_total = cm_cont->cont_mark_total;
05126         resume_mc->cont_mark_offset = cm_cont->cont_mark_offset;
05127         resume_mc->cont_mark_pos_bottom = cm_cont->cont_mark_pos_bottom;
05128         resume_mc->cont_mark_stack_copied = cm_cont->cont_mark_stack_copied;
05129 
05130         resume_mc->cont = cm_cont;
05131 
05132         resume_mc->cm_caches = 1; /* conservative assumption */
05133 
05134         resume_mc->next = p->meta_continuation;
05135         if (p->meta_continuation)
05136           resume_mc->depth = p->meta_continuation->depth + 1;
05137       }
05138     } else
05139       resume_mc = NULL;
05140     if (resume_mc) {
05141       if (cont->composable) {
05142         /* Prune resume_mc continuation marks that have replacements
05143            in the deepest frame of cont, and add extra_marks */
05144         prune_cont_marks(resume_mc, cont, extra_marks);
05145       }
05146       
05147       mc = clone_meta_cont(cont->meta_continuation, NULL, -1, NULL, NULL, resume_mc, 0);
05148     } else if (shortcut_prompt) {
05149       mc = clone_meta_cont(cont->meta_continuation, NULL, -1, NULL, NULL, p->meta_continuation, 0);
05150     } else
05151       mc = cont->meta_continuation;
05152     p->meta_continuation = mc;
05153   }
05154 
05155   if (shortcut_prompt) {
05156     /* In shortcut mode, we need to preserve saved runstacks
05157        that were pruned when capturing the continuation. */
05158     Scheme_Saved_Stack *rs;
05159     if (shortcut_prompt->runstack_boundary_start == MZ_RUNSTACK_START)
05160       rs = p->runstack_saved;
05161     else {
05162       rs = p->runstack_saved;
05163       while (rs && (rs->runstack_start != shortcut_prompt->runstack_boundary_start)) {
05164         rs = rs->prev;
05165       }
05166       if (rs)
05167         rs = rs->prev;
05168     }
05169     if (rs)
05170       rs = clone_runstack_saved(cont->runstack_saved, NULL, rs);
05171     else
05172       rs = cont->runstack_saved;
05173     p->runstack_saved = rs;
05174   } else
05175     p->runstack_saved = cont->runstack_saved;
05176 
05177   MZ_RUNSTACK_START = cont->runstack_start;
05178   p->runstack_size = cont->runstack_size;
05179 
05180   scheme_restore_env_stack_w_thread(cont->ss, p);
05181 
05182   if (p->runstack_owner
05183       && (*p->runstack_owner == p)) {
05184     *p->runstack_owner = NULL;
05185   }
05186 
05187   if (resume)
05188     p->meta_prompt = NULL; /* in case there's a GC before we can set it */
05189 
05190   p->runstack_owner = cont->runstack_owner;
05191   if (p->runstack_owner && (*p->runstack_owner != p)) {
05192     Scheme_Thread *op;
05193     op = *p->runstack_owner;
05194     if (op) {
05195       Scheme_Saved_Stack *saved;
05196       saved = copy_out_runstack(op, op->runstack, op->runstack_start, NULL, NULL);
05197       op->runstack_swapped = saved;
05198     }
05199     *p->runstack_owner = p;
05200   }
05201 
05202   /* Copy stack back in: p->runstack and p->runstack_saved arrays
05203      are already restored, so the shape is certainly the same as
05204      when cont->runstack_copied was made. If we have a derived
05205      continuation, then we're sharing it's base runstack. */
05206   copy_in_runstack(p, cont->runstack_copied, 0);
05207   {
05208     long done = cont->runstack_copied->runstack_size, size;
05209     sub_cont = cont;
05210     while (sub_cont) {
05211       if (sub_cont->buf.cont
05212           && (sub_cont->runstack_start == sub_cont->buf.cont->runstack_start)) {
05213         /* Copy shared part in: */
05214         sub_cont = sub_cont->buf.cont;
05215         size = sub_cont->runstack_copied->runstack_size;
05216         if (size) {
05217           /* Skip the first item, since that's the call/cc argument,
05218              which we don't want from the outer continuation. */
05219           memcpy(MZ_RUNSTACK XFORM_OK_PLUS done, 
05220                  sub_cont->runstack_copied->runstack_start + 1, 
05221                  (size - 1) * sizeof(Scheme_Object *));
05222           done += (size - 1);
05223         }
05224       } else
05225         break;
05226     }
05227   }
05228     
05229   if (p->cont_mark_stack_owner
05230       && (*p->cont_mark_stack_owner == p))
05231     *p->cont_mark_stack_owner = NULL;
05232 
05233   p->cont_mark_stack_owner = cont->cont_mark_stack_owner;
05234   if (p->cont_mark_stack_owner
05235       && (*p->cont_mark_stack_owner != p)) {
05236     Scheme_Thread *op;
05237     op = *p->cont_mark_stack_owner;
05238     if (op) {
05239       Scheme_Cont_Mark *msaved;
05240       msaved = copy_out_mark_stack(op, op->cont_mark_stack, NULL, NULL, NULL, 0);
05241       op->cont_mark_stack_swapped = msaved;
05242     }
05243     *p->cont_mark_stack_owner = p;
05244     /* In case there's a GC before we copy in marks: */
05245     MZ_CONT_MARK_STACK = 0;
05246   }
05247 
05248   /* If there's a resume, then set up a meta prompt.
05249      We also need a meta-prompt if we're returning from a composed
05250      continuation to a continuation captured under a meta-prompt,
05251      or truncated somewhere along the way. */
05252   if (resume || (for_prompt && cont->need_meta_prompt)) {
05253     Scheme_Prompt *meta_prompt;
05254 
05255     meta_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
05256     meta_prompt->so.type = scheme_prompt_type;
05257     meta_prompt->stack_boundary = cont->prompt_stack_start;
05258     meta_prompt->boundary_overflow_id = NULL;
05259     {
05260       Scheme_Cont *tc;
05261       for (tc = cont; tc->buf.cont; tc = tc->buf.cont) {
05262       }
05263       meta_prompt->mark_boundary = tc->cont_mark_offset;
05264     }
05265     meta_prompt->prompt_buf = cont->prompt_buf;
05266     {
05267       /* Reverse-engineer where the saved runstack ends: */
05268       Scheme_Cont *rs_cont = cont;
05269       Scheme_Saved_Stack *saved, *actual;
05270       int delta = 0;
05271       while (rs_cont->buf.cont) {
05272         delta += rs_cont->runstack_copied->runstack_size;
05273         rs_cont = rs_cont->buf.cont;
05274         if (rs_cont->runstack_copied->runstack_size) {
05275           delta -= 1; /* overlap for not-saved call/cc argument */
05276         }
05277       }
05278       actual = NULL;
05279       for (saved = rs_cont->runstack_copied; saved->prev; saved = saved->prev) {
05280         if (!actual)
05281           actual = p->runstack_saved;
05282         else
05283           actual = actual->prev;
05284       }
05285       if (actual) {
05286         meta_prompt->runstack_boundary_start = actual->runstack_start;
05287         meta_prompt->runstack_boundary_offset = actual->runstack_offset + saved->runstack_size;
05288       } else {
05289         meta_prompt->runstack_boundary_start = MZ_RUNSTACK_START;
05290         meta_prompt->runstack_boundary_offset = (MZ_RUNSTACK - MZ_RUNSTACK_START) + saved->runstack_size + delta;
05291       }
05292     }
05293 
05294     p->meta_prompt = meta_prompt;
05295   }
05296 
05297   /* For copying cont marks back in, we need a list of sub_conts,
05298      deepest to shallowest: */
05299   copied_cms = cont->cont_mark_offset;
05300   for (sub_cont = cont->buf.cont; sub_cont; sub_cont = sub_cont->buf.cont) {
05301     copied_cms = sub_cont->cont_mark_offset;
05302     sub_conts = scheme_make_raw_pair((Scheme_Object *)sub_cont, sub_conts);
05303   }
05304 
05305   if (!shortcut_prompt) {    
05306     Scheme_Cont *tc;
05307     for (tc = cont; tc->buf.cont; tc = tc->buf.cont) {
05308     }
05309     p->cont_mark_stack_bottom = tc->cont_mark_offset;
05310     p->cont_mark_pos_bottom = tc->cont_mark_pos_bottom;
05311   }
05312 
05313   if (for_prompt) {
05314     /* leave p->dw alone */
05315   } else {
05316     /* For dynamic-winds after the "common" intersection
05317        (see eval.c), execute the pre thunks. Make a list
05318        of these first because they have to be done in the
05319        inverse order of `prev' linkage. */
05320     Scheme_Dynamic_Wind *dw, *all_dw;
05321     Scheme_Dynamic_Wind_List *dwl = NULL;
05322     int common_depth, dwl_len = 0;
05323 
05324     /* The thread's dw is set to the common dw. */
05325 
05326     if (resume) {
05327       /* Figure out which dynamic winds use meta-continuations
05328          after an added one. */
05329       if (cont->composable) {
05330         /* All of them! */
05331         p->next_meta++;
05332       } else {
05333         /* D-Ws after the tag are now one further way:
05334            after the newly inserted meta-continuation for this tag. */
05335         p->dw = common_dw;
05336         p->next_meta = common_next_meta;
05337         if (p->dw) { /* can be empty if there's only the implicit prompt */
05338           /* also, there may be no dw with prompt_tag if there's only the implicit prompt */
05339           all_dw = clone_dyn_wind(p->dw, cont->prompt_tag, -1, NULL, 1, 0);
05340           for (dw = all_dw; dw && !SAME_OBJ(dw->prompt_tag, cont->prompt_tag); dw = dw->prev) {
05341             p->dw = p->dw->prev;
05342           }
05343           if (dw)
05344             dw->next_meta += 1;
05345           p->dw = all_dw;
05346         }
05347       }
05348     } else {
05349       p->dw = common_dw;
05350       p->next_meta = common_next_meta;
05351     }
05352 
05353     if (cont->dw) {
05354       int meta_depth;
05355 
05356       common_depth = (p->dw ? p->dw->depth : -1);
05357       all_dw = clone_dyn_wind(cont->dw, NULL, cont->common_dw_depth, p->dw, 0, 0);
05358 
05359       if ((common_depth != -1) && (common_depth != all_dw->depth)) {
05360         /* Move p->next_meta to the last added dw's next_meta. */
05361         for (dw = all_dw; dw->prev->depth != common_depth; dw = dw->prev) {
05362         }
05363         dw->next_meta = p->next_meta;
05364       }
05365       
05366       meta_depth = cont->next_meta;
05367       for (dw = all_dw; dw && (dw->depth != common_depth); dw = dw->prev) {
05368         Scheme_Dynamic_Wind_List *cell;
05369 
05370         cell = MALLOC_ONE_RT(Scheme_Dynamic_Wind_List);
05371 #ifdef MZTAG_REQUIRED
05372         cell->type = scheme_rt_dyn_wind_cell;
05373 #endif
05374         cell->dw = dw;
05375         cell->meta_depth = meta_depth;
05376         cell->next = dwl;
05377         dwl = cell;
05378         dwl_len++;
05379 
05380         meta_depth += dw->next_meta;
05381       }
05382       copied_cms = exec_dyn_wind_pres(dwl, dwl_len, cont, copied_cms, clear_cm_caches, &sub_conts);
05383       p = scheme_current_thread;
05384       p->dw = all_dw;
05385       p->next_meta = cont->next_meta;      
05386     }
05387   }
05388 
05389   if (!for_prompt)
05390     p->suspend_break = 0;
05391 
05392   /* Finish copying cont mark stack back in. */
05393     
05394   MZ_CONT_MARK_POS = cont->ss.cont_mark_pos;
05395   MZ_CONT_MARK_STACK = cont->ss.cont_mark_stack;
05396   copy_in_mark_stack(p, cont->cont_mark_stack_copied, 
05397                      MZ_CONT_MARK_STACK, copied_cms,
05398                      cont->cont_mark_offset, &sub_conts,
05399                      clear_cm_caches);
05400         
05401   if (SAME_OBJ(result, SCHEME_MULTIPLE_VALUES)) {
05402     p->ku.multiple.array = mv;
05403     p->ku.multiple.count = mc;
05404   }
05405 }
05406 
05407 static Scheme_Object *
05408 internal_call_cc (int argc, Scheme_Object *argv[])
05409 {
05410   Scheme_Object *ret, * volatile prompt_tag;
05411   Scheme_Cont * volatile cont;
05412   Scheme_Cont *sub_cont;
05413   Scheme_Meta_Continuation *prompt_cont, *barrier_cont;
05414   MZ_MARK_POS_TYPE prompt_pos, barrier_pos;
05415   Scheme_Thread *p = scheme_current_thread;
05416   Scheme_Prompt *prompt, *barrier_prompt, *effective_barrier_prompt;
05417   GC_CAN_IGNORE void *stack_start;
05418   int composable;
05419 
05420   if (argc > 1)
05421     prompt_tag = argv[1];
05422   else
05423     prompt_tag = scheme_default_prompt_tag;
05424 
05425   composable = (argc > 2);
05426 
05427   prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL, SCHEME_PTR_VAL(prompt_tag), 
05428                                                                  NULL, &prompt_cont, &prompt_pos);
05429   if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, prompt_tag)) {
05430     scheme_arg_mismatch((composable
05431                          ? "call-with-composable-continuation"
05432                          : "call-with-current-continuation"), 
05433                         "continuation includes no prompt with the given tag: ",
05434                         prompt_tag);
05435     return NULL;
05436   }
05437 
05438   barrier_prompt = scheme_get_barrier_prompt(&barrier_cont, &barrier_pos);
05439 
05440   if (composable) {
05441     if (!prompt && !barrier_prompt->is_barrier) {
05442       /* Pseduo-prompt ok. */
05443     } else {
05444       if (!prompt
05445           || scheme_is_cm_deeper(prompt_cont, prompt_pos, barrier_cont, barrier_pos)) {
05446         scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
05447                          "call-with-composable-continuation: cannot capture past continuation barrier");
05448       }
05449     }
05450   }
05451 
05452   effective_barrier_prompt = barrier_prompt;
05453   if (effective_barrier_prompt && prompt) {
05454     if (scheme_is_cm_deeper(barrier_cont, barrier_pos,
05455                             prompt_cont, prompt_pos))
05456       effective_barrier_prompt = NULL;
05457   }
05458 
05459   if (composable)
05460     sub_cont = NULL;
05461   else
05462     sub_cont = (Scheme_Cont *)scheme_extract_one_cc_mark(NULL, cont_key);
05463   if (sub_cont && ((sub_cont->save_overflow != p->overflow)
05464                  || (sub_cont->prompt_tag != prompt_tag)
05465                  || (sub_cont->barrier_prompt != effective_barrier_prompt)
05466                  || (sub_cont->meta_continuation != p->meta_continuation))) {
05467     sub_cont = NULL;
05468   }
05469   if (sub_cont && (sub_cont->ss.cont_mark_pos == MZ_CONT_MARK_POS)) {
05470     Scheme_Object *argv2[1];
05471 #ifdef MZ_USE_JIT
05472     ret = scheme_native_stack_trace();
05473 #endif    
05474     /* Old cont is the same as this one, except that it may
05475        have different marks (not counting cont_key). */
05476     if (!sub_cont->cont_mark_nonshare
05477        && (find_shareable_marks() == MZ_CONT_MARK_STACK)
05478 #ifdef MZ_USE_JIT
05479        && (SAME_OBJ(ret, sub_cont->native_trace)
05480            /* Maybe a single-function loop, where we re-allocated the
05481               last pair in the trace, but it's the same name: */
05482            || (ret 
05483                 && sub_cont->native_trace
05484                 && SCHEME_PAIRP(ret)
05485               && SCHEME_PAIRP(sub_cont->native_trace)
05486               && SAME_OBJ(SCHEME_CAR(ret), SCHEME_CAR(sub_cont->native_trace))
05487               && SAME_OBJ(SCHEME_CDR(ret), SCHEME_CDR(sub_cont->native_trace))))
05488 #endif
05489        ) {
05490       /* Just use this one. */
05491       cont = sub_cont;
05492     } else {
05493       /* Only continuation marks can be different. Mostly just re-use sub_cont. */
05494       long offset;
05495       Scheme_Cont_Mark *msaved;
05496 
05497       cont = MALLOC_ONE_TAGGED(Scheme_Cont);
05498       cont->so.type = scheme_cont_type;
05499       cont->buf.cont = sub_cont;
05500       sub_cont = sub_cont->buf.cont;
05501 
05502       /* This mark stack won't be restored, but it may be
05503         used by `continuation-marks'. */
05504       cont->ss.cont_mark_stack = MZ_CONT_MARK_STACK;
05505       msaved = copy_out_mark_stack(p, cont->ss.cont_mark_stack, sub_cont, &offset, NULL, 0);
05506       cont->cont_mark_stack_copied = msaved;
05507       cont->cont_mark_offset = offset;
05508       cont->cont_mark_total = cont->ss.cont_mark_stack;
05509       offset = find_shareable_marks();
05510       cont->cont_mark_nonshare = cont->ss.cont_mark_stack - offset;
05511 #ifdef MZ_USE_JIT
05512       cont->native_trace = ret;
05513 #endif
05514     }
05515 
05516     argv2[0] = (Scheme_Object *)cont;
05517     return _scheme_tail_apply(argv[0], 1, argv2);
05518   }
05519 
05520   cont = grab_continuation(p, 0, composable, prompt_tag, sub_cont, 
05521                            prompt, prompt_cont, prompt_pos,
05522                            barrier_prompt, effective_barrier_prompt, barrier_cont, barrier_pos);
05523 
05524   scheme_zero_unneeded_rands(p);
05525 
05526   scheme_flatten_config(scheme_current_config());
05527 
05528   {
05529     void *overflow_id;
05530 
05531     overflow_id = (p->overflow
05532                    ? (p->overflow->id
05533                       ? p->overflow->id
05534                       : p->overflow)
05535                    : NULL);
05536 
05537     if (prompt 
05538         && !prompt_cont
05539         && (prompt->boundary_overflow_id == overflow_id)) {
05540       /* Must be inside barrier_prompt, or it wouldn't be allowed.
05541          Must be inside meta_prompt, or prompt_cont would be non-NULL.
05542          Must be inside overflow, or the ids wouldn't match. */
05543       stack_start = prompt->stack_boundary;
05544     } else {
05545       Scheme_Prompt *meta_prompt;
05546 
05547       if (!barrier_prompt->is_barrier)
05548         barrier_prompt = NULL;
05549       else if (barrier_prompt->boundary_overflow_id != overflow_id)
05550         barrier_prompt = NULL;
05551       meta_prompt = p->meta_prompt;
05552       if (meta_prompt)
05553         if (meta_prompt->boundary_overflow_id != overflow_id)
05554           meta_prompt = NULL;
05555 
05556       if (barrier_prompt && meta_prompt) {
05557         barrier_prompt = NULL;
05558       }
05559 
05560       if (barrier_prompt)
05561         stack_start = barrier_prompt->stack_boundary;
05562       else if (meta_prompt)
05563         stack_start = meta_prompt->stack_boundary;
05564       else
05565         stack_start = p->stack_start;
05566     }
05567   }
05568 
05569   /* Use cont->stack_start when calling `cont' directly
05570      from the same meta-continuation. Use cont->prompt_stack_start 
05571      when calling `cont' composably (i.e., when supplying a resume). */
05572   cont->prompt_stack_start = stack_start;
05573 
05574   /* Zero out any local variable that shouldn't be saved by the
05575      continuation.  The meta-continuation for the prompt is an
05576      especially important one to zero out (otherwise we build up
05577      chains). */
05578   prompt_cont = NULL;
05579   barrier_cont = NULL;
05580 
05581   if (scheme_setjmpup_relative(&cont->buf, cont, stack_start, sub_cont)) {
05582     /* We arrive here when the continuation is applied */
05583     Scheme_Object *result, *extra_marks;
05584     Scheme_Overflow *resume;
05585     Scheme_Cont *use_next_cont;
05586     Scheme_Dynamic_Wind *common_dw;
05587     Scheme_Prompt *shortcut_prompt;
05588     int common_next_meta, empty_to_next_mc;
05589 
05590     p = scheme_current_thread; /* maybe different than before */
05591 
05592     result = cont->value;
05593     cont->value = NULL;
05594     
05595     resume = cont->resume_to;
05596     cont->resume_to = NULL;
05597 
05598     use_next_cont = cont->use_next_cont;
05599     cont->use_next_cont = NULL;
05600   
05601     extra_marks = cont->extra_marks;
05602     cont->extra_marks = NULL;
05603 
05604     common_dw = cont->common_dw;
05605     cont->common_dw = NULL;
05606 
05607     common_next_meta = cont->common_next_meta;
05608     cont->common_next_meta = 0;
05609   
05610     shortcut_prompt = cont->shortcut_prompt;
05611     cont->shortcut_prompt = NULL;
05612 
05613     empty_to_next_mc = cont->empty_to_next_mc;
05614     cont->empty_to_next_mc = 0;
05615 
05616     restore_continuation(cont, p, 0, result, resume, empty_to_next_mc, 
05617                          prompt_tag, sub_cont, 
05618                          common_dw, common_next_meta, shortcut_prompt,
05619                          !!resume, 1, 
05620                          use_next_cont, extra_marks);
05621 
05622     /* We may have just re-activated breaking: */
05623     scheme_check_break_now();
05624     
05625     return result;
05626   } else {
05627     Scheme_Object *argv2[1];
05628 
05629     argv2[0] = (Scheme_Object *)cont;
05630     ret = _scheme_tail_apply(argv[0], 1, argv2);
05631     return ret;
05632   }
05633 }
05634 
05635 static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[])
05636 {
05637   return ((SCHEME_CONTP(argv[0]) || SCHEME_ECONTP(argv[0]))
05638           ? scheme_true
05639           : scheme_false);
05640 }
05641 
05642 void scheme_takeover_stacks(Scheme_Thread *p)
05643      /* When a contination captured in on e thread is invoked in another,
05644        the two threads can start using the same runstack, and possibly
05645        also the same cont-mark stack. This function swaps out the
05646        current owner in favor of p */
05647        
05648 {
05649   if (p->runstack_owner && ((*p->runstack_owner) != p)) {
05650     Scheme_Thread *op;
05651     Scheme_Saved_Stack *swapped;
05652     op = *p->runstack_owner;
05653     if (op) {
05654       swapped = copy_out_runstack(op, op->runstack, op->runstack_start, NULL, NULL);
05655       op->runstack_swapped = swapped;
05656     }
05657     *(p->runstack_owner) = p;
05658     copy_in_runstack(p, p->runstack_swapped, 1);
05659     p->runstack_swapped = NULL;
05660   }
05661 
05662   if (p->cont_mark_stack_owner && ((*p->cont_mark_stack_owner) != p)) {
05663     Scheme_Thread *op;
05664     Scheme_Cont_Mark *swapped;
05665     op = *p->cont_mark_stack_owner;
05666     if (op) {
05667       swapped = copy_out_mark_stack(op, op->cont_mark_stack, NULL, NULL, NULL, 0);
05668       op->cont_mark_stack_swapped = swapped;
05669     }
05670     *(p->cont_mark_stack_owner) = p;
05671     copy_in_mark_stack(p, p->cont_mark_stack_swapped, MZ_CONT_MARK_STACK, 0, 0, NULL, 0);
05672     p->cont_mark_stack_swapped = NULL;
05673   }
05674 }
05675 
05676 static Scheme_Object *
05677 call_with_continuation_barrier (int argc, Scheme_Object *argv[])
05678 {
05679   scheme_check_proc_arity("call-with-continuation-barrier", 0, 0, argc, argv);
05680 
05681   return scheme_apply_multi(argv[0], 0, NULL);
05682 }
05683 
05684 Scheme_Prompt *scheme_get_barrier_prompt(Scheme_Meta_Continuation **_meta_cont,
05685                                          MZ_MARK_POS_TYPE *_pos)
05686 {
05687   return (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL, 
05688                                                                barrier_prompt_key,
05689                                                                NULL,
05690                                                                _meta_cont,
05691                                                                _pos);
05692 }
05693 
05694 
05695 static Scheme_Object *make_prompt_tag (int argc, Scheme_Object *argv[])
05696 {
05697   Scheme_Object *o, *key;
05698 
05699   if (argc && !SCHEME_SYMBOLP(argv[0]))
05700     scheme_wrong_type("make-continuation-prompt-tag", "symbol", 0, argc, argv);
05701 
05702   key = scheme_make_pair(scheme_false, scheme_false);
05703 
05704   o = scheme_alloc_object();
05705   o->type = scheme_prompt_tag_type;
05706   SCHEME_CAR(o) = key;
05707   SCHEME_CDR(o) = (argc ? argv[0] : NULL);
05708 
05709   return o;
05710 }
05711 
05712 static Scheme_Object *get_default_prompt_tag (int argc, Scheme_Object *argv[])
05713 {
05714   return scheme_default_prompt_tag;
05715 }
05716 
05717 static Scheme_Object *prompt_tag_p (int argc, Scheme_Object *argv[])
05718 {
05719   return (SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[0]))
05720           ? scheme_true
05721           : scheme_false);
05722 }
05723 
05724 Scheme_Overflow *scheme_get_thread_end_overflow(void)
05725 {
05726   Scheme_Overflow *overflow;
05727   overflow = MALLOC_ONE_RT(Scheme_Overflow);
05728 #ifdef MZTAG_REQUIRED
05729   overflow->type = scheme_rt_overflow;
05730 #endif
05731   overflow->eot = 1;
05732   return overflow;
05733 }
05734 
05735 
05736 void scheme_drop_prompt_meta_continuations(Scheme_Object *prompt_tag)
05737 {
05738   Scheme_Meta_Continuation *mc;
05739 
05740   mc = scheme_current_thread->meta_continuation;
05741   while (!SAME_OBJ(mc->prompt_tag, prompt_tag)) {
05742     if (mc->overflow) {
05743       scheme_signal_error("meta-continuation to drop is not just a placeholder?!");
05744     }
05745     mc = mc->next;
05746   }
05747 
05748   scheme_current_thread->meta_continuation = mc;
05749 }
05750 
05751 MZ_DO_NOT_INLINE(Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *_prompt_tag, 
05752                                                                Scheme_Object *proc, int argc, Scheme_Object **argv));
05753 
05754 Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *_prompt_tag, 
05755                                               Scheme_Object *proc, int argc, Scheme_Object **argv)
05756 {
05757   /* Put space on the stack to record a longjmp target,
05758      in case a following continuation is restored for a
05759      different prompt.
05760      By putting this information on the stack, it will
05761      get captured if there's a further capture. */
05762   Scheme_Thread *p;
05763   Scheme_Object * volatile prompt_tag = _prompt_tag;
05764   mz_jmp_buf newbuf, * volatile savebuf;
05765   Scheme_Object *val;
05766   int cc_count = scheme_cont_capture_count;
05767   
05768   prompt->prompt_buf = &newbuf;
05769   prompt = NULL; /* to avoid prompt chains */
05770 
05771   p = scheme_current_thread;
05772 
05773   savebuf = p->error_buf;
05774   p->error_buf = &newbuf;
05775 
05776   /* Initial meta-continuation says to fall through. This
05777      one can get replaced when the current continuation
05778      is captured and then restored. */
05779   {
05780     Scheme_Meta_Continuation *resume_mc;
05781     if (available_prompt_mc) {
05782       resume_mc = available_prompt_mc;
05783       available_prompt_mc = NULL;
05784     } else
05785       resume_mc = MALLOC_ONE_RT(Scheme_Meta_Continuation);
05786 #ifdef MZTAG_REQUIRED
05787     resume_mc->type = scheme_rt_meta_cont;
05788 #endif
05789     resume_mc->prompt_tag = prompt_tag;
05790     if (p->meta_continuation) {
05791       resume_mc->next = p->meta_continuation;
05792       resume_mc->depth = p->meta_continuation->depth + 1;
05793     }
05794     resume_mc->meta_tail_pos = MZ_CONT_MARK_POS + 2;
05795     p->meta_continuation = resume_mc;
05796   }
05797 
05798   if (scheme_setjmp(newbuf)) {
05799     /*
05800       We can get here in three ways:
05801         1. abort-current-continuation with this prompt's tag:
05802            In this case, p->cjs.jumping_to_continuation is the
05803            prompt, p->cjs.val is a value to deliver to the
05804            prompt handler, and p->cjs.is_escape is unset.
05805            [This is a jump in the normal error/abort chain.]
05806         2. applying a continuation that is delimited by the prompt tag
05807            (in which case the jump originates from scheme_do_eval):
05808            In this case, p->cjs.jumping_to_continuation is the
05809            prompt, p->cjs.val is a continuation, and
05810            p->cjs.is_escape is set.
05811            [This is a jump in the special continuation-application
05812             direct mode.]
05813         3. other exception-level escape:
05814            In this case, p->cjs.jumping_to_continuation is the
05815            target (maybe an escape continuation), p->cjs.val is
05816            information to propagate to the target, and p->cjs.is_escape 
05817            is unset.
05818            [This is a jump in the normal error/abort chain.]
05819     */
05820     val = NULL;
05821   } else {
05822     val = _scheme_apply_multi(proc, argc, argv);
05823   }
05824 
05825   p = scheme_current_thread;
05826   p->error_buf = savebuf;
05827 
05828   {
05829     Scheme_Meta_Continuation *resume_mc;
05830     Scheme_Overflow *resume;
05831     
05832     resume = p->meta_continuation->overflow;
05833     resume_mc = p->meta_continuation;
05834     p->meta_continuation = p->meta_continuation->next;
05835 
05836     /* The following test was once useful for finding bugs. However,
05837        dropping meta-continuations that represent empty continuations
05838        (see for_composable in clone_meta_cont) interferes with the test. */
05839     /*
05840       if (!SAME_OBJ(resume_mc->prompt_tag, prompt_tag)) {
05841         scheme_signal_error("meta-continuation prompt tag does not match current prompt tag");
05842       }
05843     */
05844 
05845     if (cc_count == scheme_cont_capture_count) {
05846       memset(resume_mc, 0, sizeof(Scheme_Meta_Continuation));
05847 #ifdef MZTAG_REQUIRED
05848       resume_mc->type = scheme_rt_meta_cont;
05849 #endif
05850       available_prompt_mc = resume_mc;
05851     }
05852 
05853     if (!resume) {
05854       /* We return NULL if there's an escape of some sort (see above), 
05855          otherwise we return the result value. */
05856       return val;
05857     } else if (resume->eot) {
05858       /* There's nothing left in the continuation, 
05859          so just end the thread. We havent restored
05860          the thread state from the prompt, so flush
05861          anything that might otherwise have a clean-up action: */
05862       MZ_RUNSTACK = NULL;
05863       MZ_RUNSTACK_START = NULL;
05864       MZ_CONT_MARK_STACK = 0;
05865       p->runstack_start = NULL;
05866       p->runstack = NULL;
05867       p->runstack_size = 0;
05868       p->runstack_saved = NULL;
05869       p->cont_mark_stack_segments = NULL;
05870       scheme_end_current_thread();
05871       return NULL;
05872     } else {
05873       /* Continue by jumping to a meta-continuation. If
05874          val, then p->cjs.jumping_to_continuation is unset,
05875          so it's ok to communicate val via p->cjs.val. The
05876          target for this jump is in compose_continuation(). */
05877       p->next_meta -= 1;
05878       if (val) {
05879         if (val == SCHEME_MULTIPLE_VALUES) {
05880           if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
05881             p->values_buffer = NULL;
05882         }
05883         p->cjs.val = val;
05884       }
05885       p->stack_start = resume->stack_start;
05886       p->decompose_mc = resume_mc;
05887       scheme_longjmpup(&resume->jmp->cont);
05888       return NULL;
05889     }
05890   }
05891 }
05892 
05893 MZ_DO_NOT_INLINE(Scheme_Object *scheme_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *prompt_tag, 
05894                                                         Scheme_Object *proc, int argc, Scheme_Object **argv));
05895 
05896 Scheme_Object *scheme_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *prompt_tag, 
05897                                        Scheme_Object *proc, int argc, Scheme_Object **argv)
05898 {
05899   /* Grab stack address, then continue on with final step: */
05900   prompt->stack_boundary = PROMPT_STACK(proc);
05901 
05902   proc = scheme_finish_apply_for_prompt(prompt, prompt_tag, proc, argc, argv);
05903 
05904   return proc;
05905 }
05906 
05907 static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain, 
05908                                            Scheme_Object *loop_prompt, int empty_to_next_mc)
05909 /* continuation arguments should be in `cont' already */
05910 {
05911   /* Apply continuation as composable. There may or may not
05912      be a prompt immediately wrapping this application, depending on
05913      whether the continuation was captured as composable. */
05914   Scheme_Overflow *overflow;
05915   Scheme_Overflow_Jmp *jmp;
05916   Scheme_Cont *saved;
05917   Scheme_Prompt *saved_meta_prompt;
05918   Scheme_Thread *p = scheme_current_thread;
05919 
05920   scheme_about_to_move_C_stack();
05921 
05922   reset_cjs(&p->cjs);
05923   
05924   saved_meta_prompt = p->meta_prompt;
05925 
05926   /* Grab a continuation so that we capture the current Scheme stack,
05927      etc.: */
05928   saved = grab_continuation(p, 1, 0, NULL, NULL, NULL, NULL, 0, NULL, NULL, NULL, 0);
05929 
05930   if (p->meta_prompt)
05931     saved->prompt_stack_start = p->meta_prompt->stack_boundary;
05932 
05933   overflow = MALLOC_ONE_RT(Scheme_Overflow);
05934 #ifdef MZTAG_REQUIRED
05935   overflow->type = scheme_rt_overflow;
05936 #endif
05937   overflow->prev = p->overflow;
05938   overflow->stack_start = p->stack_start;
05939 
05940   jmp = MALLOC_ONE_RT(Scheme_Overflow_Jmp);
05941 #ifdef MZTAG_REQUIRED
05942   jmp->type = scheme_rt_overflow_jmp;
05943 #endif
05944   overflow->jmp = jmp;
05945 
05946   saved->resume_to = overflow; /* used by eval to jump to current meta-continuation */
05947   offstack_cont = saved;
05948   saved = NULL;
05949 
05950   scheme_init_jmpup_buf(&overflow->jmp->cont);
05951 
05952   offstack_overflow = overflow;
05953   overflow = NULL; /* so it's not saved in the continuation */
05954 
05955   if (scheme_setjmpup(&offstack_overflow->jmp->cont, 
05956                       offstack_overflow->jmp, 
05957                       p->stack_start)) {
05958     /* Returning. (Jumped here from finish_apply_for_prompt,
05959        scheme_compose_continuation, scheme_eval, or start_child.)
05960        
05961        We can return for several reasons:
05962         1. We got a result value.
05963            In that case, p->cjs.val holds the value, and
05964            p->cjs.jumping_to_continuation is NULL.
05965         2. There's an escape, and p->cjs.jumping_to_continuation
05966            is set. It could be a prompt, in which case we're
05967            escaping to the prompt, or it could be an
05968            error escape. In the former case, we may or may not be 
05969            applying a continuation at the target; see
05970            scheme_finish_apply_for_prompt() for those possibilities.
05971     */
05972     Scheme_Object *v;
05973     Scheme_Meta_Continuation *mc, *dmc;
05974 
05975     p = scheme_current_thread;
05976 
05977     dmc = p->decompose_mc;
05978     p->decompose_mc = NULL;
05979     saved = dmc->cont;
05980     overflow = dmc->overflow;
05981 
05982     if (!p->cjs.jumping_to_continuation) {
05983       /* Got a result: */
05984       v = p->cjs.val;
05985       p->cjs.val = NULL;
05986       if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
05987         if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
05988           p->values_buffer = NULL;
05989       }
05990     } else {
05991       /* Some sort of escape, to be handled by the caller,
05992          or to be handled below if it's an escape to loop_prompt.  */
05993       v = NULL;
05994     }
05995     mc = p->meta_continuation;
05996     p->meta_prompt = saved_meta_prompt; /* Set meta_prompt before restoring runstack,
05997                                            since GC erases meta-prompt-blocked portion
05998                                            on the runstack. */
05999     restore_continuation(saved, p, 1, v, NULL, 0,
06000                          NULL, NULL,
06001                          NULL, 0, NULL,
06002                          1, !p->cjs.jumping_to_continuation, 
06003                          NULL, NULL);
06004 
06005     p->meta_continuation = mc;
06006 
06007     /* There can be two kinds of loops:
06008          1. An escape to the current prompt to invoke another
06009             continuation.
06010          2. A trampoline to turn a composable-continuation
06011             application into a tail call; in this case,
06012             jumping_to_continuation = #t. */
06013     if (!v && ((loop_prompt
06014                 && SAME_OBJ((Scheme_Object *)p->cjs.jumping_to_continuation,
06015                             loop_prompt)
06016                 && p->cjs.is_escape)
06017                || (!loop_prompt
06018                    && p->cjs.jumping_to_continuation
06019                    && SCHEME_VECTORP((Scheme_Object *)p->cjs.jumping_to_continuation)))) {
06020       /* We'll handle this escape directly, to avoid re-computing
06021          saved and overflow. */
06022       cont = (Scheme_Cont *)p->cjs.val;
06023       if (SCHEME_VECTORP((Scheme_Object *)p->cjs.jumping_to_continuation)) {
06024         /* Instead of installing marks in `saved' now, ask `cont' to do it, 
06025            since `cont' may have some of its own replacements. */
06026         cont->extra_marks = (Scheme_Object *)p->cjs.jumping_to_continuation;
06027       }
06028       reset_cjs(&p->cjs);
06029       /* The current meta-continuation may have changed since capture: */
06030       saved->meta_continuation = p->meta_continuation;
06031       /* Fall though to continuation application below. */
06032     } else {
06033       return v;
06034     }
06035   } else {
06036     saved = offstack_cont;
06037     overflow = offstack_overflow;
06038     offstack_cont = NULL;
06039     offstack_overflow = NULL;
06040   }
06041 
06042   scheme_current_thread->suspend_break++;
06043   
06044   /* Here's where we jump to the target: */
06045   cont->use_next_cont = saved;
06046   cont->resume_to = overflow;
06047   cont->empty_to_next_mc = (char)empty_to_next_mc;
06048   scheme_current_thread->stack_start = cont->prompt_stack_start;
06049   scheme_longjmpup(&cont->buf);
06050 
06051   ESCAPED_BEFORE_HERE;
06052 }
06053 
06054 static void continue_prompt_escape()
06055 {
06056   Scheme_Thread *p = scheme_current_thread;
06057   Scheme_Prompt *targetc = (Scheme_Prompt *)p->cjs.jumping_to_continuation;
06058 
06059   scheme_drop_prompt_meta_continuations(targetc->tag);
06060 
06061   if ((!targetc->boundary_overflow_id && !p->overflow)
06062       || (targetc->boundary_overflow_id == p->overflow->id)) {
06063     /* Jump directly to the target. */
06064     scheme_longjmp(*targetc->prompt_buf, 1);
06065   } else {
06066     /* More hassle: need to unwind overflows to get to the prompt. */
06067     Scheme_Overflow *overflow = p->overflow;
06068     while (overflow->prev
06069            && (!overflow->prev->id
06070                || (overflow->prev->id != targetc->boundary_overflow_id))) {
06071       overflow = overflow->prev;
06072     }
06073     p->overflow = overflow;
06074     p->stack_start = overflow->stack_start;
06075     scheme_longjmpup(&overflow->jmp->cont);
06076   }
06077 }
06078 
06079 static void restore_from_prompt(Scheme_Prompt *prompt)
06080 {
06081   Scheme_Thread *p = scheme_current_thread;
06082 
06083   while (MZ_RUNSTACK_START != prompt->runstack_boundary_start) {
06084     MZ_RUNSTACK_START = p->runstack_saved->runstack_start;
06085     p->runstack_saved = p->runstack_saved->prev;
06086   }
06087 
06088   MZ_RUNSTACK = MZ_RUNSTACK_START + prompt->runstack_boundary_offset;
06089   MZ_CONT_MARK_STACK = prompt->mark_boundary;
06090   MZ_CONT_MARK_POS = prompt->boundary_mark_pos;
06091   
06092   p->runstack_size = prompt->runstack_size;
06093 
06094   if (prompt->boundary_overflow_id) {
06095     while (p->overflow->id != prompt->boundary_overflow_id) {
06096       p->overflow = p->overflow->prev;
06097     }
06098   } else
06099     p->overflow = NULL;
06100 }
06101 
06102 static void prompt_unwind_dw(Scheme_Object *prompt_tag)
06103 {
06104   int delta = 0;
06105   Scheme_Thread *p = scheme_current_thread;
06106 
06107   while (p->dw && !SAME_OBJ(p->dw->prompt_tag, prompt_tag)) {
06108     delta += p->dw->next_meta;
06109     p->dw = p->dw->prev;
06110   }
06111   if (!p->dw) {
06112     scheme_signal_error("Lost prompt dynamic-wind record!\n");
06113   } else {
06114     delta += p->dw->next_meta;
06115     p->dw = p->dw->prev;
06116     p->next_meta += delta;
06117   }
06118 }
06119 
06120 static void prompt_unwind_one_dw(Scheme_Object *prompt_tag)
06121 {
06122   Scheme_Thread *p = scheme_current_thread;
06123   if (!p->dw || !SAME_OBJ(p->dw->prompt_tag, prompt_tag)) {
06124     scheme_signal_error("Dynamic-wind record doesn't match prompt!\n");
06125   } else
06126     prompt_unwind_dw(prompt_tag);
06127 }
06128 
06129 static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
06130 {
06131   Scheme_Object *v;
06132   Scheme_Thread *p = scheme_current_thread;
06133   Scheme_Object *proc = in_argv[0], *prompt_tag;
06134   Scheme_Prompt *prompt;
06135   int argc, handler_argument_error = 0;
06136 # define QUICK_PROMPT_ARGS 3
06137   Scheme_Object **argv, *a[QUICK_PROMPT_ARGS], *handler;
06138   Scheme_Cont_Frame_Data cframe;
06139   Scheme_Dynamic_Wind *prompt_dw;
06140   int cc_count = scheme_cont_capture_count;
06141 
06142   argc = in_argc - 3;
06143   if (argc <= 0) {
06144     argc = 0;
06145     argv = NULL;
06146   } else {
06147     int i;
06148     if (argc <= QUICK_PROMPT_ARGS)
06149       argv = a;
06150     else
06151       argv = MALLOC_N(Scheme_Object *, argc);
06152     for (i = 0; i < argc; i++) {
06153       argv[i] = in_argv[i+3];
06154     }
06155   }
06156 
06157   scheme_check_proc_arity("call-with-continuation-prompt", argc, 0, in_argc, in_argv);
06158   if (in_argc > 1) {
06159     if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(in_argv[1]))) {
06160       scheme_wrong_type("call-with-continuation-prompt", "continuation-prompt-tag",
06161                         1, in_argc, in_argv);
06162     }
06163     prompt_tag = in_argv[1];
06164   } else
06165     prompt_tag = scheme_default_prompt_tag;
06166 
06167   if (in_argc > 2) {
06168     if (SCHEME_TRUEP(in_argv[2]) && !SCHEME_PROCP(in_argv[2]))
06169       scheme_wrong_type("call-with-continuation-prompt", "procedure or #f", 2, in_argc, in_argv);
06170     handler = in_argv[2];
06171   } else
06172     handler = scheme_false;
06173 
06174   do {
06175     /* loop implements the default prompt handler */
06176 
06177     if (available_regular_prompt) {
06178       /* `call-with-continuation-prompt' is used by `with-handlers' which might
06179          easily occur in a loop. Try to avoid allocation, even if only for unnested
06180          prompts. */
06181       prompt = available_regular_prompt;
06182       available_regular_prompt = NULL;
06183     } else
06184       prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
06185 
06186     prompt->so.type = scheme_prompt_type;
06187 
06188     prompt->tag = prompt_tag;
06189 
06190     scheme_push_continuation_frame(&cframe);
06191     scheme_set_cont_mark(SCHEME_PTR_VAL(prompt_tag), (Scheme_Object *)prompt);
06192 
06193     /* Note: prompt save marks after the one corresponding to itself,
06194        so that restoring a continuation captured under the prompt
06195        doesn't re-install this prompt. (Instead, the prompt that applies
06196        is the one in the invocation context). */
06197 
06198     ASSERT_SUSPEND_BREAK_ZERO();
06199 
06200     initialize_prompt(p, prompt, NULL);
06201 
06202     if (p->overflow) {
06203       ensure_overflow_id(p->overflow);
06204       prompt->boundary_overflow_id = p->overflow->id;
06205     }
06206 
06207     prompt->runstack_size = p->runstack_size;
06208 
06209     if (available_prompt_dw) {
06210       prompt_dw = available_prompt_dw;
06211       available_prompt_dw = NULL;
06212     } else
06213       prompt_dw = MALLOC_ONE_RT(Scheme_Dynamic_Wind);
06214 #ifdef MZTAG_REQUIRED
06215     prompt_dw->type = scheme_rt_dyn_wind;
06216 #endif
06217     prompt_dw->prompt_tag = prompt_tag;
06218     if (p->dw) {
06219       prompt_dw->next_meta = p->next_meta;
06220       prompt_dw->prev = p->dw;
06221       prompt_dw->depth = p->dw->depth + 1;
06222     }
06223 
06224     p->next_meta = 0;
06225     p->dw = prompt_dw;
06226 
06227     v = scheme_apply_for_prompt(prompt, prompt_tag, proc, argc, argv);
06228 
06229     /* >> An escape can jump directly here, instead of going through the
06230        usual escape chain of setjmps. That means we need to reset everything,
06231        such as the runstack pointer. The information we need is in the
06232        prompt record. */
06233 
06234     p = scheme_current_thread;
06235 
06236     restore_from_prompt(prompt);
06237 
06238     p->suspend_break = 0;
06239 
06240     if (!v) {
06241       /* There was an escape. See scheme_finish_apply_for_prompt for the possibilities. */
06242       if (SAME_OBJ((Scheme_Object *)p->cjs.jumping_to_continuation,
06243                    (Scheme_Object *)prompt)) {
06244         /* Jumping to this prompt, maybe to apply a different
06245            continuation... */
06246         if (p->cjs.is_escape) {
06247           /* Yes, a different continuation. That is, apply a non-functional continuation 
06248              that is based on a (potentially) different prompt. The d-w record
06249              is already removed as necessary at the cont call site in "eval.c". 
06250              Loop, in case we have a kind of tail-call to another such contionuation: */
06251           Scheme_Cont *target;
06252 
06253           target = (Scheme_Cont *)p->cjs.val;
06254           reset_cjs(&p->cjs);
06255 
06256           v = compose_continuation(target, 1, (Scheme_Object *)prompt, 0);
06257         
06258           if (v) {
06259             /* Got a result: */
06260             prompt_unwind_one_dw(prompt_tag);
06261             handler = NULL;
06262           } else {
06263             /* Escaping, maybe to here... */
06264             p = scheme_current_thread;
06265             if (SAME_OBJ((Scheme_Object *)p->cjs.jumping_to_continuation,
06266                          (Scheme_Object *)prompt)) {
06267               /* Jump to here. If p->cjs.is_escape, then 
06268                  we want to apply a continuation --- again. */
06269               if (p->cjs.is_escape) {
06270                 /* this should have been caught in compose_continuation */
06271                 scheme_signal_error("escape-to-prompt escaped!");
06272                 return NULL;
06273               } else {
06274                 /* It's an abort to here, so fall though and
06275                    pick up the values. */
06276                 prompt_unwind_one_dw(prompt_tag);
06277                 v = NULL;
06278               }
06279             } else if (p->cjs.is_escape) {
06280               /* We're trying to get to a prompt in this meta-continuation.
06281                  Jump again. */
06282               continue_prompt_escape();
06283               return NULL;
06284             } else {
06285               /* Exception-level or call/ec escape. Continue jumping: */
06286               restore_from_prompt(prompt);
06287               prompt_unwind_one_dw(prompt_tag);
06288               scheme_longjmp(*p->error_buf, 1);
06289               return NULL;
06290             }
06291           }
06292         } else {
06293           /* It was an abort to here; fall through, which picks up
06294              p->cjs.val to deliver to the handler. First discard the
06295              dw record that we introduced. */
06296           prompt_unwind_one_dw(prompt_tag);
06297           v = NULL;
06298         }
06299 
06300         /* At this point, v can be non-NULL if a continuation
06301            delivered a value. */
06302 
06303         if (!v) {
06304           argc = p->cjs.num_vals;
06305 
06306           if (argc == 1) {
06307             a[0] = p->cjs.val;
06308             argv = a;
06309           } else
06310             argv = (Scheme_Object **)p->cjs.val;
06311 
06312           reset_cjs(&p->cjs);
06313 
06314           if (SAME_OBJ(handler, scheme_values_func)) {
06315             v = scheme_values(argc, argv);
06316             handler = NULL;
06317           } else if (SCHEME_FALSEP(handler)) {
06318             if (argc == 1) {
06319               if (!scheme_check_proc_arity(NULL, 0, 0, argc, argv)) {
06320                 /* delay error until we clean up: */
06321                 handler_argument_error = 1;
06322                 handler = NULL;
06323               } else {
06324                 proc = a[0];
06325                 argc = 0;
06326                 argv = NULL;
06327               }
06328             } else {
06329               /* wrong number of arguments returned to default handler */
06330               handler_argument_error = 1;
06331               handler = NULL;
06332             }
06333           }
06334         } else {
06335           argc = 0;
06336           argv = NULL;
06337         }
06338       } else {
06339         /* Other error-like escape: */
06340         if ((p->dw != prompt_dw)
06341             && (!p->dw || !prompt_dw->id || (p->dw->id != prompt_dw->id))) {
06342           /* A full continuation jump was interrupted by an
06343              escape continuation jump (in a dw pre or post thunk). */
06344         } else
06345           prompt_unwind_one_dw(prompt_tag);
06346         scheme_longjmp(*p->error_buf, 1);
06347         return NULL;
06348       }
06349     } else {
06350       prompt_unwind_one_dw(prompt_tag);
06351       handler = NULL;
06352       argc = 0;
06353       argv = NULL;
06354     }
06355 
06356     scheme_pop_continuation_frame(&cframe);
06357 
06358     if (cc_count == scheme_cont_capture_count) {
06359       if (!available_regular_prompt) {
06360         memset(prompt, 0, sizeof(Scheme_Prompt));
06361         prompt->so.type = scheme_prompt_type;
06362         available_regular_prompt = prompt;
06363       }
06364       if (!available_prompt_dw) {
06365         memset(prompt_dw, 0, sizeof(Scheme_Dynamic_Wind));
06366 #ifdef MZTAG_REQUIRED
06367         prompt_dw->type = scheme_rt_dyn_wind;
06368 #endif
06369         available_prompt_dw = prompt_dw;
06370       }
06371     }
06372   } while (handler && SCHEME_FALSEP(handler));
06373 
06374   if (handler_argument_error) {
06375     if (argc == 1) {
06376       scheme_check_proc_arity("default-continuation-prompt-handler", 0, 0, argc, argv);
06377     } else {
06378       scheme_wrong_return_arity("call-with-continuation-prompt", 1, argc, argv,
06379                                 "application of default prompt handler");
06380     }
06381   }
06382 
06383   if (handler) {
06384     return _scheme_tail_apply(handler, argc, argv);
06385   } else
06386     return v;
06387 }
06388 
06389 static Scheme_Object *propagate_abort(int argc, Scheme_Object **argv)
06390 {
06391   Scheme_Object **argv2;
06392 
06393   argv2 = MALLOC_N(Scheme_Object *, argc + 1);
06394   memcpy(argv2 XFORM_OK_PLUS 1, argv, sizeof(Scheme_Object *) * argc);
06395   argv2[0] = scheme_default_prompt_tag;
06396 
06397   return _scheme_apply(abort_continuation_proc, argc+1, argv2);
06398 }
06399 
06400 static Scheme_Object *do_call_with_prompt(Scheme_Closed_Prim f, void *data, 
06401                                           int multi, int top_level)
06402 {
06403   Scheme_Object *prim, *a[3];
06404 
06405   prim = scheme_make_closed_prim(f, data);
06406   a[0] = prim;
06407   a[1] = scheme_default_prompt_tag;
06408   a[2] = scheme_make_prim(propagate_abort);
06409 
06410   if (multi) {
06411     if (top_level)
06412       return scheme_apply_multi(call_with_prompt_proc, 3, a);
06413     else
06414       return _scheme_apply_multi(call_with_prompt_proc, 3, a);
06415   } else {
06416     if (top_level)
06417       return scheme_apply(call_with_prompt_proc, 3, a);
06418     else
06419       return _scheme_apply(call_with_prompt_proc, 3, a);
06420   }
06421 }
06422 
06423 Scheme_Object *scheme_call_with_prompt(Scheme_Closed_Prim f, void *data)
06424 {
06425   return do_call_with_prompt(f, data, 0, 1);
06426 }
06427 
06428 Scheme_Object *scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data)
06429 {
06430   return do_call_with_prompt(f, data, 1, 1);
06431 }
06432 
06433 Scheme_Object *_scheme_call_with_prompt(Scheme_Closed_Prim f, void *data)
06434 {
06435   return do_call_with_prompt(f, data, 0, 0);
06436 }
06437 
06438 Scheme_Object *_scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data)
06439 {
06440   return do_call_with_prompt(f, data, 1, 0);
06441 }
06442 
06443 Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Scheme_Object *value)
06444 {
06445   Scheme_Meta_Continuation *mc;
06446   int empty_to_next_mc;
06447 
06448   if (num_rands != 1) {
06449     value = scheme_values(num_rands, (Scheme_Object **)value);
06450     {
06451       Scheme_Thread *p = scheme_current_thread;
06452       if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
06453         p->values_buffer = NULL;
06454     }
06455   }
06456   cont->value = value;
06457   cont->common_dw_depth = -1;
06458 
06459   mc = scheme_current_thread->meta_continuation;
06460   if (mc && mc->pseudo && mc->meta_tail_pos == MZ_CONT_MARK_POS) {
06461     /* The existing meta-continuation is the same as the
06462        current continuation. Trampoline through the meta-continuation
06463        to implement the call as a tail call.
06464        We also need to propagate continuation marks here, if any,
06465        back to the trampoline. They get merged with the trampoline's
06466        meta-continuation when `cont' is applied. */
06467     Scheme_Thread *p = scheme_current_thread;
06468     Scheme_Object *cm_info;
06469     long findpos, bottom, pos;
06470     int count, mcount, i;
06471 
06472     p->meta_continuation = mc->next;
06473 
06474     bottom = (long)p->cont_mark_stack_bottom;
06475     count = 0;
06476     for (findpos = (long)MZ_CONT_MARK_STACK - 1; findpos >= bottom; findpos--) {
06477       GC_CAN_IGNORE Scheme_Cont_Mark *seg;
06478 
06479       seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
06480       pos = findpos & SCHEME_MARK_SEGMENT_MASK;
06481       if (seg[pos].pos != MZ_CONT_MARK_POS)
06482         break;
06483       count++;
06484     }
06485     mcount = 0;
06486     for (findpos = (long)mc->cont_mark_total; findpos--; ) {
06487       if (mc->cont_mark_stack_copied[findpos].pos != mc->cont_mark_pos)
06488         break;
06489       mcount++;
06490     }
06491 
06492     cm_info = scheme_make_vector((count + mcount) * 2, NULL);
06493     for (findpos = (long)MZ_CONT_MARK_STACK - 1, i = 0; i < count; findpos--, i++) {
06494       GC_CAN_IGNORE Scheme_Cont_Mark *seg;
06495 
06496       seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
06497       pos = findpos & SCHEME_MARK_SEGMENT_MASK;
06498       SCHEME_VEC_ELS(cm_info)[2*i] = seg[pos].key;
06499       SCHEME_VEC_ELS(cm_info)[(2*i)+1] = seg[pos].val;
06500     }
06501     for (findpos = (long)mc->cont_mark_total - 1, i = 0; i < mcount; findpos--, i++) {
06502       SCHEME_VEC_ELS(cm_info)[2*(count + i)] = mc->cont_mark_stack_copied[findpos].key;
06503       SCHEME_VEC_ELS(cm_info)[(2*(count + i))+1] = mc->cont_mark_stack_copied[findpos].val;
06504     }
06505 
06506     p->cjs.jumping_to_continuation = cm_info; /* vector => trampoline */
06507     p->cjs.val = (Scheme_Object *)cont;
06508     p->cjs.num_vals = 1;
06509     p->cjs.is_escape = 1;
06510 
06511     p->stack_start = mc->overflow->stack_start;
06512     p->decompose_mc = mc;
06513 
06514     scheme_longjmpup(&mc->overflow->jmp->cont);
06515     return NULL;
06516   } else if (mc && mc->meta_tail_pos == MZ_CONT_MARK_POS) {
06517     empty_to_next_mc = 1;
06518   } else {
06519     empty_to_next_mc = 0;
06520   }
06521 
06522   value = compose_continuation(cont, 0, NULL, empty_to_next_mc);
06523   
06524   scheme_current_thread->next_meta -= 1;
06525 
06526   if (!value) {
06527     /* Continue escape --- maybe a direct jump to a prompt
06528        in this meta-continuation. */
06529     Scheme_Thread *p = scheme_current_thread;
06530     if (p->cjs.is_escape) {
06531       /* We're trying to get to a prompt in this meta-continuation.
06532          Jump again. */
06533       continue_prompt_escape();
06534     } else {
06535       scheme_longjmp(*scheme_current_thread->error_buf, 1);
06536     }
06537   }
06538 
06539   return value;
06540 }
06541 
06542 static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[])
06543 {
06544   Scheme_Object *prompt_tag;
06545   Scheme_Prompt *prompt;
06546   Scheme_Thread *p = scheme_current_thread;
06547 
06548   prompt_tag = argv[0];
06549   if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
06550     scheme_wrong_type("abort-current-continuation", "continuation-prompt-tag",
06551                       0, argc, argv);
06552   }
06553 
06554   prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag));
06555   if (!prompt && SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
06556     prompt = original_default_prompt;
06557 
06558   if (!prompt) {
06559     scheme_arg_mismatch("abort-current-continuation", 
06560                         "continuation includes no prompt with the given tag: ",
06561                         prompt_tag);
06562     return NULL;
06563   }
06564 
06565   if (argc == 2) {
06566     p->cjs.num_vals = 1;
06567     p->cjs.val = argv[1];
06568   } else {
06569     Scheme_Object **vals;
06570     int i;
06571     vals = MALLOC_N(Scheme_Object *, argc - 1);
06572     for (i = argc; i-- > 1; ) {
06573       vals[i-1] = argv[i];
06574     }
06575     p->cjs.num_vals = argc - 1;
06576     p->cjs.val = (Scheme_Object *)vals;
06577   }
06578   p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
06579 
06580   scheme_longjmp(*p->error_buf, 1);
06581 
06582   return NULL;
06583 }
06584 
06585 static Scheme_Object *call_with_control (int argc, Scheme_Object *argv[])
06586 {
06587   Scheme_Object *prompt_tag;
06588   Scheme_Object *a[3];
06589 
06590   scheme_check_proc_arity("call-with-composable-continuation", 1, 0, argc, argv);
06591   if (argc > 1) {
06592     if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) {
06593       scheme_wrong_type("call-with-composable-continuation", "continuation-prompt-tag",
06594                         1, argc, argv);
06595     }
06596     prompt_tag = argv[1];
06597   } else
06598     prompt_tag = scheme_default_prompt_tag;
06599 
06600   a[0] = argv[0];
06601   a[1] = prompt_tag;
06602   a[2] = scheme_true;
06603 
06604   /* Trampoline to internal_call_cc. This trampoline ensures that
06605      the runstack is flushed before we try to grab the continuation. */
06606   return _scheme_tail_apply(internal_call_cc_prim, 3, a);
06607 }
06608 
06609 static Scheme_Object *continuation_marks(Scheme_Thread *p,
06610                                     Scheme_Object *_cont,
06611                                     Scheme_Object *econt,
06612                                          Scheme_Meta_Continuation *mc,
06613                                          Scheme_Object *prompt_tag,
06614                                          char *who,
06615                                     int just_chain)
06616      /* cont => p is not used */
06617 {
06618   Scheme_Cont *cont = (Scheme_Cont *)_cont, *top_cont;
06619   Scheme_Cont_Mark_Chain *first = NULL, *last = NULL;
06620   Scheme_Cont_Mark_Set *set;
06621   Scheme_Object *cache, *nt;
06622   long findpos, bottom;
06623   long cmpos, cdelta = 0;
06624   int found_tag = 0;
06625 
06626   if (cont && SAME_OBJ(cont->prompt_tag, prompt_tag))
06627     found_tag = 1;
06628   if (!prompt_tag)
06629     found_tag = 1;
06630 
06631   do {
06632     if (econt) {
06633       findpos = (long)((Scheme_Escaping_Cont *)econt)->envss.cont_mark_stack;
06634       cmpos = (long)((Scheme_Escaping_Cont *)econt)->envss.cont_mark_pos;
06635       if (mc) {
06636         cdelta = mc->cont_mark_offset;
06637         bottom = 0;
06638       } else
06639         bottom = p->cont_mark_stack_bottom;
06640     } else if (cont) {
06641       findpos = (long)cont->ss.cont_mark_stack;
06642       cmpos = (long)cont->ss.cont_mark_pos;
06643       cdelta = cont->cont_mark_offset;
06644       bottom = 0;
06645     } else if (mc) {
06646       findpos = (long)mc->cont_mark_stack;
06647       cmpos = (long)mc->cont_mark_pos;
06648       cdelta = mc->cont_mark_offset;
06649       bottom = 0;
06650     } else {
06651       findpos = (long)MZ_CONT_MARK_STACK;
06652       cmpos = (long)MZ_CONT_MARK_POS;
06653       if (!p->cont_mark_stack_segments)
06654         findpos = 0;
06655       bottom = p->cont_mark_stack_bottom;
06656     }
06657 
06658     top_cont = cont;
06659 
06660     while (findpos-- > bottom) {
06661       Scheme_Cont_Mark *find;
06662       long pos;
06663 
06664       if (cont) {
06665         while (findpos < cdelta) {
06666           if (!cont->runstack_copied) {
06667             /* Current cont was just a mark-stack variation of
06668                next cont, so skip the next cont. */
06669             cont = cont->buf.cont;
06670           }
06671           cont = cont->buf.cont;
06672           if (cont)
06673             cdelta = cont->cont_mark_offset;
06674           else
06675             break;
06676         }
06677         if (!cont)
06678           break;
06679         find = cont->cont_mark_stack_copied;
06680         pos = findpos - cdelta;
06681       } else if (mc) {
06682         if (findpos < cdelta)
06683           break;
06684         find = mc->cont_mark_stack_copied;
06685         pos = findpos - cdelta;
06686       } else {
06687         GC_CAN_IGNORE Scheme_Cont_Mark *seg;
06688 
06689         seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
06690         pos = findpos & SCHEME_MARK_SEGMENT_MASK;
06691         find = seg;
06692       }
06693 
06694       /* A cache is one of:
06695           NULL (empty)
06696           #f (empty)
06697           hash-table: maps prompt tag to tag-cache
06698           chain : for default_scheme_prompt_tag
06699           (vector chain key val depth) : chain is for default_scheme_prompt_tag,
06700                                          key+val+depth is for !prompt_tag
06701 
06702           A tag-cache is one of:
06703           chain : the chain we're looking for
06704           (vector chain key val depth) : key = NULL implies that val is
06705                                          a table of mappings from keys to (cons val depth)s
06706       */
06707 
06708       if (prompt_tag && (find[pos].key == SCHEME_PTR_VAL(prompt_tag))) {
06709         found_tag = 1;
06710         /* Break out of outer loop, too: */
06711         mc = NULL;
06712         p = NULL;
06713         econt = NULL;
06714         cont = NULL;
06715         break;
06716       }
06717 
06718       cache = find[pos].cache;
06719       if (cache) {
06720         if (SCHEME_FALSEP(cache))
06721           cache = NULL;
06722         if (cache) {
06723           if (SCHEME_HASHTP(cache))
06724             cache = scheme_hash_get((Scheme_Hash_Table *)cache, prompt_tag ? prompt_tag : scheme_false);
06725           else if (prompt_tag != scheme_default_prompt_tag)
06726             cache = NULL;
06727         }
06728         if (cache && SCHEME_VECTORP(cache)) {
06729           cache = SCHEME_VEC_ELS(cache)[0];
06730         }
06731       }
06732 
06733       if (cache) {
06734         if (((Scheme_Cont_Mark_Chain *)cache)->key) {
06735           if (last)
06736             last->next = (Scheme_Cont_Mark_Chain *)cache;
06737           else
06738             first = (Scheme_Cont_Mark_Chain *)cache;
06739           
06740           found_tag = 1; /* cached => tag is there */
06741         } else {
06742           /* bogus: tag wasn't there when we cached this chain */
06743         }
06744 
06745         /* Break out of outer loop, too: */
06746         mc = NULL;
06747         p = NULL;
06748         econt = NULL;
06749         cont = NULL;
06750 
06751         break;
06752       } else {
06753         Scheme_Cont_Mark_Chain *pr;
06754         pr = MALLOC_ONE_RT(Scheme_Cont_Mark_Chain);
06755         pr->so.type = scheme_cont_mark_chain_type;
06756         pr->key = find[pos].key;
06757         pr->val = find[pos].val;
06758         pr->pos = find[pos].pos;
06759         pr->next = NULL;
06760         if (mc) {
06761           if (mc->cm_shared) {
06762             Scheme_Cont_Mark *cp;
06763             cp = MALLOC_N(Scheme_Cont_Mark, mc->cont_mark_total);
06764             memcpy(cp, mc->cont_mark_stack_copied, mc->cont_mark_total * sizeof(Scheme_Cont_Mark));
06765             mc->cont_mark_stack_copied = cp;
06766             find = cp;
06767             mc->cm_shared = 0;
06768           }
06769           mc->cm_caches = 1;
06770         }
06771         cache = find[pos].cache;
06772         if (cache && !SCHEME_FALSEP(cache)) {
06773           if (SCHEME_HASHTP(cache)) {
06774             Scheme_Hash_Table *ht = (Scheme_Hash_Table *)cache;
06775             cache = scheme_hash_get(ht, prompt_tag ? prompt_tag : scheme_false);
06776             if (!cache) {
06777               scheme_hash_set(ht, prompt_tag ? prompt_tag : scheme_false, (Scheme_Object *)pr);
06778             } else {
06779               /* cache must be a vector */
06780               SCHEME_VEC_ELS(cache)[0] = (Scheme_Object *)pr;
06781             }
06782           } else if (!SCHEME_VECTORP(cache)) {
06783             /* cache is a chain and the tag is not the default prompt tag */
06784             Scheme_Hash_Table *ht;
06785             ht = scheme_make_hash_table(SCHEME_hash_ptr);
06786             scheme_hash_set(ht, scheme_default_prompt_tag, cache);
06787             scheme_hash_set(ht, prompt_tag ? prompt_tag : scheme_false, (Scheme_Object *)pr);
06788             find[pos].cache = (Scheme_Object *)ht;
06789           } else {
06790             /* cache must be a vector */
06791             if (prompt_tag == scheme_default_prompt_tag)
06792               SCHEME_VEC_ELS(cache)[0] = (Scheme_Object *)pr;
06793             else {
06794               /* Need to split up the default and NULL tags. Don't
06795                  try to use cache for just the null tag, in case
06796                  it's use by other copies. */
06797               Scheme_Hash_Table *ht;
06798               Scheme_Object *vec;
06799               ht = scheme_make_hash_table(SCHEME_hash_ptr);
06800               vec = scheme_make_vector(4, NULL);
06801               SCHEME_VEC_ELS(vec)[1] = SCHEME_VEC_ELS(cache)[1];
06802               SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(cache)[2];
06803               SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(cache)[3];
06804               scheme_hash_set(ht, scheme_false, vec);
06805               if (!prompt_tag)
06806                 SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)pr;
06807               else
06808                 scheme_hash_set(ht, prompt_tag, (Scheme_Object *)pr);
06809               find[pos].cache = (Scheme_Object *)ht;
06810             }
06811           }
06812         } else if (prompt_tag == scheme_default_prompt_tag) {
06813           find[pos].cache = (Scheme_Object *)pr;
06814         } else {
06815           cache = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr);
06816           scheme_hash_set((Scheme_Hash_Table *)cache, 
06817                           prompt_tag ? prompt_tag : scheme_false, 
06818                           (Scheme_Object *)pr);
06819           find[pos].cache = cache;
06820         }
06821         if (last)
06822           last->next = pr;
06823         else
06824           first = pr;
06825 
06826         last = pr;
06827       }
06828     }
06829 
06830     if (mc) {
06831       mc = mc->next;
06832     } else if (top_cont) {
06833       mc = top_cont->meta_continuation;
06834     } else if (econt) {
06835       mc = p->meta_continuation;
06836     } else if (p) {
06837       mc = p->meta_continuation;
06838     }
06839     cont = NULL;
06840     econt = NULL;
06841     p = NULL;
06842   } while (mc);
06843 
06844   if (!found_tag) {
06845     if (!SAME_OBJ(prompt_tag, scheme_default_prompt_tag)) {
06846       /* The chain is cached. Destroy it, so that future cache references
06847          will indicate that the tag is not present (as opposed to delivering
06848          the bogus chain). */
06849       while (first) {
06850         first->key = NULL;
06851         first = first->next;
06852       }
06853       if (!who)
06854         return NULL;
06855       scheme_arg_mismatch(who,
06856                           "no corresponding prompt in the continuation: ",
06857                           prompt_tag);
06858     }
06859   }
06860 
06861   if (just_chain)
06862     return (Scheme_Object *)first;
06863 
06864 #ifdef MZ_USE_JIT
06865   if (_cont)
06866     nt = ((Scheme_Cont *)_cont)->native_trace;
06867   else if (econt)
06868     nt = ((Scheme_Escaping_Cont *)econt)->native_trace;
06869   else
06870     nt = scheme_native_stack_trace();
06871 #else
06872   nt = NULL;
06873 #endif
06874 
06875   set = MALLOC_ONE_TAGGED(Scheme_Cont_Mark_Set);
06876   set->so.type = scheme_cont_mark_set_type;
06877   set->chain = first;
06878   set->cmpos = cmpos;
06879   set->native_stack_trace = nt;
06880 
06881   return (Scheme_Object *)set;
06882 }
06883 
06884 Scheme_Object *scheme_current_continuation_marks(Scheme_Object *prompt_tag)
06885 {
06886   return continuation_marks(scheme_current_thread, NULL, NULL, NULL, 
06887                             prompt_tag ? prompt_tag : scheme_default_prompt_tag,
06888                             "continuation-marks",
06889                             0);
06890 }
06891 
06892 Scheme_Object *scheme_all_current_continuation_marks()
06893 {
06894   return continuation_marks(scheme_current_thread, NULL, NULL, NULL, 
06895                             NULL,
06896                             "continuation-marks",
06897                             0);
06898 }
06899 
06900 static Scheme_Object *
06901 cc_marks(int argc, Scheme_Object *argv[])
06902 {
06903   if (argc) {
06904     if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[0]))) {
06905       scheme_wrong_type("current-continuation-marks", "continuation-prompt-tag",
06906                         0, argc, argv);
06907     }
06908 
06909     if (!SAME_OBJ(scheme_default_prompt_tag, argv[0]))
06910       if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(argv[0])))
06911         scheme_arg_mismatch("current-continuation-marks",
06912                             "no corresponding prompt in the continuation: ",
06913                             argv[0]);
06914   }
06915 
06916   return scheme_current_continuation_marks(argc ? argv[0] : NULL);
06917 }
06918 
06919 static Scheme_Object *
06920 cont_marks(int argc, Scheme_Object *argv[])
06921 {
06922   Scheme_Object *prompt_tag;
06923 
06924   if (!SCHEME_CONTP(argv[0]) && !SCHEME_ECONTP(argv[0]) && !SCHEME_THREADP(argv[0]))
06925     scheme_wrong_type("continuation-marks", "continuation or thread", 0, argc, argv);
06926 
06927   if (argc > 1) {
06928     if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) {
06929       scheme_wrong_type("continuation-marks", "continuation-prompt-tag",
06930                         1, argc, argv);
06931     }
06932     prompt_tag = argv[1];
06933   } else
06934     prompt_tag = scheme_default_prompt_tag;
06935 
06936   if (SCHEME_ECONTP(argv[0])) {
06937     if (!scheme_escape_continuation_ok(argv[0])) {
06938       scheme_arg_mismatch("continuation-marks",
06939                        "escape continuation not in the current thread's continuation: ",
06940                        argv[0]);
06941       return NULL;
06942     } else {
06943       Scheme_Meta_Continuation *mc;
06944       scheme_extract_one_cc_mark_with_meta(NULL, argv[0], NULL, &mc, NULL);
06945 
06946       return continuation_marks(scheme_current_thread, NULL, argv[0], mc, prompt_tag, 
06947                                 "continuation-marks", 0);
06948     }
06949   } else if (SCHEME_THREADP(argv[0])) {
06950     Scheme_Thread *t = (Scheme_Thread *)argv[0];
06951     Scheme_Object *m;
06952 
06953     while (t->nestee) {
06954       t = t->nestee;
06955     }
06956 
06957     if (SAME_OBJ(t, scheme_current_thread))
06958       return scheme_current_continuation_marks(prompt_tag);
06959 
06960     while (t->return_marks_to) {
06961       scheme_thread_block(0.0);
06962     }
06963 
06964     if (!(t->running & MZTHREAD_RUNNING)) {
06965       /* empty marks */
06966       Scheme_Cont_Mark_Set *set;
06967 
06968       set = MALLOC_ONE_TAGGED(Scheme_Cont_Mark_Set);
06969       set->so.type = scheme_cont_mark_set_type;
06970       set->chain = NULL;
06971       set->cmpos = 1;
06972       set->native_stack_trace = NULL;
06973 
06974       return (Scheme_Object *)set;
06975     } else {
06976       scheme_start_atomic(); /* just in case */
06977 
06978       t->return_marks_to = scheme_current_thread;
06979       t->returned_marks = prompt_tag;
06980       scheme_swap_thread(t);
06981       
06982       m = t->returned_marks;
06983       t->returned_marks = NULL;
06984       
06985       scheme_end_atomic_no_swap();
06986 
06987       return m;
06988     }
06989   } else {
06990     return continuation_marks(NULL, argv[0], NULL, NULL, prompt_tag, 
06991                               "continuation-marks", 0);
06992   }
06993 }
06994 
06995 static Scheme_Object *
06996 cc_marks_p(int argc, Scheme_Object *argv[])
06997 {
06998   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type))
06999     return scheme_false;
07000   else
07001     return scheme_true;
07002 }
07003 
07004 static Scheme_Object *
07005 extract_cc_marks(int argc, Scheme_Object *argv[])
07006 {
07007   Scheme_Cont_Mark_Chain *chain;
07008   Scheme_Object *first = scheme_null, *last = NULL, *key, *prompt_tag;
07009   Scheme_Object *pr;
07010 
07011   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
07012     scheme_wrong_type("continuation-mark-set->list", "continuation-mark-set", 0, argc, argv);
07013     return NULL;
07014   }
07015   if (argc > 2) {
07016     if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[2]))) {
07017       scheme_wrong_type("continuation-mark-set->list", "continuation-prompt-tag",
07018                         2, argc, argv);
07019     }
07020     prompt_tag = argv[2];
07021   } else
07022     prompt_tag = scheme_default_prompt_tag;
07023 
07024   chain = ((Scheme_Cont_Mark_Set *)argv[0])->chain;
07025   key = argv[1];
07026 
07027   if ((key == scheme_parameterization_key)
07028       || (key == scheme_break_enabled_key)
07029       || (key == scheme_exn_handler_key)) {
07030     scheme_signal_error("continuation-mark-set->list: secret key leaked!");
07031     return NULL;
07032   }
07033 
07034   prompt_tag = SCHEME_PTR_VAL(prompt_tag);
07035 
07036   while (chain) {
07037     if (chain->key == key) {
07038       pr = scheme_make_pair(chain->val, scheme_null);
07039       if (last)
07040        SCHEME_CDR(last) = pr;
07041       else
07042        first = pr;
07043       last = pr;
07044     } else if (chain->key == prompt_tag)
07045       break;
07046 
07047     chain = chain->next;
07048   }
07049 
07050   return first;
07051 }
07052 
07053 static Scheme_Object *
07054 extract_cc_markses(int argc, Scheme_Object *argv[])
07055 {
07056   Scheme_Cont_Mark_Chain *chain;
07057   Scheme_Object *first = scheme_null, *last = NULL;
07058   Scheme_Object *pr, **keys, *vals, *none, *prompt_tag;
07059   int len, i;
07060   long last_pos;
07061 
07062   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
07063     scheme_wrong_type("continuation-mark-set->list*", "continuation-mark-set", 0, argc, argv);
07064     return NULL;
07065   }
07066   len = scheme_proper_list_length(argv[1]);
07067   if (len < 0) {
07068     scheme_wrong_type("continuation-mark-set->list*", "list", 1, argc, argv);
07069     return NULL;
07070   }
07071   if (argc > 2)
07072     none = argv[2];
07073   else
07074     none = scheme_false;
07075   if (argc > 3) {
07076     if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) {
07077       scheme_wrong_type("continuation-mark-set->list*", "continuation-prompt-tag",
07078                         3, argc, argv);
07079     }
07080     prompt_tag = argv[3];
07081   } else
07082     prompt_tag = scheme_default_prompt_tag;
07083 
07084   keys = MALLOC_N(Scheme_Object *, len);
07085   for (pr = argv[1], i = 0; SCHEME_PAIRP(pr); pr = SCHEME_CDR(pr), i++) {
07086     keys[i] = SCHEME_CAR(pr);
07087     if ((keys[i] == scheme_parameterization_key)
07088        || (keys[i] == scheme_break_enabled_key)
07089        || (keys[i] == scheme_exn_handler_key)) {
07090       scheme_signal_error("continuation-mark-set->list: secret key leaked!");
07091       return NULL;
07092     }
07093   }
07094 
07095   prompt_tag = SCHEME_PTR_VAL(prompt_tag);
07096 
07097   chain = ((Scheme_Cont_Mark_Set *)argv[0])->chain;
07098   last_pos = ((Scheme_Cont_Mark_Set *)argv[0])->cmpos + 2;
07099 
07100   while (chain) {
07101     for (i = 0; i < len; i++) {
07102       if (SAME_OBJ(chain->key, keys[i])) {
07103        long pos;
07104        pos = (long)chain->pos;
07105        if (pos != last_pos) {
07106          vals = scheme_make_vector(len, none);
07107          last_pos = pos;
07108          pr = scheme_make_pair(vals, scheme_null);
07109          if (last)
07110            SCHEME_CDR(last) = pr;
07111          else
07112            first = pr;
07113          last = pr;
07114        } else
07115          vals = SCHEME_CAR(last);
07116        SCHEME_VEC_ELS(vals)[i] = chain->val;
07117       }
07118     }
07119 
07120     if (SAME_OBJ(chain->key, prompt_tag))
07121       break;
07122     
07123     chain = chain->next;
07124   }
07125 
07126   return first;
07127 }
07128 
07129 Scheme_Object *
07130 scheme_get_stack_trace(Scheme_Object *mark_set)
07131 {
07132   Scheme_Object *l, *n, *m, *name, *loc;
07133   Scheme_Object *a[2];
07134 
07135   l = ((Scheme_Cont_Mark_Set *)mark_set)->native_stack_trace;
07136 
07137   if (!l) {
07138     a[0] = mark_set;
07139     a[1] = scheme_stack_dump_key;
07140     
07141     l = extract_cc_marks(2, a);
07142   } else {
07143     /* Copy l: */
07144     Scheme_Object *first = scheme_null, *last = NULL;
07145     while (SCHEME_PAIRP(l)) {
07146       n = scheme_make_pair(SCHEME_CAR(l), scheme_null);
07147       if (last)
07148        SCHEME_CDR(last) = n;
07149       else
07150        first = n;
07151       last = n;
07152       l = SCHEME_CDR(l);
07153     }
07154     l = first;
07155   }
07156 
07157   /* Filter out NULLs */
07158   while (SCHEME_PAIRP(l) && !SCHEME_CAR(l)) {
07159     l = SCHEME_CDR(l);
07160   }
07161   for (n = l; SCHEME_PAIRP(n); ) { 
07162     m = SCHEME_CDR(n);
07163     if (SCHEME_NULLP(m))
07164       break;
07165     if (SCHEME_CAR(m)) {
07166       n = m;
07167     } else {
07168       SCHEME_CDR(n) = SCHEME_CDR(m);
07169     }
07170   }
07171 
07172   /* Make srclocs */
07173   for (n = l; SCHEME_PAIRP(n); n = SCHEME_CDR(n)) { 
07174     name = SCHEME_CAR(n);
07175     if (SCHEME_VECTORP(name)) {
07176       loc = scheme_make_location(SCHEME_VEC_ELS(name)[1],
07177                              SCHEME_VEC_ELS(name)[2],
07178                              SCHEME_VEC_ELS(name)[3],
07179                              SCHEME_VEC_ELS(name)[4],
07180                              SCHEME_VEC_ELS(name)[5]);
07181       if (SCHEME_TRUEP(SCHEME_VEC_ELS(name)[6]))
07182        name = scheme_make_pair(scheme_false, loc);
07183       else
07184        name = scheme_make_pair(SCHEME_VEC_ELS(name)[0], loc);
07185     } else {
07186       name = scheme_make_pair(name, scheme_false);
07187     }
07188     SCHEME_CAR(n) = name;
07189   }
07190 
07191   return l;
07192 }
07193 
07194 static Scheme_Object *
07195 extract_cc_proc_marks(int argc, Scheme_Object *argv[])
07196 {
07197   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
07198     scheme_wrong_type("continuation-mark-set->context", "continuation-mark-set", 0, argc, argv);
07199     return NULL;
07200   }
07201 
07202   return scheme_get_stack_trace(argv[0]);
07203 }
07204 
07205 Scheme_Object *
07206 scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key, 
07207                                      Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta,
07208                                      MZ_MARK_POS_TYPE *_vpos)
07209 {
07210   if (mark_set) {
07211     Scheme_Cont_Mark_Chain *chain;
07212     chain = ((Scheme_Cont_Mark_Set *)mark_set)->chain;
07213     while (chain) {
07214       if (chain->key == key)
07215        return chain->val;
07216       else 
07217        chain = chain->next;
07218     }
07219   } else {
07220     long findpos, bottom, startpos;
07221     long pos;
07222     Scheme_Object *val = NULL;
07223     MZ_MARK_POS_TYPE vpos = 0;
07224     Scheme_Object *cache;
07225     Scheme_Meta_Continuation *mc = NULL;
07226     Scheme_Cont_Mark *seg;
07227     Scheme_Thread *p = scheme_current_thread;
07228 
07229     do {
07230       if (mc) {
07231         startpos = mc->cont_mark_total;
07232         bottom = 0;
07233       } else {
07234         startpos = (long)MZ_CONT_MARK_STACK;
07235         if (!p->cont_mark_stack_segments)
07236           findpos = 0;
07237         bottom = p->cont_mark_stack_bottom;
07238       }
07239 
07240       findpos = startpos;
07241 
07242       /* Search mark stack, checking caches along the way: */
07243       while (findpos-- > bottom) {
07244         if (mc) {
07245           seg = mc->cont_mark_stack_copied;
07246           pos = findpos;
07247         } else {
07248           seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
07249           pos = findpos & SCHEME_MARK_SEGMENT_MASK;
07250         }
07251 
07252         if (SAME_OBJ(seg[pos].key, key)) {
07253           val = seg[pos].val;
07254           vpos = seg[pos].pos;
07255           break;
07256         } else {
07257           cache = seg[pos].cache;
07258           if (cache && SCHEME_HASHTP(cache))
07259             cache = scheme_hash_get((Scheme_Hash_Table *)cache, 
07260                                     prompt_tag ? prompt_tag : scheme_false);
07261           else if (prompt_tag)
07262             cache = NULL;
07263           if (cache && SCHEME_VECTORP(cache)) {
07264             /* If slot 1 has a key, this cache has just one key--value
07265                pair. Otherwise, slot 2 is a hash table. */
07266             if (SCHEME_VEC_ELS(cache)[1]) {
07267               if (SAME_OBJ(SCHEME_VEC_ELS(cache)[1], key)) {
07268                 val = SCHEME_VEC_ELS(cache)[2];
07269                 vpos = (MZ_MARK_POS_TYPE)SCHEME_VEC_ELS(cache)[3];
07270                 break;
07271               }
07272             } else {
07273               Scheme_Hash_Table *ht;
07274               ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2];
07275               val = scheme_hash_get(ht, key);
07276               if (val) {
07277                 vpos = (MZ_MARK_POS_TYPE)SCHEME_CDR(val);
07278                 val = SCHEME_CAR(val);
07279                 break;
07280               }
07281             }
07282           }
07283        }
07284       }
07285 
07286       pos = startpos - findpos;
07287       if (pos > 16) {
07288         pos >>= 1;
07289         findpos = findpos + pos;
07290         if (mc) {
07291           seg = mc->cont_mark_stack_copied;
07292           pos = findpos;
07293         } else {
07294           seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
07295           pos = findpos & SCHEME_MARK_SEGMENT_MASK;
07296         }
07297 
07298         /* See continuation_marks() for information on what
07299            cache can be: */
07300         cache = seg[pos].cache;
07301         {
07302           Scheme_Hash_Table *cht;
07303           if (cache && SCHEME_HASHTP(cache)) {
07304             cht = (Scheme_Hash_Table *)cache;
07305             cache = scheme_hash_get(cht, prompt_tag ? prompt_tag : scheme_false);
07306           } else if (prompt_tag) {
07307             cht = scheme_make_hash_table(SCHEME_hash_ptr);
07308             if (cache) {
07309               if (SCHEME_VECTORP(cache)) {
07310                 Scheme_Object *vec;
07311                 if (SCHEME_VEC_ELS(cache)[0])
07312                   scheme_hash_set(cht, scheme_default_prompt_tag, SCHEME_VEC_ELS(cache)[0]);
07313                 /* Don't try to re-use cache just for the null key */
07314                 vec = scheme_make_vector(4, NULL);
07315                 SCHEME_VEC_ELS(vec)[1] = SCHEME_VEC_ELS(cache)[1];
07316                 SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(cache)[2];
07317                 SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(cache)[3];
07318                 scheme_hash_set(cht, scheme_false, vec);
07319               } else {
07320                 scheme_hash_set(cht, scheme_default_prompt_tag, cache);
07321               }
07322               cache = NULL;
07323             }
07324             seg[pos].cache = (Scheme_Object *)cht;
07325           } else
07326             cht = NULL;
07327 
07328           if (!cache || !SCHEME_VECTORP(cache)) {
07329             /* No cache so far, so map one key */
07330             cache = scheme_make_vector(4, NULL);
07331             SCHEME_VEC_ELS(cache)[1] = key;
07332             SCHEME_VEC_ELS(cache)[2] = val;
07333             SCHEME_VEC_ELS(cache)[3] = (Scheme_Object *)vpos;
07334             if (cht) {
07335               scheme_hash_set(cht, prompt_tag ? prompt_tag : scheme_false, cache);
07336             } else {
07337               if (seg[pos].cache && !SCHEME_FALSEP(seg[pos].cache))
07338                 SCHEME_VEC_ELS(cache)[0] = seg[pos].cache;
07339               seg[pos].cache = cache;
07340             }
07341           } else {
07342             if (SCHEME_VEC_ELS(cache)[1]) {
07343               /* More than one cached key, now; create hash table */
07344               Scheme_Hash_Table *ht;
07345               ht = scheme_make_hash_table(SCHEME_hash_ptr);
07346               scheme_hash_set(ht, key, scheme_make_raw_pair(val, (Scheme_Object *)vpos));
07347               scheme_hash_set(ht, SCHEME_VEC_ELS(cache)[1], scheme_make_raw_pair(SCHEME_VEC_ELS(cache)[2],
07348                                                                                  SCHEME_VEC_ELS(cache)[3]));
07349               SCHEME_VEC_ELS(cache)[1] = NULL;
07350               SCHEME_VEC_ELS(cache)[2] = (Scheme_Object *)ht;
07351             } else {
07352               /* Already have a hash table */
07353               Scheme_Hash_Table *ht;
07354               ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2];
07355               scheme_hash_set(ht, key, scheme_make_raw_pair(val, (Scheme_Object *)vpos));
07356             }
07357           }
07358         }
07359       }
07360 
07361       if (val) {
07362         if (_meta)
07363           *_meta = mc;
07364         if (_vpos)
07365           *_vpos = vpos;
07366         return val;
07367       }
07368       
07369       if (mc) {
07370         mc = mc->next;
07371       } else {
07372         mc = p->meta_continuation;
07373       }
07374     } while (mc);
07375   }
07376   
07377   if (key == scheme_parameterization_key) {
07378     return (Scheme_Object *)scheme_current_thread->init_config;
07379   }
07380   if (key == scheme_break_enabled_key) {
07381     return scheme_current_thread->init_break_cell;
07382   }
07383   
07384   return NULL;
07385 }
07386 
07387 Scheme_Object *
07388 scheme_extract_one_cc_mark(Scheme_Object *mark_set, Scheme_Object *key)
07389 {
07390   return scheme_extract_one_cc_mark_with_meta(mark_set, key, NULL, NULL, NULL);
07391 }
07392 
07393 Scheme_Object *
07394 scheme_extract_one_cc_mark_to_tag(Scheme_Object *mark_set, Scheme_Object *key,
07395                                   Scheme_Object *prompt_tag)
07396 {
07397   return scheme_extract_one_cc_mark_with_meta(mark_set, key, prompt_tag, NULL, NULL);
07398 }
07399 
07400 static Scheme_Object *
07401 extract_one_cc_mark(int argc, Scheme_Object *argv[])
07402 {
07403   Scheme_Object *r;
07404   Scheme_Object *prompt_tag;
07405 
07406   if (SCHEME_TRUEP(argv[0])
07407       && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type))
07408     scheme_wrong_type("continuation-mark-set-first", "continuation-mark-set or #f", 0, argc, argv);
07409   
07410   if ((argv[1] == scheme_parameterization_key)
07411       || (argv[1] == scheme_break_enabled_key)) {
07412     /* Minor hack: these keys are used in "startup.ss" to access
07413        parameterizations, and we want that access to go through
07414        prompts. If they keys somehow leaked, it's ok, because that
07415        doesn't expose anything that isn't already exposed by functions
07416        like `current-parameterization'. */
07417     prompt_tag = NULL; 
07418   } else
07419     prompt_tag = scheme_default_prompt_tag;
07420 
07421   if (argc > 3) {
07422     if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) {
07423       scheme_wrong_type("continuation-mark-set-first", "continuation-prompt-tag",
07424                         3, argc, argv);
07425     }
07426     prompt_tag = argv[3];
07427 
07428     if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)) {
07429       if (SCHEME_FALSEP(argv[0])) {
07430         if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag)))
07431           scheme_arg_mismatch("continuation-mark-set-first",
07432                               "no corresponding prompt in the current continuation: ",
07433                               prompt_tag);
07434       }
07435     }
07436   } 
07437 
07438   r = scheme_extract_one_cc_mark_with_meta(SCHEME_TRUEP(argv[0]) ? argv[0] : NULL, argv[1], 
07439                                            prompt_tag, NULL, NULL);
07440   if (!r) {
07441     if (argc > 2)
07442       r = argv[2];
07443     else
07444       r = scheme_false;
07445   }
07446 
07447   return r;
07448 }
07449 
07450 int scheme_is_cm_deeper(Scheme_Meta_Continuation *m1, MZ_MARK_POS_TYPE p1,
07451                         Scheme_Meta_Continuation *m2, MZ_MARK_POS_TYPE p2)
07452 {
07453   if (m1 != m2) {
07454     if (!m1)
07455       return 0;
07456     if (!m2)
07457       return 1;
07458     return (m1->depth < m2->depth);
07459   }
07460   return p1 < p2;
07461 }
07462 
07463 static Scheme_Object *continuation_prompt_available(int argc, Scheme_Object *argv[])
07464 {
07465   Scheme_Object *prompt_tag;
07466 
07467   prompt_tag = argv[0];
07468   if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
07469     scheme_wrong_type("continuation-prompt-available?", "continuation-prompt-tag",
07470                       0, argc, argv);
07471   }
07472 
07473   if (argc > 1) {
07474     if (SCHEME_ECONTP(argv[1])) {
07475       if (!scheme_escape_continuation_ok(argv[1])) {
07476         scheme_arg_mismatch("continuation-prompt-available?",
07477                             "escape continuation not in the current thread's continuation: ",
07478                             argv[1]);
07479         return NULL;
07480       } else {
07481         Scheme_Meta_Continuation *mc;
07482 
07483         if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
07484           return scheme_true;
07485 
07486         scheme_extract_one_cc_mark_with_meta(NULL, argv[1], NULL, &mc, NULL);
07487         
07488         if (continuation_marks(scheme_current_thread, NULL, argv[1], mc, prompt_tag, 
07489                                NULL, 0))
07490           return scheme_true;
07491       }
07492     } else if (SCHEME_CONTP(argv[1])) {
07493       if (continuation_marks(NULL, argv[1], NULL, NULL, prompt_tag, NULL, 0))
07494         return scheme_true;
07495     } else {
07496       scheme_wrong_type("continuation-prompt-available?", "continuation",
07497                         1, argc, argv);
07498     }
07499   } else {
07500     if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
07501       return scheme_true;
07502 
07503     if (scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag)))
07504       return scheme_true;
07505   }
07506 
07507   return scheme_false;
07508 }
07509 
07510 /*========================================================================*/
07511 /*                             dynamic-wind                               */
07512 /*========================================================================*/
07513 
07514 typedef struct {
07515   MZTAG_IF_REQUIRED
07516   Scheme_Object *pre, *act, *post;
07517 } Dyn_Wind;
07518 
07519 static void pre_post_dyn_wind(Scheme_Object *prepost)
07520 {
07521   Scheme_Cont_Frame_Data cframe;
07522 
07523   /* Cancel internal suspend in eval or dyn-wind, because we convert
07524      it to a parameterize. */
07525   --scheme_current_thread->suspend_break;
07526   ASSERT_SUSPEND_BREAK_ZERO();
07527 
07528   scheme_push_break_enable(&cframe, 0, 0);
07529 
07530   /* Here's the main call: */
07531   (void)_scheme_apply_multi(prepost, 0, NULL);
07532 
07533   scheme_pop_break_enable(&cframe, 0);
07534 
07535   /* Restore internal suspend: */
07536   scheme_current_thread->suspend_break++;
07537 }
07538 
07539 static Scheme_Object *do_dyn_wind(void *d)
07540 {
07541   Dyn_Wind *dw;
07542   dw = (Dyn_Wind *)d;
07543 
07544   return _scheme_apply_multi(dw->act, 0, NULL);
07545 }
07546 
07547 static void pre_dyn_wind(void *d)
07548 {
07549   pre_post_dyn_wind(((Dyn_Wind *)d)->pre);
07550 }
07551 
07552 static void post_dyn_wind(void *d)
07553 {
07554   pre_post_dyn_wind(((Dyn_Wind *)d)->post);
07555 }
07556 
07557 static Scheme_Object *dynamic_wind(int c, Scheme_Object *argv[])
07558 {
07559   Dyn_Wind *dw;
07560   Scheme_Object *v;
07561 
07562   scheme_check_proc_arity("dynamic-wind", 0, 0, c, argv);
07563   scheme_check_proc_arity("dynamic-wind", 0, 1, c, argv);
07564   scheme_check_proc_arity("dynamic-wind", 0, 2, c, argv);
07565 
07566   dw = MALLOC_ONE_RT(Dyn_Wind);
07567 #ifdef MZTAG_REQUIRED
07568   dw->type = scheme_rt_dyn_wind_info;
07569 #endif
07570 
07571   dw->pre = argv[0];
07572   dw->act = argv[1];
07573   dw->post = argv[2];
07574 
07575   v = scheme_dynamic_wind(pre_dyn_wind, do_dyn_wind, post_dyn_wind, NULL,
07576                        (void *)dw);
07577 
07578   /* We may have just re-activated breaking: */
07579   {
07580     Scheme_Thread *p = scheme_current_thread;
07581     if (p->external_break && scheme_can_break(p)) {
07582       Scheme_Object **save_values;
07583       int save_count;
07584 
07585       if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
07586        save_count = p->ku.multiple.count;
07587        save_values = p->ku.multiple.array;
07588        p->ku.multiple.array = NULL;
07589        if (SAME_OBJ(save_values, p->values_buffer))
07590          p->values_buffer = NULL;
07591       } else {
07592        save_count = 0;
07593        save_values = NULL;
07594       }
07595 
07596       scheme_thread_block_w_thread(0.0, p);
07597       p->ran_some = 1;
07598 
07599       if (save_values) {
07600        p->ku.multiple.count = save_count;
07601        p->ku.multiple.array = save_values;
07602       }
07603     }
07604   }
07605 
07606   return v;
07607 }
07608 
07609 Scheme_Object *scheme_dynamic_wind(void (*pre)(void *),
07610                                Scheme_Object *(* volatile act)(void *),
07611                                void (* volatile post)(void *),
07612                                Scheme_Object *(*jmp_handler)(void *),
07613                                void * volatile data)
07614 {
07615   mz_jmp_buf newbuf;
07616   Scheme_Object * volatile v, ** volatile save_values;
07617   volatile int err;
07618   Scheme_Dynamic_Wind * volatile dw;
07619   volatile int save_count, old_cac;
07620   Scheme_Thread *p;
07621   int delta;
07622 
07623   p = scheme_current_thread;
07624 
07625   dw = MALLOC_ONE_RT(Scheme_Dynamic_Wind);
07626 #ifdef MZTAG_REQUIRED
07627   dw->type = scheme_rt_dyn_wind;
07628 #endif
07629 
07630   dw->data = data;
07631   dw->pre = pre;
07632   dw->post = post;
07633   dw->prev = p->dw;
07634   if (dw->prev)
07635     dw->depth = dw->prev->depth + 1;
07636   else
07637     dw->depth = 0;
07638   dw->next_meta = p->next_meta;
07639 
07640   if (pre) {
07641     ASSERT_SUSPEND_BREAK_ZERO();
07642     p->suspend_break++;
07643     pre(data);
07644     p = scheme_current_thread;
07645     --p->suspend_break;
07646   }
07647 
07648   p->next_meta = 0;
07649   p->dw = dw;
07650   
07651   dw->saveerr = scheme_current_thread->error_buf;
07652   scheme_current_thread->error_buf = &newbuf;
07653 
07654    scheme_save_env_stack_w_thread(dw->envss, p);
07655 
07656   if (scheme_setjmp(newbuf)) {
07657     p = scheme_current_thread;
07658     scheme_restore_env_stack_w_thread(dw->envss, p);
07659     if ((p->dw != dw)
07660         && (!p->dw || !dw->id || (p->dw->id != dw->id))) {
07661       /* A full continuation jump was interrupted by an
07662         escape continuation jump (in a dw pre or post thunk). Either
07663            1. this dw's post is already done for an interupted upward
07664               jump; or
07665            2. we never actually got this far for an interrupted
07666              downward jump.
07667         In either case, skip up until we get to the right level. */
07668       scheme_longjmp(*dw->saveerr, 1);
07669     } else {
07670       if (jmp_handler)
07671        v = jmp_handler(data);
07672       else
07673        v = NULL;
07674       err = !v;
07675     }
07676   } else {
07677     if (pre) {
07678       /* Need to check for a break, in case one was queued during
07679         pre: */
07680       scheme_check_break_now();
07681     }
07682 
07683     v = act(data);
07684 
07685     err = 0;
07686   }
07687 
07688   p = scheme_current_thread;
07689   if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
07690     save_count = p->ku.multiple.count;
07691     save_values = p->ku.multiple.array;
07692     p->ku.multiple.array = NULL;
07693     if (SAME_OBJ(save_values, p->values_buffer))
07694       p->values_buffer = NULL;
07695   } else {
07696     save_count = 0;
07697     save_values = NULL;
07698   }
07699 
07700   delta = p->dw->next_meta;
07701   p->dw = p->dw->prev; /* note: use p->dw, not dw, in case
07702                           continuation was composed */
07703   p->next_meta += delta;
07704 
07705   /* Don't run Scheme-based dyn-winds when we're killing a nested thread. */
07706   if (err && p->cjs.is_kill && (post == post_dyn_wind))
07707     post = NULL;
07708 
07709   old_cac = scheme_continuation_application_count;
07710 
07711   if (post) {
07712     p->error_buf = &newbuf;
07713     if (scheme_setjmp(newbuf)) {
07714       p = scheme_current_thread;
07715       scheme_restore_env_stack_w_thread(dw->envss, p);
07716       err = 1;
07717     } else {
07718       Scheme_Continuation_Jump_State cjs;
07719       p = scheme_current_thread;
07720       ASSERT_SUSPEND_BREAK_ZERO();
07721       p->suspend_break++;
07722       copy_cjs(&cjs, &p->cjs);
07723       reset_cjs(&p->cjs);
07724       post(data);
07725       copy_cjs(&p->cjs, &cjs);
07726       p = scheme_current_thread;
07727       --p->suspend_break;
07728     }
07729   }
07730 
07731   if (err) {
07732     /* If we're escaping to a prompt or escape continuation,
07733        check that it's still there. */
07734     if ((old_cac != scheme_continuation_application_count)