Back to index

plt-scheme  4.2.1
eval.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 contains 
00027 
00028         * the main eval-apply loop, in scheme_do_eval()
00029 
00030         * the main compile loop, int scheme_compile_expand_expr()
00031 
00032         * compilation and bytecode [un]marshaling for
00033              - applications
00034              - sequences (along with code in syntax.c)
00035              - branches (along with code in syntax.c)
00036              - with-continuation-mark
00037            [These are here instead of syntax.c because they are
00038             tightly integrated into the evaluation loop.]
00039 
00040         * C and Scheme stack management routines
00041 
00042    Evaluation:
00043 
00044    The bytecode evaluator uses the C stack for continuations, and a
00045    separate Scheme stack for activation-frame variables and collecting
00046    application arguments. Closures are flat, so mutable variables are
00047    boxed. A third stack is used for continuation marks, only as
00048    needed.
00049 
00050    Tail calls are, for the most part, gotos within scheme_do_eval(). A
00051    C function called by the main evaluation loop can perform a
00052    trampoling tail call via scheme_tail_apply. The trampoline must
00053    return to its caller without allocating any memory, because an
00054    allocation optimization in the tail-call code assumes no GCs will
00055    occur between the time that a tail call is issued and the time when
00056    it's handled.
00057 
00058    Multiple values are returned as a special SCHEME_MULTIPLE_VALUES
00059    token that indicates actual values are stored in the current
00060    thread's record.
00061 
00062    The apply half of the eval-apply loop branches on all possible
00063    application types. All primitive functions (including cons) are
00064    implemented by C functions outside the loop. Continuation
00065    applications are handled directly in scheme_do_eval(). That leaves
00066    calls to closures, which are also performed within scheme_do_eval()
00067    (so that most tail calls avoid the trampoline), and native code,
00068    which is analogous to a primitive.
00069 
00070    The eval half of the loop detects a limited set of core syntactic
00071    forms, such as application and letrecs. Otherwise, it dispatches to
00072    external functions to implement elaborate syntactic forms, such as
00073    begin0 and case-lambda expressions.
00074 
00075    When collecting the arguments for an application, scheme_do_eval()
00076    avoids recursive C calls to evaluate arguments by recogzining
00077    easily-evaluated expressions, such as constrants and variable
00078    lookups. This can be viewed as a kind of half-way A-normalization.
00079 
00080    Bytecodes are not linear. They're actually trees of expression
00081    nodes.
00082 
00083    Top-level variables (global or module) are referenced through the
00084    Scheme stack, so that the variables can be "re-linked" each time a
00085    module is instantiated. Syntax constants are similarly accessed
00086    through the Scheme stack. The global variables and syntax objects
00087    are sometimes called the "prefix", and scheme_push_prefix()
00088    initializes the prefix portion of the stack.
00089 
00090    Compilation:
00091 
00092    Compilation works in four passes.
00093 
00094    The first pass, called "compile", performs most of the work and
00095    tracks variable usage (including whether a variable is mutated or
00096    not).
00097 
00098    The second pass, called "optimize", performs constant propagation,
00099    constant folding, and function inlining; this pass mutates records
00100    produced by the first pass. 
00101 
00102    The third pass, called "resolve", finishes compilation by computing
00103    variable offsets and indirections (often mutating the records
00104    produced by the first pass). It is also responsible for closure
00105    conversion (i.e., converting closure content to arguments) and
00106    lifting (of procedures that close over nothing or only globals).
00107    Beware that the resulting bytecode object is a graph, not a tree,
00108    due to sharing (potentially cyclic) of closures that are "empty"
00109    but actually refer to other "empty" closures.
00110 
00111    The fourth pass, "sfs", performs another liveness analysis on stack
00112    slows and inserts operations to clear stack slots as necessary to
00113    make execution safe for space. In particular, dead slots need to be
00114    cleared before a non-tail call into arbitrary Scheme code.
00115 
00116    Just-in-time compilation:
00117 
00118    If the JIT is enabled, then `eval' processes a compiled expression
00119    one more time (functionally): `lambda' and `case-lambda' forms are
00120    converted to native-code generators, instead of bytecode variants.
00121 
00122 */
00123 
00124 #include "schpriv.h"
00125 #include "schrunst.h"
00126 #include "schexpobs.h"
00127 
00128 #ifdef USE_STACKAVAIL
00129 #include <malloc.h>
00130 #endif
00131 #ifdef UNIX_FIND_STACK_BOUNDS
00132 #include <signal.h>
00133 #include <sys/time.h>
00134 #include <sys/resource.h>
00135 #endif
00136 #ifdef BEOS_FIND_STACK_BOUNDS
00137 # include <be/kernel/OS.h>
00138 #endif
00139 #ifdef OSKIT_FIXED_STACK_BOUNDS
00140 # include <oskit/machine/base_stack.h>
00141 #endif
00142 #include "schmach.h"
00143 #ifdef MACOS_STACK_LIMIT
00144 #include <Memory.h>
00145 #endif
00146 
00147 #define EMBEDDED_DEFINES_START_ANYWHERE 0
00148 
00149 /* globals */
00150 volatile int scheme_fuel_counter;
00151 
00152 int scheme_startup_use_jit = 1;
00153 void scheme_set_startup_use_jit(int v) { scheme_startup_use_jit =  v; }
00154 
00155 /* THREAD LOCAL SHARED */
00156 #ifdef USE_STACK_BOUNDARY_VAR
00157 THREAD_LOCAL unsigned long scheme_stack_boundary;
00158 THREAD_LOCAL unsigned long volatile scheme_jit_stack_boundary;
00159 #endif
00160 static THREAD_LOCAL Scheme_Object *quick_stx;
00161 
00162 /* global counters */
00163 /* FIXME needs to be atomically incremented */
00164 int scheme_overflow_count;
00165 int get_overflow_count() { return scheme_overflow_count; }
00166 int scheme_continuation_application_count;
00167 
00168 /* read-only globals */
00169 Scheme_Object *scheme_eval_waiting;
00170 Scheme_Object *scheme_multiple_values;
00171 static Scheme_Object *app_expander;
00172 static Scheme_Object *datum_expander;
00173 static Scheme_Object *top_expander;
00174 static Scheme_Object *stop_expander;
00175 /* symbols */
00176 static Scheme_Object *app_symbol;
00177 static Scheme_Object *datum_symbol;
00178 static Scheme_Object *top_symbol;
00179 static Scheme_Object *top_level_symbol;
00180 static Scheme_Object *define_values_symbol;
00181 static Scheme_Object *letrec_values_symbol;
00182 static Scheme_Object *lambda_symbol;
00183 static Scheme_Object *unknown_symbol;
00184 static Scheme_Object *void_link_symbol;
00185 static Scheme_Object *quote_symbol;
00186 static Scheme_Object *letrec_syntaxes_symbol;
00187 static Scheme_Object *begin_symbol;
00188 static Scheme_Object *let_values_symbol;
00189 static Scheme_Object *internal_define_symbol;
00190 static Scheme_Object *module_symbol;
00191 static Scheme_Object *module_begin_symbol;
00192 static Scheme_Object *expression_symbol;
00193 static Scheme_Object *protected_symbol;
00194 Scheme_Object *scheme_stack_dump_key;
00195 static Scheme_Object *zero_rands_ptr; /* &zero_rands_ptr is dummy rands pointer */
00196 
00197 /* locals */
00198 static Scheme_Object *eval(int argc, Scheme_Object *argv[]);
00199 static Scheme_Object *compile(int argc, Scheme_Object *argv[]);
00200 static Scheme_Object *compiled_p(int argc, Scheme_Object *argv[]);
00201 static Scheme_Object *expand(int argc, Scheme_Object **argv);
00202 static Scheme_Object *local_expand(int argc, Scheme_Object **argv);
00203 static Scheme_Object *local_expand_expr(int argc, Scheme_Object **argv);
00204 static Scheme_Object *local_expand_catch_lifts(int argc, Scheme_Object **argv);
00205 static Scheme_Object *local_transformer_expand(int argc, Scheme_Object **argv);
00206 static Scheme_Object *local_transformer_expand_catch_lifts(int argc, Scheme_Object **argv);
00207 static Scheme_Object *local_eval(int argc, Scheme_Object **argv);
00208 static Scheme_Object *expand_once(int argc, Scheme_Object **argv);
00209 static Scheme_Object *expand_to_top_form(int argc, Scheme_Object **argv);
00210 static Scheme_Object *enable_break(int, Scheme_Object *[]);
00211 static Scheme_Object *current_eval(int argc, Scheme_Object *[]);
00212 static Scheme_Object *current_compile(int argc, Scheme_Object *[]);
00213 
00214 static Scheme_Object *eval_stx(int argc, Scheme_Object *argv[]);
00215 static Scheme_Object *compile_stx(int argc, Scheme_Object *argv[]);
00216 static Scheme_Object *expand_stx(int argc, Scheme_Object **argv);
00217 static Scheme_Object *expand_stx_once(int argc, Scheme_Object **argv);
00218 static Scheme_Object *expand_stx_to_top_form(int argc, Scheme_Object **argv);
00219 static Scheme_Object *top_introduce_stx(int argc, Scheme_Object **argv);
00220 
00221 static Scheme_Object *allow_set_undefined(int argc, Scheme_Object **argv);
00222 static Scheme_Object *compile_module_constants(int argc, Scheme_Object **argv);
00223 static Scheme_Object *use_jit(int argc, Scheme_Object **argv);
00224 static Scheme_Object *disallow_inline(int argc, Scheme_Object **argv);
00225 
00226 static Scheme_Object *app_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00227 static Scheme_Object *app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00228 static Scheme_Object *datum_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00229 static Scheme_Object *datum_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00230 static Scheme_Object *top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00231 static Scheme_Object *top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00232 
00233 static Scheme_Object *write_application(Scheme_Object *obj);
00234 static Scheme_Object *read_application(Scheme_Object *obj);
00235 static Scheme_Object *write_sequence(Scheme_Object *obj);
00236 static Scheme_Object *read_sequence(Scheme_Object *obj);
00237 static Scheme_Object *read_sequence_save_first(Scheme_Object *obj);
00238 static Scheme_Object *write_branch(Scheme_Object *obj);
00239 static Scheme_Object *read_branch(Scheme_Object *obj);
00240 static Scheme_Object *write_with_cont_mark(Scheme_Object *obj);
00241 static Scheme_Object *read_with_cont_mark(Scheme_Object *obj);
00242 static Scheme_Object *write_syntax(Scheme_Object *obj);
00243 static Scheme_Object *read_syntax(Scheme_Object *obj);
00244 static Scheme_Object *write_quote_syntax(Scheme_Object *obj);
00245 static Scheme_Object *read_quote_syntax(Scheme_Object *obj);
00246 
00247 static Scheme_Object *scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, 
00248                                            Scheme_Compile_Expand_Info *rec, int drec, 
00249                                            int app_position);
00250 
00251 static Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env);
00252 
00253 #define cons(x,y) scheme_make_pair(x,y)
00254 
00255 typedef void (*DW_PrePost_Proc)(void *);
00256 
00257 #ifdef MZ_PRECISE_GC
00258 static void register_traversers(void);
00259 #endif
00260 
00261 /* Lookahead types for evaluating application arguments. */
00262 /* 4 cases + else => magic number for some compilers doing a switch? */
00263 enum {
00264   SCHEME_EVAL_CONSTANT = 0,
00265   SCHEME_EVAL_GLOBAL,
00266   SCHEME_EVAL_LOCAL,
00267   SCHEME_EVAL_LOCAL_UNBOX,
00268   SCHEME_EVAL_GENERAL
00269 };
00270 
00271 #define icons scheme_make_pair
00272 
00273 /*========================================================================*/
00274 /*                             initialization                             */
00275 /*========================================================================*/
00276 
00277 void
00278 scheme_init_eval (Scheme_Env *env)
00279 {
00280 #ifdef MZ_PRECISE_GC
00281   register_traversers();
00282 #endif
00283 
00284 #ifdef MZ_EVAL_WAITING_CONSTANT
00285   scheme_eval_waiting = MZ_EVAL_WAITING_CONSTANT;
00286 #else
00287   REGISTER_SO(scheme_eval_waiting);
00288   scheme_eval_waiting = scheme_alloc_eternal_object();
00289   scheme_eval_waiting->type = scheme_eval_waiting_type;
00290 #endif
00291 
00292 #ifdef MZ_EVAL_WAITING_CONSTANT
00293   scheme_multiple_values = MZ_MULTIPLE_VALUES_CONSTANT;
00294 #else
00295   REGISTER_SO(scheme_multiple_values);
00296   scheme_multiple_values = scheme_alloc_eternal_object();
00297   scheme_multiple_values->type = scheme_multiple_values_type;
00298 #endif
00299 
00300   REGISTER_SO(define_values_symbol);
00301   REGISTER_SO(letrec_values_symbol);
00302   REGISTER_SO(lambda_symbol);
00303   REGISTER_SO(unknown_symbol);
00304   REGISTER_SO(void_link_symbol);
00305   REGISTER_SO(quote_symbol);
00306   REGISTER_SO(letrec_syntaxes_symbol);
00307   REGISTER_SO(begin_symbol);
00308   REGISTER_SO(let_values_symbol);
00309   
00310   define_values_symbol    = scheme_intern_symbol("define-values");
00311   letrec_values_symbol    = scheme_intern_symbol("letrec-values");
00312   let_values_symbol       = scheme_intern_symbol("let-values");
00313   lambda_symbol           = scheme_intern_symbol("lambda");
00314   unknown_symbol          = scheme_intern_symbol("unknown");
00315   void_link_symbol        = scheme_intern_symbol("-v");
00316   quote_symbol            = scheme_intern_symbol("quote");
00317   letrec_syntaxes_symbol  = scheme_intern_symbol("letrec-syntaxes+values");
00318   begin_symbol            = scheme_intern_symbol("begin");
00319   
00320   REGISTER_SO(module_symbol);
00321   REGISTER_SO(module_begin_symbol);
00322   REGISTER_SO(internal_define_symbol);
00323   REGISTER_SO(expression_symbol);
00324   REGISTER_SO(top_level_symbol);
00325   REGISTER_SO(protected_symbol);
00326 
00327   module_symbol           = scheme_intern_symbol("module");
00328   module_begin_symbol     = scheme_intern_symbol("module-begin");
00329   internal_define_symbol  = scheme_intern_symbol("internal-define");
00330   expression_symbol       = scheme_intern_symbol("expression");
00331   top_level_symbol        = scheme_intern_symbol("top-level");
00332   protected_symbol        = scheme_intern_symbol("protected");
00333 
00334   REGISTER_SO(scheme_stack_dump_key);
00335   scheme_stack_dump_key = scheme_make_symbol("stk"); /* uninterned! */
00336 
00337   scheme_install_type_writer(scheme_application_type, write_application);
00338   scheme_install_type_reader(scheme_application_type, read_application);
00339   scheme_install_type_writer(scheme_application2_type, write_application);
00340   scheme_install_type_reader(scheme_application2_type, read_application);
00341   scheme_install_type_writer(scheme_application3_type, write_application);
00342   scheme_install_type_reader(scheme_application3_type, read_application);
00343   scheme_install_type_writer(scheme_sequence_type, write_sequence);
00344   scheme_install_type_reader(scheme_sequence_type, read_sequence);
00345   scheme_install_type_writer(scheme_branch_type, write_branch);
00346   scheme_install_type_reader(scheme_branch_type, read_branch);
00347   scheme_install_type_writer(scheme_with_cont_mark_type, write_with_cont_mark);
00348   scheme_install_type_reader(scheme_with_cont_mark_type, read_with_cont_mark);
00349   scheme_install_type_writer(scheme_quote_syntax_type, write_quote_syntax);
00350   scheme_install_type_reader(scheme_quote_syntax_type, read_quote_syntax);
00351   scheme_install_type_writer(scheme_syntax_type, write_syntax);
00352   scheme_install_type_reader(scheme_syntax_type, read_syntax);
00353   scheme_install_type_writer(scheme_begin0_sequence_type, write_sequence);
00354   scheme_install_type_reader(scheme_begin0_sequence_type, read_sequence_save_first);
00355   
00356   GLOBAL_PRIM_W_ARITY2("eval",        eval,     1, 2, 0, -1, env);
00357   GLOBAL_PRIM_W_ARITY2("eval-syntax", eval_stx, 1, 2, 0, -1, env);
00358 
00359   GLOBAL_PRIM_W_ARITY("compile",                                 compile,                               1, 1, env);
00360   GLOBAL_PRIM_W_ARITY("compile-syntax",                          compile_stx,                           1, 1, env);
00361   GLOBAL_PRIM_W_ARITY("compiled-expression?",                    compiled_p,                            1, 1, env);
00362   GLOBAL_PRIM_W_ARITY("expand",                                  expand,                                1, 1, env);
00363   GLOBAL_PRIM_W_ARITY("expand-syntax",                           expand_stx,                            1, 1, env);
00364   GLOBAL_PRIM_W_ARITY("local-expand",                            local_expand,                          3, 4, env);
00365   GLOBAL_PRIM_W_ARITY("syntax-local-expand-expression",          local_expand_expr,                     1, 1, env);
00366   GLOBAL_PRIM_W_ARITY("syntax-local-bind-syntaxes",              local_eval,                            3, 3, env);
00367   GLOBAL_PRIM_W_ARITY("local-expand/capture-lifts",              local_expand_catch_lifts,              3, 5, env);
00368   GLOBAL_PRIM_W_ARITY("local-transformer-expand",                local_transformer_expand,              3, 4, env);
00369   GLOBAL_PRIM_W_ARITY("local-transformer-expand/capture-lifts",  local_transformer_expand_catch_lifts,  3, 5, env);
00370   GLOBAL_PRIM_W_ARITY("expand-once",                             expand_once,                           1, 1, env);
00371   GLOBAL_PRIM_W_ARITY("expand-syntax-once",                      expand_stx_once,                       1, 1, env);
00372   GLOBAL_PRIM_W_ARITY("expand-to-top-form",                      expand_to_top_form,                    1, 1, env);
00373   GLOBAL_PRIM_W_ARITY("expand-syntax-to-top-form",               expand_stx_to_top_form,                1, 1, env);
00374   GLOBAL_PRIM_W_ARITY("namespace-syntax-introduce",              top_introduce_stx,                     1, 1, env);
00375   GLOBAL_PRIM_W_ARITY("break-enabled",                           enable_break,                          0, 1, env);
00376 
00377   GLOBAL_PARAMETER("current-eval",                      current_eval,             MZCONFIG_EVAL_HANDLER,          env);
00378   GLOBAL_PARAMETER("current-compile",                   current_compile,          MZCONFIG_COMPILE_HANDLER,       env);
00379   GLOBAL_PARAMETER("compile-allow-set!-undefined",      allow_set_undefined,      MZCONFIG_ALLOW_SET_UNDEFINED,   env);
00380   GLOBAL_PARAMETER("compile-enforce-module-constants",  compile_module_constants, MZCONFIG_COMPILE_MODULE_CONSTS, env);
00381   GLOBAL_PARAMETER("eval-jit-enabled",                  use_jit,                  MZCONFIG_USE_JIT,               env);
00382   GLOBAL_PARAMETER("compile-context-preservation-enabled", disallow_inline,       MZCONFIG_DISALLOW_INLINE,       env);
00383   
00384   REGISTER_SO(app_symbol);
00385   REGISTER_SO(datum_symbol);
00386   REGISTER_SO(top_symbol);
00387 
00388   app_symbol    = scheme_intern_symbol("#%app");
00389   datum_symbol  = scheme_intern_symbol("#%datum");
00390   top_symbol    = scheme_intern_symbol("#%top");
00391 
00392   REGISTER_SO(app_expander);
00393   REGISTER_SO(datum_expander);
00394   REGISTER_SO(top_expander);
00395 
00396   app_expander    = scheme_make_compiled_syntax(app_syntax,   app_expand);
00397   datum_expander  = scheme_make_compiled_syntax(datum_syntax, datum_expand);
00398   top_expander    = scheme_make_compiled_syntax(top_syntax,   top_expand);
00399   scheme_add_global_keyword("#%app",    app_expander,   env);
00400   scheme_add_global_keyword("#%datum",  datum_expander, env);
00401   scheme_add_global_keyword("#%top",    top_expander,   env);
00402 }
00403 
00404 void scheme_init_eval_places()
00405 {
00406   REGISTER_SO(quick_stx);
00407 }
00408 
00409 /*========================================================================*/
00410 /*                   C stack and Scheme stack handling                    */
00411 /*========================================================================*/
00412 
00413 # define DO_CHECK_FOR_BREAK(p, e) \
00414        if (DECREMENT_FUEL(scheme_fuel_counter, 1) <= 0) { \
00415          e scheme_thread_block(0); \
00416           (p)->ran_some = 1; \
00417        }
00418 
00419 Scheme_Object *
00420 scheme_handle_stack_overflow(Scheme_Object *(*k)(void))
00421 {
00422   /* "Stack overflow" means running out of C-stack space. The other
00423      end of this handler (i.e., the target for the longjmp) is
00424      scheme_top_level_do in fun.c */
00425   Scheme_Thread       *p = scheme_current_thread;
00426   Scheme_Overflow     *overflow;
00427   Scheme_Overflow_Jmp *jmp;
00428 
00429   scheme_about_to_move_C_stack();
00430 
00431   p->overflow_k = k;
00432   scheme_overflow_count++;
00433 
00434   overflow = MALLOC_ONE_RT(Scheme_Overflow);
00435 #ifdef MZTAG_REQUIRED
00436   overflow->type = scheme_rt_overflow;
00437 #endif
00438   /* push old overflow */
00439   overflow->prev = scheme_current_thread->overflow;
00440   p->overflow = overflow;
00441 
00442   overflow->stack_start = p->stack_start;
00443 
00444   jmp = MALLOC_ONE_RT(Scheme_Overflow_Jmp);
00445 #ifdef MZTAG_REQUIRED
00446   jmp->type = scheme_rt_overflow_jmp;
00447 #endif
00448   overflow->jmp = jmp;
00449 
00450   scheme_init_jmpup_buf(&overflow->jmp->cont);
00451   scheme_zero_unneeded_rands(scheme_current_thread); /* for GC */
00452 
00453   if (scheme_setjmpup(&overflow->jmp->cont, overflow->jmp, p->stack_start)) {
00454     p = scheme_current_thread;
00455     overflow = p->overflow;
00456     p->overflow = overflow->prev;
00457     p->error_buf = overflow->jmp->savebuf;
00458     if (!overflow->jmp->captured) /* reset if not captured in a continuation */
00459       scheme_reset_jmpup_buf(&overflow->jmp->cont);
00460     if (!scheme_overflow_reply) {
00461       /* No reply value means we should continue some escape. */
00462       if (p->cjs.jumping_to_continuation
00463           && p->cjs.is_escape) {
00464         /* Jump directly to prompt: */
00465         Scheme_Prompt *prompt = (Scheme_Prompt *)p->cjs.jumping_to_continuation;
00466         scheme_longjmp(*prompt->prompt_buf, 1);
00467       } else if (p->cjs.jumping_to_continuation
00468                  && SCHEME_CONTP(p->cjs.jumping_to_continuation)) {
00469         Scheme_Cont *c = (Scheme_Cont *)p->cjs.jumping_to_continuation;
00470         p->cjs.jumping_to_continuation = NULL;
00471         scheme_longjmpup(&c->buf);
00472       } else {
00473         /* Continue normal escape: */
00474         scheme_longjmp(scheme_error_buf, 1);
00475       }
00476     } else {
00477       Scheme_Object *reply = scheme_overflow_reply;
00478       scheme_overflow_reply = NULL;
00479       return reply;
00480     }
00481   } else {
00482     p->stack_start = scheme_overflow_stack_start;
00483     scheme_longjmpup(&scheme_overflow_jmp->cont);
00484   }
00485   return NULL; /* never gets here */
00486 }
00487 
00488 void scheme_init_stack_check()
00489      /* Finds the C stack limit --- platform-specific. */
00490 {
00491   int *v, stack_grows_up;
00492   unsigned long deeper;
00493 #ifdef UNIX_FIND_STACK_BOUNDS
00494   struct rlimit rl;
00495 #endif
00496   
00497   deeper = scheme_get_deeper_address();
00498   stack_grows_up = (deeper > (unsigned long)&v);
00499 
00500 #ifdef STACK_GROWS_UP
00501   if (!stack_grows_up) {
00502     if (scheme_console_printf)
00503       scheme_console_printf("Stack grows DOWN, not UP.\n");
00504     else
00505       printf("Stack grows DOWN, not UP.\n");
00506     exit(1);
00507   }
00508 #endif
00509 #ifdef STACK_GROWS_DOWN
00510   if (stack_grows_up) {
00511     if (scheme_console_printf)
00512       scheme_console_printf("Stack grows UP, not DOWN.\n");
00513     else
00514       printf("Stack grows UP, not DOWN.\n");
00515     exit(1);
00516   }
00517 #endif
00518 
00519 #ifdef USE_STACK_BOUNDARY_VAR
00520   if (!scheme_stack_boundary) {
00521 # ifdef ASSUME_FIXED_STACK_SIZE
00522     scheme_stack_boundary = scheme_get_current_os_thread_stack_base();
00523     if (stack_grows_up)
00524       scheme_stack_boundary += (FIXED_STACK_SIZE - STACK_SAFETY_MARGIN);
00525     else
00526       scheme_stack_boundary += (STACK_SAFETY_MARGIN - FIXED_STACK_SIZE);
00527 # endif
00528 
00529 # ifdef WINDOWS_FIND_STACK_BOUNDS
00530     scheme_stack_boundary = scheme_get_current_os_thread_stack_base();
00531     scheme_stack_boundary += (STACK_SAFETY_MARGIN - 0x100000);
00532 # endif
00533 
00534 # ifdef MACOS_FIND_STACK_BOUNDS
00535     scheme_stack_boundary = (unsigned long)&v +  STACK_SAFETY_MARGIN - StackSpace();
00536 # endif
00537 
00538 # ifdef PALMOS_FIND_STACK_BOUNDS
00539     {
00540       Ptr s, e;
00541       SysGetStackInfo(Ptr &s, &e);
00542       scheme_stack_boundary = (unsigned long)e + STACK_SAFETY_MARGIN;
00543     }
00544 # endif
00545 
00546 # ifdef BEOS_FIND_STACK_BOUNDS
00547     {
00548       thread_info info;
00549       get_thread_info(find_thread(NULL), &info);
00550       scheme_stack_boundary = (unsigned long)info.stack_base + STACK_SAFETY_MARGIN;
00551     }
00552 # endif
00553 
00554 # ifdef OSKIT_FIXED_STACK_BOUNDS
00555     scheme_stack_boundary = (unsigned long)base_stack_start + STACK_SAFETY_MARGIN;
00556 # endif
00557 
00558 # ifdef UNIX_FIND_STACK_BOUNDS
00559     getrlimit(RLIMIT_STACK, &rl);
00560   
00561     {
00562       unsigned long bnd, lim;
00563       bnd = (unsigned long)scheme_get_current_os_thread_stack_base();
00564 
00565       lim = (unsigned long)rl.rlim_cur;
00566 #  ifdef UNIX_STACK_MAXIMUM
00567       if (lim > UNIX_STACK_MAXIMUM)
00568         lim = UNIX_STACK_MAXIMUM;
00569 #  endif
00570 
00571       if (stack_grows_up)
00572         bnd += (lim - STACK_SAFETY_MARGIN);
00573       else
00574         bnd += (STACK_SAFETY_MARGIN - lim);
00575 
00576       scheme_stack_boundary = bnd;
00577     }
00578 # endif
00579   }
00580 #endif
00581 
00582 #ifdef USE_STACK_BOUNDARY_VAR
00583   scheme_jit_stack_boundary = scheme_stack_boundary;
00584 #endif
00585 }
00586 
00587 
00588 int scheme_check_runstack(long size)
00589      /* Checks whether the Scheme stack has `size' room left */
00590 {
00591   return ((MZ_RUNSTACK - MZ_RUNSTACK_START) >= (size + SCHEME_TAIL_COPY_THRESHOLD));
00592 }
00593 
00594 void *scheme_enlarge_runstack(long size, void *(*k)())
00595      /* Adds a Scheme stack segment, of at least `size' bytes */
00596 {
00597   Scheme_Thread *p = scheme_current_thread;
00598   Scheme_Saved_Stack *saved;
00599   void *v;
00600   int cont_count;
00601   volatile int escape;
00602   mz_jmp_buf newbuf, * volatile savebuf;
00603 
00604   saved = MALLOC_ONE_RT(Scheme_Saved_Stack);
00605 
00606 #ifdef MZTAG_REQUIRED
00607   saved->type = scheme_rt_saved_stack;
00608 #endif
00609   saved->prev = p->runstack_saved;
00610   saved->runstack_start = MZ_RUNSTACK_START;
00611   saved->runstack_offset = (MZ_RUNSTACK - MZ_RUNSTACK_START);
00612   saved->runstack_size = p->runstack_size;
00613   
00614   size += SCHEME_TAIL_COPY_THRESHOLD;
00615 
00616   if (size) {
00617     /* If we keep growing the stack, then probably it
00618        needs to be much larger, so at least double the 
00619        stack size, to a point: */
00620     long min_size;
00621     min_size = 2 * (p->runstack_size);
00622     if (min_size > 128000)
00623       min_size = 128000;
00624     if (size < min_size)
00625       size = min_size;
00626   } else {
00627     /* This is for a prompt. Re-use the current size, 
00628        up to a point: */
00629     size = p->runstack_size;
00630     if (size > 1000)
00631       size = 1000;
00632   }
00633 
00634   if (p->spare_runstack && (size <= p->spare_runstack_size)) {
00635     size = p->spare_runstack_size;
00636     MZ_RUNSTACK_START = p->spare_runstack;
00637     p->spare_runstack = NULL;
00638   } else {
00639     MZ_RUNSTACK_START = scheme_alloc_runstack(size);
00640   }
00641   p->runstack_size = size;
00642   MZ_RUNSTACK = MZ_RUNSTACK_START + size;
00643   p->runstack_saved = saved;
00644   
00645   cont_count = scheme_cont_capture_count;
00646 
00647   savebuf = p->error_buf;
00648   p->error_buf = &newbuf;
00649   if (scheme_setjmp(newbuf)) {
00650     v = NULL;
00651     escape = 1;
00652     p = scheme_current_thread; /* might have changed! */
00653   } else {
00654     v = k();
00655     escape = 0;
00656     p = scheme_current_thread; /* might have changed! */
00657 
00658     if (cont_count == scheme_cont_capture_count) {
00659       if (!p->spare_runstack || (p->runstack_size > p->spare_runstack_size)) {
00660         p->spare_runstack = MZ_RUNSTACK_START;
00661         p->spare_runstack_size = p->runstack_size;
00662       }
00663     }
00664   }
00665 
00666   p->error_buf = savebuf;
00667 
00668   saved = p->runstack_saved;
00669 
00670   p->runstack_saved = saved->prev;
00671   MZ_RUNSTACK_START = saved->runstack_start;
00672   MZ_RUNSTACK = MZ_RUNSTACK_START + saved->runstack_offset;
00673   p->runstack_size = saved->runstack_size;
00674 
00675   if (escape) {
00676     scheme_longjmp(*p->error_buf, 1);
00677   }
00678 
00679   return v;
00680 }
00681 
00682 /*========================================================================*/
00683 /*           compiling applications, sequences, and branches              */
00684 /*========================================================================*/
00685 
00686 static int is_current_inspector_call(Scheme_Object *a)
00687 {
00688   if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) {
00689     Scheme_App_Rec *app = (Scheme_App_Rec *)a;
00690     if (!app->num_args
00691         && SAME_OBJ(app->args[0], scheme_current_inspector_proc))
00692       return 1;
00693   }
00694   return 0;
00695 }
00696 
00697 static int is_proc_spec_proc(Scheme_Object *p)
00698 {
00699   Scheme_Type vtype;
00700   
00701   if (SCHEME_PROCP(p)) {
00702     p = scheme_get_or_check_arity(p, -1);
00703     if (SCHEME_INTP(p)) {
00704       return (SCHEME_INT_VAL(p) >= 1);
00705     } else if (SCHEME_STRUCTP(p)
00706                && scheme_is_struct_instance(scheme_arity_at_least, p)) {
00707       p = ((Scheme_Structure *)p)->slots[0];
00708       if (SCHEME_INTP(p))
00709         return (SCHEME_INT_VAL(p) >= 1);
00710     }
00711     return 0;
00712   }
00713 
00714   vtype = SCHEME_TYPE(p);
00715 
00716   if (vtype == scheme_unclosed_procedure_type) {
00717     if (((Scheme_Closure_Data *)p)->num_params >= 1)
00718       return 1;
00719   }
00720 
00721   return 0;
00722 }
00723 
00724 static void note_match(int actual, int expected, Optimize_Info *warn_info)
00725 {
00726   if (!warn_info || (expected == -1))
00727     return;
00728 
00729   if (actual != expected) {
00730     scheme_log(NULL,
00731                SCHEME_LOG_WARNING,
00732                0,
00733                "warning%s: optimizer detects %d values produced when %d expected",
00734                scheme_optimize_context_to_string(warn_info->context),
00735                actual, expected);
00736   }
00737 }
00738 
00739 int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
00740                           Optimize_Info *warn_info)
00741      /* Checks whether the bytecode `o' returns `vals' values with no
00742         side-effects and without pushing and using continuation marks. 
00743         -1 for vals means that any return count is ok.
00744         Also used with fully resolved expression by `module' to check 
00745         for "functional" bodies. 
00746         If warn_info is supplied, complain when a mismatch is detected. */
00747 {
00748   Scheme_Type vtype;
00749 
00750   /* FIXME: can overflow the stack */
00751 
00752  try_again:
00753 
00754   vtype = SCHEME_TYPE(o);
00755 
00756   if ((vtype > _scheme_compiled_values_types_) 
00757       || ((vtype == scheme_local_type)
00758           && !(SCHEME_LOCAL_FLAGS(o) & SCHEME_LOCAL_CLEAR_ON_READ))
00759       || ((vtype == scheme_local_unbox_type)
00760           && !(SCHEME_LOCAL_FLAGS(o) & SCHEME_LOCAL_CLEAR_ON_READ))
00761       || (vtype == scheme_unclosed_procedure_type)
00762       || (vtype == scheme_compiled_unclosed_procedure_type)
00763       || (vtype == scheme_case_lambda_sequence_type)
00764       || (vtype == scheme_quote_syntax_type)
00765       || (vtype == scheme_compiled_quote_syntax_type)) {
00766     note_match(1, vals, warn_info);
00767     return ((vals == 1) || (vals < 0));
00768   }
00769 
00770   if (vtype == scheme_toplevel_type) {
00771     note_match(1, vals, warn_info);
00772     if (resolved && ((vals == 1) || (vals < 0))) {
00773       if (SCHEME_TOPLEVEL_FLAGS(o) 
00774           & (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY))
00775         return 1;
00776       else
00777         return 0;
00778     }
00779   }
00780 
00781   if (vtype == scheme_compiled_toplevel_type) {
00782     note_match(1, vals, warn_info);
00783     if ((vals == 1) || (vals < 0)) {
00784       if (SCHEME_TOPLEVEL_FLAGS(o) 
00785           & (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY))
00786         return 1;
00787       else
00788         return 0;
00789     }
00790   }
00791 
00792   if ((vtype == scheme_syntax_type)
00793       && (SCHEME_PINT_VAL(o) == CASE_LAMBDA_EXPD)) {
00794     note_match(1, vals, warn_info);
00795     return 1;
00796   }
00797 
00798   if ((vtype == scheme_compiled_quote_syntax_type)) {
00799     note_match(1, vals, warn_info);
00800     return ((vals == 1) || (vals < 0));
00801   }
00802 
00803   if ((vtype == scheme_branch_type)) {
00804     Scheme_Branch_Rec *b;
00805     b = (Scheme_Branch_Rec *)o;
00806     return (scheme_omittable_expr(b->test, 1, fuel - 1, resolved, warn_info)
00807            && scheme_omittable_expr(b->tbranch, vals, fuel - 1, resolved, warn_info)
00808            && scheme_omittable_expr(b->fbranch, vals, fuel - 1, resolved, warn_info));
00809   }
00810 
00811 #if 0
00812   /* We can't do this because a set! to a lexical is turned into
00813      a let_value_type! */
00814   if ((vtype == scheme_let_value_type)) {
00815     Scheme_Let_Value *lv = (Scheme_Let_Value *)o;
00816     return (scheme_omittable_expr(lv->value, lv->count, fuel - 1, resolved, warn_info)
00817            && scheme_omittable_expr(lv->body, vals, fuel - 1, resolved, warn_info));
00818   }
00819 #endif
00820 
00821   if ((vtype == scheme_let_one_type)) {
00822     Scheme_Let_One *lo = (Scheme_Let_One *)o;
00823     return (scheme_omittable_expr(lo->value, 1, fuel - 1, resolved, warn_info)
00824            && scheme_omittable_expr(lo->body, vals, fuel - 1, resolved, warn_info));
00825   }
00826 
00827   if ((vtype == scheme_let_void_type)) {
00828     Scheme_Let_Void *lv = (Scheme_Let_Void *)o;
00829     /* recognize (letrec ([x <omittable>]) ...): */
00830     if (SAME_TYPE(SCHEME_TYPE(lv->body), scheme_let_value_type)) {
00831       Scheme_Let_Value *lv2 = (Scheme_Let_Value *)lv->body;
00832       if ((lv2->count == 1)
00833           && (lv2->position == 0)
00834           && scheme_omittable_expr(lv2->value, 1, fuel - 1, resolved, warn_info))
00835         o = lv2->body;
00836       else
00837         o = lv->body;
00838     } else
00839       o = lv->body;
00840     goto try_again;
00841   }
00842 
00843   if ((vtype == scheme_compiled_let_void_type)) {
00844     /* recognize another (let ([x <omittable>]) ...) pattern: */
00845     Scheme_Let_Header *lh = (Scheme_Let_Header *)o;
00846     if ((lh->count == 1) && (lh->num_clauses == 1)) {
00847       if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) {
00848         Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
00849         if (scheme_omittable_expr(lv->value, 1, fuel - 1, resolved, warn_info)) {
00850           o = lv->body;
00851           goto try_again;
00852         }
00853       }
00854     }
00855   }
00856 
00857   if ((vtype == scheme_letrec_type)) {
00858     o = ((Scheme_Letrec *)o)->body;
00859     goto try_again;
00860   }
00861 
00862   if ((vtype == scheme_application_type)) {
00863     /* Look for multiple values, or for `make-struct-type'.
00864        (The latter is especially useful to Honu.) */
00865     Scheme_App_Rec *app = (Scheme_App_Rec *)o;
00866     if ((app->num_args >= 4) && (app->num_args <= 10)
00867         && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) {
00868       note_match(5, vals, warn_info);
00869       if ((vals == 5) || (vals < 0)) {
00870       /* Look for (make-struct-type sym #f non-neg-int non-neg-int [omitable null]) */
00871         if (SCHEME_SYMBOLP(app->args[1])
00872             && SCHEME_FALSEP(app->args[2])
00873             && SCHEME_INTP(app->args[3])
00874             && (SCHEME_INT_VAL(app->args[3]) >= 0)
00875             && SCHEME_INTP(app->args[4])
00876             && (SCHEME_INT_VAL(app->args[4]) >= 0)
00877             && ((app->num_args < 5)
00878                 || scheme_omittable_expr(app->args[5], 1, fuel - 1, resolved, warn_info))
00879             && ((app->num_args < 6)
00880                 || SCHEME_NULLP(app->args[6]))
00881             && ((app->num_args < 7)
00882                 || SCHEME_FALSEP(app->args[7])
00883                 || is_current_inspector_call(app->args[7]))
00884             && ((app->num_args < 8)
00885                 || SCHEME_FALSEP(app->args[8])
00886                 || is_proc_spec_proc(app->args[8]))
00887             && ((app->num_args < 9)
00888                 || SCHEME_NULLP(app->args[9]))) {
00889           return 1;
00890         }
00891       }
00892     }
00893     /* (values <omittable> ...) */
00894     if (SAME_OBJ(scheme_values_func, app->args[0])) {
00895       note_match(app->num_args, vals, warn_info);
00896       if ((app->num_args == vals) || (vals < 0)) {
00897        int i;
00898        for (i = app->num_args; i--; ) {
00899          if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info))
00900            return 0;
00901        }
00902        return 1;
00903       }
00904     }
00905     /* ({void,list,list*,vector,vector-immutable} <omittable> ...) */
00906     if (SAME_OBJ(scheme_void_proc, app->args[0])
00907         || SAME_OBJ(scheme_list_proc, app->args[0])
00908         || SAME_OBJ(scheme_list_star_proc, app->args[0])
00909         || SAME_OBJ(scheme_vector_proc, app->args[0])
00910         || SAME_OBJ(scheme_vector_immutable_proc, app->args[0])) {
00911       note_match(1, vals, warn_info);
00912       if ((vals == 1) || (vals < 0)) {
00913         int i;
00914        for (i = app->num_args; i--; ) {
00915          if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info))
00916            return 0;
00917        }
00918        return 1;
00919       }
00920     }
00921     return 0;
00922   }
00923 
00924   if ((vtype == scheme_application2_type)) {
00925     /* ({values,void,list,list*,vector,vector-immutable,box} <omittable>) */
00926     Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
00927     if (SAME_OBJ(scheme_values_func, app->rator)
00928         || SAME_OBJ(scheme_void_proc, app->rator)
00929         || SAME_OBJ(scheme_list_proc, app->rator)
00930         || SAME_OBJ(scheme_list_star_proc, app->rator)
00931         || SAME_OBJ(scheme_vector_proc, app->rator)
00932         || SAME_OBJ(scheme_vector_immutable_proc, app->rator)
00933         || SAME_OBJ(scheme_box_proc, app->rator)) {
00934       note_match(1, vals, warn_info);
00935       if ((vals == 1) || (vals < 0)) {
00936        if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info))
00937          return 1;
00938       }
00939     }
00940   }
00941 
00942   if ((vtype == scheme_application3_type)) {
00943     /* (values <omittable> <omittable>) */
00944     Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
00945     if (SAME_OBJ(scheme_values_func, app->rator)) {
00946       note_match(2, vals, warn_info);
00947       if ((vals == 2) || (vals < 0)) {
00948         if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info)
00949             && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info))
00950          return 1;
00951       }
00952     }
00953     /* ({void,cons,list,list*,vector,vector-immutable) <omittable> <omittable>) */
00954     if (SAME_OBJ(scheme_void_proc, app->rator)
00955         || SAME_OBJ(scheme_cons_proc, app->rator)
00956         || SAME_OBJ(scheme_mcons_proc, app->rator)
00957         || SAME_OBJ(scheme_list_proc, app->rator)
00958         || SAME_OBJ(scheme_list_star_proc, app->rator)
00959         || SAME_OBJ(scheme_vector_proc, app->rator)
00960         || SAME_OBJ(scheme_vector_immutable_proc, app->rator)) {
00961       note_match(1, vals, warn_info);
00962       if ((vals == 1) || (vals < 0)) {
00963        if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info)
00964            && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info))
00965          return 1;
00966       }
00967     }
00968   }
00969 
00970   return 0;
00971 }
00972 
00973 int scheme_is_compiled_procedure(Scheme_Object *o, int can_be_closed, int can_be_liftable)
00974 {
00975   if (SAME_TYPE(SCHEME_TYPE(o), scheme_compiled_unclosed_procedure_type)) {
00976     if (!can_be_closed || !can_be_liftable) {
00977       Scheme_Closure_Data *data;
00978       data = (Scheme_Closure_Data *)o;
00979       /* Because == 0 is like a constant */
00980       if (!can_be_closed && !data->closure_size)
00981         return 0;
00982       /* Because procs that reference only globals are lifted: */
00983       if (!can_be_liftable && (data->closure_size == 1) && scheme_closure_has_top_level(data))
00984         return 0;
00985     }
00986     return 1;
00987   } else
00988     return 0;
00989 }
00990 
00991 int scheme_get_eval_type(Scheme_Object *obj)
00992      /* Categories for short-cutting recursive calls to the evaluator */
00993 {
00994   Scheme_Type type;
00995 
00996   type = SCHEME_TYPE(obj);
00997 
00998   if (type > _scheme_values_types_)
00999     return SCHEME_EVAL_CONSTANT;
01000   else if (SAME_TYPE(type, scheme_local_type))
01001     return SCHEME_EVAL_LOCAL;
01002   else if (SAME_TYPE(type, scheme_local_unbox_type))
01003     return SCHEME_EVAL_LOCAL_UNBOX;
01004   else if (SAME_TYPE(type, scheme_toplevel_type))
01005     return SCHEME_EVAL_GLOBAL;
01006   else
01007     return SCHEME_EVAL_GENERAL;
01008 }    
01009 
01010 static Scheme_Object *try_apply(Scheme_Object *f, Scheme_Object *args, Scheme_Object *context)
01011      /* Apply `f' to `args' and ignore failues --- used for constant
01012         folding attempts */
01013 {
01014   Scheme_Object * volatile result;
01015   Scheme_Object * volatile exn = NULL;
01016   mz_jmp_buf *savebuf, newbuf;
01017 
01018   scheme_current_thread->reading_delayed = NULL;
01019   scheme_current_thread->constant_folding = (context ? context : scheme_true);
01020   savebuf = scheme_current_thread->error_buf;
01021   scheme_current_thread->error_buf = &newbuf;
01022 
01023   if (scheme_setjmp(newbuf)) {
01024     result = NULL;
01025     exn = scheme_current_thread->reading_delayed;
01026   } else
01027     result = _scheme_apply_to_list(f, args);
01028   
01029   scheme_current_thread->error_buf = savebuf;
01030   scheme_current_thread->constant_folding = NULL;
01031   scheme_current_thread->reading_delayed = NULL;
01032 
01033   if (scheme_current_thread->cjs.is_kill) {
01034     scheme_longjmp(*scheme_current_thread->error_buf, 1);
01035   }
01036 
01037   if (exn)
01038     scheme_raise(exn);
01039 
01040   return result;
01041 }
01042 
01043 static int foldable_body(Scheme_Object *f)
01044 {
01045   Scheme_Closure_Data *d;
01046   
01047   d = SCHEME_COMPILED_CLOS_CODE(f);
01048 
01049   scheme_delay_load_closure(d);
01050 
01051   return (SCHEME_TYPE(d->code) > _scheme_values_types_);
01052 }
01053 
01054 static Scheme_Object *make_application(Scheme_Object *v)
01055 {
01056   Scheme_Object *o;
01057   int i, nv;
01058   volatile int n;
01059 
01060   o = v;
01061   n = 0;
01062   nv = 0;
01063   while (!SCHEME_NULLP(o)) {
01064     Scheme_Type type;
01065     
01066     n++;
01067     type = SCHEME_TYPE(SCHEME_CAR(o));
01068     if (type < _scheme_compiled_values_types_)
01069       nv = 1;
01070     o = SCHEME_CDR(o);
01071   }
01072 
01073   if (!nv) {
01074     /* They're all values. Applying folding prim or closure? */
01075     Scheme_Object *f;
01076 
01077     f = SCHEME_CAR(v);
01078 
01079     if ((SCHEME_PRIMP(f) && ((((Scheme_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK)
01080                              == SCHEME_PRIM_OPT_FOLDING))
01081        || (SCHEME_CLSD_PRIMP(f) 
01082            && ((((Scheme_Closed_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK)
01083                 == SCHEME_PRIM_OPT_FOLDING))
01084        || (SAME_TYPE(SCHEME_TYPE(f), scheme_closure_type)
01085            && (foldable_body(f)))) {
01086       f = try_apply(f, SCHEME_CDR(v), scheme_false);
01087       
01088       if (f)
01089        return f;
01090     }
01091   }
01092 
01093   if (n == 2) {
01094     Scheme_App2_Rec *app;
01095 
01096     app = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
01097     app->iso.so.type = scheme_application2_type;
01098 
01099     app->rator = SCHEME_CAR(v);
01100     v = SCHEME_CDR(v);
01101     app->rand = SCHEME_CAR(v);
01102     
01103     return (Scheme_Object *)app;
01104   } else if (n == 3) {
01105     Scheme_App3_Rec *app;
01106 
01107     app = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
01108     app->iso.so.type = scheme_application3_type;
01109 
01110     app->rator = SCHEME_CAR(v);
01111     v = SCHEME_CDR(v);
01112     app->rand1 = SCHEME_CAR(v);
01113     v = SCHEME_CDR(v);
01114     app->rand2 = SCHEME_CAR(v);
01115 
01116     return (Scheme_Object *)app;
01117   } else {
01118     Scheme_App_Rec *app;
01119 
01120     app = scheme_malloc_application(n);
01121     
01122     for (i = 0; i < n; i++, v = SCHEME_CDR(v)) {
01123       app->args[i] = SCHEME_CAR(v);
01124     }
01125 
01126     return (Scheme_Object *)app;
01127   }
01128 }
01129 
01130 Scheme_App_Rec *scheme_malloc_application(int n)
01131 {
01132   Scheme_App_Rec *app;
01133   int size;
01134 
01135   size = (sizeof(Scheme_App_Rec) 
01136          + ((n - 1) * sizeof(Scheme_Object *))
01137          + n * sizeof(char));
01138   app = (Scheme_App_Rec *)scheme_malloc_tagged(size);
01139 
01140   app->so.type = scheme_application_type;
01141 
01142   app->num_args = n - 1;
01143 
01144   return app;
01145 }
01146 
01147 void scheme_finish_application(Scheme_App_Rec *app)
01148 {
01149   int i, devals, n;
01150 
01151   n = app->num_args + 1;
01152 
01153   devals = sizeof(Scheme_App_Rec) + (app->num_args * sizeof(Scheme_Object *));
01154 
01155   for (i = 0; i < n; i++) {
01156     char etype;
01157     etype = scheme_get_eval_type(app->args[i]);
01158     ((char *)app XFORM_OK_PLUS devals)[i] = etype;
01159   }
01160 }
01161 
01162 static Scheme_Object *check_converted_rator(Scheme_Object *rator, Resolve_Info *info, Scheme_Object **new_rator,
01163                                             int orig_arg_cnt, int *_rdelta)
01164 {
01165   Scheme_Object *lifted;
01166   int flags;
01167 
01168   if (!SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type))
01169     return NULL;
01170 
01171   (void)scheme_resolve_info_lookup(info, SCHEME_LOCAL_POS(rator), &flags, &lifted, orig_arg_cnt + 1);
01172 
01173   if (lifted && SCHEME_RPAIRP(lifted)) {
01174     Scheme_Object *vec, *arity;
01175 
01176     *new_rator = SCHEME_CAR(lifted);
01177     vec = SCHEME_CDR(lifted);
01178     *_rdelta = 0;
01179 
01180     if (SCHEME_VEC_SIZE(vec) > 1) {
01181       /* Check that actual argument count matches expected. If
01182          it doesn't, we need to generate explicit code to report
01183          the error, so that the conversion's arity change isn't
01184          visible. */
01185       arity = SCHEME_VEC_ELS(vec)[0];
01186       if (SCHEME_INTP(arity)) {
01187         if (orig_arg_cnt == SCHEME_INT_VAL(arity))
01188           arity = NULL;
01189       } else {
01190         arity = SCHEME_BOX_VAL(arity);
01191         if (orig_arg_cnt >= SCHEME_INT_VAL(arity))
01192           arity = NULL;
01193         else {
01194           Scheme_App2_Rec *app;
01195           app = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
01196           app->iso.so.type = scheme_application2_type;
01197           app->rator = scheme_make_arity_at_least;
01198           app->rand = arity;
01199           arity = (Scheme_Object *)app;
01200           *_rdelta = 1; /* so app gets resolved */
01201         }
01202       }
01203       /* If arity is non-NULL, there's a mismatch. */
01204       if (arity) {
01205         /* Generate a call to `raise-arity-error' instead of
01206            the current *new_rator: */
01207         Scheme_Object *old_rator = *new_rator;
01208         if (SAME_TYPE(SCHEME_TYPE(old_rator), scheme_toplevel_type)) {
01209           /* More coordinate trouble. old_rator was computed for an
01210              application with a potentially different number of arguments. */
01211           int delta;
01212           delta = 3 - SCHEME_VEC_SIZE(vec);
01213           if (delta)
01214             old_rator = scheme_shift_toplevel(old_rator, delta);
01215         }
01216         vec = scheme_make_vector(3, NULL);
01217         SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(0);
01218         SCHEME_VEC_ELS(vec)[1] = old_rator;
01219         SCHEME_VEC_ELS(vec)[2] = arity;
01220         *new_rator = scheme_raise_arity_error_proc;
01221       }
01222     }
01223 
01224     return vec;
01225   } else
01226     return NULL;
01227 }
01228 
01229 static Scheme_Object *resolve_application(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count)
01230 {
01231   Resolve_Info *info;
01232   Scheme_App_Rec *app;
01233   int i, n, devals;
01234 
01235   app = (Scheme_App_Rec *)o;
01236 
01237   n = app->num_args + 1;
01238 
01239   if (!already_resolved_arg_count) {
01240     /* Check whether this is an application of a converted closure: */
01241     Scheme_Object *additions = NULL, *rator;
01242     int rdelta;
01243     additions = check_converted_rator(app->args[0], orig_info, &rator, n - 1, &rdelta);
01244     if (additions) {
01245       /* Expand application with m arguments */
01246       Scheme_App_Rec *app2;
01247       Scheme_Object *loc;
01248       int m;
01249       m = SCHEME_VEC_SIZE(additions) - 1;
01250       app2 = scheme_malloc_application(n + m);
01251       for (i = 0; i < m; i++) {
01252         loc = SCHEME_VEC_ELS(additions)[i+1];
01253         if (SCHEME_BOXP(loc)) 
01254           loc = SCHEME_BOX_VAL(loc);
01255         app2->args[i + 1] = loc;
01256       }
01257       for (i = 1; i < n; i++) {
01258         app2->args[i + m] = app->args[i];
01259       }
01260       app2->args[0] = rator;
01261       n += m;
01262       app = app2;
01263       already_resolved_arg_count = m + 1 + rdelta;
01264     }
01265   }
01266 
01267   devals = sizeof(Scheme_App_Rec) + ((n - 1) * sizeof(Scheme_Object *));
01268   
01269   info = scheme_resolve_info_extend(orig_info, n - 1, 0, 0);
01270   
01271   for (i = 0; i < n; i++) {
01272     Scheme_Object *le;
01273     if (already_resolved_arg_count) {
01274       already_resolved_arg_count--;
01275     } else {
01276       le = scheme_resolve_expr(app->args[i], info);
01277       app->args[i] = le;
01278     }
01279   }
01280 
01281   info->max_let_depth += (n - 1);
01282   if (orig_info->max_let_depth < info->max_let_depth)
01283     orig_info->max_let_depth = info->max_let_depth;
01284 
01285   for (i = 0; i < n; i++) {
01286     char et;
01287     et = scheme_get_eval_type(app->args[i]);
01288     ((char *)app XFORM_OK_PLUS devals)[i] = et;
01289   }
01290 
01291   return (Scheme_Object *)app;
01292 }
01293 
01294 static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count);
01295 
01296 static void set_app2_eval_type(Scheme_App2_Rec *app)
01297 {
01298   short et;
01299 
01300   et = scheme_get_eval_type(app->rand);
01301   et = et << 3;
01302   et += scheme_get_eval_type(app->rator);
01303   
01304   SCHEME_APPN_FLAGS(app) = et;
01305 }
01306 
01307 void scheme_reset_app2_eval_type(Scheme_App2_Rec *app)
01308 {
01309   set_app2_eval_type(app);
01310 }
01311 
01312 static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count)
01313 {
01314   Resolve_Info *info;
01315   Scheme_App2_Rec *app;
01316   Scheme_Object *le;
01317 
01318   app = (Scheme_App2_Rec *)o;
01319 
01320   if (!already_resolved_arg_count) {
01321     /* Check whether this is an application of a converted closure: */
01322     Scheme_Object *additions = NULL, *rator;
01323     int rdelta;
01324     additions = check_converted_rator(app->rator, orig_info, &rator, 1, &rdelta);
01325     if (additions) {
01326       int m;
01327       m = SCHEME_VEC_SIZE(additions) - 1;
01328       if (!m) {
01329         app->rator = rator;
01330         already_resolved_arg_count = 1 + rdelta;
01331       } else if (m > 1) {
01332         /* Expand application with m arguments */
01333         Scheme_App_Rec *app2;
01334         Scheme_Object *loc;
01335         int i;
01336         app2 = scheme_malloc_application(2 + m);
01337         for (i = 0; i < m; i++) {
01338           loc = SCHEME_VEC_ELS(additions)[i+1];
01339           if (SCHEME_BOXP(loc))
01340             loc = SCHEME_BOX_VAL(loc);
01341           app2->args[i + 1] = loc;
01342         }
01343         app2->args[0] = rator;
01344         app2->args[m+1] = app->rand;
01345         return resolve_application((Scheme_Object *)app2, orig_info, m + 1 + rdelta);
01346       } else {
01347         Scheme_App3_Rec *app2;
01348         Scheme_Object *loc;
01349         app2 = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
01350         app2->iso.so.type = scheme_application3_type;
01351         app2->rator = rator;
01352         loc = SCHEME_VEC_ELS(additions)[1];
01353         if (SCHEME_BOXP(loc))
01354           loc = SCHEME_BOX_VAL(loc);
01355         app2->rand1 = loc;
01356         app2->rand2 = app->rand;
01357         return resolve_application3((Scheme_Object *)app2, orig_info, 2 + rdelta);
01358       }
01359     }
01360   }
01361 
01362   info = scheme_resolve_info_extend(orig_info, 1, 0, 0);
01363 
01364   if (!already_resolved_arg_count) {
01365     le = scheme_resolve_expr(app->rator, info);
01366     app->rator = le;
01367   } else
01368     already_resolved_arg_count--;
01369 
01370   if (!already_resolved_arg_count) {
01371     le = scheme_resolve_expr(app->rand, info);
01372     app->rand = le;
01373   } else
01374     already_resolved_arg_count--;
01375 
01376   info->max_let_depth += 1;
01377   if (orig_info->max_let_depth < info->max_let_depth)
01378     orig_info->max_let_depth = info->max_let_depth;
01379 
01380   set_app2_eval_type(app);
01381         
01382   return (Scheme_Object *)app;
01383 }
01384 
01385 static int eq_testable_constant(Scheme_Object *v)
01386 {
01387   if (SCHEME_SYMBOLP(v)
01388       || SCHEME_FALSEP(v)
01389       || SAME_OBJ(v, scheme_true)
01390       || SCHEME_VOIDP(v))
01391     return 1;
01392 
01393   if (SCHEME_CHARP(v) && (SCHEME_CHAR_VAL(v) < 256))
01394     return 1;
01395 
01396   if (SCHEME_INTP(v) 
01397       && (SCHEME_INT_VAL(v) < (1 << 29))
01398       && (SCHEME_INT_VAL(v) > -(1 << 29)))
01399     return 1;
01400 
01401   return 0;
01402 }
01403 
01404 static void set_app3_eval_type(Scheme_App3_Rec *app)
01405 {
01406   short et;
01407 
01408   et = scheme_get_eval_type(app->rand2);
01409   et = et << 3;
01410   et += scheme_get_eval_type(app->rand1);
01411   et = et << 3;
01412   et += scheme_get_eval_type(app->rator);
01413   
01414   SCHEME_APPN_FLAGS(app) = et;
01415 }
01416 
01417 static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count)
01418 {
01419   Resolve_Info *info;
01420   Scheme_App3_Rec *app;
01421   Scheme_Object *le;
01422 
01423   app = (Scheme_App3_Rec *)o;
01424 
01425   if (!already_resolved_arg_count) {
01426     /* Check whether this is an application of a converted closure: */
01427     Scheme_Object *additions = NULL, *rator;
01428     int rdelta;
01429     additions = check_converted_rator(app->rator, orig_info, &rator, 2, &rdelta);
01430     if (additions) {
01431       int m, i;
01432       m = SCHEME_VEC_SIZE(additions) - 1;
01433       if (m) {
01434         /* Expand application with m arguments */
01435         Scheme_App_Rec *app2;
01436         Scheme_Object *loc;
01437         app2 = scheme_malloc_application(3 + m);
01438         for (i = 0; i < m; i++) {
01439           loc = SCHEME_VEC_ELS(additions)[i+1];
01440           if (SCHEME_BOXP(loc))
01441             loc = SCHEME_BOX_VAL(loc);
01442           app2->args[i + 1] = loc;
01443         }
01444         app2->args[0] = rator;
01445         app2->args[m+1] = app->rand1;
01446         app2->args[m+2] = app->rand2;
01447         return resolve_application((Scheme_Object *)app2, orig_info, m + 1 + rdelta);
01448       } else {
01449         app->rator = rator;
01450         already_resolved_arg_count = 1 + rdelta;
01451       }
01452     }
01453   }
01454 
01455   info = scheme_resolve_info_extend(orig_info, 2, 0, 0);
01456 
01457   if (already_resolved_arg_count) {
01458     already_resolved_arg_count--;
01459   } else {
01460     le = scheme_resolve_expr(app->rator, info);
01461     app->rator = le;
01462   }
01463 
01464   if (already_resolved_arg_count) {
01465     already_resolved_arg_count--;
01466   } else {
01467     le = scheme_resolve_expr(app->rand1, info);
01468     app->rand1 = le;
01469   }
01470 
01471   if (already_resolved_arg_count) {
01472     already_resolved_arg_count--;
01473   } else {
01474     le = scheme_resolve_expr(app->rand2, info);
01475     app->rand2 = le;
01476   }
01477 
01478   /* Optimize `equal?' or `eqv?' test on certain types
01479      to `eq?'. This is especially helpful for the JIT. */
01480   if ((SAME_OBJ(app->rator, scheme_equal_prim)
01481        || SAME_OBJ(app->rator, scheme_eqv_prim))
01482       && (eq_testable_constant(app->rand1)
01483          || eq_testable_constant(app->rand2))) {
01484     app->rator = scheme_eq_prim;
01485   }
01486 
01487   set_app3_eval_type(app);
01488 
01489   info->max_let_depth += 2;
01490   if (orig_info->max_let_depth < info->max_let_depth)
01491     orig_info->max_let_depth = info->max_let_depth;
01492 
01493   return (Scheme_Object *)app;
01494 }
01495 
01496 Scheme_Object *
01497 scheme_make_branch(Scheme_Object *test, Scheme_Object *thenp,
01498                  Scheme_Object *elsep)
01499 {
01500   Scheme_Branch_Rec *b;
01501 
01502   if (SCHEME_TYPE(test) > _scheme_compiled_values_types_) {
01503     if (SCHEME_FALSEP(test))
01504       return elsep;
01505     else
01506       return thenp;
01507   }
01508 
01509   b = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
01510   b->so.type = scheme_branch_type;
01511 
01512   b->test = test;
01513   b->tbranch = thenp;
01514   b->fbranch = elsep;
01515 
01516   return (Scheme_Object *)b;
01517 }
01518 
01519 static Scheme_Object *resolve_branch(Scheme_Object *o, Resolve_Info *info)
01520 {
01521   Scheme_Branch_Rec *b;
01522   Scheme_Object *t, *tb, *fb;
01523 
01524   b = (Scheme_Branch_Rec *)o;
01525 
01526   t = scheme_resolve_expr(b->test, info);
01527   tb = scheme_resolve_expr(b->tbranch, info);
01528   fb = scheme_resolve_expr(b->fbranch, info);
01529 
01530   b->test = t;
01531   b->tbranch = tb;
01532   b->fbranch = fb;
01533 
01534   return o;
01535 }
01536 
01537 static Scheme_Object *resolve_wcm(Scheme_Object *o, Resolve_Info *info)
01538 {
01539   Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
01540   Scheme_Object *k, *v, *b;
01541 
01542   k = scheme_resolve_expr(wcm->key, info);
01543   v = scheme_resolve_expr(wcm->val, info);
01544   b = scheme_resolve_expr(wcm->body, info);
01545   wcm->key = k;
01546   wcm->val = v;
01547   wcm->body = b;
01548 
01549   return (Scheme_Object *)wcm;
01550 }
01551 
01552 static Scheme_Sequence *malloc_sequence(int count)
01553 {
01554   return (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence)
01555                                            + (count - 1) 
01556                                            * sizeof(Scheme_Object *));
01557 }
01558 
01559 Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
01560 {
01561   /* We have to be defensive in processing `seq'; it might be bad due
01562      to a bad .zo */
01563   Scheme_Object *list, *v, *good;
01564   Scheme_Sequence *o;
01565   int count, i, k, total, last, first, setgood, addconst;
01566   Scheme_Type type;
01567 
01568   type = scheme_sequence_type;
01569 
01570   list = seq;
01571   count = i = 0;
01572   good = NULL;
01573   total = 0;
01574   first = 1;
01575   setgood = 1;
01576   while (SCHEME_PAIRP(list)) {
01577     v = SCHEME_CAR(list);
01578     list = SCHEME_CDR(list);
01579     last = SCHEME_NULLP(list);
01580 
01581     if (((opt > 0) || !first) && SAME_TYPE(SCHEME_TYPE(v), type)) {
01582       /* "Inline" nested begins */
01583       count += ((Scheme_Sequence *)v)->count;
01584       total++;
01585     } else if (opt 
01586               && (((opt > 0) && !last) || ((opt < 0) && !first))
01587               && scheme_omittable_expr(v, -1, -1, 0, NULL)) {
01588       /* A value that is not the result. We'll drop it. */
01589       total++;
01590     } else {
01591       if (setgood)
01592        good = v;
01593       count++;
01594       total++;
01595     }
01596     i++;
01597     if (first) {
01598       if (opt < 0)
01599        setgood = 0;
01600       first = 0;
01601     }
01602   }
01603 
01604   if (!SCHEME_NULLP(list))
01605     return NULL; /* bad .zo */
01606 
01607   if (!count)
01608     return scheme_compiled_void();
01609   
01610   if (count == 1) {
01611     if (opt < -1) {
01612       /* can't optimize away a begin0 at read time; it's too late, since the
01613          return is combined with EXPD_BEGIN0 */
01614       addconst = 1;
01615     } else if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1, 0, NULL)) {
01616       /* We can't optimize (begin0 expr cont) to expr because
01617         exp is not in tail position in the original (so we'd mess
01618         up continuation marks). */
01619       addconst = 1;
01620     } else
01621       return good;
01622   } else
01623     addconst = 0;
01624 
01625   o = malloc_sequence(count + addconst);
01626 
01627   o->so.type = ((opt < 0) ? scheme_begin0_sequence_type : scheme_sequence_type);
01628   o->count = count + addconst;
01629   
01630   --total;
01631   for (i = k = 0; i < count; k++) {
01632     v = SCHEME_CAR(seq);
01633     seq = SCHEME_CDR(seq);
01634 
01635     if (((opt > 0) || k) && SAME_TYPE(SCHEME_TYPE(v), type)) {
01636       int c, j;
01637       Scheme_Object **a;
01638 
01639       c = ((Scheme_Sequence *)v)->count;
01640       a = ((Scheme_Sequence *)v)->array; /* <-- mismaligned for precise GC */
01641       for (j = 0; j < c; j++) {
01642        o->array[i++] = a[j];
01643       }
01644     } else if (opt 
01645               && (((opt > 0) && (k < total))
01646                  || ((opt < 0) && k))
01647               && scheme_omittable_expr(v, -1, -1, 0, NULL)) {
01648       /* Value not the result. Do nothing. */
01649     } else
01650       o->array[i++] = v;
01651   }
01652 
01653   if (addconst)
01654     o->array[i] = scheme_make_integer(0);
01655   
01656   return (Scheme_Object *)o;
01657 }
01658 
01659 static Scheme_Object *look_for_letv_change(Scheme_Sequence *s)
01660 {
01661   int i;
01662 
01663   /* Change (begin e1 ... (set!-for-let [x 10] (void)) e2 ...)
01664      to (begin e1 ... (set!-for-let [x 10] e2 ...)), which 
01665      avoids an unneeded recursive call in the evaluator */
01666 
01667   for (i = 0; i < s->count - 1; i++) {
01668     Scheme_Object *v;
01669     v = s->array[i];
01670     if (SAME_TYPE(SCHEME_TYPE(v), scheme_let_value_type)) {
01671       Scheme_Let_Value *lv = (Scheme_Let_Value *)v;
01672       if (scheme_omittable_expr(lv->body, 1, -1, 0, NULL)) {
01673        int esize = s->count - (i + 1);
01674        int nsize = i + 1;
01675        Scheme_Object *nv, *ev;
01676 
01677        if (nsize > 1) {
01678          Scheme_Sequence *naya;
01679 
01680          naya = malloc_sequence(nsize);
01681          naya->so.type = scheme_sequence_type;
01682          naya->count = nsize;
01683          nv = (Scheme_Object *)naya;
01684 
01685          for (i = 0; i < nsize; i++) {
01686            naya->array[i] = s->array[i];
01687          }
01688        } else
01689          nv = (Scheme_Object *)lv;
01690 
01691        if (esize > 1) {
01692          Scheme_Sequence *e;
01693          e = malloc_sequence(esize);
01694          e->so.type = scheme_sequence_type;
01695          e->count = esize;
01696 
01697          for (i = 0; i < esize; i++) {
01698            e->array[i] = s->array[i + nsize];
01699          }
01700 
01701          ev = (Scheme_Object *)look_for_letv_change(e);
01702        } else
01703          ev = s->array[nsize]; 
01704 
01705        lv->body = ev;
01706 
01707        return nv;
01708       }
01709     }
01710   }
01711 
01712   return (Scheme_Object *)s;
01713 }
01714 
01715 static Scheme_Object *resolve_sequence(Scheme_Object *o, Resolve_Info *info)
01716 {
01717   Scheme_Sequence *s = (Scheme_Sequence *)o;
01718   int i;
01719 
01720   for (i = s->count; i--; ) {
01721     Scheme_Object *le;
01722     le = scheme_resolve_expr(s->array[i], info);
01723     s->array[i] = le;
01724   }
01725   
01726   return look_for_letv_change(s);
01727 }
01728 
01729 Scheme_Object *scheme_make_syntax_resolved(int idx, Scheme_Object *data)
01730 {
01731   Scheme_Object *v;
01732 
01733   v = scheme_alloc_object();
01734   v->type = scheme_syntax_type;
01735   SCHEME_PINT_VAL(v) = idx;
01736   SCHEME_IPTR_VAL(v) = (void *)data;
01737 
01738   return v;
01739 }
01740 
01741 Scheme_Object *scheme_make_syntax_compiled(int idx, Scheme_Object *data)
01742 {
01743   Scheme_Object *v;
01744 
01745   v = scheme_alloc_object();
01746   v->type = scheme_compiled_syntax_type;
01747   SCHEME_PINT_VAL(v) = idx;
01748   SCHEME_IPTR_VAL(v) = (void *)data;
01749 
01750   return v;  
01751 }
01752 
01753 static Scheme_Object *link_module_variable(Scheme_Object *modidx,
01754                                       Scheme_Object *varname,
01755                                       int check_access, Scheme_Object *insp,
01756                                       int pos, int mod_phase,
01757                                       Scheme_Env *env, 
01758                                            Scheme_Object **exprs, int which)
01759 {
01760   Scheme_Object *modname;
01761   Scheme_Env *menv;
01762   int self = 0;
01763 
01764   /* If it's a name id, resolve the name. */
01765   modname = scheme_module_resolve(modidx, 1);
01766 
01767   if (env->module && SAME_OBJ(env->module->modname, modname)
01768       && (env->mod_phase == mod_phase)) {
01769     self = 1;
01770     menv = env;
01771   } else {
01772     menv = scheme_module_access(modname, env, mod_phase);
01773     
01774     if (!menv && env->phase) {
01775       /* The failure might be due a laziness in required-syntax
01776         execution. Force all laziness at the prior level 
01777         and try again. */
01778       scheme_module_force_lazy(env, 1);
01779       menv = scheme_module_access(modname, env, mod_phase);
01780     }
01781     
01782     if (!menv) {
01783       scheme_wrong_syntax("link", NULL, varname,
01784                        "namespace mismatch; reference (phase %d) to a module"
01785                           " %D that is not available (phase level %d); reference"
01786                        " appears in module: %D", 
01787                        env->phase,
01788                           modname,
01789                           mod_phase,
01790                           env->module ? env->module->modname : scheme_false);
01791       return NULL;
01792     }
01793 
01794     if (check_access && !SAME_OBJ(menv, env)) {
01795       varname = scheme_check_accessible_in_module(menv, insp, NULL, varname, NULL, NULL, 
01796                                                   insp, NULL, pos, 0, NULL, NULL, env, NULL);
01797     }
01798   }
01799 
01800   if (exprs) {
01801     if (self) {
01802       exprs[which] = varname;
01803     } else {
01804       if (mod_phase != 0)
01805         modname = scheme_make_pair(modname, scheme_make_integer(mod_phase));
01806       modname = scheme_make_pair(varname, modname);
01807       exprs[which] = modname;
01808     }
01809   }
01810 
01811   return (Scheme_Object *)scheme_global_bucket(varname, menv);
01812 }
01813 
01814 static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env *env,
01815                                     Scheme_Object *src_modidx, 
01816                                     Scheme_Object *dest_modidx)
01817 {
01818   Scheme_Object *expr = exprs[which];
01819 
01820   if (SCHEME_FALSEP(expr)) {
01821     /* See scheme_make_environment_dummy */
01822     return (Scheme_Object *)scheme_global_bucket(begin_symbol, env);
01823   } else if (SCHEME_PAIRP(expr) || SCHEME_SYMBOLP(expr)) {
01824     /* Simplified module reference */
01825     Scheme_Object *modname, *varname;
01826     int mod_phase = 0;
01827     if (SCHEME_SYMBOLP(expr)) {
01828       varname = expr;
01829       modname = env->module->modname;
01830       mod_phase = env->mod_phase;
01831     } else {
01832       varname = SCHEME_CAR(expr);
01833       modname = SCHEME_CDR(expr);
01834       if (SCHEME_PAIRP(modname)) {
01835         mod_phase = SCHEME_INT_VAL(SCHEME_CDR(modname));
01836         modname = SCHEME_CAR(modname);
01837       }
01838     }
01839     return link_module_variable(modname,
01840                                 varname,
01841                                 0, NULL,
01842                                 -1, mod_phase,
01843                                 env, 
01844                                 NULL, 0);
01845   } else if (SAME_TYPE(SCHEME_TYPE(expr), scheme_variable_type)) {
01846     Scheme_Bucket_With_Home *b = (Scheme_Bucket_With_Home *)expr;
01847     
01848     if (!env || !b->home->module)
01849       return (Scheme_Object *)b;
01850     else
01851       return link_module_variable(b->home->module->modname,
01852                               (Scheme_Object *)b->bucket.bucket.key,
01853                               1, b->home->module->insp,
01854                               -1, b->home->mod_phase,
01855                               env, 
01856                                   exprs, which);
01857   } else {
01858     Module_Variable *mv = (Module_Variable *)expr;
01859     
01860     return link_module_variable(scheme_modidx_shift(mv->modidx,
01861                                                     src_modidx,
01862                                                     dest_modidx),
01863                             mv->sym, 1, mv->insp,
01864                             mv->pos, mv->mod_phase,
01865                             env,
01866                                 exprs, which);
01867   }
01868 }
01869 
01870 static Scheme_Object *resolve_k(void)
01871 {
01872   Scheme_Thread *p = scheme_current_thread;
01873   Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1;
01874   Resolve_Info *info = (Resolve_Info *)p->ku.k.p2;
01875 
01876   p->ku.k.p1 = NULL;
01877   p->ku.k.p2 = NULL;
01878 
01879   return scheme_resolve_expr(expr, info);
01880 }
01881 
01882 Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info)
01883 {
01884   Scheme_Type type = SCHEME_TYPE(expr);
01885 
01886 #ifdef DO_STACK_CHECK
01887 # include "mzstkchk.h"
01888   {
01889     Scheme_Thread *p = scheme_current_thread;
01890 
01891     p->ku.k.p1 = (void *)expr;
01892     p->ku.k.p2 = (void *)info;
01893 
01894     return scheme_handle_stack_overflow(resolve_k);
01895   }
01896 #endif
01897 
01898   switch (type) {
01899   case scheme_local_type:
01900     {
01901       int pos, flags;
01902       Scheme_Object *lifted;
01903       
01904       pos = scheme_resolve_info_lookup(info, SCHEME_LOCAL_POS(expr), &flags, &lifted, 0);
01905       if (lifted) {
01906         /* Lexical reference replaced with top-level reference for a lifted value: */
01907         return lifted;
01908       } else {
01909         return scheme_make_local((flags & SCHEME_INFO_BOXED) 
01910                                  ? scheme_local_unbox_type
01911                                  : scheme_local_type,
01912                                  pos,
01913                                  0);
01914       }
01915     }
01916   case scheme_compiled_syntax_type:
01917     {
01918       Scheme_Syntax_Resolver f;
01919          
01920       f = scheme_syntax_resolvers[SCHEME_PINT_VAL(expr)];
01921       return f((Scheme_Object *)SCHEME_IPTR_VAL(expr), info);
01922     }
01923   case scheme_application_type:
01924     return resolve_application(expr, info, 0);
01925   case scheme_application2_type:
01926     return resolve_application2(expr, info, 0);
01927   case scheme_application3_type:
01928     return resolve_application3(expr, info, 0);
01929   case scheme_sequence_type:
01930     return resolve_sequence(expr, info);
01931   case scheme_branch_type:
01932     return resolve_branch(expr, info);
01933   case scheme_with_cont_mark_type:
01934     return resolve_wcm(expr, info);
01935   case scheme_compiled_unclosed_procedure_type:
01936     return scheme_resolve_closure_compilation(expr, info, 1, 0, 0, NULL);
01937   case scheme_compiled_let_void_type:
01938     return scheme_resolve_lets(expr, info);
01939   case scheme_compiled_toplevel_type:
01940     return scheme_resolve_toplevel(info, expr, 1);
01941   case scheme_compiled_quote_syntax_type:
01942     {
01943       Scheme_Quote_Syntax *qs;
01944       int i, c, p;
01945 
01946       i = SCHEME_LOCAL_POS(expr);
01947       i = scheme_resolve_quote_syntax_offset(i, info);
01948       c = scheme_resolve_toplevel_pos(info);
01949       p = scheme_resolve_quote_syntax_pos(info);
01950 
01951       qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax);
01952       qs->so.type = scheme_quote_syntax_type;
01953       qs->depth = c;
01954       qs->position = i;
01955       qs->midpoint = p;
01956 
01957       return (Scheme_Object *)qs;
01958     }
01959   case scheme_variable_type:
01960   case scheme_module_variable_type:
01961     scheme_signal_error("got top-level in wrong place");
01962     return 0;
01963   default:
01964     return expr;
01965   }
01966 }
01967 
01968 Scheme_Object *scheme_resolve_list(Scheme_Object *expr, Resolve_Info *info)
01969 {
01970   Scheme_Object *first = scheme_null, *last = NULL;
01971 
01972   while (SCHEME_PAIRP(expr)) {
01973     Scheme_Object *pr;
01974 
01975     pr = scheme_make_pair(scheme_resolve_expr(SCHEME_CAR(expr), info),
01976                        scheme_null);
01977 
01978     if (last)
01979       SCHEME_CDR(last) = pr;
01980     else
01981       first = pr;
01982     last = pr;
01983 
01984     expr = SCHEME_CDR(expr);
01985   }
01986 
01987   return first;
01988 }
01989 
01990 /*========================================================================*/
01991 /*                               uncompile                                */
01992 /*========================================================================*/
01993 
01994 #if 0
01995 
01996 /* For debugging, currently incomplete: */
01997 
01998 static Scheme_Object *uncompile(int argc, Scheme_Object *argv[]);
01999 Scheme_Object *scheme_uncompile_expr(Scheme_Object *expr, Resolve_Prefix *prefix);
02000 
02001 static Scheme_Object *uncompile_k()
02002 {
02003   Scheme_Thread *p = scheme_current_thread;
02004   Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1;
02005   Resolve_Prefix *prefix = (Resolve_Prefix *)p->ku.k.p2;
02006 
02007   p->ku.k.p1 = NULL;
02008   p->ku.k.p2 = NULL;
02009 
02010   return scheme_uncompile_expr(expr, prefix);
02011 }
02012 
02013 Scheme_Object *scheme_uncompile_expr(Scheme_Object *expr, Resolve_Prefix *prefix)
02014 {
02015   char buf[32];
02016 
02017 #ifdef DO_STACK_CHECK
02018 # include "mzstkchk.h"
02019   {
02020     Scheme_Thread *p = scheme_current_thread;
02021 
02022     p->ku.k.p1 = (void *)expr;
02023     p->ku.k.p2 = (void *)prefix;
02024 
02025     return scheme_handle_stack_overflow(uncompile_k);
02026   }
02027 #endif
02028 
02029   switch (SCHEME_TYPE(expr)) {
02030   case scheme_toplevel_type:
02031     {
02032       expr = prefix->toplevels[SCHEME_TOPLEVEL_POS(expr)];
02033       if (SAME_TYPE(SCHEME_TYPE(expr), scheme_variable_type)) {
02034        return cons(scheme_intern_symbol("#%top"),
02035                   (Scheme_Object *)((Scheme_Bucket *)expr)->key);
02036       } else {
02037        Module_Variable *mv = (Module_Variable *)expr;
02038 
02039        return cons(scheme_intern_symbol("#%top"),
02040                   cons(mv->modidx, mv->sym));
02041       }
02042     }
02043   case scheme_local_type:
02044     {
02045       sprintf(buf, "@%d", SCHEME_LOCAL_POS(expr));
02046       return scheme_intern_symbol(buf);
02047     }
02048   case scheme_local_unbox_type:
02049     {
02050       sprintf(buf, "@!%d", SCHEME_LOCAL_POS(expr));
02051       return scheme_intern_symbol(buf);
02052     }
02053   case scheme_compiled_syntax_type:
02054     {
02055       return scheme_void;
02056     }
02057   case scheme_application_type:
02058     {
02059       Scheme_App_Rec *app = (Scheme_App_Rec *)expr;
02060       int i;
02061       expr = scheme_null;
02062       for (i = app->num_args + 1; i--; ) {
02063        expr = cons(scheme_uncompile_expr(app->args[i], prefix),
02064                   expr);
02065       }
02066       return expr;
02067     }
02068   case scheme_application2_type:
02069     {
02070       Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr;
02071       return cons(scheme_uncompile_expr(app->rator, prefix),
02072                 cons(scheme_uncompile_expr(app->rand, prefix),
02073                      scheme_null));
02074     }
02075   case scheme_application3_type:
02076     {
02077       Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr;
02078       return cons(scheme_uncompile_expr(app->rator, prefix),
02079                 cons(scheme_uncompile_expr(app->rand1, prefix),
02080                      cons(scheme_uncompile_expr(app->rand2, prefix),
02081                          scheme_null)));
02082     }
02083   case scheme_sequence_type:
02084   case scheme_branch_type:
02085   case scheme_with_cont_mark_type:
02086     return scheme_void;
02087   case scheme_let_value_type:
02088     {
02089       Scheme_Let_Value *lv = (Scheme_Let_Value *)expr;
02090       sprintf(buf, "@%d", lv->position);
02091       return cons(scheme_intern_symbol("let!"),
02092                 cons(scheme_make_integer(lv->count),
02093                      cons(scheme_intern_symbol(buf),
02094                          cons(scheme_uncompile_expr(lv->value, prefix),
02095                              cons(scheme_uncompile_expr(lv->body, prefix),
02096                                   scheme_null)))));
02097     }
02098   case scheme_let_void_type:
02099     {
02100       Scheme_Let_Void *lv = (Scheme_Let_Void *)expr;
02101       return cons(scheme_intern_symbol("let-undefined"),
02102                 cons(scheme_make_integer(lv->count),
02103                      cons(scheme_uncompile_expr(lv->body, prefix),
02104                          scheme_null)));
02105     }
02106   case scheme_letrec_type:
02107     {
02108       Scheme_Letrec *lr = (Scheme_Letrec *)expr;
02109       int i;
02110 
02111       expr = scheme_null;
02112       for (i = lr->count; i--; ) {
02113        sprintf(buf, "@%d", i);
02114        expr = cons(cons(scheme_intern_symbol(buf),
02115                       cons(scheme_uncompile_expr(lr->procs[i], prefix),
02116                            scheme_null)),
02117                   expr);
02118       }
02119       
02120       return cons(scheme_intern_symbol("letrec!"),
02121                 cons(expr,
02122                      cons(scheme_uncompile_expr(lr->body, prefix),
02123                          scheme_null)));
02124     }
02125   case scheme_let_one_type:
02126     {
02127       Scheme_Let_One *lo = (Scheme_Let_One *)expr;
02128       return cons(scheme_intern_symbol("let"),
02129                 cons(scheme_uncompile_expr(lo->value, prefix),
02130                      cons(scheme_uncompile_expr(lo->body, prefix),
02131                          scheme_null)));
02132     }
02133   case scheme_unclosed_procedure_type:
02134     {
02135       Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr;
02136       Scheme_Object *vec;
02137       int i;
02138       vec = scheme_make_vector(data->closure_size, NULL);
02139       for (i = data->closure_size; i--; ) {
02140        SCHEME_VEC_ELS(vec)[i] = scheme_make_integer(data->closure_map[i]);
02141       }
02142       return cons(scheme_intern_symbol((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? "lambda*" : "lambda"),
02143                 cons(data->name ? data->name : scheme_false,
02144                      cons(scheme_make_integer(data->num_params),
02145                          cons(vec,
02146                              cons(scheme_uncompile_expr(data->code, prefix),
02147                                   scheme_null)))));
02148     }
02149   default:
02150     if (SCHEME_CLOSUREP(expr)) {
02151       return scheme_uncompile_expr((Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(expr), prefix);
02152     }
02153     return cons(scheme_intern_symbol("quote"), cons(expr, scheme_null));
02154   }
02155 }
02156 
02157 static Scheme_Object *
02158 uncompile(int argc, Scheme_Object *argv[])
02159 {
02160   Scheme_Compilation_Top *t;
02161 
02162   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_compilation_top_type))
02163     scheme_wrong_type("compiled->datum", "compiled code", 0, argc, argv);
02164 
02165   t = (Scheme_Compilation_Top *)argv[0];
02166 
02167   return scheme_uncompile_expr(t->code, t->prefix);
02168 }
02169 
02170 #endif
02171 
02172 /*========================================================================*/
02173 /*                               optimize                                 */
02174 /*========================================================================*/
02175 
02176 static Scheme_Object *try_optimize_fold(Scheme_Object *f, Scheme_Object *o, Optimize_Info *info)
02177 {
02178   if ((SCHEME_PRIMP(f) 
02179        && ((((Scheme_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK)
02180            == SCHEME_PRIM_OPT_FOLDING))
02181       || (SCHEME_CLSD_PRIMP(f) 
02182          && ((((Scheme_Closed_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK)
02183               == SCHEME_PRIM_OPT_FOLDING))) {
02184     Scheme_Object *args;
02185     
02186     switch (SCHEME_TYPE(o)) {
02187     case scheme_application_type:
02188       {
02189        Scheme_App_Rec *app = (Scheme_App_Rec *)o;
02190        int i;
02191        
02192        args = scheme_null;
02193        for (i = app->num_args; i--; ) {
02194          args = scheme_make_pair(app->args[i + 1], args);
02195        }
02196       }
02197       break;
02198     case scheme_application2_type:
02199       {
02200        Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
02201        args = scheme_make_pair(app->rand, scheme_null);
02202       }
02203       break;
02204     case scheme_application3_type:
02205     default:
02206       {
02207        Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
02208        args = scheme_make_pair(app->rand1, 
02209                             scheme_make_pair(app->rand2,
02210                                            scheme_null));
02211       }
02212       break;
02213     }
02214     
02215     return try_apply(f, args, info->context);
02216   }
02217   
02218   return NULL;
02219 }
02220 
02221 static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data, Optimize_Info *info,
02222                                 int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3)
02223 {
02224   Scheme_Let_Header *lh;
02225   Scheme_Compiled_Let_Value *lv, *prev = NULL;
02226   int i;
02227   int *flags, flag;
02228 
02229   if (!argc) {
02230     info = scheme_optimize_info_add_frame(info, 0, 0, 0);
02231     info->inline_fuel >>= 1;
02232     p = scheme_optimize_expr(p, info);
02233     info->next->single_result = info->single_result;
02234     info->next->preserves_marks = info->preserves_marks;
02235     scheme_optimize_info_done(info);
02236     return p;
02237   }
02238 
02239   lh = MALLOC_ONE_TAGGED(Scheme_Let_Header);
02240   lh->iso.so.type = scheme_compiled_let_void_type;
02241   lh->count = argc;
02242   lh->num_clauses = argc;
02243 
02244   for (i = 0; i < argc; i++) {
02245     lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
02246     lv->so.type = scheme_compiled_let_value_type;
02247     lv->count = 1;
02248     lv->position = i;
02249 
02250     if (app)
02251       lv->value = app->args[i + 1];
02252     else if (app3)
02253       lv->value = (i ? app3->rand2 : app3->rand1);
02254     else if (app2)
02255       lv->value = app2->rand;
02256 
02257     flag = scheme_closure_argument_flags(data, i);
02258     flags = (int *)scheme_malloc_atomic(sizeof(int));
02259     flags[0] = flag;
02260     lv->flags = flags;
02261 
02262     if (prev)
02263       prev->body = (Scheme_Object *)lv;
02264     else
02265       lh->body = (Scheme_Object *)lv;
02266     prev = lv;
02267   }
02268 
02269   if (prev)
02270     prev->body = p;
02271   else
02272     lh->body = p;
02273 
02274   return scheme_optimize_lets((Scheme_Object *)lh, info, 1);
02275 }
02276 
02277 #if 0
02278 # define LOG_INLINE(x) x
02279 #else
02280 # define LOG_INLINE(x) /*empty*/
02281 #endif
02282 
02283 Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int argc,
02284                                Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3,
02285                                    int *_flags)
02286 /* If not app, app2, or app3, just return a known procedure, if any */
02287 {
02288   int offset = 0, single_use = 0;
02289   Scheme_Object *bad_app = NULL;
02290 
02291   if (info->inline_fuel < 0)
02292     return NULL;
02293   
02294   if (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) {
02295     /* Found a `((lambda' */
02296     single_use = 1;
02297   }
02298 
02299   if (SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) {
02300     /* Check for inlining: */
02301     le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le), &offset, &single_use);
02302     if (!le)
02303       return NULL;
02304   }
02305 
02306   while (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_toplevel_type)) {
02307     single_use = 0;
02308     if (info->top_level_consts) {
02309       int pos;
02310       pos = SCHEME_TOPLEVEL_POS(le);
02311       le = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
02312       if (!le)
02313        return NULL;
02314     } else
02315       return NULL;
02316   }
02317 
02318   if (le && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) {
02319     Scheme_Closure_Data *data = (Scheme_Closure_Data *)le;
02320     int sz;
02321 
02322     if (!app && !app2 && !app3) {
02323       return le;
02324     }
02325 
02326     *_flags = SCHEME_CLOSURE_DATA_FLAGS(data);
02327       
02328     if (data->num_params == argc) {
02329       sz = scheme_closure_body_size(data, 1);
02330 
02331       if ((sz >= 0) && (single_use || (sz <= (info->inline_fuel * (argc + 2))))) {
02332        le = scheme_optimize_clone(0, data->code, info, offset, argc);
02333        if (le) {
02334          LOG_INLINE(fprintf(stderr, "Inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???"));
02335           return apply_inlined(le, data, info, argc, app, app2, app3);
02336        } else {
02337           LOG_INLINE(fprintf(stderr, "No inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???"));
02338         }
02339       } else {
02340         LOG_INLINE(fprintf(stderr, "No fuel %s %d*%d/%d\n", data->name ? scheme_write_to_string(data->name, NULL) : "???", 
02341                            sz, info->inline_fuel * (argc + 2),
02342                            info->inline_fuel));
02343       }
02344     } else {
02345       if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
02346           || (argc + 1 < data->num_params)) {
02347         /* Issue warning below */
02348         bad_app = (Scheme_Object *)data;
02349       }
02350     }
02351   }
02352 
02353   if (le && SCHEME_PRIMP(le)) {
02354     int opt;
02355     opt = ((Scheme_Prim_Proc_Header *)le)->flags & SCHEME_PRIM_OPT_MASK;
02356     if (opt >= SCHEME_PRIM_OPT_NONCM)
02357       *_flags = (CLOS_PRESERVES_MARKS | CLOS_SINGLE_RESULT);
02358   }
02359 
02360   if (le && SCHEME_PROCP(le)) {
02361     Scheme_Object *a[1];
02362     a[0] = le;
02363     if (!scheme_check_proc_arity(NULL, argc, 0, 1, a))  {
02364       bad_app = le;
02365     }
02366   }
02367 
02368   if (bad_app) {
02369     int len;
02370     const char *pname, *context;
02371     pname = scheme_get_proc_name(bad_app, &len, 0);
02372     context = scheme_optimize_context_to_string(info->context);
02373     scheme_log(NULL,
02374                SCHEME_LOG_WARNING,
02375                0,
02376                "warning%s: optimizer detects procedure incorrectly applied to %d arguments%s%s",
02377                context,
02378                argc,
02379                pname ? ": " : "",
02380                pname ? pname : "");
02381   }
02382   
02383   return NULL;
02384 }
02385 
02386 char *scheme_optimize_context_to_string(Scheme_Object *context)
02387 {
02388   if (context) {
02389     Scheme_Object *mod, *func;
02390     const char *ctx, *prefix, *mctx, *mprefix;
02391     char *all;
02392     int clen, plen, mclen, mplen, len;
02393 
02394     if (SCHEME_PAIRP(context)) {
02395       func = SCHEME_CAR(context);
02396       mod = SCHEME_CDR(context);
02397     } else if (SAME_TYPE(SCHEME_TYPE(context), scheme_module_type)) {
02398       func = scheme_false;
02399       mod = context;
02400     } else {
02401       func = context;
02402       mod = scheme_false;
02403     }
02404 
02405     if (SAME_TYPE(SCHEME_TYPE(func), scheme_compiled_unclosed_procedure_type)) {
02406       Scheme_Object *name;
02407 
02408       name = ((Scheme_Closure_Data *)func)->name;
02409       if (name) {
02410         if (SCHEME_VECTORP(name)) {
02411           Scheme_Object *port;
02412           int print_width = 1024;
02413           long plen;
02414           
02415           port = scheme_make_byte_string_output_port();
02416 
02417           scheme_write_proc_context(port, print_width,
02418                                     SCHEME_VEC_ELS(name)[0],
02419                                     SCHEME_VEC_ELS(name)[1], SCHEME_VEC_ELS(name)[2],
02420                                     SCHEME_VEC_ELS(name)[3], SCHEME_VEC_ELS(name)[4],
02421                                     SCHEME_TRUEP(SCHEME_VEC_ELS(name)[6]));
02422 
02423           ctx = scheme_get_sized_byte_string_output(port, &plen);
02424           prefix = " in: ";
02425         } else {
02426           ctx = scheme_get_proc_name(func, &len, 0);
02427           prefix = " in: ";
02428         }
02429       } else {
02430         ctx = "";
02431         prefix = "";
02432       }
02433     } else {
02434       ctx = "";
02435       prefix = "";
02436     }
02437 
02438     if (SAME_TYPE(SCHEME_TYPE(mod), scheme_module_type)) {
02439       mctx = scheme_display_to_string(((Scheme_Module *)mod)->modname, NULL);
02440       mprefix = " in module: ";
02441     } else {
02442       mctx = "";
02443       mprefix = "";
02444     }
02445 
02446     clen = strlen(ctx);
02447     plen = strlen(prefix);
02448     mclen = strlen(mctx);
02449     mplen = strlen(mprefix);
02450 
02451     if (!clen && !mclen)
02452       return "";
02453 
02454     all = scheme_malloc_atomic(clen + plen + mclen + mplen + 1);
02455     memcpy(all, prefix, plen);
02456     memcpy(all + plen, ctx, clen);
02457     memcpy(all + plen + clen, mprefix, mplen);
02458     memcpy(all + plen + clen + mplen, mctx, mclen);
02459     all[clen + plen + mclen + mplen] = 0;
02460     return all;
02461   } else
02462     return "";
02463 }
02464 
02465 static void reset_rator(Scheme_Object *app, Scheme_Object *a)
02466 {
02467   switch (SCHEME_TYPE(app)) {
02468   case scheme_application_type:
02469     ((Scheme_App_Rec *)app)->args[0] = a;
02470     break;
02471   case scheme_application2_type:
02472     ((Scheme_App2_Rec *)app)->rator = a;
02473     break;
02474   case scheme_application3_type:
02475     ((Scheme_App3_Rec *)app)->rator = a;
02476     break;
02477   }
02478 }
02479 
02480 static Scheme_Object *check_app_let_rator(Scheme_Object *app, Scheme_Object *rator, Optimize_Info *info, int argc)
02481 {
02482   if (SAME_TYPE(SCHEME_TYPE(rator), scheme_compiled_let_void_type)) {
02483     Scheme_Let_Header *head = (Scheme_Let_Header *)rator;
02484 
02485     if ((head->count == 1) && (head->num_clauses == 1)) {
02486       Scheme_Object *body;
02487       Scheme_Compiled_Let_Value *clv;
02488 
02489       clv = (Scheme_Compiled_Let_Value *)head->body;
02490       body = clv->body;
02491       if (SAME_TYPE(SCHEME_TYPE(body), scheme_local_type)
02492           && (SCHEME_LOCAL_POS(body) == 0)
02493           && scheme_is_compiled_procedure(clv->value, 1, 1)) {
02494         
02495         reset_rator(app, scheme_false);
02496         app = scheme_optimize_shift(app, 1, 0);
02497         reset_rator(app, scheme_make_local(scheme_local_type, 0, 0));
02498 
02499         clv->body = app;
02500         
02501         if (clv->flags[0] & SCHEME_WAS_APPLIED_EXCEPT_ONCE) {
02502           clv->flags[0] -= SCHEME_WAS_APPLIED_EXCEPT_ONCE;
02503           clv->flags[0] |= SCHEME_WAS_ONLY_APPLIED;
02504         }
02505         
02506         return scheme_optimize_expr(rator, info);
02507       }
02508     }
02509   }
02510 
02511   return NULL;
02512 }
02513 
02514 static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info)
02515 {
02516   Scheme_Object *le;
02517   Scheme_App_Rec *app;
02518   int i, n, all_vals = 1, rator_flags = 0;
02519 
02520   app = (Scheme_App_Rec *)o;
02521 
02522   le = check_app_let_rator(o, app->args[0], info, app->num_args);
02523   if (le) return le;
02524 
02525   n = app->num_args + 1;
02526 
02527   for (i = 0; i < n; i++) {
02528     if (!i) {
02529       le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags);
02530       if (le)
02531        return le;
02532     }
02533      
02534     le = scheme_optimize_expr(app->args[i], info);
02535     app->args[i] = le;
02536 
02537     if (!i) {
02538       if (SAME_TYPE(SCHEME_TYPE(app->args[0]),scheme_compiled_unclosed_procedure_type)) {
02539         /* Found "((lambda" after optimizing; try again */
02540         le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags);
02541         if (le)
02542           return le;
02543       }
02544     }
02545 
02546 
02547     if (i && (SCHEME_TYPE(le) < _scheme_compiled_values_types_))
02548       all_vals = 0;
02549   }
02550 
02551   if (all_vals) {
02552     le = try_optimize_fold(app->args[0], (Scheme_Object *)app, info);
02553     if (le)
02554       return le;
02555   }
02556 
02557   info->size += 1;
02558 
02559   info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
02560   info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
02561   if (rator_flags & CLOS_RESULT_TENTATIVE) {
02562     info->preserves_marks = -info->preserves_marks;
02563     info->single_result = -info->single_result;
02564   }
02565 
02566   if (!app->num_args && SAME_OBJ(app->args[0], scheme_list_proc))
02567     return scheme_null;
02568 
02569   return (Scheme_Object *)app;
02570 }
02571 
02572 static Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *rand)
02573 {
02574   Scheme_Object *c = NULL;
02575 
02576   if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(rand)))
02577     c = rand;
02578   if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) {
02579     int offset;
02580     Scheme_Object *expr;
02581     expr = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(rand), 0);
02582     c = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL);
02583   }
02584   if (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_toplevel_type)) {
02585     if (info->top_level_consts) {
02586       int pos;
02587       
02588       while (1) {
02589         pos = SCHEME_TOPLEVEL_POS(rand);
02590         c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
02591         if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_toplevel_type))
02592           rand = c;
02593         else
02594           break;
02595       }
02596     }
02597   }    
02598 
02599   if (c && SAME_TYPE(scheme_noninline_proc_type, SCHEME_TYPE(c))) {
02600     c = SCHEME_BOX_VAL(c);
02601   
02602     while (SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_let_void_type)) {
02603       /* This must be (let ([x <proc>]) <proc>); see scheme_is_statically_proc() */
02604       Scheme_Let_Header *lh = (Scheme_Let_Header *)c;
02605       Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
02606       c = lv->body;
02607     }
02608   }
02609 
02610   if (c 
02611       && (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(c))
02612           || (SAME_TYPE(scheme_compiled_syntax_type, SCHEME_TYPE(c))
02613               && (SCHEME_PINT_VAL(c) == CASE_LAMBDA_EXPD))))
02614     return c;
02615 
02616   return NULL;
02617 }
02618 
02619 static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *info)
02620 {
02621   Scheme_App2_Rec *app;
02622   Scheme_Object *le;
02623   int rator_flags = 0;
02624 
02625   app = (Scheme_App2_Rec *)o;
02626 
02627   le = check_app_let_rator(o, app->rator, info, 1);
02628   if (le) return le;
02629 
02630   le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags);
02631   if (le)
02632     return le;
02633 
02634   le = scheme_optimize_expr(app->rator, info);
02635   app->rator = le;
02636 
02637   if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) {
02638     /* Found "((lambda" after optimizing; try again */
02639     le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags);
02640     if (le)
02641       return le;
02642   }
02643 
02644   le = scheme_optimize_expr(app->rand, info);
02645   app->rand = le;
02646   if (SCHEME_TYPE(le) > _scheme_compiled_values_types_) {
02647     le = try_optimize_fold(app->rator, (Scheme_Object *)app, info);
02648     if (le)
02649       return le;
02650   }
02651 
02652   if (SAME_OBJ(scheme_procedure_p_proc, app->rator)) {
02653     if (lookup_constant_proc(info, app->rand)) {
02654       info->preserves_marks = 1;
02655       info->single_result = 1;
02656       return scheme_true;
02657     }
02658   }
02659 
02660   if ((SAME_OBJ(scheme_values_func, app->rator)
02661        || SAME_OBJ(scheme_list_star_proc, app->rator))
02662       && scheme_omittable_expr(app->rand, 1, -1, 0, info)) {
02663     info->preserves_marks = 1;
02664     info->single_result = 1;
02665     return app->rand;
02666   }
02667 
02668   info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
02669   info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
02670   if (rator_flags & CLOS_RESULT_TENTATIVE) {
02671     info->preserves_marks = -info->preserves_marks;
02672     info->single_result = -info->single_result;
02673   }
02674 
02675   return (Scheme_Object *)app;
02676 }
02677 
02678 static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *info)
02679 {
02680   Scheme_App3_Rec *app;
02681   Scheme_Object *le;
02682   int all_vals = 1;
02683   int rator_flags = 0;
02684 
02685   app = (Scheme_App3_Rec *)o;
02686 
02687   le = check_app_let_rator(o, app->rator, info, 2);
02688   if (le) return le;
02689 
02690   le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags);
02691   if (le)
02692     return le;
02693 
02694   le = scheme_optimize_expr(app->rator, info);
02695   app->rator = le;
02696 
02697   if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) {
02698     /* Found "((lambda" after optimizing; try again */
02699     le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags);
02700     if (le)
02701       return le;
02702   }
02703 
02704   /* 1st arg */
02705 
02706   le = scheme_optimize_expr(app->rand1, info);
02707   app->rand1 = le;
02708 
02709   if (SCHEME_TYPE(le) < _scheme_compiled_values_types_)
02710     all_vals = 0;
02711 
02712   /* 2nd arg */
02713 
02714   le = scheme_optimize_expr(app->rand2, info);
02715   app->rand2 = le;
02716 
02717   if (SCHEME_TYPE(le) < _scheme_compiled_values_types_)
02718     all_vals = 0;
02719 
02720   /* Fold or continue */
02721 
02722   if (all_vals) {
02723     le = try_optimize_fold(app->rator, (Scheme_Object *)app, info);
02724     if (le)
02725       return le;
02726   }
02727 
02728   info->size += 1;
02729 
02730   /* Check for (call-with-values (lambda () M) N): */
02731   if (SAME_OBJ(app->rator, scheme_call_with_values_proc)) {
02732     if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_compiled_unclosed_procedure_type)) {
02733       Scheme_Closure_Data *data = (Scheme_Closure_Data *)app->rand1;
02734 
02735       if (!data->num_params) {
02736         /* Convert to apply-values form: */ 
02737         return scheme_optimize_apply_values(app->rand2, data->code, info,
02738                                             ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT)
02739                                              ? ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)
02740                                                 ? -1
02741                                                 : 1)
02742                                              : 0));
02743       }
02744     }
02745   }
02746 
02747   if (SAME_OBJ(scheme_procedure_arity_includes_proc, app->rator)) {
02748     if (SCHEME_INTP(app->rand2)) {
02749       Scheme_Object *proc;
02750       Scheme_Case_Lambda *cl;
02751       int i, cnt;
02752 
02753       proc = lookup_constant_proc(info, app->rand1);      
02754       if (proc) {
02755         if (SAME_TYPE(SCHEME_TYPE(proc), scheme_compiled_unclosed_procedure_type)) {
02756           cnt = 1;
02757           cl = NULL;
02758         } else {
02759           cl = (Scheme_Case_Lambda *)SCHEME_IPTR_VAL(proc);
02760           cnt = cl->count;
02761         }
02762 
02763         for (i = 0; i < cnt; i++) {
02764           if (cl) proc = cl->array[i];
02765           
02766           if (SAME_TYPE(SCHEME_TYPE(proc), scheme_compiled_unclosed_procedure_type)) {
02767             Scheme_Closure_Data *data = (Scheme_Closure_Data *)proc;
02768             int n = SCHEME_INT_VAL(app->rand2), ok;
02769             if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
02770               ok = ((data->num_params - 1) <= n);
02771             } else {
02772               ok = (data->num_params == n);
02773             }
02774             if (ok) {
02775               info->preserves_marks = 1;
02776               info->single_result = 1;
02777               return scheme_true;
02778             }
02779           } else {
02780             break;
02781           }
02782         }
02783 
02784         if (i == cnt) {
02785           info->preserves_marks = 1;
02786           info->single_result = 1;
02787           return scheme_false;
02788         }
02789       }
02790     }
02791   }
02792 
02793 
02794   info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
02795   info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
02796   if (rator_flags & CLOS_RESULT_TENTATIVE) {
02797     info->preserves_marks = -info->preserves_marks;
02798     info->single_result = -info->single_result;
02799   }
02800 
02801   return (Scheme_Object *)app;
02802 }
02803 
02804 Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e, 
02805                                             Optimize_Info *info,
02806                                             int e_single_result)
02807 /* f and e are already optimized */
02808 {
02809   Scheme_Object *f_is_proc = NULL;
02810 
02811   info->preserves_marks = 0;
02812   info->single_result = 0;
02813 
02814   {
02815     Scheme_Object *rev;
02816     if (SAME_TYPE(SCHEME_TYPE(f), scheme_local_type)) {
02817       rev = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(f), 1);
02818     } else
02819       rev = f;
02820 
02821     if (rev) {
02822       int rator2_flags;
02823       Scheme_Object *o_f;
02824       o_f = optimize_for_inline(info, rev, 1, NULL, NULL, NULL, &rator2_flags);
02825       if (o_f) {
02826         f_is_proc = rev;
02827 
02828         if (SAME_TYPE(SCHEME_TYPE(o_f), scheme_compiled_unclosed_procedure_type)) {
02829           Scheme_Closure_Data *data2 = (Scheme_Closure_Data *)o_f;
02830           int flags = SCHEME_CLOSURE_DATA_FLAGS(data2);
02831           info->preserves_marks = !!(flags & CLOS_PRESERVES_MARKS);
02832           info->single_result = !!(flags & CLOS_SINGLE_RESULT);
02833           if (flags & CLOS_RESULT_TENTATIVE) {
02834             info->preserves_marks = -info->preserves_marks;
02835             info->single_result = -info->single_result;
02836           }
02837         }
02838       }
02839     }
02840     
02841     if (!f_is_proc && SCHEME_PROCP(f)) {
02842       f_is_proc = f;
02843     }
02844   }
02845 
02846   if (f_is_proc && (e_single_result > 0)) {
02847     /* Just make it an application (N M): */
02848     Scheme_App2_Rec *app2;
02849     Scheme_Object *cloned, *f_cloned;
02850 
02851     app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
02852     app2->iso.so.type = scheme_application2_type;
02853     
02854     /* We'd like to try to inline here. The problem is that
02855        e (the argument) has been optimized already,
02856        which means it's in the wrong coordinate system.
02857        If we can shift-clone it, then it will be back in the right
02858        coordinates. */
02859     
02860     cloned = scheme_optimize_clone(1, e, info, 0, 0);
02861     if (cloned) {
02862       if (SAME_TYPE(SCHEME_TYPE(f_is_proc), scheme_compiled_unclosed_procedure_type))
02863         f_cloned = scheme_optimize_clone(1, f_is_proc, info, 0, 0);
02864       else {
02865         /* Otherwise, no clone is needed; in the case of a lexical
02866            variable, we already reversed it. */
02867         f_cloned = f_is_proc;
02868       }
02869 
02870       if (f_cloned) {
02871         app2->rator = f_cloned;
02872         app2->rand = cloned;
02873         info->inline_fuel >>= 1; /* because we've already optimized the rand */
02874         return optimize_application2((Scheme_Object *)app2, info);
02875       }
02876     }
02877      
02878     app2->rator = f;
02879     app2->rand = e;
02880     return (Scheme_Object *)app2;
02881   }
02882 
02883   return scheme_make_syntax_compiled(APPVALS_EXPD, cons(f, e));
02884 }
02885 
02886 static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info)
02887 {
02888   Scheme_Sequence *s = (Scheme_Sequence *)o;
02889   Scheme_Object *le;
02890   int i;
02891   int drop = 0, preserves_marks = 0, single_result = 0;
02892 
02893   for (i = s->count; i--; ) {
02894     le = scheme_optimize_expr(s->array[i], info);
02895     if (i == s->count - 1) {
02896       single_result = info->single_result;
02897       preserves_marks = info->preserves_marks;
02898     }
02899 
02900     /* Inlining and constant propagation can expose
02901        omittable expressions. */
02902     if ((i + 1 != s->count)
02903        && scheme_omittable_expr(le, -1, -1, 0, NULL)) {
02904       drop++;
02905       s->array[i] = NULL;
02906     } else {
02907       s->array[i] = le;
02908     }
02909   }
02910 
02911   info->preserves_marks = preserves_marks;
02912   info->single_result = single_result;
02913 
02914   if (drop + 1 == s->count) {
02915     return s->array[drop];
02916   } else if (drop) {
02917     Scheme_Sequence *s2;
02918     int j = 0;
02919 
02920     s2 = malloc_sequence(s->count - drop);
02921     s2->so.type = scheme_sequence_type;
02922     s2->count = s->count - drop;
02923 
02924     for (i = 0; i < s->count; i++) {
02925       if (s->array[i]) {
02926        s2->array[j++] = s->array[i];
02927       }
02928     }
02929 
02930     s = s2;
02931   }
02932 
02933   info->size += 1;
02934 
02935   return (Scheme_Object *)s;
02936 }
02937 
02938 int scheme_compiled_duplicate_ok(Scheme_Object *fb)
02939 {
02940   return (SCHEME_VOIDP(fb)
02941          || SAME_OBJ(fb, scheme_true)
02942          || SCHEME_FALSEP(fb)
02943          || SCHEME_SYMBOLP(fb)
02944          || SCHEME_KEYWORDP(fb)
02945          || SCHEME_EOFP(fb)
02946          || SCHEME_INTP(fb)
02947          || SCHEME_NULLP(fb)
02948          || (SCHEME_CHARP(fb) && (SCHEME_CHAR_VAL(fb) < 256))
02949          || SAME_TYPE(SCHEME_TYPE(fb), scheme_local_type)
02950           /* Values that are hashed by the printer to avoid
02951              duplication: */
02952          || SCHEME_CHAR_STRINGP(fb) 
02953           || SCHEME_BYTE_STRINGP(fb)
02954           || SAME_TYPE(SCHEME_TYPE(fb), scheme_regexp_type)
02955           || SCHEME_NUMBERP(fb)
02956          || SCHEME_PRIMP(fb));
02957 }
02958 
02959 static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
02960 {
02961   Scheme_Branch_Rec *b;
02962   Scheme_Object *t, *tb, *fb;
02963   int preserves_marks = 1, single_result = 1;
02964 
02965   b = (Scheme_Branch_Rec *)o;
02966 
02967   t = b->test;
02968   tb = b->tbranch;
02969   fb = b->fbranch;
02970   
02971   /* Try optimize: (if (not x) y z) => (if x z y) */
02972   while (1) {
02973     if (SAME_TYPE(SCHEME_TYPE(t), scheme_application2_type)) {
02974       Scheme_App2_Rec *app;
02975       
02976       app = (Scheme_App2_Rec *)t;
02977       if (SAME_PTR(scheme_not_prim, app->rator)) {
02978        t = tb;
02979        tb = fb;
02980        fb = t;
02981        t = app->rand;
02982       } else
02983        break;
02984     } else
02985       break;
02986   }
02987 
02988   if (SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_let_void_type)) {
02989     /* Maybe convert: (let ([x M]) (if x x N)) => (if M #t N) */
02990     t = scheme_optimize_lets_for_test(t, info);
02991   } else
02992     t = scheme_optimize_expr(t, info);
02993 
02994   /* For test position, convert (if <expr> #t #f) to <expr> */
02995   if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)
02996       && SAME_OBJ(((Scheme_Branch_Rec *)t)->tbranch, scheme_true)
02997       && SAME_OBJ(((Scheme_Branch_Rec *)t)->fbranch, scheme_false))
02998     t = ((Scheme_Branch_Rec *)t)->test;
02999 
03000   if (SCHEME_TYPE(t) > _scheme_compiled_values_types_) {
03001     if (SCHEME_FALSEP(t))
03002       return scheme_optimize_expr(fb, info);
03003     else
03004       return scheme_optimize_expr(tb, info);
03005   } else if (SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_quote_syntax_type)
03006              || SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_unclosed_procedure_type))
03007     return scheme_optimize_expr(tb, info);
03008 
03009   tb = scheme_optimize_expr(tb, info);
03010 
03011   if (!info->preserves_marks) 
03012     preserves_marks = 0;
03013   else if (info->preserves_marks < 0)
03014     preserves_marks = -1;
03015   if (!info->single_result) 
03016     single_result = 0;
03017   else if (info->single_result < 0)
03018     single_result = -1;
03019 
03020   fb = scheme_optimize_expr(fb, info);
03021 
03022   if (!info->preserves_marks) 
03023     preserves_marks = 0;
03024   else if (preserves_marks && (info->preserves_marks < 0))
03025     preserves_marks = -1;
03026   if (!info->single_result) 
03027     single_result = 0;
03028   else if (single_result && (info->single_result < 0))
03029     single_result = -1;
03030 
03031   info->preserves_marks = preserves_marks;
03032   info->single_result = single_result;
03033 
03034   /* Try optimize: (if x x #f) => x */
03035   if (SAME_TYPE(SCHEME_TYPE(t), scheme_local_type)
03036       && SAME_TYPE(SCHEME_TYPE(tb), scheme_local_type)
03037       && (SCHEME_LOCAL_POS(t) == SCHEME_LOCAL_POS(tb))
03038       && SCHEME_FALSEP(fb)) {
03039     return t;
03040   }
03041 
03042   /* Convert: (if (if M N #f) M2 K) => (if M (if N M2 K) K)
03043      for simple constants K. This is useful to expose simple
03044      tests to the JIT. */
03045   if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)
03046       && scheme_compiled_duplicate_ok(fb)) {
03047     Scheme_Branch_Rec *b2 = (Scheme_Branch_Rec *)t;
03048     if (SCHEME_FALSEP(b2->fbranch)) {
03049       Scheme_Branch_Rec *b3;
03050       b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
03051       b3->so.type = scheme_branch_type;
03052       b3->test = b2->tbranch;
03053       b3->tbranch = tb;
03054       b3->fbranch = fb;
03055       t = b2->test;
03056       tb = (Scheme_Object *)b3;
03057     }
03058   }
03059 
03060   b->test = t;
03061   b->tbranch = tb;
03062   b->fbranch = fb;
03063 
03064   info->size += 1;
03065 
03066   return o;
03067 }
03068 
03069 static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info)
03070 {
03071   Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
03072   Scheme_Object *k, *v, *b;
03073 
03074   k = scheme_optimize_expr(wcm->key, info);
03075 
03076   v = scheme_optimize_expr(wcm->val, info);
03077 
03078   b = scheme_optimize_expr(wcm->body, info);
03079 
03080   /* info->single_result is already set */
03081   info->preserves_marks = 0;
03082 
03083   wcm->key = k;
03084   wcm->val = v;
03085   wcm->body = b;
03086 
03087   info->size += 1;
03088 
03089   return (Scheme_Object *)wcm;
03090 }
03091 
03092 static Scheme_Object *optimize_k(void)
03093 {
03094   Scheme_Thread *p = scheme_current_thread;
03095   Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1;
03096   Optimize_Info *info = (Optimize_Info *)p->ku.k.p2;
03097 
03098   p->ku.k.p1 = NULL;
03099   p->ku.k.p2 = NULL;
03100 
03101   return scheme_optimize_expr(expr, info);
03102 }
03103 
03104 Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
03105 {
03106   Scheme_Type type = SCHEME_TYPE(expr);
03107 
03108 #ifdef DO_STACK_CHECK
03109 # include "mzstkchk.h"
03110   {
03111     Scheme_Thread *p = scheme_current_thread;
03112 
03113     p->ku.k.p1 = (void *)expr;
03114     p->ku.k.p2 = (void *)info;
03115 
03116     return scheme_handle_stack_overflow(optimize_k);
03117   }
03118 #endif
03119 
03120   info->preserves_marks = 1;
03121   info->single_result = 1;
03122 
03123   switch (type) {
03124   case scheme_local_type:
03125     {
03126       Scheme_Object *val;
03127       int pos, delta;
03128       
03129       info->size += 1;
03130 
03131       pos = SCHEME_LOCAL_POS(expr);
03132 
03133       val = scheme_optimize_info_lookup(info, pos, NULL, NULL);
03134       if (val) {
03135         if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type))
03136           return scheme_optimize_expr(val, info);
03137        return val;
03138       }
03139 
03140       delta = scheme_optimize_info_get_shift(info, pos);
03141       if (delta)
03142        expr = scheme_make_local(scheme_local_type, pos + delta, 0);
03143 
03144       return expr;
03145     }
03146   case scheme_compiled_syntax_type:
03147     {
03148       Scheme_Syntax_Optimizer f;
03149          
03150       f = scheme_syntax_optimizers[SCHEME_PINT_VAL(expr)];
03151       return f((Scheme_Object *)SCHEME_IPTR_VAL(expr), info);
03152     }
03153   case scheme_application_type:
03154     return optimize_application(expr, info);
03155   case scheme_application2_type:
03156     return optimize_application2(expr, info);
03157   case scheme_application3_type:
03158     return optimize_application3(expr, info);
03159   case scheme_sequence_type:
03160     return optimize_sequence(expr, info);
03161   case scheme_branch_type:
03162     return optimize_branch(expr, info);
03163   case scheme_with_cont_mark_type:
03164     return optimize_wcm(expr, info);
03165   case scheme_compiled_unclosed_procedure_type:
03166     return scheme_optimize_closure_compilation(expr, info);
03167   case scheme_compiled_let_void_type:
03168     return scheme_optimize_lets(expr, info, 0);
03169   case scheme_compiled_toplevel_type:
03170     if (info->top_level_consts) {
03171       int pos;
03172       Scheme_Object *c;
03173 
03174       while (1) {
03175         pos = SCHEME_TOPLEVEL_POS(expr);
03176         c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
03177         if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_toplevel_type))
03178           expr = c;
03179         else
03180           break;
03181       }
03182 
03183       if (c) {
03184        if (scheme_compiled_duplicate_ok(c))
03185          return c;
03186 
03187        /* We can't inline, but mark the top level as a constant, 
03188           so we can direct-jump and avoid null checks in JITed code: */
03189        expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_CONST);
03190       } else {
03191        /* false is mapped to a table of non-constant ready values: */
03192        c = scheme_hash_get(info->top_level_consts, scheme_false);
03193        if (c) {
03194          c = scheme_hash_get((Scheme_Hash_Table *)c, scheme_make_integer(pos));
03195 
03196          if (c) {
03197            /* We can't inline, but mark the top level as ready, 
03198               so we can avoid null checks in JITed code: */
03199            expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_READY);
03200          }
03201        }
03202       }
03203     }
03204     scheme_optimize_info_used_top(info);
03205     return expr;
03206   case scheme_compiled_quote_syntax_type:
03207     scheme_optimize_info_used_top(info);
03208     return expr;
03209   case scheme_variable_type:
03210   case scheme_module_variable_type:
03211     scheme_signal_error("got top-level in wrong place");
03212     return 0;
03213   default:
03214     info->size += 1;
03215     return expr;
03216   }
03217 }
03218 
03219 Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_Info *info, int delta, int closure_depth)
03220 /* Past closure_depth, need to reverse optimize to unoptimzed with respect to info;
03221    delta is the amount to skip in info to get to the frame that bound the code.
03222    If dup_ok is 1, then the old copy will be dropped, so it's ok to "duplicate"
03223    any constant. */
03224 {
03225   int t;
03226 
03227   t = SCHEME_TYPE(expr);
03228 
03229   switch(t) {
03230   case scheme_local_type:
03231     {
03232       int pos = SCHEME_LOCAL_POS(expr);
03233       if (pos >= closure_depth) {
03234        expr = scheme_optimize_reverse(info, pos + delta - closure_depth, 0);
03235        if (closure_depth)
03236          expr = scheme_make_local(scheme_local_type, SCHEME_LOCAL_POS(expr) + closure_depth, 0);
03237       }
03238       return expr;
03239     }
03240   case scheme_compiled_syntax_type:
03241     {
03242       Scheme_Syntax_Cloner f;
03243          
03244       f = scheme_syntax_cloners[SCHEME_PINT_VAL(expr)];
03245       if (!f) return NULL;
03246       return f(dup_ok, (Scheme_Object *)SCHEME_IPTR_VAL(expr), info, delta, closure_depth);
03247     }
03248   case scheme_application2_type:
03249     {
03250       Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr, *app2;
03251       
03252       app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
03253       app2->iso.so.type = scheme_application2_type;
03254       
03255       expr = scheme_optimize_clone(dup_ok, app->rator, info, delta, closure_depth);
03256       if (!expr) return NULL;
03257       app2->rator = expr;
03258       
03259       expr = scheme_optimize_clone(dup_ok, app->rand, info, delta, closure_depth);
03260       if (!expr) return NULL;
03261       app2->rand = expr;
03262 
03263       return (Scheme_Object *)app2;
03264     }
03265   case scheme_application_type:
03266     {
03267       Scheme_App_Rec *app = (Scheme_App_Rec *)expr, *app2;
03268       int i;
03269       
03270       app2 = scheme_malloc_application(app->num_args + 1);
03271 
03272       for (i = app->num_args + 1; i--; ) {
03273        expr = scheme_optimize_clone(dup_ok, app->args[i], info, delta, closure_depth);
03274        if (!expr) return NULL;
03275        app2->args[i] = expr;
03276       }
03277 
03278       return (Scheme_Object *)app2;
03279     }
03280   case scheme_application3_type:
03281     {
03282       Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr, *app2;
03283       
03284       app2 = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
03285       app2->iso.so.type = scheme_application3_type;
03286       
03287       expr = scheme_optimize_clone(dup_ok, app->rator, info, delta, closure_depth);
03288       if (!expr) return NULL;
03289       app2->rator = expr;
03290       
03291       expr = scheme_optimize_clone(dup_ok, app->rand1, info, delta, closure_depth);
03292       if (!expr) return NULL;
03293       app2->rand1 = expr;
03294       
03295       expr = scheme_optimize_clone(dup_ok, app->rand2, info, delta, closure_depth);
03296       if (!expr) return NULL;
03297       app2->rand2 = expr;
03298 
03299       return (Scheme_Object *)app2;
03300     }
03301   case scheme_compiled_let_void_type:
03302     {
03303       Scheme_Let_Header *head = (Scheme_Let_Header *)expr, *head2;
03304       Scheme_Object *body;
03305       Scheme_Compiled_Let_Value *lv, *lv2, *prev = NULL;
03306       int i, *flags, sz;
03307 
03308       head2 = MALLOC_ONE_TAGGED(Scheme_Let_Header);
03309       head2->iso.so.type = scheme_compiled_let_void_type;
03310       head2->count = head->count;
03311       head2->num_clauses = head->num_clauses;
03312       SCHEME_LET_FLAGS(head2) = SCHEME_LET_FLAGS(head);
03313 
03314       /* Build let-value change: */
03315       body = head->body;
03316       for (i = head->num_clauses; i--; ) {
03317        lv = (Scheme_Compiled_Let_Value *)body;
03318 
03319        sz = sizeof(int) * lv->count;
03320        flags = (int *)scheme_malloc_atomic(sz);
03321        memcpy(flags, lv->flags, sz);
03322 
03323        lv2 = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
03324        lv2->so.type = scheme_compiled_let_value_type;
03325        lv2->count = lv->count;
03326        lv2->position = lv->position;
03327        lv2->flags = flags;
03328 
03329        expr = scheme_optimize_clone(dup_ok, lv->value, info, delta, closure_depth + head->count);
03330        if (!expr) return NULL;
03331        lv2->value = expr;
03332 
03333        if (prev)
03334          prev->body = (Scheme_Object *)lv2;
03335        else
03336          head2->body = (Scheme_Object *)lv2;
03337        prev = lv2;
03338 
03339        body = lv->body;
03340       }
03341       if (prev) 
03342        prev->body = body;
03343       else
03344        head2->body = body;
03345 
03346       expr = scheme_optimize_clone(dup_ok, body, info, delta, closure_depth + head->count);
03347       if (!expr) return NULL;
03348 
03349       if (prev) 
03350        prev->body = expr;
03351       else
03352        head2->body = expr;
03353       
03354       return (Scheme_Object *)head2;
03355     }
03356   case scheme_sequence_type:
03357   case scheme_begin0_sequence_type:
03358     {
03359       Scheme_Sequence *seq = (Scheme_Sequence *)expr, *seq2;
03360       int i;
03361 
03362       seq2 = malloc_sequence(seq->count);
03363       seq2->so.type = seq->so.type;
03364       seq2->count = seq->count;
03365 
03366       for (i = seq->count; i--; ) {
03367        expr = scheme_optimize_clone(dup_ok, seq->array[i], info, delta, closure_depth);
03368        if (!expr) return NULL;
03369        seq2->array[i] = expr;
03370       }
03371       
03372       return (Scheme_Object *)seq2;
03373     }
03374   case scheme_branch_type:
03375     {
03376       Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr, *b2;
03377 
03378       b2 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
03379       b2->so.type = scheme_branch_type;
03380 
03381       expr = scheme_optimize_clone(dup_ok, b->test, info, delta, closure_depth);
03382       if (!expr) return NULL;
03383       b2->test = expr;
03384 
03385       expr = scheme_optimize_clone(dup_ok, b->tbranch, info, delta, closure_depth);
03386       if (!expr) return NULL;
03387       b2->tbranch = expr;
03388 
03389       expr = scheme_optimize_clone(dup_ok, b->fbranch, info, delta, closure_depth);
03390       if (!expr) return NULL;
03391       b2->fbranch = expr;
03392 
03393       return (Scheme_Object *)b2;
03394     }
03395   case scheme_compiled_unclosed_procedure_type:
03396     return scheme_clone_closure_compilation(dup_ok, expr, info, delta, closure_depth);
03397   case scheme_compiled_toplevel_type:
03398   case scheme_compiled_quote_syntax_type:
03399     return expr;
03400   default:
03401     if (t > _scheme_compiled_values_types_) {
03402       if (dup_ok || scheme_compiled_duplicate_ok(expr))
03403        return expr;
03404     }
03405   }
03406 
03407   return NULL;
03408 }
03409 
03410 Scheme_Object *scheme_optimize_shift(Scheme_Object *expr, int delta, int after_depth)
03411 /* Shift lexical addresses deeper by delta if already deeper than after_depth;
03412    can mutate. */
03413 {
03414   int t;
03415 
03416   /* FIXME: need stack check */
03417     
03418   t = SCHEME_TYPE(expr);
03419   
03420   switch(t) {
03421   case scheme_local_type:
03422   case scheme_local_unbox_type:
03423     {
03424       int pos = SCHEME_LOCAL_POS(expr);
03425       if (pos >= after_depth) {
03426         expr = scheme_make_local(t, SCHEME_LOCAL_POS(expr) + delta, 0);
03427       }
03428       return expr;
03429     }
03430   case scheme_compiled_syntax_type:
03431     {
03432       Scheme_Syntax_Shifter f;
03433       
03434       f = scheme_syntax_shifters[SCHEME_PINT_VAL(expr)];
03435       
03436       if (!f) {
03437         scheme_signal_error("scheme_optimize_shift: no shift available for %d", SCHEME_PINT_VAL(expr));
03438         return NULL;
03439       }
03440       return f((Scheme_Object *)SCHEME_IPTR_VAL(expr), delta, after_depth);
03441     }
03442   case scheme_application_type:
03443     {
03444       Scheme_App_Rec *app = (Scheme_App_Rec *)expr;
03445       int i;
03446       
03447       for (i = app->num_args + 1; i--; ) {
03448        expr = scheme_optimize_shift(app->args[i], delta, after_depth);
03449        app->args[i] = expr;
03450       }
03451 
03452       return (Scheme_Object *)app;
03453     }
03454   case scheme_application2_type:
03455     {
03456       Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr;
03457       
03458       expr = scheme_optimize_shift(app->rator, delta, after_depth);
03459       app->rator = expr;
03460       
03461       expr = scheme_optimize_shift(app->rand, delta, after_depth);
03462       app->rand = expr;
03463 
03464       return (Scheme_Object *)app;
03465     }
03466   case scheme_application3_type:
03467     {
03468       Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr;
03469       
03470       expr = scheme_optimize_shift(app->rator, delta, after_depth);
03471       app->rator = expr;
03472       
03473       expr = scheme_optimize_shift(app->rand1, delta, after_depth);
03474       app->rand1 = expr;
03475       
03476       expr = scheme_optimize_shift(app->rand2, delta, after_depth);
03477       app->rand2 = expr;
03478 
03479       return (Scheme_Object *)app;
03480     }
03481   case scheme_compiled_let_void_type:
03482     {
03483       Scheme_Let_Header *head = (Scheme_Let_Header *)expr;
03484       Scheme_Object *body;
03485       Scheme_Compiled_Let_Value *lv = NULL;
03486       int i;
03487 
03488       /* Build let-value change: */
03489       body = head->body;
03490       for (i = head->num_clauses; i--; ) {
03491        lv = (Scheme_Compiled_Let_Value *)body;
03492 
03493        expr = scheme_optimize_shift(lv->value, delta, after_depth + head->count);
03494        lv->value = expr;
03495 
03496         body = lv->body;
03497       }
03498       expr = scheme_optimize_shift(body, delta, after_depth + head->count);
03499 
03500       if (head->num_clauses)
03501        lv->body = expr;
03502       else
03503        head->body = expr;
03504       
03505       return (Scheme_Object *)head;
03506     }
03507   case scheme_sequence_type:
03508   case scheme_begin0_sequence_type:
03509     {
03510       Scheme_Sequence *seq = (Scheme_Sequence *)expr;
03511       int i;
03512 
03513       for (i = seq->count; i--; ) {
03514        expr = scheme_optimize_shift(seq->array[i], delta, after_depth);
03515        seq->array[i] = expr;
03516       }
03517       
03518       return (Scheme_Object *)seq;
03519     }
03520   case scheme_branch_type:
03521     {
03522       Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr;
03523 
03524       expr = scheme_optimize_shift(b->test, delta, after_depth);
03525       b->test = expr;
03526 
03527       expr = scheme_optimize_shift(b->tbranch, delta, after_depth);
03528       b->tbranch = expr;
03529 
03530       expr = scheme_optimize_shift(b->fbranch, delta, after_depth);
03531       b->fbranch = expr;
03532 
03533       return (Scheme_Object *)b;
03534     }
03535   case scheme_with_cont_mark_type:
03536     {
03537       Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr;
03538 
03539       expr = scheme_optimize_shift(wcm->key, delta, after_depth);
03540       wcm->key = expr;
03541 
03542       expr = scheme_optimize_shift(wcm->val, delta, after_depth);
03543       wcm->val = expr;
03544 
03545       expr = scheme_optimize_shift(wcm->body, delta, after_depth);
03546       wcm->body = expr;
03547 
03548       return (Scheme_Object *)wcm;      
03549     }
03550   case scheme_compiled_unclosed_procedure_type:
03551     return scheme_shift_closure_compilation(expr, delta, after_depth);
03552   case scheme_compiled_toplevel_type:
03553   case scheme_compiled_quote_syntax_type:
03554     return expr;
03555   default:
03556     return expr;
03557   }
03558 
03559   return NULL;
03560 }
03561 
03562 /*========================================================================*/
03563 /*                                  sfs                                   */
03564 /*========================================================================*/
03565 
03566 /* For debugging and measuring the worst-case cost of sfs clears: */
03567 #define MAX_SFS_CLEARING 0
03568 
03569 #define SFS_LOG(x) /* nothing */
03570 
03571 Scheme_Object *scheme_sfs(Scheme_Object *o, SFS_Info *info, int max_let_depth)
03572 {
03573   int init, i;
03574 
03575   SFS_LOG(printf("sfs %d\n", SCHEME_TYPE(o)));
03576 
03577   if (!info) {
03578     info = scheme_new_sfs_info(max_let_depth);
03579   }
03580 
03581   info->pass = 0;
03582   info->ip = 1;
03583   info->saved = scheme_null;
03584   info->min_touch = -1;
03585   info->max_touch = -1;
03586   info->tail_pos = 1;
03587   init = info->stackpos;
03588   o = scheme_sfs_expr(o, info, -1);
03589 
03590   if (info->seqn)
03591     scheme_signal_error("ended in the middle of an expression?");
03592 
03593 # if MAX_SFS_CLEARING
03594   info->max_nontail = info->ip;
03595 # endif
03596 
03597   for (i = info->depth; i-- > init; ) {
03598     info->max_calls[i] = info->max_nontail;
03599   }
03600 
03601   {
03602     Scheme_Object *v;
03603     v = scheme_reverse(info->saved);
03604     info->saved = v;
03605   }
03606 
03607   info->pass = 1;
03608   info->seqn = 0;
03609   info->ip = 1;
03610   info->tail_pos = 1;
03611   info->stackpos = init;
03612   o = scheme_sfs_expr(o, info, -1);
03613 
03614   return o;
03615 }
03616 
03617 SFS_Info *scheme_new_sfs_info(int depth)
03618 {
03619   SFS_Info *info;
03620   int *max_used, *max_calls;
03621 
03622   info = MALLOC_ONE_RT(SFS_Info);
03623   SET_REQUIRED_TAG(info->type = scheme_rt_sfs_info);
03624 
03625   info->depth = depth;
03626   info->stackpos = depth;
03627   info->tlpos = depth;
03628 
03629   max_used = (int *)scheme_malloc_atomic(sizeof(int) * depth);
03630   max_calls = (int *)scheme_malloc_atomic(sizeof(int) * depth);
03631 
03632   memset(max_used, 0, sizeof(int) * depth);
03633   memset(max_calls, 0, sizeof(int) * depth);
03634 
03635   info->max_used = max_used;
03636   info->max_calls = max_calls;
03637 
03638   return info;
03639 }
03640 
03641 static void scheme_sfs_save(SFS_Info *info, Scheme_Object *v)
03642 {
03643   if (info->pass)
03644     scheme_signal_error("internal error: wrong pass to save info");
03645   v = scheme_make_pair(v, info->saved);
03646   info->saved = v;
03647 }
03648 
03649 static Scheme_Object *scheme_sfs_next_saved(SFS_Info *info)
03650 {
03651   Scheme_Object *v;
03652 
03653   if (!info->pass)
03654     scheme_signal_error("internal error: wrong pass to get saved info");
03655   if (!SCHEME_PAIRP(info->saved))
03656     scheme_signal_error("internal error: no saved info");
03657 
03658   v = SCHEME_CAR(info->saved);
03659   info->saved = SCHEME_CDR(info->saved);
03660   return v;
03661 }
03662 
03663 void scheme_sfs_start_sequence(SFS_Info *info, int cnt, int last_is_tail)
03664 {
03665   info->seqn += (cnt - (last_is_tail ? 1 : 0));
03666 }
03667 
03668 void scheme_sfs_push(SFS_Info *info, int cnt, int track)
03669 {
03670   info->stackpos -= cnt;
03671 
03672   if (info->stackpos < 0)
03673     scheme_signal_error("internal error: pushed too deep");
03674 
03675   if (track) {
03676     while (cnt--) {
03677       scheme_sfs_used(info, cnt);
03678     }
03679   }
03680 }
03681 
03682 void scheme_sfs_used(SFS_Info *info, int pos)
03683 {
03684   if (info->pass)
03685     return;
03686 
03687   pos += info->stackpos;
03688 
03689   if ((pos < 0) || (pos >= info->depth)) {
03690     scheme_signal_error("internal error: stack use out of bounds");
03691   }
03692   if (pos == info->tlpos)
03693     scheme_signal_error("internal error: misuse of toplevel pointer");
03694 
03695   SFS_LOG(printf("touch %d %d\n", pos, info->ip));
03696   
03697   if ((info->min_touch == -1)
03698       || (pos < info->min_touch))
03699     info->min_touch = pos;
03700   if (pos > info->max_touch)
03701     info->max_touch = pos;
03702 
03703   info->max_used[pos] = info->ip;
03704 }
03705 
03706 Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre)
03707 {
03708   int len, i;
03709   Scheme_Object *loc;
03710   Scheme_Sequence *s;
03711 
03712   if (SCHEME_NULLP(clears))
03713     return expr;
03714 
03715   len = scheme_list_length(clears);
03716 
03717   s = malloc_sequence(len + 1);
03718   s->so.type = (pre ? scheme_sequence_type : scheme_begin0_sequence_type);
03719   s->count = len + 1;
03720   s->array[pre ? len : 0] = expr;
03721 
03722   for (i = 0; i < len; i++) {
03723     loc = scheme_make_local(scheme_local_type,
03724                             SCHEME_INT_VAL(SCHEME_CAR(clears)),
03725                             SCHEME_LOCAL_CLEAR_ON_READ);
03726     s->array[i + (pre ? 0 : 1)] = loc;
03727     clears = SCHEME_CDR(clears);    
03728   }
03729 
03730   if (pre)
03731     return (Scheme_Object *)s;
03732   else
03733     return scheme_make_syntax_resolved(BEGIN0_EXPD, (Scheme_Object *)s);
03734 }
03735 
03736 static void sfs_note_app(SFS_Info *info, Scheme_Object *rator)
03737 {
03738   if (!info->pass) {
03739     if (!info->tail_pos) {
03740       if (SAME_OBJ(scheme_values_func, rator))
03741         /* no need to clear for app of `values' */
03742         return;
03743       if (SCHEME_PRIMP(rator)) {
03744         int opt;
03745         opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
03746         if (opt >= SCHEME_PRIM_OPT_IMMEDIATE)
03747           /* Don't need to clear stack before an immediate/folding call */
03748           return;
03749       }
03750       info->max_nontail = info->ip;
03751     } else {
03752       if (!MAX_SFS_CLEARING && (info->selfpos >= 0)) {
03753         if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) {
03754           if ((SCHEME_LOCAL_POS(rator) + info->stackpos) == info->selfpos) {
03755             /* No point in clearing out any of the closure before the
03756                tail call. */
03757             int i;
03758             for (i = info->selflen; i--; ) {
03759               if ((info->selfstart + i) != info->tlpos)
03760                 scheme_sfs_used(info, (info->selfstart - info->stackpos) + i);
03761             }
03762           }
03763         }
03764       }
03765     }
03766   }
03767 }
03768 
03769 static Scheme_Object *sfs_application(Scheme_Object *o, SFS_Info *info)
03770 {
03771   Scheme_Object *orig, *naya = NULL;
03772   Scheme_App_Rec *app;
03773   int i, n;
03774 
03775   app = (Scheme_App_Rec *)o;
03776   n = app->num_args + 1;
03777 
03778   scheme_sfs_start_sequence(info, n, 0);
03779   scheme_sfs_push(info, n-1, 0);
03780 
03781   for (i = 0; i < n; i++) {
03782     orig = app->args[i];
03783     naya = scheme_sfs_expr(orig, info, -1);
03784     app->args[i] = naya;
03785   }
03786 
03787   sfs_note_app(info, app->args[0]);
03788 
03789   scheme_finish_application(app);
03790 
03791   return o;
03792 }
03793 
03794 static Scheme_Object *sfs_application2(Scheme_Object *o, SFS_Info *info)
03795 {
03796   Scheme_App2_Rec *app;
03797   Scheme_Object *nrator, *nrand;
03798 
03799   app = (Scheme_App2_Rec *)o;
03800 
03801   scheme_sfs_start_sequence(info, 2, 0);
03802   scheme_sfs_push(info, 1, 0);
03803 
03804   nrator = scheme_sfs_expr(app->rator, info, -1);
03805   nrand = scheme_sfs_expr(app->rand, info, -1);
03806   app->rator = nrator;
03807   app->rand = nrand;
03808 
03809   sfs_note_app(info, app->rator);
03810 
03811   set_app2_eval_type(app);
03812   
03813   return o;
03814 }
03815 
03816 static Scheme_Object *sfs_application3(Scheme_Object *o, SFS_Info *info)
03817 {
03818   Scheme_App3_Rec *app;
03819   Scheme_Object *nrator, *nrand1, *nrand2;
03820 
03821   app = (Scheme_App3_Rec *)o;
03822 
03823   scheme_sfs_start_sequence(info, 3, 0);
03824   scheme_sfs_push(info, 2, 0);
03825 
03826   nrator = scheme_sfs_expr(app->rator, info, -1);
03827   nrand1 = scheme_sfs_expr(app->rand1, info, -1);
03828   nrand2 = scheme_sfs_expr(app->rand2, info, -1);
03829   
03830   app->rator = nrator;
03831   app->rand1 = nrand1;
03832   app->rand2 = nrand2;
03833 
03834   sfs_note_app(info, app->rator);
03835 
03836   set_app3_eval_type(app);
03837 
03838   return o;
03839 }
03840 
03841 static Scheme_Object *sfs_sequence(Scheme_Object *o, SFS_Info *info)
03842 {
03843   Scheme_Object *orig, *naya;
03844   Scheme_Sequence *seq;
03845   int i, n;
03846 
03847   seq = (Scheme_Sequence *)o;
03848   n = seq->count;
03849 
03850   scheme_sfs_start_sequence(info, n, 1);
03851 
03852   for (i = 0; i < n; i++) {
03853     orig = seq->array[i];
03854     naya = scheme_sfs_expr(orig, info, -1);
03855     seq->array[i] = naya;
03856   }
03857 
03858   return o;
03859 }
03860 
03861 #define SFS_BRANCH_W 4
03862 
03863 static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip, 
03864                                      Scheme_Object *vec, int delta,
03865                                      Scheme_Object *tbranch)
03866 {
03867   int t_min_t, t_max_t, t_cnt, n, stackpos, i, save_nt, b_end, nt;
03868   Scheme_Object *t_vec, *o;
03869   Scheme_Object *clears = scheme_null;
03870 
03871   info->min_touch = -1;
03872   info->max_touch = -1;
03873   save_nt = info->max_nontail;
03874 
03875   SFS_LOG(printf("%d %d %s %d\n", info->pass, ip, (delta ? "else" : "then"), ip));
03876 
03877   if (info->pass) {
03878     /* Re-install max_used entries that refer to the branch */
03879     o = SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W];
03880     t_min_t = SCHEME_INT_VAL(o);
03881     o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2];
03882     nt = SCHEME_INT_VAL(o);
03883     if (nt > info->max_nontail)
03884       info->max_nontail = nt;
03885     if (t_min_t > -1) {
03886       t_vec = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1];
03887       t_cnt = SCHEME_VEC_SIZE(t_vec);
03888       for (i = 0; i < t_cnt; i++) {
03889         o = SCHEME_VEC_ELS(t_vec)[i];
03890         if (SCHEME_INTP(o)) {
03891           n = SCHEME_INT_VAL(o);
03892           SFS_LOG(printf(" @%d %d\n", i + t_min_t, n));
03893           if (info->max_used[i + t_min_t] < n) {
03894             SFS_LOG(printf(" |%d %d %d\n", i + t_min_t, n, info->max_nontail));
03895             info->max_used[i + t_min_t] = n;
03896             info->max_calls[i + t_min_t] = info->max_nontail;
03897           }
03898         }
03899       }
03900     }
03901     /* If the other branch has last use for something not used in this
03902        branch, and if there's a non-tail call in this branch
03903        of later, then we'll have to start with explicit clears. 
03904        Note that it doesn't matter whether the other branch actually
03905        clears them (i.e., the relevant non-tail call might be only
03906        in this branch). */
03907     o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3];
03908     b_end = SCHEME_INT_VAL(o);
03909     SFS_LOG(printf(" %d %d %d %d\n", nt, ip, b_end, save_nt));
03910     if (((nt > (ip + 1)) && (nt < b_end)) /* => non-tail call in branch */
03911         || ((ip + 1) < save_nt)) { /* => non-tail call after branches */
03912       SFS_LOG(printf(" other\n"));
03913       o = SCHEME_VEC_ELS(vec)[(1 - delta) * SFS_BRANCH_W];
03914       t_min_t = SCHEME_INT_VAL(o);
03915       if (t_min_t > -1) {
03916         int at_ip, pos;
03917         t_vec = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 1];
03918         t_cnt = SCHEME_VEC_SIZE(t_vec);
03919         o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 2];
03920         nt = SCHEME_INT_VAL(o);
03921         o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 3];
03922         b_end = SCHEME_INT_VAL(o);
03923         for (i = 0; i < t_cnt; i++) {
03924           o = SCHEME_VEC_ELS(t_vec)[i];
03925           if (SCHEME_INTP(o)) {
03926             n = SCHEME_INT_VAL(o);
03927             pos = i + t_min_t;
03928             at_ip = info->max_used[pos];
03929             SFS_LOG(printf(" ?%d %d %d\n", pos, n, at_ip));
03930             /* is last use in other branch? */
03931             if (((!delta && (at_ip == ip))
03932                  || (delta && (at_ip == n)))) {
03933               /* Yes, so add clear */
03934               SFS_LOG(printf(" !%d %d %d\n", pos, n, at_ip));
03935               pos -= info->stackpos;
03936               clears = scheme_make_pair(scheme_make_integer(pos), 
03937                                         clears);
03938             }
03939           }
03940         }
03941       }
03942     }
03943   }
03944 
03945   stackpos = info->stackpos;
03946 
03947   tbranch = scheme_sfs_expr(tbranch, info, -1);
03948 
03949   if (info->pass)
03950     info->max_nontail = save_nt;
03951 # if MAX_SFS_CLEARING
03952   else
03953     info->max_nontail = info->ip;
03954 # endif
03955 
03956   tbranch = scheme_sfs_add_clears(tbranch, clears, 1);
03957 
03958   if (!info->pass) {
03959     t_min_t = info->min_touch;
03960     t_max_t = info->max_touch;
03961     if (t_min_t < stackpos)
03962       t_min_t = stackpos;
03963     if (t_max_t < stackpos)
03964       t_max_t = -1;
03965     SFS_LOG(printf("%d %s %d [%d,%d] /%d\n", info->pass, (delta ? "else" : "then"), ip, 
03966                    t_min_t, t_max_t, stackpos));
03967     if (t_max_t < 0) {
03968       t_min_t = -1;
03969       t_vec = scheme_false;
03970     } else {
03971       t_cnt = t_max_t - t_min_t + 1;
03972       t_vec = scheme_make_vector(t_cnt, NULL);
03973       for (i = 0; i < t_cnt; i++) {
03974         n = info->max_used[i + t_min_t];
03975         SFS_LOG(printf("%d %s %d %d -> %d/%d\n", info->pass, (delta ? "else" : "then"), ip, 
03976                        i + t_min_t, n, info->max_calls[i+ t_min_t]));
03977         if (n > ip) {
03978           SCHEME_VEC_ELS(t_vec)[i] = scheme_make_integer(n);
03979           info->max_used[i + t_min_t] = ip;
03980         } else {
03981           SCHEME_VEC_ELS(t_vec)[i] = scheme_false;
03982         }
03983       }
03984     }
03985     SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W] = scheme_make_integer(t_min_t);
03986     SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1] = t_vec;
03987     SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2] = scheme_make_integer(info->max_nontail);
03988     SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3] = scheme_make_integer(info->ip);
03989   }
03990 
03991   memset(info->max_used + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int));
03992   memset(info->max_calls + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int));
03993 
03994   info->stackpos = stackpos;
03995 
03996   return tbranch;
03997 }
03998 
03999 static Scheme_Object *sfs_branch(Scheme_Object *o, SFS_Info *info)
04000 {
04001   Scheme_Branch_Rec *b;
04002   Scheme_Object *t, *tb, *fb, *vec;
04003   int ip, min_t, max_t;
04004 
04005   b = (Scheme_Branch_Rec *)o;
04006 
04007   scheme_sfs_start_sequence(info, 1, 0);
04008 
04009   t = scheme_sfs_expr(b->test, info, -1);
04010 
04011   ip = info->ip;
04012   info->ip++;
04013   /* Use ip to represent all uses in the two branches.
04014      Use ip+1 to represent all non-tail calls in the two branches. */
04015 
04016   min_t = info->min_touch;
04017   max_t = info->max_touch;
04018 
04019   SFS_LOG(printf(" after test: %d %d\n", min_t, max_t));
04020 
04021   if (!info->pass) {
04022     vec = scheme_make_vector(SFS_BRANCH_W * 2, NULL);
04023     scheme_sfs_save(info, vec);
04024   } else {
04025     vec = scheme_sfs_next_saved(info);
04026   }
04027 
04028   tb = sfs_one_branch(info, ip, vec, 0, b->tbranch);
04029 
04030   if (!info->pass) {
04031     if ((min_t == -1)
04032         || ((info->min_touch > -1) && (info->min_touch < min_t)))
04033       min_t = info->min_touch;
04034     if (info->max_touch > max_t)
04035       max_t = info->max_touch;
04036     if (info->max_nontail > ip + 1)
04037       info->max_nontail = ip + 1;
04038   }
04039 
04040   fb = sfs_one_branch(info, ip, vec, 1, b->fbranch);
04041 
04042   if (!info->pass) {
04043     if ((min_t == -1)
04044         || ((info->min_touch > -1) && (info->min_touch < min_t)))
04045       min_t = info->min_touch;
04046     if (info->max_touch > max_t)
04047       max_t = info->max_touch;
04048     if (info->max_nontail > ip + 1)
04049       info->max_nontail = ip + 1;
04050   }
04051 
04052   SFS_LOG(printf(" done if: %d %d\n", min_t, max_t));
04053   
04054   info->min_touch = min_t;
04055   info->max_touch = max_t;
04056   
04057   b->test = t;
04058   b->tbranch = tb;
04059   b->fbranch = fb;
04060 
04061   return o;
04062 }
04063 
04064 static Scheme_Object *sfs_let_value(Scheme_Object *o, SFS_Info *info)
04065 {
04066   Scheme_Let_Value *lv = (Scheme_Let_Value *)o;
04067   Scheme_Object *body, *rhs, *clears = scheme_null;
04068   int i, pos;
04069 
04070   scheme_sfs_start_sequence(info, 2, 1);
04071 
04072   rhs = scheme_sfs_expr(lv->value, info, -1);
04073 
04074   if (!info->pass
04075       || (info->ip < info->max_nontail)) {
04076     for (i = 0; i < lv->count; i++) {
04077       pos = lv->position + i;
04078       if (!info->pass)
04079         scheme_sfs_used(info, pos);
04080       else {
04081         int spos;
04082         spos = pos + info->stackpos;
04083         if ((info->max_used[spos] == info->ip)
04084             && (info->max_calls[spos] > info->ip)) {
04085           /* No one is using the id after we set it.
04086              We still need to set it, in case it's boxed and shared,
04087              but then remove the binding or box. */
04088           clears = scheme_make_pair(scheme_make_integer(pos),
04089                                     clears);
04090         }
04091       }
04092     }
04093   }
04094 
04095   body = scheme_sfs_expr(lv->body, info, -1);
04096 
04097   body = scheme_sfs_add_clears(body, clears, 1);
04098 
04099   lv->value = rhs;
04100   lv->body = body;
04101   
04102   return o;
04103 }
04104 
04105 static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
04106 {
04107   Scheme_Let_One *lo = (Scheme_Let_One *)o;
04108   Scheme_Object *body, *rhs, *vec;
04109   int pos, save_mnt, ip, et;
04110 
04111   scheme_sfs_start_sequence(info, 2, 1);
04112 
04113   scheme_sfs_push(info, 1, 1);
04114   ip = info->ip;
04115   pos = info->stackpos;
04116   save_mnt = info->max_nontail;
04117 
04118   if (!info->pass) {
04119     vec = scheme_make_vector(3, NULL);
04120     scheme_sfs_save(info, vec);
04121   } else {
04122     vec = scheme_sfs_next_saved(info);
04123     if (SCHEME_VEC_SIZE(vec) != 3)
04124       scheme_signal_error("internal error: bad vector length");
04125     info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
04126     info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
04127     info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
04128   }
04129 
04130   rhs = scheme_sfs_expr(lo->value, info, -1);
04131   body = scheme_sfs_expr(lo->body, info, -1);
04132 
04133 # if MAX_SFS_CLEARING
04134   if (!info->pass)
04135     info->max_nontail = info->ip;
04136 # endif
04137   
04138   if (!info->pass) {
04139     int n;
04140     info->max_calls[pos] = info->max_nontail;
04141     n = info->max_used[pos];
04142     SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
04143     n = info->max_calls[pos];
04144     SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
04145     SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
04146   } else {
04147     info->max_nontail = save_mnt;
04148 
04149     if (info->max_used[pos] <= ip) {
04150       /* No one is using it, so either don't push the real value, or 
04151          clear it if there's a later non-tail call.
04152          The optimizer normally would have converted away the binding, but
04153          it might not because (1) it was introduced late by inlining,
04154          or (2) the rhs expression doesn't always produce a single
04155          value. */
04156       if (scheme_omittable_expr(rhs, 1, -1, 1, NULL)) {
04157         rhs = scheme_false;
04158       } else if (ip < info->max_calls[pos]) {
04159         Scheme_Object *clr;
04160         Scheme_Sequence *s;
04161         s = malloc_sequence(2);
04162         s->so.type = scheme_sequence_type;
04163         s->count = 2;
04164         clr = scheme_make_local(scheme_local_type, 0, SCHEME_LOCAL_CLEAR_ON_READ);
04165         s->array[0] = clr;
04166         s->array[1] = body;
04167         body = (Scheme_Object *)s;
04168       }
04169     }
04170   }
04171 
04172   lo->value = rhs;
04173   lo->body = body;
04174 
04175   et = scheme_get_eval_type(lo->value);
04176   SCHEME_LET_EVAL_TYPE(lo) = et;
04177 
04178   return o;
04179 }
04180 
04181 static Scheme_Object *sfs_let_void(Scheme_Object *o, SFS_Info *info)
04182 {
04183   Scheme_Let_Void *lv = (Scheme_Let_Void *)o;
04184   Scheme_Object *body;
04185   int i, pos, save_mnt;
04186   Scheme_Object *vec;
04187     
04188   scheme_sfs_push(info, lv->count, 1);
04189   pos = info->stackpos;
04190   save_mnt = info->max_nontail;
04191 
04192   if (!info->pass) {
04193     vec = scheme_make_vector(lv->count + 1, NULL);
04194     scheme_sfs_save(info, vec);
04195   } else {
04196     vec = scheme_sfs_next_saved(info);
04197     if (!SCHEME_VECTORP(vec))
04198       scheme_signal_error("internal error: not a vector");
04199     for (i = 0; i < lv->count; i++) {
04200       info->max_used[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[i]);
04201       info->max_calls[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
04202     }
04203     info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
04204   }
04205 
04206   body = scheme_sfs_expr(lv->body, info, -1);
04207 
04208 # if MAX_SFS_CLEARING
04209   if (!info->pass)
04210     info->max_nontail = info->ip;
04211 # endif
04212 
04213   if (!info->pass) {
04214     int n;
04215     SCHEME_VEC_ELS(vec)[lv->count] = scheme_make_integer(info->max_nontail);
04216     for (i = 0; i < lv->count; i++) {
04217       n = info->max_used[pos + i];
04218       SCHEME_VEC_ELS(vec)[i] = scheme_make_integer(n);
04219     }
04220   } else {
04221     info->max_nontail = save_mnt;
04222   }
04223 
04224   lv->body = body;
04225 
04226   return o;
04227 }
04228 
04229 static Scheme_Object *sfs_letrec(Scheme_Object *o, SFS_Info *info)
04230 {
04231   Scheme_Letrec *lr = (Scheme_Letrec *)o;
04232   Scheme_Object **procs, *v, *clears = scheme_null;
04233   int i, count;
04234 
04235   count = lr->count;
04236 
04237   scheme_sfs_start_sequence(info, count + 1, 1);
04238 
04239   procs = lr->procs;
04240 
04241   for (i = 0; i < count; i++) { 
04242     v = scheme_sfs_expr(procs[i], info, i);
04243 
04244     if (SAME_TYPE(SCHEME_TYPE(v), scheme_syntax_type)
04245         && (SCHEME_PINT_VAL(v) == BEGIN0_EXPD)) {
04246       /* Some clearing actions were added to the closure.
04247          Lift them out. */
04248       int j;
04249       Scheme_Sequence *cseq = (Scheme_Sequence *)SCHEME_IPTR_VAL(v);
04250       for (j = 1; j < cseq->count; j++) {
04251         int pos;
04252         pos = SCHEME_LOCAL_POS(cseq->array[j]);
04253         clears = scheme_make_pair(scheme_make_integer(pos), clears);
04254       }
04255       v = cseq->array[0];
04256     }
04257     procs[i] = v;
04258   }
04259 
04260   v = scheme_sfs_expr(lr->body, info, -1);
04261 
04262   v = scheme_sfs_add_clears(v, clears, 1);
04263 
04264   lr->body = v;
04265 
04266   return o;
04267 }
04268 
04269 static Scheme_Object *sfs_wcm(Scheme_Object *o, SFS_Info *info)
04270 {
04271   Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
04272   Scheme_Object *k, *v, *b;
04273 
04274   scheme_sfs_start_sequence(info, 3, 1);
04275 
04276   k = scheme_sfs_expr(wcm->key, info, -1);
04277   v = scheme_sfs_expr(wcm->val, info, -1);
04278   b = scheme_sfs_expr(wcm->body, info, -1);
04279   
04280   wcm->key = k;
04281   wcm->val = v;
04282   wcm->body = b;
04283 
04284   return o;
04285 }
04286 
04287 Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos)
04288 {
04289   Scheme_Type type = SCHEME_TYPE(expr);
04290   int seqn, stackpos, tp;
04291 
04292   seqn = info->seqn;
04293   stackpos = info->stackpos;
04294   tp = info->tail_pos;
04295   if (seqn) {
04296     info->seqn = 0;
04297     info->tail_pos = 0;
04298   }
04299   info->ip++;
04300 
04301   switch (type) {
04302   case scheme_local_type:
04303   case scheme_local_unbox_type:
04304     if (!info->pass)
04305       scheme_sfs_used(info, SCHEME_LOCAL_POS(expr));
04306     else {
04307       int pos, at_ip;
04308       pos = SCHEME_LOCAL_POS(expr);
04309       at_ip = info->max_used[info->stackpos + pos];
04310       if (at_ip < info->max_calls[info->stackpos + pos]) {
04311         if (at_ip == info->ip) {
04312           /* Clear on read: */
04313           expr = scheme_make_local(type, pos, SCHEME_LOCAL_CLEAR_ON_READ);
04314         } else {
04315           /* Someone else clears it: */
04316           expr = scheme_make_local(type, pos, SCHEME_LOCAL_OTHER_CLEARS);
04317         }
04318       } else {
04319 # if MAX_SFS_CLEARING
04320         scheme_signal_error("should have been cleared somewhere");
04321 # endif
04322       }
04323     }
04324     break;
04325   case scheme_syntax_type:
04326     {
04327       Scheme_Syntax_SFSer f;
04328       Scheme_Object *orig, *naya;
04329       
04330       f = scheme_syntax_sfsers[SCHEME_PINT_VAL(expr)];
04331       orig = SCHEME_IPTR_VAL(expr);
04332       naya = f(orig, info);
04333       if (!SAME_OBJ(orig, naya))
04334         expr = naya;
04335     }
04336     break;
04337   case scheme_application_type:
04338     expr = sfs_application(expr, info);
04339     break;
04340   case scheme_application2_type:
04341     expr = sfs_application2(expr, info);
04342     break;
04343   case scheme_application3_type:
04344     expr = sfs_application3(expr, info);
04345     break;
04346   case scheme_sequence_type:
04347     expr = sfs_sequence(expr, info);
04348     break;
04349   case scheme_branch_type:
04350     expr = sfs_branch(expr, info);
04351     break;
04352   case scheme_with_cont_mark_type:
04353     expr = sfs_wcm(expr, info);
04354     break;
04355   case scheme_unclosed_procedure_type:
04356     expr = scheme_sfs_closure(expr, info, closure_self_pos);
04357     break;
04358   case scheme_let_value_type:
04359     expr = sfs_let_value(expr, info);
04360     break;
04361   case scheme_let_void_type:
04362     expr = sfs_let_void(expr, info);
04363     break;
04364   case scheme_letrec_type:
04365     expr = sfs_letrec(expr, info);
04366     break;
04367   case scheme_let_one_type:
04368     expr = sfs_let_one(expr, info);
04369     break;
04370   case scheme_closure_type:
04371     {
04372       Scheme_Closure *c = (Scheme_Closure *)expr;
04373       if (ZERO_SIZED_CLOSUREP(c)) {
04374         Scheme_Object *code;
04375        code = scheme_sfs_closure((Scheme_Object *)c->code, info, closure_self_pos);
04376         if (SAME_TYPE(SCHEME_TYPE(code), scheme_syntax_type)
04377             && (SCHEME_PINT_VAL(code) == BEGIN0_EXPD)) {
04378           Scheme_Sequence *seq = (Scheme_Sequence *)SCHEME_IPTR_VAL(code);
04379           c->code = (Scheme_Closure_Data *)seq->array[0];
04380           seq->array[0] = expr;
04381           expr = code;
04382         } else {
04383           c->code = (Scheme_Closure_Data *)code;
04384         }
04385       }
04386     }
04387     break;
04388   case scheme_toplevel_type:
04389     {
04390       int c = SCHEME_TOPLEVEL_DEPTH(expr);
04391       if (info->stackpos + c != info->tlpos)
04392         scheme_signal_error("toplevel access not at expected place");
04393     }
04394     break;
04395   case scheme_case_closure_type:
04396     {
04397       /* FIXME: maybe need to handle eagerly created closure */
04398     }
04399     break;
04400   default:
04401     break;
04402   }
04403 
04404   info->ip++;
04405 
04406   if (seqn) {
04407     info->seqn = seqn - 1;
04408     memset(info->max_used + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int));
04409     memset(info->max_calls + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int));
04410     info->stackpos = stackpos;
04411     info->tail_pos = tp;
04412   }
04413 
04414   return expr;
04415 }
04416 
04417 /*========================================================================*/
04418 /*                                  JIT                                   */
04419 /*========================================================================*/
04420 
04421 #ifdef MZ_USE_JIT
04422 
04423 static Scheme_Object *jit_application(Scheme_Object *o)
04424 {
04425   Scheme_Object *orig, *naya = NULL;
04426   Scheme_App_Rec *app, *app2;
04427   int i, n, size;
04428 
04429   app = (Scheme_App_Rec *)o;
04430   n = app->num_args + 1;
04431 
04432   for (i = 0; i < n; i++) {
04433     orig = app->args[i];
04434     naya = scheme_jit_expr(orig);
04435     if (!SAME_OBJ(orig, naya))
04436       break;
04437   }
04438 
04439   if (i >= n)
04440     return o;
04441 
04442   size = (sizeof(Scheme_App_Rec) 
04443          + ((n - 1) * sizeof(Scheme_Object *))
04444          + n * sizeof(char));
04445   app2 = (Scheme_App_Rec *)scheme_malloc_tagged(size);
04446   memcpy(app2, app, size);
04447   app2->args[i] = naya;
04448 
04449   for (i++; i < n; i++) {
04450     orig = app2->args[i];
04451     naya = scheme_jit_expr(orig);
04452     app2->args[i] = naya;
04453   }
04454   
04455   return (Scheme_Object *)app2;
04456 }
04457 
04458 static Scheme_Object *jit_application2(Scheme_Object *o)
04459 {
04460   Scheme_App2_Rec *app;
04461   Scheme_Object *nrator, *nrand;
04462 
04463   app = (Scheme_App2_Rec *)o;
04464 
04465   nrator = scheme_jit_expr(app->rator);
04466   nrand = scheme_jit_expr(app->rand);
04467   
04468   if (SAME_OBJ(nrator, app->rator)
04469       && SAME_OBJ(nrand, app->rand))
04470     return o;
04471 
04472   app = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
04473   memcpy(app, o, sizeof(Scheme_App2_Rec));
04474   app->rator = nrator;
04475   app->rand = nrand;
04476 
04477   return (Scheme_Object *)app;
04478 }
04479 
04480 static Scheme_Object *jit_application3(Scheme_Object *o)
04481 {
04482   Scheme_App3_Rec *app;
04483   Scheme_Object *nrator, *nrand1, *nrand2;
04484 
04485   app = (Scheme_App3_Rec *)o;
04486 
04487   nrator = scheme_jit_expr(app->rator);
04488   nrand1 = scheme_jit_expr(app->rand1);
04489   nrand2 = scheme_jit_expr(app->rand2);
04490   
04491   if (SAME_OBJ(nrator, app->rator)
04492       && SAME_OBJ(nrand1, app->rand1)
04493       && SAME_OBJ(nrand2, app->rand2))
04494     return o;
04495 
04496   app = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
04497   memcpy(app, o, sizeof(Scheme_App3_Rec));
04498   app->rator = nrator;
04499   app->rand1 = nrand1;
04500   app->rand2 = nrand2;
04501 
04502   return (Scheme_Object *)app;
04503 }
04504 
04505 static Scheme_Object *jit_sequence(Scheme_Object *o)
04506 {
04507   Scheme_Object *orig, *naya = NULL;
04508   Scheme_Sequence *seq, *seq2;
04509   int i, n, size;
04510 
04511   seq = (Scheme_Sequence *)o;
04512   n = seq->count;
04513 
04514   for (i = 0; i < n; i++) {
04515     orig = seq->array[i];
04516     naya = scheme_jit_expr(orig);
04517     if (!SAME_OBJ(orig, naya))
04518       break;
04519   }
04520 
04521   if (i >= n)
04522     return o;
04523 
04524   size = (sizeof(Scheme_Sequence) 
04525          + ((n - 1) * sizeof(Scheme_Object *)));
04526   seq2 = (Scheme_Sequence *)scheme_malloc_tagged(size);
04527   memcpy(seq2, seq, size);
04528   seq2->array[i] = naya;
04529 
04530   for (i++; i < n; i++) {
04531     orig = seq2->array[i];
04532     naya = scheme_jit_expr(orig);
04533     seq2->array[i] = naya;
04534   }
04535   
04536   return (Scheme_Object *)seq2;
04537 }
04538 
04539 static Scheme_Object *jit_branch(Scheme_Object *o)
04540 {
04541   Scheme_Branch_Rec *b;
04542   Scheme_Object *t, *tb, *fb;
04543 
04544   b = (Scheme_Branch_Rec *)o;
04545 
04546   t = scheme_jit_expr(b->test);
04547   tb = scheme_jit_expr(b->tbranch);
04548   fb = scheme_jit_expr(b->fbranch);
04549 
04550   if (SAME_OBJ(t, b->test)
04551       && SAME_OBJ(tb, b->tbranch)
04552       && SAME_OBJ(fb, b->fbranch))
04553     return o;
04554 
04555   b = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
04556   memcpy(b, o, sizeof(Scheme_Branch_Rec));
04557   b->test = t;
04558   b->tbranch = tb;
04559   b->fbranch = fb;
04560 
04561   return (Scheme_Object *)b;
04562 }
04563 
04564 static Scheme_Object *jit_let_value(Scheme_Object *o)
04565 {
04566   Scheme_Let_Value *lv = (Scheme_Let_Value *)o;
04567   Scheme_Object *body, *rhs;
04568 
04569   rhs = scheme_jit_expr(lv->value);
04570   body = scheme_jit_expr(lv->body);
04571 
04572   if (SAME_OBJ(rhs, lv->value)
04573       && SAME_OBJ(body, lv->body))
04574     return o;
04575 
04576   lv = MALLOC_ONE_TAGGED(Scheme_Let_Value);
04577   memcpy(lv, o, sizeof(Scheme_Let_Value));
04578   lv->value = rhs;
04579   lv->body = body;
04580 
04581   return (Scheme_Object *)lv;
04582 }
04583 
04584 static Scheme_Object *jit_let_one(Scheme_Object *o)
04585 {
04586   Scheme_Let_One *lo = (Scheme_Let_One *)o;
04587   Scheme_Object *body, *rhs;
04588 
04589   rhs = scheme_jit_expr(lo->value);
04590   body = scheme_jit_expr(lo->body);
04591 
04592   if (SAME_OBJ(rhs, lo->value)
04593       && SAME_OBJ(body, lo->body))
04594     return o;
04595 
04596   lo = MALLOC_ONE_TAGGED(Scheme_Let_One);
04597   memcpy(lo, o, sizeof(Scheme_Let_One));
04598   lo->value = rhs;
04599   lo->body = body;
04600 
04601   return (Scheme_Object *)lo;
04602 }
04603 
04604 static Scheme_Object *jit_let_void(Scheme_Object *o)
04605 {
04606   Scheme_Let_Void *lv = (Scheme_Let_Void *)o;
04607   Scheme_Object *body;
04608 
04609   body = scheme_jit_expr(lv->body);
04610 
04611   if (SAME_OBJ(body, lv->body))
04612     return o;
04613 
04614   lv = MALLOC_ONE_TAGGED(Scheme_Let_Void);
04615   memcpy(lv, o, sizeof(Scheme_Let_Void));
04616   lv->body = body;
04617 
04618   return (Scheme_Object *)lv;
04619 }
04620 
04621 static Scheme_Object *jit_letrec(Scheme_Object *o)
04622 {
04623   Scheme_Letrec *lr = (Scheme_Letrec *)o, *lr2;
04624   Scheme_Object **procs, **procs2, *v;
04625   int i, count;
04626 
04627   count = lr->count;
04628 
04629   lr2 = MALLOC_ONE_TAGGED(Scheme_Letrec);
04630   memcpy(lr2, lr, sizeof(Scheme_Letrec));
04631   
04632   procs = lr->procs;
04633   procs2 = MALLOC_N(Scheme_Object *, count);
04634   lr2->procs = procs2;
04635 
04636   for (i = 0; i < count; i++) {
04637     v = scheme_jit_closure(procs[i], (Scheme_Object *)lr2);
04638     procs2[i] = v;
04639   }
04640 
04641   v = scheme_jit_expr(lr->body);
04642   lr2->body = v;
04643 
04644   return (Scheme_Object *)lr2;
04645 }
04646 
04647 static Scheme_Object *jit_wcm(Scheme_Object *o)
04648 {
04649   Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
04650   Scheme_Object *k, *v, *b;
04651 
04652   k = scheme_jit_expr(wcm->key);
04653   v = scheme_jit_expr(wcm->val);
04654   b = scheme_jit_expr(wcm->body);
04655   if (SAME_OBJ(wcm->key, k)
04656       && SAME_OBJ(wcm->val, v)
04657       && SAME_OBJ(wcm->body, b))
04658     return o;
04659 
04660   wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
04661   memcpy(wcm, o, sizeof(Scheme_With_Continuation_Mark));
04662 
04663   wcm->key = k;
04664   wcm->val = v;
04665   wcm->body = b;
04666 
04667   return (Scheme_Object *)wcm;
04668 }
04669 
04670 Scheme_Object *scheme_jit_expr(Scheme_Object *expr)
04671 {
04672   Scheme_Type type = SCHEME_TYPE(expr);
04673 
04674   switch (type) {
04675   case scheme_syntax_type:
04676     {
04677       Scheme_Syntax_Jitter f;
04678       Scheme_Object *orig, *naya;
04679          
04680       f = scheme_syntax_jitters[SCHEME_PINT_VAL(expr)];
04681       orig = SCHEME_IPTR_VAL(expr);
04682       naya = f(orig);
04683       if (SAME_OBJ(orig, naya))
04684        return expr;
04685       
04686       return scheme_make_syntax_resolved(SCHEME_PINT_VAL(expr), naya);
04687     }
04688   case scheme_application_type:
04689     return jit_application(expr);
04690   case scheme_application2_type:
04691     return jit_application2(expr);
04692   case scheme_application3_type:
04693     return jit_application3(expr);
04694   case scheme_sequence_type:
04695     return jit_sequence(expr);
04696   case scheme_branch_type:
04697     return jit_branch(expr);
04698   case scheme_with_cont_mark_type:
04699     return jit_wcm(expr);
04700   case scheme_unclosed_procedure_type:
04701     return scheme_jit_closure(expr, NULL);
04702   case scheme_let_value_type:
04703     return jit_let_value(expr);
04704   case scheme_let_void_type:
04705     return jit_let_void(expr);
04706   case scheme_letrec_type:
04707     return jit_letrec(expr);
04708   case scheme_let_one_type:
04709     return jit_let_one(expr);
04710   case scheme_closure_type:
04711     {
04712       Scheme_Closure *c = (Scheme_Closure *)expr;
04713       if (ZERO_SIZED_CLOSUREP(c)) {
04714        /* JIT the closure body, producing a native closure: */
04715        return scheme_jit_closure((Scheme_Object *)c->code, NULL);
04716       } else
04717        return expr;
04718     }
04719   case scheme_case_closure_type:
04720     {
04721       return scheme_unclose_case_lambda(expr, 1);
04722     }
04723   default:
04724     return expr;
04725   }
04726 }
04727 
04728 #else
04729 
04730 Scheme_Object *scheme_jit_expr(Scheme_Object *expr)
04731 {
04732   return expr;
04733 }
04734 
04735 #endif
04736 
04737 /*========================================================================*/
04738 /*                       compilation info management                      */
04739 /*========================================================================*/
04740 
04741 void scheme_default_compile_rec(Scheme_Compile_Info *rec, int drec)
04742 {
04743 }
04744 
04745 void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec, 
04746                            Scheme_Compile_Info *dest, int n)
04747 {
04748   int i;
04749 
04750   for (i = 0; i < n; i++) {
04751 #ifdef MZTAG_REQUIRED
04752     dest[i].type = scheme_rt_compile_info;
04753 #endif
04754     dest[i].comp = 1;
04755     dest[i].dont_mark_local_use = src[drec].dont_mark_local_use;
04756     dest[i].resolve_module_ids = src[drec].resolve_module_ids;
04757     dest[i].no_module_cert = src[drec].no_module_cert;
04758     dest[i].value_name = scheme_false;
04759     dest[i].certs = src[drec].certs;
04760     /* should be always NULL */
04761     dest[i].observer = src[drec].observer;
04762     dest[i].pre_unwrapped = 0;
04763     dest[i].env_already = 0;
04764     dest[i].comp_flags = src[drec].comp_flags;
04765   }
04766 }
04767 
04768 void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec, 
04769                           Scheme_Expand_Info *dest, int n)
04770 {
04771   int i;
04772 
04773   for (i = 0; i < n; i++) {
04774 #ifdef MZTAG_REQUIRED
04775     dest[i].type = scheme_rt_compile_info;
04776 #endif
04777     dest[i].comp = 0;
04778     dest[i].depth = src[drec].depth;
04779     dest[i].value_name = scheme_false;
04780     dest[i].certs = src[drec].certs;
04781     dest[i].observer = src[drec].observer;
04782     dest[i].pre_unwrapped = 0;
04783     dest[i].no_module_cert = src[drec].no_module_cert;
04784     dest[i].env_already = 0;
04785     dest[i].comp_flags = src[drec].comp_flags;
04786   }
04787 }
04788 
04789 void scheme_merge_compile_recs(Scheme_Compile_Info *src, int drec, 
04790                             Scheme_Compile_Info *dest, int n)
04791 {
04792   /* Nothing to do anymore, since we moved max_let_depth to resolve phase */
04793 }
04794 
04795 void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec,
04796                          Scheme_Compile_Info *lam, int dlrec)
04797 {
04798 #ifdef MZTAG_REQUIRED
04799   lam[dlrec].type = scheme_rt_compile_info;
04800 #endif
04801   lam[dlrec].comp = 1;
04802   lam[dlrec].dont_mark_local_use = src[drec].dont_mark_local_use;
04803   lam[dlrec].resolve_module_ids = src[drec].resolve_module_ids;
04804   lam[dlrec].no_module_cert = src[drec].no_module_cert;
04805   lam[dlrec].value_name = scheme_false;
04806   lam[dlrec].certs = src[drec].certs;
04807   lam[dlrec].observer = src[drec].observer;
04808   lam[dlrec].pre_unwrapped = 0;
04809   lam[dlrec].env_already = 0;
04810   lam[dlrec].comp_flags = src[drec].comp_flags;
04811 }
04812 
04813 void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec,
04814                           Scheme_Compile_Info *lam, int dlrec)
04815 {
04816 }
04817 
04818 void scheme_compile_rec_done_local(Scheme_Compile_Info *rec, int drec)
04819 {
04820   rec[drec].value_name = scheme_false;
04821 }
04822 
04823 void scheme_rec_add_certs(Scheme_Compile_Expand_Info *src, int drec, Scheme_Object *stx)
04824 {
04825   Scheme_Object *certs;
04826   certs = scheme_stx_extract_certs(stx, src[drec].certs);
04827   src[drec].certs = certs;
04828 }
04829 
04830 /*========================================================================*/
04831 /*                         compilation dispatcher                         */
04832 /*========================================================================*/
04833 
04834 static Scheme_Object *
04835 scheme_inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, 
04836                        Scheme_Compile_Info *rec, int drec, int start_app_position)
04837 {
04838   int len;
04839 
04840   len = scheme_stx_proper_list_length(form);
04841 
04842   if (!len) {
04843     scheme_compile_rec_done_local(rec, drec);
04844     scheme_default_compile_rec(rec, drec);
04845     return scheme_null;
04846   } else if (len > 0) {
04847     Scheme_Compile_Info *recs, quick[5];
04848     int i;
04849     Scheme_Object *c, *p, *comp_first, *comp_last, *name, *first, *rest;
04850 
04851     name = rec[drec].value_name;
04852     scheme_compile_rec_done_local(rec, drec);
04853 
04854     if (len <= 5)
04855       recs = quick;
04856     else
04857       recs = MALLOC_N_RT(Scheme_Compile_Info, len);
04858     scheme_init_compile_recs(rec, drec, recs, len);
04859     recs[len - 1].value_name = name;
04860 
04861     comp_first = comp_last = NULL;
04862 
04863     for (i = 0, rest = form; i < len; i++) {
04864       first = SCHEME_STX_CAR(rest);
04865       rest = SCHEME_STX_CDR(rest);
04866 
04867       c = scheme_compile_expand_expr(first, env, recs, i,
04868                                  !i && start_app_position);
04869 
04870       p = scheme_make_pair(c, scheme_null);
04871       if (comp_last)
04872        SCHEME_CDR(comp_last) = p;
04873       else
04874        comp_first = p;
04875       comp_last = p;
04876     }
04877 
04878     scheme_merge_compile_recs(rec, drec, recs, len);
04879 
04880     return comp_first;
04881   } else {
04882     scheme_signal_error("internal error: compile-list on non-list");
04883     return NULL;
04884   }
04885 }
04886 
04887 static Scheme_Object *compile_application(Scheme_Object *form, Scheme_Comp_Env *env,
04888                                      Scheme_Compile_Info *rec, int drec)
04889 {
04890   Scheme_Object *result;
04891   int len;
04892 
04893   len = scheme_stx_proper_list_length(form);
04894 
04895   if (len < 0)
04896     scheme_wrong_syntax(scheme_application_stx_string, NULL, form, NULL);
04897   
04898   scheme_compile_rec_done_local(rec, drec);
04899   scheme_rec_add_certs(rec, drec, form);
04900   form = scheme_inner_compile_list(form, scheme_no_defines(env), rec, drec, 1);
04901 
04902   result = make_application(form);
04903   
04904   return result;
04905 }
04906 
04907 Scheme_Object *
04908 scheme_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, 
04909                   Scheme_Compile_Info *rec, int drec)
04910 {
04911   return scheme_inner_compile_list(form, env, rec, drec, 0);
04912 }
04913 
04914 static Scheme_Object *call_compile_handler(Scheme_Object *form, int immediate_eval)
04915 {
04916   Scheme_Object *argv[2], *o;
04917 
04918   argv[0] = form;
04919   argv[1] = (immediate_eval ? scheme_true : scheme_false);
04920   o = scheme_get_param(scheme_current_config(), MZCONFIG_COMPILE_HANDLER);
04921   o = scheme_apply(o, 2, argv);
04922   
04923   if (!SAME_TYPE(SCHEME_TYPE(o), scheme_compilation_top_type)) {
04924     argv[0] = o;
04925     scheme_wrong_type("compile-handler", "compiled code", 0, -1, argv);
04926     return NULL;
04927   }
04928 
04929   return o;
04930 }
04931 
04932 static Scheme_Object *add_renames_unless_module(Scheme_Object *form, Scheme_Env *genv)
04933 {
04934   if (genv->rename_set) {
04935     if (SCHEME_STX_PAIRP(form)) {
04936       Scheme_Object *a, *d, *module_stx;
04937       
04938       a = SCHEME_STX_CAR(form);
04939       if (SCHEME_STX_SYMBOLP(a)) {
04940        a = scheme_add_rename(a, genv->rename_set);
04941         module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"),
04942                                             scheme_false, 
04943                                             scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), 
04944                                             0, 0);
04945        if (scheme_stx_module_eq(a, module_stx, genv->phase)) {
04946          /* Don't add renames to the whole module; let the 
04947             module's language take over. */
04948          d = SCHEME_STX_CDR(form);
04949          a = scheme_make_pair(a, d);
04950          form = scheme_datum_to_syntax(a, form, form, 0, 1);
04951          return form;
04952        }
04953       }
04954     }
04955   }
04956 
04957   if (genv->rename_set) {
04958     form = scheme_add_rename(form, genv->rename_set);
04959     /* this "phase shift" just attaches the namespace's module registry: */
04960     form = scheme_stx_phase_shift(form, 0, NULL, NULL, genv->export_registry);
04961   }
04962 
04963   return form;
04964 }
04965 
04966 static int get_comp_flags(Scheme_Config *config)
04967 {
04968   int comp_flags = 0;
04969 
04970   if (!config)
04971     config = scheme_current_config();
04972 
04973   if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), 
04974                                     MZCONFIG_ALLOW_SET_UNDEFINED)))
04975     comp_flags |= COMP_ALLOW_SET_UNDEFINED;
04976   if (SCHEME_FALSEP(scheme_get_param(scheme_current_config(), 
04977                                      MZCONFIG_DISALLOW_INLINE)))
04978     comp_flags |= COMP_CAN_INLINE;
04979 
04980   return comp_flags;
04981 }
04982 
04983 void scheme_enable_expression_resolve_lifts(Resolve_Info *ri)
04984 {
04985   Scheme_Object *lift_vec;
04986 
04987   lift_vec = scheme_make_vector(2, NULL);
04988   SCHEME_VEC_ELS(lift_vec)[0] = scheme_null;
04989   SCHEME_VEC_ELS(lift_vec)[1] = scheme_make_integer(0);
04990   ri->lifts = lift_vec;
04991 }
04992 
04993 Scheme_Object *scheme_merge_expression_resolve_lifts(Scheme_Object *expr, Resolve_Prefix *rp, Resolve_Info *ri)
04994 {
04995   Scheme_Object *lift_vec, *lifts;
04996   Scheme_Sequence *s;
04997   int n, i;
04998 
04999   lift_vec = ri->lifts;
05000   n = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]);
05001   if (n) {
05002     rp->num_lifts = n;
05003     lifts = SCHEME_VEC_ELS(lift_vec)[0];
05004 
05005     s = malloc_sequence(n + 1);
05006     s->so.type = scheme_sequence_type;
05007     s->count = n + 1;
05008     for (i = 0; i < n; i++, lifts = SCHEME_CDR(lifts)) {
05009       s->array[i] = SCHEME_CAR(lifts);
05010     }
05011     s->array[i] = expr;
05012 
05013     return (Scheme_Object *)s;
05014   } else
05015     return expr;
05016 }
05017 
05018 static void *compile_k(void)
05019 {
05020   Scheme_Thread *p = scheme_current_thread;
05021   Scheme_Object *form;
05022   int writeable, for_eval, rename, enforce_consts, comp_flags;
05023   Scheme_Env *genv;
05024   Scheme_Compile_Info rec, rec2;
05025   Scheme_Object *o, *rl, *tl_queue;
05026   Scheme_Compilation_Top *top;
05027   Resolve_Prefix *rp;
05028   Resolve_Info *ri;
05029   Optimize_Info *oi;
05030   Scheme_Object *gval, *insp;
05031   Scheme_Comp_Env *cenv;
05032 
05033   form = (Scheme_Object *)p->ku.k.p1;
05034   genv = (Scheme_Env *)p->ku.k.p2;
05035   writeable = p->ku.k.i1;
05036   for_eval = p->ku.k.i2;
05037   rename = p->ku.k.i3;
05038 
05039   p->ku.k.p1 = NULL;
05040   p->ku.k.p2 = NULL;
05041 
05042   if (!SCHEME_STXP(form)) {
05043     form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0);
05044     rename = 1;
05045   }
05046 
05047   /* Renamings for requires: */
05048   if (rename) {
05049     form = add_renames_unless_module(form, genv);
05050     if (genv->module) {
05051       form = scheme_stx_phase_shift(form, 0, 
05052                                 genv->module->me->src_modidx, 
05053                                 genv->module->self_modidx,
05054                                 genv->export_registry);
05055     }
05056   }
05057 
05058   tl_queue = scheme_null;
05059 
05060   {
05061     Scheme_Config *config;
05062     config = scheme_current_config();
05063     insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR);
05064     enforce_consts = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS));
05065     comp_flags = get_comp_flags(config);
05066   }
05067 
05068   while (1) {
05069     scheme_prepare_compile_env(genv);
05070 
05071     rec.comp = 1;
05072     rec.dont_mark_local_use = 0;
05073     rec.resolve_module_ids = !writeable && !genv->module;
05074     rec.no_module_cert = 0;
05075     rec.value_name = scheme_false;
05076     rec.certs = NULL;
05077     rec.observer = NULL;
05078     rec.pre_unwrapped = 0;
05079     rec.env_already = 0;
05080     rec.comp_flags = comp_flags;
05081 
05082     cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME);
05083 
05084     if (for_eval) {
05085       /* Need to look for top-level `begin', and if we
05086         find one, break it up to eval first expression
05087         before the rest. */
05088       while (1) {
05089        scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), 
05090                                     scheme_false, scheme_false, scheme_null, scheme_false);
05091        form = scheme_check_immediate_macro(form, 
05092                                        cenv, &rec, 0,
05093                                        0, &gval, NULL, NULL);
05094        if (SAME_OBJ(gval, scheme_begin_syntax)) {
05095          if (scheme_stx_proper_list_length(form) > 1){
05096            form = SCHEME_STX_CDR(form);
05097            tl_queue = scheme_append(scheme_flatten_syntax_list(form, NULL),
05098                                  tl_queue);
05099            tl_queue = scheme_append(scheme_frame_get_lifts(cenv),
05100                                  tl_queue);
05101            form = SCHEME_CAR(tl_queue);
05102            tl_queue = SCHEME_CDR(tl_queue);
05103          } else
05104            break;
05105        } else {
05106          rl = scheme_frame_get_require_lifts(cenv);
05107          o = scheme_frame_get_lifts(cenv);
05108          if (!SCHEME_NULLP(o)
05109               || !SCHEME_NULLP(rl)) {
05110            tl_queue = scheme_make_pair(form, tl_queue);
05111            tl_queue = scheme_append(o, tl_queue);
05112            tl_queue = scheme_append(rl, tl_queue);
05113            form = SCHEME_CAR(tl_queue);
05114            tl_queue = SCHEME_CDR(tl_queue);
05115          }
05116          break;
05117        }
05118       }
05119     }
05120 
05121     if (for_eval) {
05122       o = call_compile_handler(form, 1);
05123       top = (Scheme_Compilation_Top *)o;
05124     } else {
05125       /* We want to simply compile `form', but we have to loop in case
05126         an expression is lifted in the process of compiling: */
05127       Scheme_Object *l, *prev_o = NULL;
05128 
05129       while (1) {
05130        scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), 
05131                                     scheme_false, scheme_false, scheme_null, scheme_false);
05132 
05133        scheme_init_compile_recs(&rec, 0, &rec2, 1);
05134 
05135        o = scheme_compile_expr(form, cenv, &rec2, 0);
05136 
05137        /* If we had compiled an expression in a previous iteration,
05138           combine it in a sequence: */
05139        if (prev_o) {
05140          Scheme_Sequence *seq;
05141          seq = malloc_sequence(2);
05142          seq->so.type = scheme_sequence_type;
05143          seq->count = 2;
05144          seq->array[0] = o;
05145          seq->array[1] = prev_o;
05146          o = (Scheme_Object *)seq;
05147        }
05148 
05149        /* If any definitions were lifted in the process of compiling o,
05150           we need to fold them in. */
05151        l = scheme_frame_get_lifts(cenv);
05152        rl = scheme_frame_get_require_lifts(cenv);
05153        if (!SCHEME_NULLP(l)
05154             || !SCHEME_NULLP(rl)) {
05155           rl = scheme_append(rl, l);
05156           rl = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0),
05157                      rl);
05158           form = scheme_datum_to_syntax(rl, scheme_false, scheme_false, 0, 0);
05159          prev_o = o;
05160        } else 
05161          break;
05162       }
05163 
05164       oi = scheme_optimize_info_create();
05165       oi->enforce_const = enforce_consts;
05166       if (!(comp_flags & COMP_CAN_INLINE))
05167         oi->inline_fuel = -1;
05168       o = scheme_optimize_expr(o, oi);
05169 
05170       rp = scheme_resolve_prefix(0, cenv->prefix, 1);
05171       ri = scheme_resolve_info_create(rp);
05172       ri->enforce_const = enforce_consts;
05173       scheme_enable_expression_resolve_lifts(ri);
05174 
05175       o = scheme_resolve_expr(o, ri);
05176       o = scheme_sfs(o, NULL, ri->max_let_depth);
05177 
05178       o = scheme_merge_expression_resolve_lifts(o, rp, ri);
05179 
05180       rp = scheme_remap_prefix(rp, ri);
05181 
05182       top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top);
05183       top->so.type = scheme_compilation_top_type;
05184       top->max_let_depth = ri->max_let_depth;
05185       top->code = o;
05186       top->prefix = rp;
05187 
05188       if (0) { /* <- change to 1 to check compilation result */
05189         scheme_validate_code(NULL, top->code,
05190                              top->max_let_depth,
05191                              top->prefix->num_toplevels,
05192                              top->prefix->num_stxes,
05193                              top->prefix->num_lifts,
05194                              0);
05195       }
05196     }
05197 
05198     if (SCHEME_PAIRP(tl_queue)) {
05199       /* This compile is interleaved with evaluation,
05200         and we need to eval now before compiling more. */
05201       _eval_compiled_multi_with_prompt((Scheme_Object *)top, genv);
05202 
05203       form = SCHEME_CAR(tl_queue);
05204       tl_queue = SCHEME_CDR(tl_queue);
05205     } else
05206       break;
05207   }
05208 
05209   return (void *)top;
05210 }
05211 
05212 static Scheme_Object *_compile(Scheme_Object *form, Scheme_Env *env, int writeable, int for_eval, int eb, int rename)
05213 {
05214   Scheme_Thread *p = scheme_current_thread;
05215 
05216   if (SAME_TYPE(SCHEME_TYPE(form), scheme_compilation_top_type))
05217     return form;
05218 
05219   if (SCHEME_STXP(form)) {
05220     if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_compilation_top_type))
05221       return SCHEME_STX_VAL(form);
05222   }
05223 
05224   p->ku.k.p1 = form;
05225   p->ku.k.p2 = env;
05226   p->ku.k.i1 = writeable;
05227   p->ku.k.i2 = for_eval;
05228   p->ku.k.i3 = rename;
05229 
05230   return (Scheme_Object *)scheme_top_level_do(compile_k, eb);
05231 }
05232 
05233 Scheme_Object *scheme_compile(Scheme_Object *form, Scheme_Env *env, int writeable)
05234 {
05235   return _compile(form, env, writeable, 0, 1, 1);
05236 }
05237 
05238 Scheme_Object *scheme_compile_for_eval(Scheme_Object *form, Scheme_Env *env)
05239 {
05240   return _compile(form, env, 0, 1, 1, 1);
05241 }
05242 
05243 Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, 
05244                                        Scheme_Comp_Env *env, 
05245                                        Scheme_Compile_Expand_Info *rec, int drec,
05246                                        int internel_def_pos,
05247                                        Scheme_Object **current_val,
05248                                        Scheme_Comp_Env **_xenv,
05249                                        Scheme_Object *ctx)
05250 {
05251   Scheme_Object *name, *val, *certs;
05252   Scheme_Comp_Env *xenv = (_xenv ? *_xenv : NULL);
05253   Scheme_Expand_Info erec1;
05254   Scheme_Env *menv = NULL;
05255   int need_cert;
05256 
05257   SCHEME_EXPAND_OBSERVE_ENTER_CHECK(rec[drec].observer, first);
05258 
05259   while (1) {
05260     *current_val = NULL;
05261 
05262     if (SCHEME_STX_PAIRP(first)) {
05263       name = SCHEME_STX_CAR(first);
05264       need_cert = 1;
05265     } else {
05266       name = first;
05267       need_cert = 0;
05268     }
05269 
05270     if (!SCHEME_STX_SYMBOLP(name)) {
05271       SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
05272       return first;
05273     }
05274 
05275     while (1) {
05276 
05277       if (need_cert) {
05278         /* While resolving name, we need certs from `first' */
05279         scheme_init_expand_recs(rec, drec, &erec1, 1);
05280         scheme_rec_add_certs(&erec1, 0, first);
05281         certs = erec1.certs;
05282       } else
05283         certs = rec[drec].certs;
05284 
05285       val = scheme_lookup_binding(name, env, 
05286                                   SCHEME_NULL_FOR_UNBOUND
05287                                   + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
05288                                   + SCHEME_DONT_MARK_USE
05289                                   + ((!rec[drec].comp && (rec[drec].depth == -2))
05290                                      ? SCHEME_OUT_OF_CONTEXT_OK
05291                                      : 0)
05292                                   + ((rec[drec].comp && rec[drec].resolve_module_ids)
05293                                      ? SCHEME_RESOLVE_MODIDS
05294                                      : 0),
05295                                   certs, env->in_modidx,
05296                                   &menv, NULL, NULL);
05297     
05298       if (SCHEME_STX_PAIRP(first))
05299         *current_val = val;
05300 
05301       if (!val) {
05302         SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
05303         return first;
05304       } else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) {
05305         if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) {
05306           /* It's a rename. Look up the target name and try again. */
05307           name = scheme_stx_cert(scheme_rename_transformer_id(SCHEME_PTR_VAL(val)), 
05308                                  scheme_false, menv, name, NULL, 1);
05309           menv = NULL;
05310           SCHEME_USE_FUEL(1);
05311         } else {
05312           /* It's a normal macro; expand once. Also, extend env to indicate
05313              an internal-define position, if necessary. */
05314           if (!xenv) {
05315             if (internel_def_pos) {
05316               xenv = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, env, NULL);
05317               if (ctx)
05318                 xenv->intdef_name = ctx;
05319               if (_xenv)
05320                 *_xenv = xenv;
05321             } else
05322               xenv = env;
05323           }
05324           {
05325             scheme_init_expand_recs(rec, drec, &erec1, 1);
05326             erec1.depth = 1;
05327             erec1.value_name = rec[drec].value_name;
05328             first = scheme_expand_expr(first, xenv, &erec1, 0);
05329           }
05330           break; /* break to outer loop */
05331         }
05332       } else {
05333         SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
05334         return first;
05335       }
05336     }
05337   }
05338 }
05339 
05340 static Scheme_Object *
05341 compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *macro,
05342                       Scheme_Object *form, Scheme_Comp_Env *env,
05343                       Scheme_Compile_Expand_Info *rec, int drec)
05344 {
05345   Scheme_Object *xformer, *boundname;
05346 
05347   xformer = (Scheme_Object *)SCHEME_PTR_VAL(macro);
05348 
05349   if (scheme_is_set_transformer(xformer)) {
05350     /* scheme_apply_macro unwraps it */
05351   } else {
05352     if (!scheme_check_proc_arity(NULL, 1, 0, -1, &xformer)) {
05353       scheme_wrong_syntax(NULL, NULL, form, "illegal use of syntax");
05354       return NULL;
05355     }
05356   }
05357 
05358   boundname = rec[drec].value_name;
05359   if (!boundname)
05360     boundname = scheme_false;
05361 
05362   return scheme_apply_macro(name, menv, xformer, form, env, boundname, rec, drec, 0);
05363 
05364   /* caller expects rec[drec] to be used to compile the result... */
05365 }
05366 
05367 static int same_effective_env(Scheme_Comp_Env *orig, Scheme_Comp_Env *e)
05368 {
05369   while (1) {
05370     if (orig == e)
05371       return 1;
05372     if (e && e->flags & SCHEME_FOR_STOPS)
05373       e = e->next;
05374     else
05375       return 0;
05376   }
05377 }
05378 
05379 static Scheme_Object *compile_expand_expr_k(void)
05380 {
05381   Scheme_Thread *p = scheme_current_thread;
05382   Scheme_Object *form = (Scheme_Object *)p->ku.k.p1;
05383   Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2;
05384   Scheme_Compile_Info *rec = (Scheme_Compile_Info *)p->ku.k.p3;
05385 
05386   p->ku.k.p1 = NULL;
05387   p->ku.k.p2 = NULL;
05388   p->ku.k.p3 = NULL;
05389 
05390   return scheme_compile_expand_expr(form, 
05391                                 env,
05392                                 rec,
05393                                 p->ku.k.i3,
05394                                 p->ku.k.i2);
05395 }
05396 
05397 static Scheme_Object *
05398 scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, 
05399                         Scheme_Compile_Expand_Info *rec, int drec, 
05400                         int app_position)
05401 {
05402   Scheme_Object *name, *var, *stx, *normal, *can_recycle_stx = NULL, *orig_unbound_name = NULL;
05403   Scheme_Env *menv = NULL;
05404   GC_CAN_IGNORE char *not_allowed;
05405   int looking_for_top, has_orig_unbound = 0;
05406 
05407  top:
05408 
05409 #ifdef DO_STACK_CHECK
05410   {
05411 # include "mzstkchk.h"
05412     {
05413       Scheme_Thread *p = scheme_current_thread;
05414       Scheme_Compile_Expand_Info *recx;
05415 
05416       recx = MALLOC_ONE_RT(Scheme_Compile_Expand_Info);
05417       memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info));
05418 #ifdef MZTAG_REQUIRED
05419       recx->type = scheme_rt_compile_info;
05420 #endif
05421 
05422       p->ku.k.p1 = (void *)form;
05423       p->ku.k.p2 = (void *)env;
05424       p->ku.k.p3 = (void *)recx;
05425       p->ku.k.i3 = 0;
05426       p->ku.k.i2 = app_position;
05427 
05428       var = scheme_handle_stack_overflow(compile_expand_expr_k);
05429 
05430       memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info));
05431       return var;
05432     }
05433   }
05434 #endif
05435 
05436   DO_CHECK_FOR_BREAK(scheme_current_thread, ;);
05437 
05438 #if 1
05439   if (!SCHEME_STXP(form))
05440     scheme_signal_error("not syntax");
05441 #endif
05442 
05443   if (rec[drec].comp) {
05444     scheme_default_compile_rec(rec, drec);
05445   } else {
05446     SCHEME_EXPAND_OBSERVE_VISIT(rec[drec].observer,form);
05447   }
05448 
05449   if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_expanded_syntax_type)) {
05450     var = SCHEME_STX_VAL(form);
05451     if (scheme_stx_has_empty_wraps(form)
05452         && same_effective_env(SCHEME_PTR2_VAL(var), env)) {
05453       /* FIXME: this needs EXPAND_OBSERVE callbacks. */
05454       var = scheme_stx_track(SCHEME_PTR1_VAL(var), form, form);
05455       form = scheme_stx_cert(var, scheme_false, NULL, form, NULL, 1);
05456       if (!rec[drec].comp && (rec[drec].depth != -1)) {
05457         /* Already fully expanded. */
05458         return form;
05459       }
05460     } else {
05461       scheme_wrong_syntax(NULL, NULL, SCHEME_PTR1_VAL(var), 
05462                           "expanded syntax not in its original lexical context"
05463                           " (extra bindings or marks in the current context)");
05464     }
05465   }
05466 
05467   looking_for_top = 0;
05468 
05469   if (SCHEME_STX_NULLP(form)) {
05470     stx = app_symbol;
05471     not_allowed = "function application";
05472     normal = app_expander;
05473   } else if (!SCHEME_STX_PAIRP(form)) {
05474     if (SCHEME_STX_SYMBOLP(form)) {
05475       Scheme_Object *find_name = form, *lexical_binding_id;
05476       int protected = 0;
05477 
05478       while (1) {
05479         lexical_binding_id = NULL;
05480        var = scheme_lookup_binding(find_name, env, 
05481                                 SCHEME_NULL_FOR_UNBOUND
05482                                 + SCHEME_ENV_CONSTANTS_OK
05483                                 + (rec[drec].comp
05484                                    ? SCHEME_ELIM_CONST 
05485                                    : 0)
05486                                 + (app_position 
05487                                    ? SCHEME_APP_POS 
05488                                    : 0)
05489                                 + ((rec[drec].comp && rec[drec].dont_mark_local_use) ? 
05490                                    SCHEME_DONT_MARK_USE 
05491                                    : 0)
05492                                 + ((rec[drec].comp && rec[drec].resolve_module_ids)
05493                                    ? SCHEME_RESOLVE_MODIDS
05494                                    : 0)
05495                                     + ((!rec[drec].comp && (rec[drec].depth == -2))
05496                                        ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)
05497                                        : 0),
05498                                 rec[drec].certs, env->in_modidx, 
05499                                 &menv, &protected, &lexical_binding_id);
05500 
05501         SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer,find_name);
05502 
05503        if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
05504            && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
05505          /* It's a rename. Look up the target name and try again. */
05506          Scheme_Object *new_name;
05507          new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
05508          if (!rec[drec].comp) {
05509            new_name = scheme_stx_track(new_name, find_name, find_name);
05510          }
05511          new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
05512          find_name = new_name;
05513          SCHEME_USE_FUEL(1);
05514          menv = NULL;
05515          protected = 0;
05516        } else
05517          break;
05518       }
05519       
05520       if (!var) {
05521        /* Top variable */
05522        stx = top_symbol;
05523         if (env->genv->module)
05524           not_allowed = "reference to an unbound identifier";
05525         else
05526           not_allowed = "reference to a top-level identifier";
05527        normal = top_expander;
05528         has_orig_unbound = 1;
05529        form = find_name; /* in case it was re-mapped */
05530        looking_for_top = 1;
05531       } else {
05532        if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) {
05533          if (var == stop_expander) {
05534             SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer,form);
05535             SCHEME_EXPAND_OBSERVE_PRIM_STOP(rec[drec].observer);
05536             SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer,form);
05537             SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer,form);
05538            return form;
05539           } else {
05540            scheme_wrong_syntax(NULL, NULL, form, "bad syntax");
05541            return NULL;
05542          }
05543        } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) {
05544          name = form;
05545          goto macro;
05546        }
05547        
05548        if (rec[drec].comp) {
05549          scheme_compile_rec_done_local(rec, drec);
05550          if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
05551              || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type))
05552            return scheme_register_toplevel_in_prefix(var, env, rec, drec);
05553          else
05554            return var;
05555        } else {
05556           SCHEME_EXPAND_OBSERVE_VARIABLE(rec[drec].observer, form, find_name);
05557           if (lexical_binding_id) {
05558             find_name = lexical_binding_id;
05559           }
05560          if (protected) {
05561            /* Add a property to indicate that the name is protected */
05562            find_name = scheme_stx_property(find_name, protected_symbol, scheme_true);
05563          }
05564           SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, find_name);
05565          return find_name; /* which is usually == form */
05566        }
05567       }
05568     } else {
05569       /* A hack for handling lifted expressions. See compile_expand_lift_to_let. */
05570       if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_already_comp_type)) {
05571        form = SCHEME_STX_VAL(form);
05572        return SCHEME_IPTR_VAL(form);
05573       }
05574 
05575       stx = datum_symbol;
05576       not_allowed = "literal data";
05577       normal = datum_expander;
05578     }
05579   } else {
05580     name = SCHEME_STX_CAR(form);
05581     if (SCHEME_STX_SYMBOLP(name)) {
05582       /* Check for macros: */
05583       Scheme_Object *find_name = name;
05584       Scheme_Expand_Info erec1;
05585 
05586       /* While resolving name, we need certs from `form' */
05587       scheme_init_expand_recs(rec, drec, &erec1, 1);
05588       scheme_rec_add_certs(&erec1, 0, form);
05589 
05590       while (1) {
05591        var = scheme_lookup_binding(find_name, env, 
05592                                 SCHEME_APP_POS
05593                                 + SCHEME_NULL_FOR_UNBOUND
05594                                 + SCHEME_ENV_CONSTANTS_OK
05595                                 + (rec[drec].comp
05596                                    ? SCHEME_ELIM_CONST
05597                                    : 0)
05598                                 + SCHEME_DONT_MARK_USE
05599                                 + ((rec[drec].comp && rec[drec].resolve_module_ids)
05600                                    ? SCHEME_RESOLVE_MODIDS
05601                                    : 0)
05602                                     + ((!rec[drec].comp && (rec[drec].depth == -2))
05603                                        ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)
05604                                        : 0),
05605                                 erec1.certs, env->in_modidx, 
05606                                 &menv, NULL, NULL);
05607 
05608         SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name);
05609        if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
05610            && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
05611          /* It's a rename. Look up the target name and try again. */
05612          Scheme_Object *new_name;
05613          new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
05614          if (!rec[drec].comp) {
05615            new_name = scheme_stx_track(new_name, find_name, find_name);
05616          }
05617          new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
05618          find_name = new_name;
05619          SCHEME_USE_FUEL(1);
05620          menv = NULL;
05621        } else
05622          break;
05623       }
05624       
05625       if (!var) {
05626        /* apply to global variable: compile it normally */
05627         orig_unbound_name = find_name;
05628         has_orig_unbound = 1;
05629       } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)
05630                || SAME_TYPE(SCHEME_TYPE(var), scheme_local_unbox_type)) {
05631        /* apply to local variable: compile it normally */
05632       } else {
05633        if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) {
05634          goto macro;
05635        } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) {
05636          if (rec[drec].comp) {
05637            Scheme_Syntax *f;
05638            f = (Scheme_Syntax *)SCHEME_SYNTAX(var);
05639            return f(form, env, rec, drec);
05640          } else {
05641            Scheme_Syntax_Expander *f;
05642            f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var);
05643            SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer, form);
05644            form = f(form, env, rec, drec);
05645            SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer, form);
05646            SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form);
05647            return form;
05648          }
05649        }
05650        
05651        /* Else: unknown global - must be a function: compile as application */
05652       }
05653 
05654       if (!SAME_OBJ(name, find_name)) {
05655        /* the rator position was mapped */
05656        Scheme_Object *code;
05657        code = SCHEME_STX_CDR(form);
05658        code = scheme_make_pair(find_name, code);
05659        form = scheme_datum_to_syntax(code, form, form, 0, 0);
05660       }
05661     }
05662 
05663     stx = app_symbol;
05664     not_allowed = "function application";
05665     normal = app_expander;
05666   }
05667 
05668   /* Compile/expand as application, datum, or top: */
05669   if (quick_stx && rec[drec].comp) {
05670     ((Scheme_Stx *)quick_stx)->val = stx;
05671     ((Scheme_Stx *)quick_stx)->wraps = ((Scheme_Stx *)form)->wraps;
05672     ((Scheme_Stx *)quick_stx)->u.modinfo_cache = NULL;
05673     stx = quick_stx;
05674     quick_stx = NULL;
05675   } else
05676     stx = scheme_datum_to_syntax(stx, scheme_false, form, 0, 0);
05677   if (rec[drec].comp)
05678     can_recycle_stx = stx;
05679 
05680   {
05681     Scheme_Object *find_name = stx;
05682 
05683     while (1) {
05684       var = scheme_lookup_binding(find_name, env,
05685                               SCHEME_NULL_FOR_UNBOUND
05686                               + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
05687                               + SCHEME_DONT_MARK_USE
05688                                   + ((!rec[drec].comp && (rec[drec].depth == -2))
05689                                      ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)
05690                                      : 0),
05691                               rec[drec].certs, env->in_modidx, 
05692                               &menv, NULL, NULL);
05693 
05694       SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name);
05695 
05696       if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
05697          && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
05698        /* It's a rename. Look up the target name and try again. */
05699        Scheme_Object *new_name;
05700        new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
05701        if (!rec[drec].comp) {
05702          new_name = scheme_stx_track(new_name, find_name, find_name);
05703        }
05704        new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
05705        find_name = new_name;
05706        SCHEME_USE_FUEL(1);
05707        menv = NULL;
05708       } else
05709        break;
05710     }
05711   }
05712 
05713   if (!SAME_OBJ(var, normal)) {
05714     /* Someone might keep the stx: */
05715     can_recycle_stx = NULL;
05716   }
05717 
05718   if (!var && looking_for_top) {
05719     /* If form is a marked name, then force #%top binding.
05720        This is so temporaries can be used as defined ids. */
05721     Scheme_Object *nm;
05722     nm = scheme_tl_id_sym(env->genv, form, NULL, 0, NULL, NULL);
05723     if (!SAME_OBJ(nm, SCHEME_STX_VAL(form))) {
05724       stx = scheme_datum_to_syntax(top_symbol, scheme_false, scheme_sys_wraps(env), 0, 0);
05725 
05726       /* Should be either top_expander or stop_expander: */
05727       var = scheme_lookup_binding(stx, env,
05728                               SCHEME_NULL_FOR_UNBOUND
05729                               + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
05730                               + SCHEME_DONT_MARK_USE
05731                                   + ((!rec[drec].comp && (rec[drec].depth == -2))
05732                                      ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)
05733                                      : 0),
05734                               rec[drec].certs, env->in_modidx, 
05735                               &menv, NULL, NULL);
05736     }
05737   }
05738 
05739   if (var && (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
05740              || SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type))) {
05741     if (SAME_OBJ(var, stop_expander)) {
05742       /* Return original: */
05743       SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer, form);
05744       SCHEME_EXPAND_OBSERVE_PRIM_STOP(rec[drec].observer);
05745       SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer, form);
05746       SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form);
05747       return form;
05748     } else if (rec[drec].comp && SAME_OBJ(var, normal) && !rec[drec].observer) {
05749       /* Skip creation of intermediate form */
05750       Scheme_Syntax *f;
05751       rec[drec].pre_unwrapped = 1;
05752       f = (Scheme_Syntax *)SCHEME_SYNTAX(var);
05753       if (can_recycle_stx && !quick_stx)
05754         quick_stx = can_recycle_stx;
05755       return f(form, env, rec, drec);
05756     } else {
05757       form = scheme_datum_to_syntax(scheme_make_pair(stx, form), form, form, 0, 2);
05758       SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer, form);
05759 
05760       if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) {
05761        if (rec[drec].comp) {
05762          Scheme_Syntax *f;
05763          f = (Scheme_Syntax *)SCHEME_SYNTAX(var);
05764          return f(form, env, rec, drec);
05765        } else {
05766          Scheme_Syntax_Expander *f;
05767          f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var);
05768          SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer, form);
05769          form = f(form, env, rec, drec);
05770          SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer, form);
05771          SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form);
05772          return form;
05773        }
05774       } else {
05775        name = stx;
05776        goto macro;
05777       }
05778     }
05779   } else {
05780     /* Not allowed this context! */
05781     char *phase, buf[30];
05782     if (env->genv->phase == 0)
05783       phase = "";
05784     else if (env->genv->phase == 1)
05785       phase = " in the transformer environment";
05786     else {
05787       phase = buf;
05788       sprintf(buf, " at phase %ld", env->genv->phase);
05789     }
05790     if (has_orig_unbound) {
05791       scheme_wrong_syntax(scheme_compile_stx_string, 
05792                           orig_unbound_name, form, 
05793                           "unbound identifier%s "
05794                           "(and no %S syntax transformer is bound)",
05795                           phase,
05796                           SCHEME_STX_VAL(stx));
05797     } else {
05798       scheme_wrong_syntax(scheme_compile_stx_string, NULL, form, 
05799                           "bad syntax; %s is not allowed, "
05800                           "because no %S syntax transformer is bound%s",
05801                           not_allowed,
05802                           SCHEME_STX_VAL(stx),
05803                           phase);
05804     }
05805     return NULL;
05806   }
05807 
05808  macro:
05809   if (!rec[drec].comp && !rec[drec].depth) {
05810     SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form);
05811     return form; /* We've gone as deep as requested */
05812   }
05813 
05814   SCHEME_EXPAND_OBSERVE_ENTER_MACRO(rec[drec].observer, form);
05815   form = compile_expand_macro_app(name, menv, var, form, env, rec, drec);
05816   SCHEME_EXPAND_OBSERVE_EXIT_MACRO(rec[drec].observer, form);
05817 
05818   if (rec[drec].comp)
05819     goto top;
05820   else {
05821     if (rec[drec].depth > 0)
05822       --rec[drec].depth;
05823     if (rec[drec].depth)
05824       goto top;
05825     else {
05826       SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form);
05827       return form;
05828     }
05829   }
05830 }
05831 
05832 static int arg_count(Scheme_Object *lam, Scheme_Comp_Env *env)
05833 {
05834   Scheme_Object *l, *id, *form = lam;
05835   int cnt = 0;
05836   DupCheckRecord r;
05837   
05838   lam = SCHEME_STX_CDR(lam);
05839   if (!SCHEME_STX_PAIRP(lam)) return -1;
05840 
05841   l = SCHEME_STX_CAR(lam);
05842 
05843   lam = SCHEME_STX_CDR(lam);
05844   if (!SCHEME_STX_PAIRP(lam)) return -1;
05845 
05846   while (SCHEME_STX_PAIRP(lam)) { lam = SCHEME_STX_CDR(lam); }
05847   if (!SCHEME_STX_NULLP(lam)) return -1;
05848   
05849 
05850   scheme_begin_dup_symbol_check(&r, env);
05851 
05852   while (SCHEME_STX_PAIRP(l)) {
05853     id = SCHEME_STX_CAR(l);
05854     scheme_check_identifier("lambda", id, NULL, env, form);
05855     scheme_dup_symbol_check(&r, NULL, id, "argument", form);
05856     l = SCHEME_STX_CDR(l);
05857     cnt++;
05858   }
05859   if (!SCHEME_STX_NULLP(l)) return -1;
05860 
05861   return cnt;
05862 }
05863 
05864 static Scheme_Object *cert_ids(Scheme_Object *orig_ids, Scheme_Object *orig)
05865 {
05866   Scheme_Object *id, *ids = orig_ids, *pr, *first = scheme_null, *last = NULL;
05867 
05868   while (!SCHEME_STX_NULLP(ids)) {
05869 
05870     id = SCHEME_STX_CAR(ids);
05871     id = scheme_stx_cert(id, NULL, NULL, orig, NULL, 1);
05872 
05873     pr = scheme_make_pair(id, scheme_null);
05874     
05875     if (last)
05876       SCHEME_CDR(last) = pr;
05877     else
05878       first = pr;
05879     last = pr;
05880 
05881     ids = SCHEME_STX_CDR(ids);
05882   }
05883 
05884   return scheme_datum_to_syntax(first, orig_ids, orig_ids, 0, 2);
05885 }
05886 
05887 static Scheme_Object *
05888 compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env, 
05889                  Scheme_Compile_Expand_Info *rec, int drec)
05890 {
05891   Scheme_Object *form, *naya;
05892   int tsc;
05893 
05894   tsc = rec[drec].pre_unwrapped;
05895   rec[drec].pre_unwrapped = 0;
05896 
05897   scheme_rec_add_certs(rec, drec, forms);
05898   if (tsc) {
05899     form = forms;
05900   } else {
05901     form = SCHEME_STX_CDR(forms);
05902     form = scheme_datum_to_syntax(form, forms, forms, 0, 0);
05903   }
05904   
05905   if (SCHEME_STX_NULLP(form)) {
05906     /* Compile/expand empty application to null list: */
05907     if (rec[drec].comp)
05908       return scheme_null;
05909     else
05910       return scheme_datum_to_syntax(icons(quote_symbol,
05911                                           icons(form, scheme_null)),
05912                                 form,
05913                                 scheme_sys_wraps(env), 
05914                                 0, 2);
05915   } else if (!SCHEME_STX_PAIRP(form)) {
05916      /* will end in error */
05917     if (rec[drec].comp)
05918       return compile_application(form, env, rec, drec);
05919     else {
05920       rec[drec].value_name = scheme_false;
05921       naya = scheme_expand_list(form, scheme_no_defines(env), rec, drec);
05922       /* naya will be prefixed and returned... */
05923     }
05924   } else if (rec[drec].comp) {
05925     Scheme_Object *name, *origname, *gval, *orig_rest_form, *rest_form;
05926     name = SCHEME_STX_CAR(form);
05927     origname = name;
05928     
05929     name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL);
05930 
05931     /* look for ((lambda (x) ...) ...); */
05932     if (SAME_OBJ(gval, scheme_lambda_syntax)) {
05933       Scheme_Object *argsnbody;
05934        
05935       argsnbody = SCHEME_STX_CDR(name);
05936       if (SCHEME_STX_PAIRP(argsnbody)) {
05937         Scheme_Object *args, *body;
05938 
05939         args = SCHEME_STX_CAR(argsnbody);
05940         body = SCHEME_STX_CDR(argsnbody);
05941          
05942         if (SCHEME_STX_PAIRP(body)) {
05943           int pl;
05944           pl = scheme_stx_proper_list_length(args);
05945           if (pl >= 0) {
05946             Scheme_Object *bindings = scheme_null, *last = NULL;
05947             Scheme_Object *rest;
05948             int al;
05949              
05950             rest = SCHEME_STX_CDR(form);
05951             al = scheme_stx_proper_list_length(rest);
05952 
05953             if (al == pl) {       
05954               DupCheckRecord r;
05955 
05956               scheme_begin_dup_symbol_check(&r, env);
05957              
05958               while (!SCHEME_STX_NULLP(args)) {
05959                 Scheme_Object *v, *n;
05960                 
05961                 n = SCHEME_STX_CAR(args);
05962                 scheme_check_identifier("lambda", n, NULL, env, name);
05963 
05964                 /* If we don't check here, the error is in terms of `let': */
05965                 scheme_dup_symbol_check(&r, NULL, n, "argument", name);
05966   
05967                 /* Propagate certifications to bound id: */
05968                 n = scheme_stx_cert(n, NULL, NULL, name, NULL, 1);
05969 
05970                 v = SCHEME_STX_CAR(rest);
05971                 v = cons(cons(cons(n, scheme_null), cons(v, scheme_null)), scheme_null);
05972                 if (last)
05973                   SCHEME_CDR(last) = v;
05974                 else
05975                   bindings = v;
05976                 
05977                 last = v;
05978                 args = SCHEME_STX_CDR(args);
05979                 rest = SCHEME_STX_CDR(rest);
05980               }
05981 
05982               body = scheme_datum_to_syntax(icons(begin_symbol, body), form, 
05983                                             scheme_sys_wraps(env), 
05984                                             0, 2);
05985               /* Copy certifications from lambda to `body'. */
05986               body = scheme_stx_cert(body, NULL, NULL, name, NULL, 1);
05987               
05988               body = scheme_datum_to_syntax(cons(let_values_symbol,
05989                                                  cons(bindings,
05990                                                       cons(body, scheme_null))),
05991                                             form, 
05992                                             scheme_sys_wraps(env), 
05993                                             0, 2);
05994 
05995               return scheme_compile_expand_expr(body, env, rec, drec, 0);
05996             } else {
05997 #if 0
05998               scheme_wrong_syntax(scheme_application_stx_string, NULL, form, 
05999                                   "procedure application: bad ((lambda (...) ...) ...) syntax");
06000               return NULL;
06001 #endif
06002             }
06003           }
06004         }
06005       }
06006     }
06007 
06008     orig_rest_form = SCHEME_STX_CDR(form);
06009 
06010     /* Look for (call-with-values (lambda () M) (lambda (id ...) N)) */ 
06011     if (SCHEME_STX_SYMBOLP(name)) {
06012       Scheme_Object *at_first, *at_second, *the_end, *cwv_stx;
06013       at_first = SCHEME_STX_CDR(form);
06014       if (SCHEME_STX_PAIRP(at_first)) {
06015         at_second = SCHEME_STX_CDR(at_first);
06016         if (SCHEME_STX_PAIRP(at_second)) {
06017           the_end = SCHEME_STX_CDR(at_second);
06018           if (SCHEME_STX_NULLP(the_end)) {
06019             Scheme_Object *orig_at_second = at_second;
06020 
06021             cwv_stx = scheme_datum_to_syntax(scheme_intern_symbol("call-with-values"), 
06022                                              scheme_false, scheme_sys_wraps(env), 0, 0);
06023             if (scheme_stx_module_eq(name, cwv_stx, 0)) {
06024               Scheme_Object *first, *orig_first;
06025               orig_first = SCHEME_STX_CAR(at_first);
06026               first = scheme_check_immediate_macro(orig_first, env, rec, drec, 0, &gval, NULL, NULL);
06027               if (SAME_OBJ(gval, scheme_lambda_syntax) 
06028                   && SCHEME_STX_PAIRP(first)
06029                   && (arg_count(first, env) == 0)) {
06030                 Scheme_Object *second, *orig_second;
06031                 orig_second = SCHEME_STX_CAR(at_second);
06032                 second = scheme_check_immediate_macro(orig_second, env, rec, drec, 0, &gval, NULL, NULL);
06033                 if (SAME_OBJ(gval, scheme_lambda_syntax) 
06034                     && SCHEME_STX_PAIRP(second)
06035                     && (arg_count(second, env) >= 0)) {
06036                   Scheme_Object *lhs, *orig_post_first, *orig_post_second;
06037                   orig_post_first = first;
06038                   orig_post_second = second;
06039                   second = SCHEME_STX_CDR(second);
06040                   lhs = SCHEME_STX_CAR(second);
06041                   second = SCHEME_STX_CDR(second);
06042                   first = SCHEME_STX_CDR(first);
06043                   first = SCHEME_STX_CDR(first);
06044                   first = icons(begin_symbol, first);
06045                   first = scheme_datum_to_syntax(first, orig_post_first, scheme_sys_wraps(env), 0, 1);
06046                   second = icons(begin_symbol, second);
06047                   second = scheme_datum_to_syntax(second, orig_post_second, scheme_sys_wraps(env), 0, 1);
06048                   /* Copy certifications from lambda to body: */
06049                   lhs = cert_ids(lhs, orig_post_second);
06050                   first = scheme_stx_cert(first, NULL, NULL, orig_post_first, NULL, 1);
06051                   second = scheme_stx_cert(second, NULL, NULL, orig_post_second, NULL, 1);
06052                   /* Convert to let-values: */
06053                   name = icons(let_values_symbol,
06054                                icons(icons(icons(lhs, icons(first, scheme_null)), 
06055                                            scheme_null),
06056                                      icons(second, scheme_null)));
06057                   form = scheme_datum_to_syntax(name, forms, scheme_sys_wraps(env), 0, 2);
06058                   return scheme_compile_expand_expr(form, env, rec, drec, 0);
06059                 }
06060                 if (!SAME_OBJ(second, orig_second)) {
06061                   at_second = scheme_datum_to_syntax(icons(second, the_end), at_second, at_second, 0, 2);
06062                 } 
06063               }
06064               if (!SAME_OBJ(first, orig_first)
06065                   || !SAME_OBJ(at_second, orig_at_second)) {
06066                 at_first = scheme_datum_to_syntax(icons(first, at_second), at_first, at_first, 0, 2);
06067               }
06068             }
06069           }
06070         }
06071       }
06072       rest_form = at_first;
06073     } else {
06074       rest_form = orig_rest_form;
06075     }
06076 
06077     if (NOT_SAME_OBJ(name, origname)
06078         || NOT_SAME_OBJ(rest_form, orig_rest_form)) {
06079       form = scheme_datum_to_syntax(scheme_make_pair(name, rest_form), forms, forms, 0, 2);
06080     }
06081     
06082     return compile_application(form, env, rec, drec);
06083   } else {
06084     scheme_rec_add_certs(rec, drec, form);
06085     rec[drec].value_name = scheme_false;
06086     naya = scheme_expand_list(form, scheme_no_defines(env), rec, drec);
06087     /* naya will be prefixed returned... */
06088   }
06089 
06090   if (SAME_OBJ(form, naya))
06091     return forms;
06092 
06093   /* Add #%app prefix back: */
06094   {
06095     Scheme_Object *first;
06096 
06097     first = SCHEME_STX_CAR(forms);
06098     return scheme_datum_to_syntax(scheme_make_pair(first, naya),
06099                               forms,
06100                               forms, 0, 2);
06101   }
06102 }
06103 
06104 static Scheme_Object *
06105 app_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
06106 {
06107   return compile_expand_app(form, env, rec, drec);
06108 }
06109 
06110 static Scheme_Object *
06111 app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
06112 {
06113   SCHEME_EXPAND_OBSERVE_PRIM_APP(erec[drec].observer);
06114   return compile_expand_app(form, env, erec, drec);
06115 }
06116 
06117 static Scheme_Object *
06118 datum_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
06119 {
06120   Scheme_Object *c, *v;
06121 
06122   if (rec[drec].pre_unwrapped) {
06123     c = form;
06124     rec[drec].pre_unwrapped = 0;
06125   } else {
06126     c = SCHEME_STX_CDR(form);
06127     /* Need datum->syntax, in case c is a list: */
06128     c = scheme_datum_to_syntax(c, form, form, 0, 2);
06129   }
06130 
06131   v = SCHEME_STX_VAL(c);
06132   if (SCHEME_KEYWORDP(v)) {
06133     scheme_wrong_syntax("#%datum", NULL, c, "keyword used as an expression");
06134     return NULL;
06135   }
06136 
06137   return scheme_syntax_to_datum(c, 0, NULL);
06138 }
06139 
06140 static Scheme_Object *
06141 datum_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
06142 {
06143   Scheme_Object *rest, *v;
06144 
06145   SCHEME_EXPAND_OBSERVE_PRIM_DATUM(erec[drec].observer);
06146 
06147   rest = SCHEME_STX_CDR(form);
06148 
06149   v = SCHEME_STX_VAL(rest);
06150   if (SCHEME_KEYWORDP(v)) {
06151     scheme_wrong_syntax("#%datum", NULL, rest, "keyword used as an expression");
06152     return NULL;
06153   }
06154 
06155   return scheme_datum_to_syntax(icons(quote_symbol,
06156                                       icons(rest, scheme_null)),
06157                                 form,
06158                                 scheme_sys_wraps(env), 
06159                                 0, 2);
06160 }
06161 
06162 static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
06163 {
06164   Scheme_Object *c;
06165 
06166   if (rec[drec].pre_unwrapped) {
06167     c = form;
06168     rec[drec].pre_unwrapped = 0;
06169   } else
06170     c = SCHEME_STX_CDR(form);
06171 
06172   if (!SCHEME_STX_SYMBOLP(c))
06173     scheme_wrong_syntax(NULL, NULL, form, NULL);
06174 
06175   if (env->genv->module) {
06176     Scheme_Object *modidx, *symbol = c, *tl_id;
06177     int bad;
06178 
06179     tl_id = scheme_tl_id_sym(env->genv, symbol, NULL, 0, NULL, NULL);
06180     if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) {
06181       /* Since the module has a rename for this id, it's certainly defined. */
06182     } else {
06183       modidx = scheme_stx_module_name(NULL, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, 
06184                                       NULL, NULL, NULL, NULL, NULL);
06185       if (modidx) {
06186        /* If it's an access path, resolve it: */
06187        if (env->genv->module
06188            && SAME_OBJ(scheme_module_resolve(modidx, 1), env->genv->module->modname))
06189          bad = 0;
06190        else
06191          bad = 1;
06192       } else
06193        bad = 1;
06194 
06195       if (env->genv->disallow_unbound) {
06196        if (bad || !scheme_lookup_in_table(env->genv->toplevel, (const char *)SCHEME_STX_SYM(c))) {
06197           GC_CAN_IGNORE const char *reason;
06198           if (env->genv->phase == 1) {
06199             reason = "unbound identifier in module (transformer environment)";
06200             /* Check in the run-time environment */
06201             if (scheme_lookup_in_table(env->genv->template_env->toplevel, (const char *)SCHEME_STX_SYM(c))) {
06202               reason = ("unbound identifier in module (in the transformer environment, which does"
06203                         " not include the run-time definition)");
06204             } else if (env->genv->template_env->syntax
06205                        && scheme_lookup_in_table(env->genv->template_env->syntax, (const char *)SCHEME_STX_SYM(c))) {
06206               reason = ("unbound identifier in module (in the transformer environment, which does"
06207                         " not include the macro definition that is visible to run-time expressions)");
06208             }
06209           } else
06210             reason = "unbound identifier in module";
06211          scheme_wrong_syntax(when, NULL, c, reason);
06212        }
06213       }
06214     }
06215   }
06216 
06217   return c;
06218 }
06219 
06220 static Scheme_Object *
06221 top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
06222 {
06223   Scheme_Object *c;
06224 
06225   c = check_top(scheme_compile_stx_string, form, env, rec, drec);
06226 
06227   c = scheme_tl_id_sym(env->genv, c, NULL, 0, NULL, NULL);
06228 
06229   if (env->genv->module && !rec[drec].resolve_module_ids) {
06230     /* Self-reference in a module; need to remember the modidx.  Don't
06231        need a pos, because the symbol's gensym-ness (if any) will be
06232        preserved within the module. */
06233     c = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, 
06234                                 c, env->genv->module->insp,
06235                                 -1, env->genv->mod_phase);
06236   } else {
06237     c = (Scheme_Object *)scheme_global_bucket(c, env->genv);
06238   }
06239 
06240   return scheme_register_toplevel_in_prefix(c, env, rec, drec);
06241 }
06242 
06243 static Scheme_Object *
06244 top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
06245 {
06246   SCHEME_EXPAND_OBSERVE_PRIM_TOP(erec[drec].observer);
06247   check_top(scheme_expand_stx_string, form, env, erec, drec);
06248   return form;
06249 }
06250 
06251 Scheme_Object *scheme_compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, 
06252                                Scheme_Compile_Info *rec, int drec)
06253 {
06254   return scheme_compile_expand_expr(form, env, rec, drec, 0);
06255 }
06256 
06257 Scheme_Object *scheme_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, 
06258                               Scheme_Expand_Info *erec, int drec)
06259 {
06260   return scheme_compile_expand_expr(form, env, erec, drec, 0);
06261 }
06262 
06263 static Scheme_Object *pair_lifted(Scheme_Object *_ip, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *env)
06264 {
06265   Scheme_Comp_Env **ip = (Scheme_Comp_Env **)_ip, *naya;
06266   Scheme_Object *ids, *id;
06267   int pos;
06268 
06269   pos = scheme_list_length(*_ids);
06270   naya = scheme_new_compilation_frame(pos, SCHEME_CAPTURE_LIFTED, (*ip)->next, NULL);
06271   (*ip)->next = naya;
06272   *ip = naya;
06273 
06274   for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) {
06275     id = SCHEME_CAR(ids);
06276     scheme_add_compilation_binding(--pos, id, naya);
06277   }
06278 
06279   return icons(*_ids, icons(expr, scheme_null));
06280 }
06281 
06282 static Scheme_Object *add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env,
06283                                        Scheme_Object *orig_form, int comp_rev)
06284 {
06285   Scheme_Object *revl, *a;
06286 
06287   if (SCHEME_NULLP(l)) return obj;
06288 
06289   revl = scheme_reverse(l);
06290 
06291   if (comp_rev) {
06292     /* We've already compiled the body of this let
06293        with the bindings in reverse order. So insert a series of `lets'
06294        to match that order: */
06295     if (!SCHEME_NULLP(SCHEME_CDR(l))) {
06296       for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
06297         a = scheme_reverse(SCHEME_CAR(SCHEME_CAR(l)));
06298         for (; !SCHEME_NULLP(a); a = SCHEME_CDR(a)) {
06299           obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
06300                       icons(icons(icons(icons(SCHEME_CAR(a), scheme_null), icons(SCHEME_CAR(a), scheme_null)),
06301                                   scheme_null),
06302                             icons(obj, scheme_null)));
06303         }
06304       }
06305     }
06306   }
06307 
06308   for (; SCHEME_PAIRP(revl); revl = SCHEME_CDR(revl)) {
06309     a = SCHEME_CAR(revl);
06310     obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
06311                 icons(icons(a, scheme_null),
06312                       icons(obj, scheme_null)));
06313   }
06314 
06315   obj = scheme_datum_to_syntax(obj, orig_form, scheme_false, 0, 0);
06316   
06317   return obj;
06318 }
06319  
06320 static Scheme_Object *compile_expand_expr_lift_to_let_k(void);
06321 
06322 static Scheme_Object *
06323 compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
06324                             Scheme_Expand_Info *rec, int drec)
06325 {
06326   Scheme_Expand_Info recs[2];
06327   Scheme_Object *l, *orig_form = form, *context_key;
06328   Scheme_Comp_Env *inserted, **ip;
06329 
06330   /* This function only works when `env' has no lexical bindings,
06331      because we might insert new ones at the beginning.  In
06332      particular, we might insert frames between `inserted' and
06333      `env'.
06334 
06335      This function also relies on the way that compilation of `let'
06336      works. A let-bound variable is compiled to a count of the frames
06337      to skip and the index within the frame, so we can insert new
06338      frames without affecting lookups computed so far. Inserting each
06339      new frame before any previous one turns out to be consistent with
06340      the nested `let's that we generate at the end. 
06341 
06342      Some optimizations can happen later, for example constant
06343      propagate.  But these optimizations take place on the result of
06344      this function, so we don't have to worry about them.  
06345 
06346      Don't generate a `let*' expression instead of nested `let's,
06347      because the compiler actually takes shortcuts (that are
06348      inconsistent with our frame nesting) instead of expanding `let*'
06349      to `let'. */
06350 
06351 #ifdef DO_STACK_CHECK
06352   {
06353 # include "mzstkchk.h"
06354     {
06355       Scheme_Thread *p = scheme_current_thread;
06356       Scheme_Compile_Expand_Info *recx;
06357 
06358       recx = MALLOC_ONE_RT(Scheme_Compile_Expand_Info);
06359       memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info));
06360 #ifdef MZTAG_REQUIRED
06361       recx->type = scheme_rt_compile_info;
06362 #endif
06363 
06364       p->ku.k.p1 = (void *)form;
06365       p->ku.k.p2 = (void *)env;
06366       p->ku.k.p3 = (void *)recx;
06367 
06368       form = scheme_handle_stack_overflow(compile_expand_expr_lift_to_let_k);
06369 
06370       memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info));
06371       return form;
06372     }
06373   }
06374 #endif
06375 
06376   inserted = scheme_new_compilation_frame(0, 0, env, NULL);
06377 
06378   ip = MALLOC_N(Scheme_Comp_Env *, 1);
06379   *ip = inserted;
06380 
06381   context_key = scheme_generate_lifts_key();
06382   
06383   scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false, 
06384                               context_key, NULL, scheme_false);
06385 
06386   if (rec[drec].comp) {
06387     scheme_init_compile_recs(rec, drec, recs, 2);
06388     form = scheme_compile_expr(form, inserted, recs, 0);
06389   } else {
06390     scheme_init_expand_recs(rec, drec, recs, 2);
06391     form = scheme_expand_expr(form, inserted, recs, 0);
06392   }
06393 
06394   l = scheme_frame_get_lifts(inserted);
06395   if (SCHEME_NULLP(l)) {
06396     /* No lifts */
06397     if (rec[drec].comp)
06398       scheme_merge_compile_recs(rec, drec, recs, 1);
06399     return form;
06400   } else {
06401     /* We have lifts, so add let* wrapper and go again */
06402     Scheme_Object *o;
06403     if (rec[drec].comp) {
06404       /* Wrap compiled part so the compiler recognizes it later: */
06405       o = scheme_alloc_object();
06406       o->type = scheme_already_comp_type;
06407       SCHEME_IPTR_VAL(o) = form;
06408     } else
06409       o = form;
06410     form = add_lifts_as_let(o, l, env, orig_form, rec[drec].comp);
06411     SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(rec[drec].observer, form);
06412     form = compile_expand_expr_lift_to_let(form, env, recs, 1);
06413     if (rec[drec].comp)
06414       scheme_merge_compile_recs(rec, drec, recs, 2);
06415     return form;
06416   }
06417 }
06418 
06419 static Scheme_Object *compile_expand_expr_lift_to_let_k(void)
06420 {
06421   Scheme_Thread *p = scheme_current_thread;
06422   Scheme_Object *form = (Scheme_Object *)p->ku.k.p1;
06423   Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2;
06424   Scheme_Compile_Info *rec = (Scheme_Compile_Info *)p->ku.k.p3;
06425 
06426   p->ku.k.p1 = NULL;
06427   p->ku.k.p2 = NULL;
06428   p->ku.k.p3 = NULL;
06429 
06430   return compile_expand_expr_lift_to_let(form, env, rec, 0);
06431 }
06432 
06433 Scheme_Object *
06434 scheme_compile_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
06435                             Scheme_Compile_Info *rec, int drec)
06436 {
06437   return compile_expand_expr_lift_to_let(form, env, rec, drec);
06438 }
06439 
06440 Scheme_Object *
06441 scheme_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
06442                             Scheme_Expand_Info *erec, int drec)
06443 {
06444   return compile_expand_expr_lift_to_let(form, env, erec, drec);
06445 }
06446 
06447 static Scheme_Object *
06448 scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, 
06449                          Scheme_Compile_Expand_Info *rec, int drec)
06450 /* This ugly code parses a block of code, transforming embedded
06451    define-values and define-syntax into letrec and letrec-syntax.
06452    It is espcailly ugly because we have to expand macros
06453    before deciding what we have. */
06454 {
06455   Scheme_Object *first, *rib, *ctx, *ectx, *orig = forms;
06456   void **d;
06457   Scheme_Comp_Env *xenv = NULL;
06458   Scheme_Compile_Info recs[2];
06459   DupCheckRecord r;
06460 
06461   if (rec[drec].comp) {
06462     scheme_default_compile_rec(rec, drec);
06463   } else {
06464     SCHEME_EXPAND_OBSERVE_ENTER_BLOCK(rec[drec].observer, forms);
06465   }
06466 
06467   if (SCHEME_STX_NULLP(forms)) {
06468     if (rec[drec].comp) {
06469       scheme_compile_rec_done_local(rec, drec);
06470       return scheme_null;
06471     } else {
06472       SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(rec[drec].observer, forms);
06473       SCHEME_EXPAND_OBSERVE_ENTER_LIST(rec[drec].observer, forms);
06474       SCHEME_EXPAND_OBSERVE_EXIT_LIST(rec[drec].observer, forms);
06475       return forms;
06476     }
06477   }
06478 
06479   rib = scheme_make_rename_rib();
06480   ctx = scheme_alloc_object();
06481   ctx->type = scheme_intdef_context_type;
06482   d = MALLOC_N(void*, 3);
06483   d[0] = env;
06484   SCHEME_PTR1_VAL(ctx) = d;
06485   SCHEME_PTR2_VAL(ctx) = rib;
06486   ectx = scheme_make_pair(ctx, scheme_null);
06487   scheme_begin_dup_symbol_check(&r, env);
06488 
06489  try_again:
06490 
06491   SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
06492 
06493   if (!SCHEME_STX_PAIRP(forms)) {
06494     scheme_wrong_syntax(scheme_begin_stx_string, NULL, forms, "bad syntax");
06495     return NULL;
06496   }
06497 
06498   first = SCHEME_STX_CAR(forms);
06499 
06500   {
06501     /* Need to send both parts (before & after) of block rename */
06502     Scheme_Object *old_first;
06503 
06504     old_first = first;
06505     first = scheme_add_rename_rib(first, rib);
06506     
06507     SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer,old_first,first);
06508   }
06509 
06510   {
06511     Scheme_Object *gval, *result;
06512     int more = 1;
06513 
06514     result = forms;
06515 
06516     /* Check for macro expansion, which could mask the real
06517        define-values, define-syntax, etc.: */
06518     first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx);
06519     
06520     if (SAME_OBJ(gval, scheme_begin_syntax)) {
06521       /* Inline content */
06522       Scheme_Object *orig_forms = forms;
06523 
06524       SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(rec[drec].observer);
06525 
06526       /* FIXME: Redundant with check done by scheme_flatten_begin below? */
06527       if (scheme_stx_proper_list_length(first) < 0)
06528        scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, 
06529                          "bad syntax (" IMPROPER_LIST_FORM ")");
06530 
06531       forms = SCHEME_STX_CDR(forms);
06532 
06533       if (SCHEME_STX_NULLP(forms)) {
06534        /* A `begin' that ends the block.  An `inferred-name' property
06535           attached to this begin should apply to the ultimate last
06536           thing in the block. */
06537        Scheme_Object *v;
06538        v = scheme_check_name_property(first, rec[drec].value_name);
06539        rec[drec].value_name = v;
06540       }
06541 
06542       forms = scheme_flatten_begin(first, forms);
06543 
06544       SCHEME_EXPAND_OBSERVE_SPLICE(rec[drec].observer, forms);
06545 
06546       if (SCHEME_STX_NULLP(forms)) {
06547        scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, 
06548                          "bad syntax (empty form)");
06549       }
06550 
06551       forms = scheme_datum_to_syntax(forms, orig_forms, orig_forms, 0, 0);
06552 
06553       goto try_again;
06554     } else if (SAME_OBJ(gval, scheme_define_values_syntax)
06555               || SAME_OBJ(gval, scheme_define_syntaxes_syntax)) {
06556       /* Turn defines into a letrec: */
06557       Scheme_Object *var, *vars, *v, *link;
06558       Scheme_Object *l = scheme_null, *start = NULL;
06559       Scheme_Object *stx_l = scheme_null, *stx_start = NULL;
06560       int is_val;
06561 
06562       while (1) {
06563        int cnt;
06564 
06565        is_val = SAME_OBJ(gval, scheme_define_values_syntax);
06566        
06567        v = SCHEME_STX_CDR(first);
06568 
06569         if (is_val) {
06570           SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(rec[drec].observer);
06571         } else {
06572           SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(rec[drec].observer);
06573         }
06574        
06575        if (!SCHEME_STX_PAIRP(v))
06576          scheme_wrong_syntax(NULL, NULL, first, 
06577                            "bad syntax (" IMPROPER_LIST_FORM ")");
06578 
06579        var = NULL;
06580        vars = SCHEME_STX_CAR(v);
06581        cnt = 0;
06582        while (SCHEME_STX_PAIRP(vars)) {
06583          var = SCHEME_STX_CAR(vars);
06584          if (!SCHEME_STX_SYMBOLP(var))
06585            scheme_wrong_syntax(NULL, var, first, 
06586                             "name must be an identifier");
06587          /* scheme_dup_symbol_check(&r, "internal definition", var, "binding", first); */
06588          vars = SCHEME_STX_CDR(vars);
06589          cnt++;
06590        }
06591        if (!SCHEME_STX_NULLP(vars)) {
06592          vars = SCHEME_STX_CAR(v);
06593          scheme_wrong_syntax(NULL, vars, first, 
06594                            "not a sequence of identifiers");
06595        }
06596 
06597        /* Preserve properties and track at the clause level: */
06598        v = scheme_datum_to_syntax(v, first, first, 0, 0);
06599        var = SCHEME_STX_CAR(first);
06600        v = scheme_stx_track(v, first, var);
06601 
06602         SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer,v);
06603 
06604        link = scheme_make_pair(v, scheme_null);
06605        if (is_val) {
06606          if (!start)
06607            start = link;
06608          else
06609            SCHEME_CDR(l) = link;
06610          l = link;
06611        } else {
06612          if (!stx_start)
06613            stx_start = link;
06614          else
06615            SCHEME_CDR(stx_l) = link;
06616          stx_l = link;
06617        }
06618 
06619        result = SCHEME_STX_CDR(result);
06620        if (!SCHEME_STX_NULLP(result) && !SCHEME_STX_PAIRP(result))
06621          scheme_wrong_syntax(NULL, NULL, first, NULL);
06622 
06623        {
06624          /* Execute internal macro definition and register non-macros */
06625          Scheme_Comp_Env *new_env;
06626          Scheme_Object *names, *expr, *l, *a;
06627          int pos;
06628 
06629          new_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF, env, rec[drec].certs);
06630 
06631          names = SCHEME_STX_CAR(v);
06632          expr = SCHEME_STX_CDR(v);
06633          if (!SCHEME_STX_PAIRP(expr)) {
06634            if (SCHEME_STX_NULLP(expr))
06635              scheme_wrong_syntax(NULL, NULL, first, 
06636                               "bad syntax (missing expression)");
06637            else
06638              scheme_wrong_syntax(NULL, NULL, first, 
06639                               "bad syntax (" IMPROPER_LIST_FORM ")");
06640          }
06641          link = SCHEME_STX_CDR(expr);
06642          if (!SCHEME_STX_NULLP(link)) {
06643            scheme_wrong_syntax(NULL, NULL, first, 
06644                             "bad syntax (extra data after expression)");
06645          }
06646          expr = SCHEME_STX_CAR(expr);
06647          
06648          scheme_add_local_syntax(cnt, new_env);
06649 
06650          /* Initialize environment slots to #f, which means "not syntax". */
06651          cnt = 0;
06652          for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
06653            a = SCHEME_STX_CAR(l);
06654            scheme_set_local_syntax(cnt++, a, scheme_false, new_env);
06655          }
06656 
06657          /* Extend shared rib with renamings */
06658          scheme_add_env_renames(rib, new_env, env);
06659 
06660           /* Check for duplicates after extending the rib with renamings,
06661              since the renamings properly track marks. */
06662           for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
06663            a = SCHEME_STX_CAR(l);
06664             scheme_dup_symbol_check(&r, "internal definition", a, "binding", first);
06665           }
06666 
06667          if (!is_val) {
06668            /* Evaluate and bind syntaxes */
06669            scheme_prepare_exp_env(new_env->genv);
06670             scheme_prepare_compile_env(new_env->genv->exp_env);
06671            pos = 0;
06672            expr = scheme_add_rename_rib(expr, rib);
06673            scheme_bind_syntaxes("local syntax definition", 
06674                              names, expr,
06675                              new_env->genv->exp_env, new_env->insp, rec, drec,
06676                              new_env, new_env,
06677                              &pos, rib);
06678          }
06679 
06680          /* Remember extended environment */
06681          ((void **)SCHEME_PTR1_VAL(ctx))[0] = new_env;
06682          env = new_env;
06683          xenv = NULL;
06684        }
06685 
06686       define_try_again:
06687        if (!SCHEME_STX_NULLP(result)) {
06688          first = SCHEME_STX_CAR(result);
06689          first = scheme_datum_to_syntax(first, forms, forms, 0, 0);
06690           {
06691             Scheme_Object *old_first;
06692             old_first = first;
06693             first = scheme_add_rename_rib(first, rib);
06694             SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
06695             SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer,old_first,first);
06696           }
06697          first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx);
06698          more = 1;
06699          if (NOT_SAME_OBJ(gval, scheme_define_values_syntax)
06700              && NOT_SAME_OBJ(gval, scheme_define_syntaxes_syntax)) {
06701            if (SAME_OBJ(gval, scheme_begin_syntax)) {
06702              /* Inline content */
06703              result = SCHEME_STX_CDR(result);
06704               SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(rec[drec].observer);
06705              result = scheme_flatten_begin(first, result);
06706              SCHEME_EXPAND_OBSERVE_SPLICE(rec[drec].observer,result);
06707               goto define_try_again;
06708            } else {
06709              /* Keep partially expanded `first': */
06710              result = SCHEME_STX_CDR(result);
06711              result = scheme_make_pair(first, result);
06712              break;
06713            }
06714          }
06715        } else
06716          break;
06717       }
06718 
06719       if (SCHEME_STX_PAIRP(result)) {
06720        if (!start)
06721          start = scheme_null;
06722         
06723        /* I think the following was intended as an optimization for `expand',
06724            since the syntax definition will be dropped. But it breaks
06725            `local-expand':
06726            if (stx_start && !(rec[drec].comp || (rec[drec].depth == -1)))
06727              stx_start = scheme_null; */
06728        if (stx_start) {
06729          result = scheme_make_pair(letrec_syntaxes_symbol,
06730                                     scheme_make_pair(stx_start,
06731                                                      scheme_make_pair(start, result)));
06732        } else {
06733          result = scheme_make_pair(letrec_values_symbol, scheme_make_pair(start, result));
06734        }
06735        result = scheme_datum_to_syntax(result, forms, scheme_sys_wraps(env), 0, 2);
06736        result = scheme_add_rename_rib(result, rib);
06737 
06738        more = 0;
06739       } else {
06740        /* Empty body: illegal. */
06741        scheme_wrong_syntax(scheme_begin_stx_string, NULL, orig, 
06742                          "no expression after a sequence of internal definitions");
06743       }
06744     }
06745 
06746     if (!more) {
06747       /* We've converted to a letrec or letrec-values+syntaxes */
06748       scheme_stx_seal_rib(rib);
06749       rec[drec].env_already = 1;
06750 
06751       if (rec[drec].comp) {
06752        result = scheme_compile_expr(result, env, rec, drec);
06753         return scheme_make_pair(result, scheme_null);
06754       } else {
06755        if (rec[drec].depth > 0)
06756          --rec[drec].depth;
06757        if (rec[drec].depth) {
06758           result = scheme_make_pair(result, scheme_null);
06759           SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(rec[drec].observer, result);
06760           return scheme_expand_list(result, env, rec, drec);
06761         } else {
06762           result = scheme_make_pair(result, scheme_null);
06763           return scheme_datum_to_syntax(result, forms, forms, 0, 0);
06764         }
06765       }
06766     }
06767   }
06768 
06769   scheme_stx_seal_rib(rib);
06770 
06771   if (rec[drec].comp) {
06772     Scheme_Object *vname, *rest;
06773 
06774     vname = rec[drec].value_name;
06775     scheme_compile_rec_done_local(rec, drec);
06776     scheme_init_compile_recs(rec, drec, recs, 2);
06777 
06778     rest = SCHEME_STX_CDR(forms);
06779     if (SCHEME_STX_NULLP(rest))
06780       recs[0].value_name = vname;
06781     else
06782       recs[1].value_name = vname;
06783 
06784     rest = scheme_datum_to_syntax(rest, forms, forms, 0, 0);
06785 
06786     first = scheme_compile_expr(first, env, recs, 0);
06787 
06788 #if EMBEDDED_DEFINES_START_ANYWHERE
06789     forms = scheme_compile_expand_block(rest, env, recs, 1);
06790 #else
06791     forms = scheme_compile_list(rest, env, recs, 1);
06792 #endif
06793     
06794     scheme_merge_compile_recs(rec, drec, recs, 2);
06795     return scheme_make_pair(first, forms);
06796   } else {
06797 #if EMBEDDED_DEFINES_START_ANYWHERE
06798     /* Expand-observe not implemented for this case,
06799        so fix that if it's ever enabled. */
06800     Scheme_Object *rest, *vname;
06801 
06802     vname = rec[drec].value_name;
06803     rec[drec].value_name = scheme_false;
06804     scheme_init_expand_recs(rec, drec, recs, 2);
06805 
06806     rest = SCHEME_STX_CDR(forms);
06807 
06808     if (SCHEME_STX_NULLP(rest))
06809       recs[0].value_name = vname;
06810     else
06811       recs[1].value_name = vname;
06812 
06813     first = scheme_expand_expr(first, env, recs, 0);
06814 
06815     rest = scheme_datum_to_syntax(rest, forms, forms, 0, -1);
06816     forms = scheme_compile_expand_block(rest, env, recs, 1);
06817     return scheme_make_pair(first, forms);
06818 #else
06819     Scheme_Object *newforms, *vname;
06820 
06821     vname = rec[drec].value_name;
06822     rec[drec].value_name = scheme_false;
06823     scheme_init_expand_recs(rec, drec, recs, 2);
06824 
06825     recs[0].value_name = vname;
06826 
06827     newforms = SCHEME_STX_CDR(forms);
06828     newforms = scheme_make_pair(first, newforms);
06829     forms = scheme_datum_to_syntax(newforms, forms, forms, 0, -1);
06830     
06831     if (scheme_stx_proper_list_length(forms) < 0)
06832       scheme_wrong_syntax(scheme_begin_stx_string, NULL, forms, "bad syntax");
06833     
06834     SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(rec[drec].observer, forms);
06835     forms = scheme_expand_list(forms, env, recs, 0);
06836     return forms;
06837 #endif
06838   }
06839 }
06840 
06841 Scheme_Object *
06842 scheme_compile_block(Scheme_Object *forms, Scheme_Comp_Env *env, 
06843                    Scheme_Compile_Info *rec, int drec)
06844 {
06845   return scheme_compile_expand_block(forms, env, rec, drec);
06846 }
06847 
06848 Scheme_Object *
06849 scheme_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
06850 {
06851   return scheme_compile_expand_block(forms, env, erec, drec);
06852 }
06853 
06854 Scheme_Object *
06855 scheme_expand_list(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
06856 {
06857   Scheme_Object *first = NULL, *last = NULL, *fm;
06858 
06859   SCHEME_EXPAND_OBSERVE_ENTER_LIST(erec[drec].observer, form);
06860 
06861   if (SCHEME_STX_NULLP(form)) {
06862     SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form);
06863     return scheme_null;
06864   }
06865 
06866   if (scheme_stx_proper_list_length(form) < 0) {
06867     /* This is already checked for anything but application */
06868     scheme_wrong_syntax(scheme_application_stx_string, NULL, form, 
06869                      "bad syntax (" IMPROPER_LIST_FORM ")");
06870   }
06871 
06872   fm = form;
06873   while (SCHEME_STX_PAIRP(fm)) {
06874     Scheme_Object *r, *p;
06875     Scheme_Expand_Info erec1;
06876 
06877     SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
06878 
06879     p = SCHEME_STX_CDR(fm);
06880     
06881     scheme_init_expand_recs(erec, drec, &erec1, 1);
06882     erec1.value_name = (SCHEME_STX_NULLP(p) ? erec[drec].value_name : scheme_false);
06883 
06884     r = SCHEME_STX_CAR(fm);
06885     r = scheme_expand_expr(r, env, &erec1, 0);
06886     p = scheme_make_pair(r, scheme_null);
06887     if (last)
06888       SCHEME_CDR(last) = p;
06889     else
06890       first = p;
06891     last = p;
06892 
06893     fm = SCHEME_STX_CDR(fm);
06894   }
06895 
06896   form = scheme_datum_to_syntax(first, form, form, 0, 0);
06897   SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form);
06898   return form;
06899 }
06900 
06901 
06902 Scheme_Object *
06903 scheme_flatten_begin(Scheme_Object *expr, Scheme_Object *append_onto)
06904 {
06905   Scheme_Object *l, *ll, *a, *name, *body;
06906   
06907   if (scheme_stx_proper_list_length(expr) < 0)
06908     scheme_wrong_syntax(NULL, NULL, expr, "bad syntax (" IMPROPER_LIST_FORM ")");
06909 
06910   name = SCHEME_STX_CAR(expr);
06911   body = SCHEME_STX_CDR(expr);
06912 
06913   /* Extract body of `begin' and add tracking information */
06914   l = scheme_copy_list(scheme_flatten_syntax_list(body, NULL));
06915   for (ll = l; !SCHEME_NULLP(ll); ll = SCHEME_CDR(ll)) {
06916     a = SCHEME_CAR(ll);
06917     a = scheme_stx_track(a, expr, name);
06918     a = scheme_stx_cert(a, NULL, NULL, expr, NULL, 1);
06919     SCHEME_CAR(ll) = a;
06920   }
06921   
06922   return scheme_append(l, append_onto);
06923 }
06924 
06925 /*========================================================================*/
06926 /*                          continuation marks                            */
06927 /*========================================================================*/
06928 
06929 void scheme_push_continuation_frame(Scheme_Cont_Frame_Data *d)
06930 {
06931   d->cont_mark_pos = MZ_CONT_MARK_POS;
06932   d->cont_mark_stack = MZ_CONT_MARK_STACK;
06933 
06934   MZ_CONT_MARK_POS += 2;
06935 }
06936 
06937 void scheme_pop_continuation_frame(Scheme_Cont_Frame_Data *d)
06938 {
06939   MZ_CONT_MARK_POS = d->cont_mark_pos;
06940   MZ_CONT_MARK_STACK = d->cont_mark_stack;
06941 }
06942 
06943 static MZ_MARK_STACK_TYPE clone_meta_cont_set_mark(Scheme_Meta_Continuation *mc, Scheme_Object *val, long findpos)
06944 {
06945   /* Clone the meta-continuation, in case it was captured by
06946      a continuation in its current state. */
06947   Scheme_Meta_Continuation *naya;
06948   Scheme_Cont_Mark *cp;
06949 
06950   naya = MALLOC_ONE_RT(Scheme_Meta_Continuation);
06951   memcpy(naya, mc, sizeof(Scheme_Meta_Continuation));
06952   cp = MALLOC_N(Scheme_Cont_Mark, naya->cont_mark_total);
06953   memcpy(cp, mc->cont_mark_stack_copied, naya->cont_mark_total * sizeof(Scheme_Cont_Mark));
06954   naya->cont_mark_stack_copied = cp;
06955   naya->copy_after_captured = scheme_cont_capture_count;
06956   mc = naya;
06957   scheme_current_thread->meta_continuation = mc;
06958 
06959   mc->cont_mark_stack_copied[findpos].val = val;
06960   mc->cont_mark_stack_copied[findpos].cache = NULL;
06961 
06962   return 0;
06963 }
06964 
06965 static MZ_MARK_STACK_TYPE new_segment_set_mark(long segpos, long pos, Scheme_Object *key, Scheme_Object *val)
06966 {
06967   Scheme_Thread *p = scheme_current_thread;
06968   Scheme_Cont_Mark *cm = NULL;
06969   int c = p->cont_mark_seg_count;
06970   Scheme_Cont_Mark **segs, *seg;
06971   long findpos;
06972   
06973   /* Note: we perform allocations before changing p to avoid GC trouble,
06974      since MzScheme adjusts a thread's cont_mark_stack_segments on GC. */
06975   segs = MALLOC_N(Scheme_Cont_Mark *, c + 1);
06976   seg = scheme_malloc_allow_interior(sizeof(Scheme_Cont_Mark) * SCHEME_MARK_SEGMENT_SIZE);
06977   segs[c] = seg;
06978   
06979   memcpy(segs, p->cont_mark_stack_segments, c * sizeof(Scheme_Cont_Mark *));
06980   
06981   p->cont_mark_seg_count++;
06982   p->cont_mark_stack_segments = segs;
06983 
06984   seg = p->cont_mark_stack_segments[segpos];
06985   cm = seg + pos;
06986   findpos = MZ_CONT_MARK_STACK;
06987   MZ_CONT_MARK_STACK++;
06988 
06989   cm->key = key;
06990   cm->val = val;
06991   cm->pos = MZ_CONT_MARK_POS; /* always odd */
06992   cm->cache = NULL;
06993 
06994   return findpos;
06995 }
06996 
06997 
06998 MZ_MARK_STACK_TYPE scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val)
06999 {
07000   Scheme_Thread *p = scheme_current_thread;
07001   Scheme_Cont_Mark *cm = NULL;
07002   long findpos, bottom;
07003 
07004   findpos = (long)MZ_CONT_MARK_STACK;
07005   bottom = (long)p->cont_mark_stack_bottom;
07006   while (1) {
07007     if (findpos-- > bottom) {
07008       Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
07009       long pos = findpos & SCHEME_MARK_SEGMENT_MASK;
07010       Scheme_Cont_Mark *find = seg + pos;
07011 
07012       if ((long)find->pos < (long)MZ_CONT_MARK_POS) {
07013         break;
07014       } else {
07015         if (find->key == key) {
07016           cm = find;
07017           break;
07018         } else {
07019           /* Assume that we'll mutate rather than allocate a new mark record. */
07020           /* This is a bad assumption for a nasty program that repeatedly
07021              creates a new key for the same frame, but it's good enough. */
07022           find->cache = NULL;
07023         }
07024       }
07025     } else {
07026       if (MZ_CONT_MARK_POS == p->cont_mark_pos_bottom + 2) {
07027         if (p->meta_continuation) {
07028           if (key != scheme_stack_dump_key) {
07029             /* Check the end of the meta-continuation's stack */
07030             Scheme_Meta_Continuation *mc = p->meta_continuation;
07031             for (findpos = (long)mc->cont_mark_total; findpos--; ) {
07032               if (mc->cont_mark_stack_copied[findpos].pos != mc->cont_mark_pos)
07033                 break;
07034               if (mc->cont_mark_stack_copied[findpos].key == key) {
07035                 if (mc->copy_after_captured < scheme_cont_capture_count) {
07036                   return clone_meta_cont_set_mark(mc, val, findpos);
07037                 }
07038                 mc->cont_mark_stack_copied[findpos].val = val;
07039                 mc->cont_mark_stack_copied[findpos].cache = NULL;
07040                 return 0;
07041               } else {
07042                 mc->cont_mark_stack_copied[findpos].cache = NULL;
07043               }
07044             }
07045           }
07046         }
07047       }
07048       break;
07049     }
07050   }
07051 
07052   if (!cm) {
07053     /* Allocate a new mark record: */
07054     long segpos;
07055     long pos;
07056     Scheme_Cont_Mark *seg;
07057 
07058     findpos = MZ_CONT_MARK_STACK;
07059     segpos = ((long)findpos) >> SCHEME_LOG_MARK_SEGMENT_SIZE;
07060     pos = ((long)findpos) & SCHEME_MARK_SEGMENT_MASK;
07061 
07062     if (segpos >= p->cont_mark_seg_count) {
07063       /* Need a new segment */
07064       return new_segment_set_mark(segpos, pos, key, val);
07065     }
07066 
07067     seg = p->cont_mark_stack_segments[segpos];
07068     cm = seg + pos;
07069     MZ_CONT_MARK_STACK = findpos + 1;
07070   }
07071 
07072   cm->key = key;
07073   cm->val = val;
07074   cm->pos = MZ_CONT_MARK_POS; /* always odd */
07075   cm->cache = NULL;
07076 
07077   return findpos;
07078 }
07079 
07080 void scheme_temp_dec_mark_depth()
07081 {
07082   MZ_CONT_MARK_POS -= 2;
07083 }
07084 
07085 void scheme_temp_inc_mark_depth()
07086 {
07087   MZ_CONT_MARK_POS += 2;
07088 }
07089 
07090 /*========================================================================*/
07091 /*                         eval-apply helpers                             */
07092 /*========================================================================*/
07093 
07094 /* called in schapp.h */
07095 
07096 static Scheme_Object *do_apply_known_k(void)
07097 {
07098   Scheme_Thread *p = scheme_current_thread;
07099   Scheme_Object **argv = (Scheme_Object **)p->ku.k.p2;
07100 
07101   p->ku.k.p2 = NULL;
07102 
07103   return _scheme_apply_known_prim_closure_multi((Scheme_Object *)p->ku.k.p1, 
07104                                           p->ku.k.i1, 
07105                                           argv);
07106 }
07107 
07108 #if 0
07109 # define DEBUG_CHECK_TYPE(v) \
07110   if ((v != SCHEME_MULTIPLE_VALUES) \
07111       && (v != SCHEME_TAIL_CALL_WAITING) \
07112       && (v != SCHEME_EVAL_WAITING) \
07113       && (SCHEME_TYPE(v) > (_scheme_last_type_ + 25))) \
07114   { Scheme_Object *o = *(Scheme_Object **)(v); \
07115     if (SCHEME_TYPE(o) > (_scheme_last_type_ + 25))\
07116        scheme_signal_error("bad type"); }
07117 #else
07118 # define DEBUG_CHECK_TYPE(v) 
07119 #endif
07120 
07121 Scheme_Object *_scheme_apply_known_prim_closure_multi(Scheme_Object *rator,
07122                                                 int argc,
07123                                                 Scheme_Object **argv)
07124 {
07125 #define PRIM_CHECK_ARITY 0
07126 #define PRIM_CHECK_MULTI 0
07127 #include "schapp.inc"
07128 }
07129 
07130 Scheme_Object *_scheme_apply_prim_closure_multi(Scheme_Object *rator,
07131                                           int argc,
07132                                           Scheme_Object **argv)
07133 {
07134 #define PRIM_CHECK_ARITY 1
07135 #define PRIM_CHECK_MULTI 0
07136 #include "schapp.inc"
07137 }
07138 
07139 Scheme_Object *_scheme_apply_known_prim_closure(Scheme_Object *rator,
07140                                           int argc,
07141                                           Scheme_Object **argv)
07142 {
07143 #define PRIM_CHECK_ARITY 0
07144 #define PRIM_CHECK_MULTI 1
07145 #include "schapp.inc"
07146 }
07147 
07148 Scheme_Object *_scheme_apply_prim_closure(Scheme_Object *rator,
07149                                      int argc,
07150                                      Scheme_Object **argv)
07151 {
07152 #define PRIM_CHECK_ARITY 1
07153 #define PRIM_CHECK_MULTI 1
07154 #include "schapp.inc"
07155 }
07156 
07157 
07158 #ifdef MZ_USE_JIT
07159 
07160 # define PRIM_APPLY_NAME _scheme_apply_from_native
07161 # define PRIM_APPLY_NAME_FAST _scheme_apply_from_native_fast
07162 # define PRIM_CHECK_VALUE 1
07163 # define PRIM_CHECK_MULTI 1
07164 # include "schnapp.inc"
07165 
07166 # define PRIM_APPLY_NAME _scheme_apply_multi_from_native
07167 # define PRIM_APPLY_NAME_FAST _scheme_apply_multi_from_native_fast
07168 # define PRIM_CHECK_VALUE 1
07169 # define PRIM_CHECK_MULTI 0
07170 # include "schnapp.inc"
07171 
07172 # define PRIM_APPLY_NAME _scheme_tail_apply_from_native
07173 # define PRIM_APPLY_NAME_FAST _scheme_tail_apply_from_native_fast
07174 /* It's ok to call primitive and closed primitives directly,
07175    since they implement further tail by trampolining. */
07176 # define PRIM_CHECK_VALUE 0
07177 # define PRIM_CHECK_MULTI 0
07178 # include "schnapp.inc"
07179 
07180 #endif
07181 
07182 Scheme_Object *scheme_check_one_value(Scheme_Object *v)
07183 {
07184   if (v == SCHEME_MULTIPLE_VALUES)
07185     scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL);
07186   return v;
07187 }
07188 
07189 static Scheme_Object *do_eval_k(void)
07190 {
07191   Scheme_Thread *p = scheme_current_thread;
07192   Scheme_Object *obj = (Scheme_Object *)p->ku.k.p1;
07193   Scheme_Object **argv = (Scheme_Object **)p->ku.k.p2;
07194 
07195   p->ku.k.p1 = NULL;
07196   p->ku.k.p2 = NULL;
07197 
07198   return scheme_do_eval(obj, 
07199                      p->ku.k.i1, 
07200                      argv,
07201                      p->ku.k.i2);
07202 }
07203 
07204 static void unbound_global(Scheme_Object *obj)
07205 {
07206   Scheme_Object *tmp;
07207 
07208   tmp = MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(obj)];
07209   tmp = ((Scheme_Object **)tmp)[SCHEME_TOPLEVEL_POS(obj)];
07210 
07211   scheme_unbound_global((Scheme_Bucket *)tmp);
07212 }
07213 
07214 static void make_tail_buffer_safe()
07215 {
07216   Scheme_Thread *p = scheme_current_thread;
07217 
07218   GC_CAN_IGNORE Scheme_Object **tb;
07219   p->tail_buffer = NULL; /* so args aren't zeroed */
07220   tb = MALLOC_N(Scheme_Object *, p->tail_buffer_size);
07221   p->tail_buffer = tb;
07222 }
07223 
07224 static Scheme_Object **evacuate_runstack(int num_rands, Scheme_Object **rands, Scheme_Object **runstack)
07225 {
07226   if (rands == runstack) {
07227     /* See [TC-SFS] in "schnapp.inc" */
07228     Scheme_Thread *p = scheme_current_thread;
07229     (void)scheme_tail_apply(scheme_void, num_rands, rands);
07230     rands = p->ku.apply.tail_rands;
07231     p->ku.apply.tail_rands = NULL;
07232     return rands;
07233   } else
07234     return rands;
07235 }
07236 
07237 static Scheme_Dynamic_Wind *intersect_dw(Scheme_Dynamic_Wind *a, Scheme_Dynamic_Wind *b, 
07238                                          Scheme_Object *prompt_tag, int b_has_tag, int *_common_depth)
07239 {
07240   int alen = 0, blen = 0;
07241   int a_has_tag = 0, a_prompt_delta = 0, b_prompt_delta = 0;
07242   Scheme_Dynamic_Wind *dw;
07243 
07244   for (dw = a; dw && (dw->prompt_tag != prompt_tag); dw = dw->prev) {
07245   }
07246   if (dw) {
07247     /* Cut off `a' below the prompt dw. */
07248     a_prompt_delta = dw->depth;
07249     a_has_tag = 1;
07250   }
07251 
07252   if (a_has_tag)
07253     a_prompt_delta += 1;
07254   if (b_has_tag)
07255     b_prompt_delta += 1;
07256 
07257   alen = (a ? a->depth + 1 : 0) - a_prompt_delta;
07258   blen = (b ? b->depth + 1 : 0) - b_prompt_delta;
07259 
07260   while (alen > blen) {
07261     --alen;
07262     a = a->prev;
07263   }
07264   if (!alen) {
07265     *_common_depth = b_prompt_delta - 1;
07266     return a;
07267   }
07268   while (blen > alen) {
07269     --blen;
07270     b = b->prev;
07271   }
07272 
07273   /* At this point, we have chains that are the same length. */
07274   while (blen) {
07275     if (SAME_OBJ(a->id ? a->id : (Scheme_Object *)a, 
07276                  b->id ? b->id : (Scheme_Object *)b))
07277       break;
07278     a = a->prev;
07279     b = b->prev;
07280     blen--;
07281   }
07282 
07283   *_common_depth = (b ? b->depth : -1);
07284 
07285   return a;
07286 }
07287 
07288 static Scheme_Prompt *lookup_cont_prompt(Scheme_Cont *c, 
07289                                          Scheme_Meta_Continuation **_prompt_mc,
07290                                          MZ_MARK_POS_TYPE *_prompt_pos,
07291                                          const char *msg)
07292 {
07293   Scheme_Prompt *prompt;
07294 
07295   prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL, 
07296                                                                  SCHEME_PTR_VAL(c->prompt_tag),
07297                                                                  NULL,
07298                                                                  _prompt_mc,
07299                                                                  _prompt_pos);
07300   if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, c->prompt_tag)) {
07301     scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
07302                      msg);
07303   }
07304 
07305   return prompt;
07306 }
07307 
07308 #define LOOKUP_NO_PROMPT "continuation application: no corresponding prompt in the current continuation"
07309 
07310 static Scheme_Prompt *check_barrier(Scheme_Prompt *prompt, 
07311                                     Scheme_Meta_Continuation *prompt_cont, MZ_MARK_POS_TYPE prompt_pos,
07312                                     Scheme_Cont *c)
07313 /* A continuation barrier is analogous to a dynamic-wind. A jump is
07314    allowed if no dynamic-wind-like barriers would be executed for
07315    the jump. */
07316 {
07317   Scheme_Prompt *barrier_prompt, *b1, *b2;
07318   Scheme_Meta_Continuation *barrier_cont;
07319   MZ_MARK_POS_TYPE barrier_pos;
07320 
07321   barrier_prompt = scheme_get_barrier_prompt(&barrier_cont, &barrier_pos);
07322   b1 = barrier_prompt;
07323   if (b1) {
07324     if (!b1->is_barrier)
07325       b1 = NULL;
07326     else if (prompt
07327              && scheme_is_cm_deeper(barrier_cont, barrier_pos,
07328                                     prompt_cont, prompt_pos))
07329       b1 = NULL;
07330   }
07331   b2 = c->barrier_prompt;
07332   if (b2) {
07333     if (!b2->is_barrier)
07334       b2 = NULL;
07335   }
07336   
07337   if (b1 != b2) {
07338     scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
07339                      "continuation application: attempt to cross a continuation barrier");
07340   }
07341 
07342   return barrier_prompt;
07343 }
07344 
07345 void scheme_recheck_prompt_and_barrier(Scheme_Cont *c)
07346 /* Check for prompt & barrier, again. We need to
07347    call this function like a d-w thunk, so that the meta
07348    continuation is right in case of an error. */
07349 {
07350   Scheme_Prompt *prompt;
07351   Scheme_Meta_Continuation *prompt_cont;
07352   MZ_MARK_POS_TYPE prompt_pos;
07353   prompt = lookup_cont_prompt(c, &prompt_cont, &prompt_pos,
07354                               LOOKUP_NO_PROMPT
07355                               " on return from `dynamic-wind' post thunk");
07356   check_barrier(prompt, prompt_cont, prompt_pos, c);
07357 }
07358 
07359 static int exec_dyn_wind_posts(Scheme_Dynamic_Wind *common, Scheme_Cont *c, int common_depth,
07360                                Scheme_Dynamic_Wind **_common)
07361 {
07362   int meta_depth;
07363   Scheme_Thread *p = scheme_current_thread;
07364   Scheme_Dynamic_Wind *dw;
07365   int old_cac = scheme_continuation_application_count;
07366 
07367   *_common = common;
07368 
07369   for (dw = p->dw; 
07370        (common ? dw->depth != common->depth : dw != common);  /* not id, which may be duplicated */
07371        ) {
07372     meta_depth = p->next_meta;
07373     p->next_meta += dw->next_meta;
07374     p->dw = dw->prev;
07375     if (dw->post) {
07376       if (meta_depth > 0) {
07377         scheme_apply_dw_in_meta(dw, 1, meta_depth, c);
07378       } else {
07379         DW_PrePost_Proc post = dw->post;
07380         
07381         MZ_CONT_MARK_POS = dw->envss.cont_mark_pos;
07382         MZ_CONT_MARK_STACK = dw->envss.cont_mark_stack;
07383         post(dw->data);
07384 
07385         if (scheme_continuation_application_count != old_cac) {
07386           scheme_recheck_prompt_and_barrier(c);
07387         }
07388       }
07389       p = scheme_current_thread;
07390       /* p->dw might not match dw if the post thunk captures a
07391          continuation that is later restored in a different 
07392          meta continuation: */
07393       dw = p->dw;
07394 
07395       /* If any continuations were applied, then the set of dynamic
07396          winds may be different now than before. Re-compute the
07397          intersection. */
07398       if (scheme_continuation_application_count != old_cac) {
07399         old_cac = scheme_continuation_application_count;
07400         
07401         common = intersect_dw(p->dw, c->dw, c->prompt_tag, c->has_prompt_dw, &common_depth);
07402         *_common = common;
07403       }
07404     } else
07405       dw = dw->prev;
07406   }
07407   return common_depth;
07408 }
07409 
07410 Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object **old_runstack)
07411 {
07412   Scheme_Thread *p = scheme_current_thread;
07413   Scheme_Cont *c;
07414   Scheme_Dynamic_Wind *common, *new_common;
07415   Scheme_Object *value;
07416   Scheme_Meta_Continuation *prompt_mc;
07417   MZ_MARK_POS_TYPE prompt_pos;
07418   Scheme_Prompt *prompt, *barrier_prompt;
07419   int common_depth;
07420       
07421   if (num_rands != 1) {
07422     GC_CAN_IGNORE Scheme_Object **vals;
07423     int i;
07424 
07425     if (rands == p->tail_buffer)
07426       make_tail_buffer_safe();
07427 
07428     vals = MALLOC_N(Scheme_Object *, num_rands);
07429     for (i = num_rands; i--; ) {
07430       vals[i] = rands[i];
07431     }
07432 
07433     value = (Scheme_Object *)vals;
07434   } else
07435     value = rands[0];
07436       
07437   c = (Scheme_Cont *)obj;
07438       
07439   DO_CHECK_FOR_BREAK(p, ;);
07440 
07441   if (!c->runstack_copied) {
07442     /* This continuation is the same as another, except
07443        that its mark stack is different. The different part
07444        of the mark stack won't be visible, so we use the other. */
07445     c = c->buf.cont;
07446   }
07447 
07448   if (c->composable) {
07449     /* Composable continuation. Jump right in... */
07450     scheme_continuation_application_count++;
07451     MZ_RUNSTACK = old_runstack;
07452     return scheme_compose_continuation(c, num_rands, value);
07453   } else {
07454     /* Aborting (Scheme-style) continuation. */
07455     int orig_cac = scheme_continuation_application_count;
07456 
07457     scheme_about_to_move_C_stack();
07458 
07459     prompt = lookup_cont_prompt(c, &prompt_mc, &prompt_pos, LOOKUP_NO_PROMPT);
07460     barrier_prompt = check_barrier(prompt, prompt_mc, prompt_pos, c);
07461 
07462     p->suspend_break++; /* restored at call/cc destination */
07463 
07464     /* Find `common', the intersection of dynamic-wind chain for 
07465        the current continuation and the given continuation, looking
07466        no further back in the current continuation than a prompt. */
07467     common = intersect_dw(p->dw, c->dw, c->prompt_tag, c->has_prompt_dw, &common_depth);
07468 
07469     /* For dynamic-winds after `common' in this
07470        continuation, execute the post-thunks */
07471     common_depth = exec_dyn_wind_posts(common, c, common_depth, &new_common);
07472     p = scheme_current_thread;
07473 
07474     if (orig_cac != scheme_continuation_application_count) {
07475       /* We checked for a barrier in exec_dyn_wind_posts, but
07476          get prompt & barrier again. */
07477       prompt = lookup_cont_prompt(c, &prompt_mc, &prompt_pos, "shouldn't fail!");
07478       barrier_prompt = scheme_get_barrier_prompt(NULL, NULL);
07479       common = new_common;
07480     }
07481 
07482     c->common_dw_depth = common_depth;
07483       
07484     if (num_rands == 1)
07485       c->value = value;
07486     else {
07487       GC_CAN_IGNORE Scheme_Object *vals;
07488       vals = scheme_values(num_rands, (Scheme_Object **)value);
07489       c->value = vals;
07490     }
07491 
07492     c->common_dw = common;
07493     c->common_next_meta = p->next_meta;
07494 
07495     scheme_continuation_application_count++;
07496 
07497     if (!prompt) {
07498       /* Invoke the continuation directly. If there's no prompt,
07499          then the prompt's job is taken by the pseudo-prompt
07500          created with a new thread or a barrier prompt. */
07501       p->meta_continuation = NULL; /* since prompt wasn't in any meta-continuation */
07502       p->meta_prompt = NULL;
07503       if ((c->barrier_prompt == barrier_prompt) && barrier_prompt) {
07504         /* Barrier determines continuation end. */
07505         c->resume_to = NULL;
07506         p->stack_start = c->stack_start;
07507       } else {
07508         /* Prompt is pseudo-prompt at thread beginning.
07509            We're effectively composing the continuation,
07510            so use it's prompt stack start. */
07511         Scheme_Overflow *oflow;
07512         oflow = scheme_get_thread_end_overflow();
07513         c->resume_to = oflow;
07514         p->stack_start = c->prompt_stack_start;
07515       }
07516       scheme_longjmpup(&c->buf);
07517     } else if (prompt->id
07518                && (prompt->id == c->prompt_id)
07519                && !prompt_mc) {
07520       /* The current prompt is the same as the one in place when
07521          capturing the continuation, so we can jump directly. */
07522       scheme_drop_prompt_meta_continuations(c->prompt_tag);
07523       c->shortcut_prompt = prompt;
07524       if ((!prompt->boundary_overflow_id && !p->overflow)
07525           || (prompt->boundary_overflow_id
07526               && (prompt->boundary_overflow_id == p->overflow->id))) {
07527         scheme_longjmpup(&c->buf);
07528       } else {
07529         /* Need to unwind overflows... */
07530         Scheme_Overflow *overflow;
07531         overflow = p->overflow;
07532         while (overflow->prev
07533                && (!overflow->prev->id
07534                    || (overflow->prev->id != prompt->boundary_overflow_id))) {
07535           overflow = overflow->prev;
07536         }
07537         /* Immediate destination is in scheme_handle_stack_overflow(). */
07538         p->cjs.jumping_to_continuation = (Scheme_Object *)c;
07539         p->overflow = overflow;
07540         p->stack_start = overflow->stack_start;
07541         scheme_longjmpup(&overflow->jmp->cont);
07542       }
07543     } else {
07544       /* The prompt is different than when we captured the continuation,
07545          so we need to compose the continuation with the current prompt. */
07546       p->cjs.jumping_to_continuation = (Scheme_Object</