Back to index

plt-scheme  4.2.1
syntax.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 
00022 /* This file implements most of the built-in syntactic forms, except
00023    the module-related forms (which are in module.c) and certain
00024    aspects of the most primitive forms, such as application (handled
00025    in eval.c) and functions (in fun.c).
00026 
00027    A primitive syntactic form consists of an expander, called by
00028    `expand' and related functions, and a compiler, used by `compile'
00029    and `eval'. (Compilation does *not* expand primitive forms first,
00030    but instead peforms any necessary expansion directly.) */
00031 
00032 #include "schpriv.h"
00033 #include "schmach.h"
00034 #include "schexpobs.h"
00035 
00036 /* globals */
00037 Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax;
00038 Scheme_Object *scheme_ref_syntax;
00039 Scheme_Object *scheme_begin_syntax;
00040 Scheme_Object *scheme_lambda_syntax;
00041 Scheme_Object *scheme_compiled_void_code;
00042 Scheme_Object scheme_undefined[1];
00043 
00044 Scheme_Syntax_Optimizer scheme_syntax_optimizers[_COUNT_EXPD_];
00045 Scheme_Syntax_Resolver scheme_syntax_resolvers[_COUNT_EXPD_];
00046 Scheme_Syntax_SFSer scheme_syntax_sfsers[_COUNT_EXPD_];
00047 Scheme_Syntax_Validater scheme_syntax_validaters[_COUNT_EXPD_];
00048 Scheme_Syntax_Executer scheme_syntax_executers[_COUNT_EXPD_];
00049 Scheme_Syntax_Jitter scheme_syntax_jitters[_COUNT_EXPD_];
00050 Scheme_Syntax_Cloner scheme_syntax_cloners[_COUNT_EXPD_];
00051 Scheme_Syntax_Shifter scheme_syntax_shifters[_COUNT_EXPD_];
00052 int scheme_syntax_protect_afters[_COUNT_EXPD_];
00053 
00054 /* locals */
00055 static Scheme_Object *lambda_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00056 static Scheme_Object *lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00057 static Scheme_Object *define_values_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00058 static Scheme_Object *define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00059 static Scheme_Object *ref_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00060 static Scheme_Object *ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00061 static Scheme_Object *quote_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00062 static Scheme_Object *quote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00063 static Scheme_Object *if_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00064 static Scheme_Object *if_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00065 static Scheme_Object *set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00066 static Scheme_Object *set_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00067 static Scheme_Object *case_lambda_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00068 static Scheme_Object *case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00069 static Scheme_Object *let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00070 static Scheme_Object *let_values_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00071 static Scheme_Object *let_star_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00072 static Scheme_Object *let_star_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00073 static Scheme_Object *letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00074 static Scheme_Object *letrec_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00075 static Scheme_Object *begin_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00076 static Scheme_Object *begin_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00077 static Scheme_Object *begin0_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00078 static Scheme_Object *begin0_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00079 static Scheme_Object *expression_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00080 static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00081 
00082 static Scheme_Object *unquote_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00083 static Scheme_Object *unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00084 
00085 static Scheme_Object *with_cont_mark_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00086 static Scheme_Object *with_cont_mark_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00087 
00088 static Scheme_Object *quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00089 static Scheme_Object *quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00090 static Scheme_Object *define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00091 static Scheme_Object *define_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00092 static Scheme_Object *define_for_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00093 static Scheme_Object *define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00094 static Scheme_Object *letrec_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00095 static Scheme_Object *letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00096 
00097 static Scheme_Object *define_values_execute(Scheme_Object *data);
00098 static Scheme_Object *ref_execute(Scheme_Object *data);
00099 static Scheme_Object *set_execute(Scheme_Object *data);
00100 static Scheme_Object *define_syntaxes_execute(Scheme_Object *expr);
00101 static Scheme_Object *define_for_syntaxes_execute(Scheme_Object *expr);
00102 static Scheme_Object *case_lambda_execute(Scheme_Object *expr);
00103 static Scheme_Object *begin0_execute(Scheme_Object *data);
00104 static Scheme_Object *apply_values_execute(Scheme_Object *data);
00105 static Scheme_Object *splice_execute(Scheme_Object *data);
00106 
00107 static Scheme_Object *bangboxenv_execute(Scheme_Object *data);
00108 
00109 static Scheme_Object *define_values_optimize(Scheme_Object *data, Optimize_Info *info);
00110 static Scheme_Object *ref_optimize(Scheme_Object *data, Optimize_Info *info);
00111 static Scheme_Object *set_optimize(Scheme_Object *data, Optimize_Info *info);
00112 static Scheme_Object *define_syntaxes_optimize(Scheme_Object *expr, Optimize_Info *info);
00113 static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *expr, Optimize_Info *info);
00114 static Scheme_Object *case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info);
00115 static Scheme_Object *begin0_optimize(Scheme_Object *data, Optimize_Info *info);
00116 static Scheme_Object *apply_values_optimize(Scheme_Object *data, Optimize_Info *info);
00117 static Scheme_Object *splice_optimize(Scheme_Object *data, Optimize_Info *info);
00118 
00119 static Scheme_Object *begin0_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
00120 static Scheme_Object *set_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
00121 static Scheme_Object *apply_values_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
00122 static Scheme_Object *splice_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
00123 
00124 static Scheme_Object *begin0_shift(Scheme_Object *data, int delta, int after_depth);
00125 static Scheme_Object *set_shift(Scheme_Object *data, int delta, int after_depth);
00126 static Scheme_Object *ref_shift(Scheme_Object *data, int delta, int after_depth);
00127 static Scheme_Object *case_lambda_shift(Scheme_Object *data, int delta, int after_depth);
00128 static Scheme_Object *apply_values_shift(Scheme_Object *data, int delta, int after_depth);
00129 static Scheme_Object *splice_shift(Scheme_Object *data, int delta, int after_depth);
00130 
00131 static Scheme_Object *define_values_resolve(Scheme_Object *data, Resolve_Info *info);
00132 static Scheme_Object *ref_resolve(Scheme_Object *data, Resolve_Info *info);
00133 static Scheme_Object *set_resolve(Scheme_Object *data, Resolve_Info *info);
00134 static Scheme_Object *define_syntaxes_resolve(Scheme_Object *expr, Resolve_Info *info);
00135 static Scheme_Object *define_for_syntaxes_resolve(Scheme_Object *expr, Resolve_Info *info);
00136 static Scheme_Object *case_lambda_resolve(Scheme_Object *expr, Resolve_Info *info);
00137 static Scheme_Object *begin0_resolve(Scheme_Object *data, Resolve_Info *info);
00138 static Scheme_Object *apply_values_resolve(Scheme_Object *data, Resolve_Info *info);
00139 static Scheme_Object *splice_resolve(Scheme_Object *data, Resolve_Info *info);
00140 
00141 static Scheme_Object *define_values_sfs(Scheme_Object *data, SFS_Info *info);
00142 static Scheme_Object *ref_sfs(Scheme_Object *data, SFS_Info *info);
00143 static Scheme_Object *set_sfs(Scheme_Object *data, SFS_Info *info);
00144 static Scheme_Object *define_syntaxes_sfs(Scheme_Object *expr, SFS_Info *info);
00145 static Scheme_Object *define_for_syntaxes_sfs(Scheme_Object *expr, SFS_Info *info);
00146 static Scheme_Object *case_lambda_sfs(Scheme_Object *expr, SFS_Info *info);
00147 static Scheme_Object *begin0_sfs(Scheme_Object *data, SFS_Info *info);
00148 static Scheme_Object *apply_values_sfs(Scheme_Object *data, SFS_Info *info);
00149 static Scheme_Object *splice_sfs(Scheme_Object *data, SFS_Info *info);
00150 static Scheme_Object *bangboxenv_sfs(Scheme_Object *data, SFS_Info *info);
00151 
00152 static void define_values_validate(Scheme_Object *data, Mz_CPort *port, 
00153                                    char *stack, Validate_TLS tls,
00154                                    int depth, int letlimit, int delta, 
00155                                int num_toplevels, int num_stxes, int num_lifts,
00156                                    struct Validate_Clearing *vc, int tailpos);
00157 static void ref_validate(Scheme_Object *data, Mz_CPort *port, 
00158                          char *stack, Validate_TLS tls,
00159                          int depth, int letlimit, int delta, 
00160                       int num_toplevels, int num_stxes, int num_lifts,
00161                          struct Validate_Clearing *vc, int tailpos);
00162 static void set_validate(Scheme_Object *data, Mz_CPort *port, 
00163                          char *stack, Validate_TLS tls,
00164                          int depth, int letlimit, int delta, 
00165                       int num_toplevels, int num_stxes, int num_lifts,
00166                          struct Validate_Clearing *vc, int tailpos);
00167 static void define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, 
00168                                      char *stack, Validate_TLS tls,
00169                                      int depth, int letlimit, int delta, 
00170                                  int num_toplevels, int num_stxes, int num_lifts,
00171                                      struct Validate_Clearing *vc, int tailpos);
00172 static void define_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, 
00173                                          char *stack, Validate_TLS tls,
00174                                          int depth, int letlimit, int delta, 
00175                                     int num_toplevels, int num_stxes, int num_lifts,
00176                                          struct Validate_Clearing *vc, int tailpos);
00177 static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, 
00178                                  char *stack, Validate_TLS tls,
00179                                  int depth, int letlimit, int delta, 
00180                              int num_toplevels, int num_stxes, int num_lifts,
00181                                  struct Validate_Clearing *vc, int tailpos);
00182 static void begin0_validate(Scheme_Object *data, Mz_CPort *port, 
00183                             char *stack, Validate_TLS tls,
00184                             int depth, int letlimit, int delta,
00185                          int num_toplevels, int num_stxes, int num_lifts,
00186                             struct Validate_Clearing *vc, int tailpos);
00187 static void apply_values_validate(Scheme_Object *data, Mz_CPort *port, 
00188                                   char *stack, Validate_TLS tls,
00189                                   int depth, int letlimit, int delta,
00190                                   int num_toplevels, int num_stxes, int num_lifts,
00191                                   struct Validate_Clearing *vc, int tailpos);
00192 static void splice_validate(Scheme_Object *data, Mz_CPort *port, 
00193                             char *stack, Validate_TLS tls,
00194                             int depth, int letlimit, int delta,
00195                             int num_toplevels, int num_stxes, int num_lifts,
00196                             struct Validate_Clearing *vc, int tailpos);
00197 static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, 
00198                                 char *stack, Validate_TLS tls,
00199                                 int depth, int letlimit, int delta,
00200                             int num_toplevels, int num_stxes, int num_lifts,
00201                                 struct Validate_Clearing *vc, int tailpos);
00202 
00203 static Scheme_Object *define_values_jit(Scheme_Object *data);
00204 static Scheme_Object *ref_jit(Scheme_Object *data);
00205 static Scheme_Object *set_jit(Scheme_Object *data);
00206 static Scheme_Object *define_syntaxes_jit(Scheme_Object *expr);
00207 static Scheme_Object *define_for_syntaxes_jit(Scheme_Object *expr);
00208 static Scheme_Object *case_lambda_jit(Scheme_Object *expr);
00209 static Scheme_Object *begin0_jit(Scheme_Object *data);
00210 static Scheme_Object *apply_values_jit(Scheme_Object *data);
00211 static Scheme_Object *splice_jit(Scheme_Object *data);
00212 static Scheme_Object *bangboxenv_jit(Scheme_Object *data);
00213 
00214 static Scheme_Object *expand_lam(int argc, Scheme_Object **argv);
00215 
00216 static Scheme_Object *write_let_value(Scheme_Object *obj);
00217 static Scheme_Object *read_let_value(Scheme_Object *obj);
00218 static Scheme_Object *write_let_void(Scheme_Object *obj);
00219 static Scheme_Object *read_let_void(Scheme_Object *obj);
00220 static Scheme_Object *write_letrec(Scheme_Object *obj);
00221 static Scheme_Object *read_letrec(Scheme_Object *obj);
00222 static Scheme_Object *write_let_one(Scheme_Object *obj);
00223 static Scheme_Object *read_let_one(Scheme_Object *obj);
00224 static Scheme_Object *write_top(Scheme_Object *obj);
00225 static Scheme_Object *read_top(Scheme_Object *obj);
00226 static Scheme_Object *write_case_lambda(Scheme_Object *obj);
00227 static Scheme_Object *read_case_lambda(Scheme_Object *obj);
00228 
00229 /* symbols */
00230 static Scheme_Object *lambda_symbol;
00231 static Scheme_Object *letrec_values_symbol;
00232 static Scheme_Object *let_star_values_symbol;
00233 static Scheme_Object *let_values_symbol;
00234 static Scheme_Object *begin_symbol;
00235 static Scheme_Object *disappeared_binding_symbol;
00236 
00237 #ifdef MZ_PRECISE_GC
00238 static void register_traversers(void);
00239 #endif
00240 
00241 #define cons(a,b) scheme_make_pair(a,b)
00242 
00243 #define max(a, b) (((a) > (b)) ? (a) : (b))
00244 
00245 #define MAX_PROC_INLINE_SIZE 256
00246 
00247 /**********************************************************************/
00248 /*                          initialization                            */
00249 /**********************************************************************/
00250 
00251 void 
00252 scheme_init_syntax (Scheme_Env *env)
00253 {
00254 #ifdef MZ_PRECISE_GC
00255   register_traversers();
00256 #endif
00257 
00258   REGISTER_SO(scheme_define_values_syntax);
00259   REGISTER_SO(scheme_define_syntaxes_syntax);
00260   REGISTER_SO(scheme_lambda_syntax);
00261   REGISTER_SO(scheme_begin_syntax);
00262   REGISTER_SO(scheme_compiled_void_code);
00263 
00264   REGISTER_SO(lambda_symbol);
00265   REGISTER_SO(letrec_values_symbol);
00266   REGISTER_SO(let_star_values_symbol);
00267   REGISTER_SO(let_values_symbol);
00268   REGISTER_SO(begin_symbol);
00269   REGISTER_SO(disappeared_binding_symbol);
00270 
00271   scheme_undefined->type = scheme_undefined_type;
00272   
00273   lambda_symbol = scheme_intern_symbol("lambda");
00274 
00275   letrec_values_symbol = scheme_intern_symbol("letrec-values");
00276   let_star_values_symbol = scheme_intern_symbol("let*-values");
00277   let_values_symbol = scheme_intern_symbol("let-values");
00278 
00279   begin_symbol = scheme_intern_symbol("begin");
00280 
00281   disappeared_binding_symbol = scheme_intern_symbol("disappeared-binding");
00282 
00283   scheme_register_syntax(DEFINE_VALUES_EXPD, 
00284                       define_values_optimize, 
00285                       define_values_resolve, define_values_sfs, define_values_validate, 
00286                       define_values_execute, define_values_jit, 
00287                       NULL, NULL, -2);
00288   scheme_register_syntax(SET_EXPD,
00289                       set_optimize,
00290                       set_resolve, set_sfs, set_validate,
00291                       set_execute, set_jit, 
00292                       set_clone, set_shift, 2);
00293   scheme_register_syntax(REF_EXPD, 
00294                       ref_optimize,
00295                       ref_resolve, ref_sfs, ref_validate, 
00296                       ref_execute, ref_jit, 
00297                       NULL, ref_shift, 0);
00298   scheme_register_syntax(DEFINE_SYNTAX_EXPD, 
00299                       define_syntaxes_optimize,
00300                       define_syntaxes_resolve, define_syntaxes_sfs, define_syntaxes_validate,
00301                       define_syntaxes_execute, define_syntaxes_jit, 
00302                       NULL, NULL, -2);
00303   scheme_register_syntax(DEFINE_FOR_SYNTAX_EXPD, 
00304                       define_for_syntaxes_optimize, 
00305                       define_for_syntaxes_resolve, define_for_syntaxes_sfs, define_for_syntaxes_validate,
00306                       define_for_syntaxes_execute, define_for_syntaxes_jit, 
00307                       NULL, NULL, -2);
00308   scheme_register_syntax(CASE_LAMBDA_EXPD, 
00309                       case_lambda_optimize,
00310                       case_lambda_resolve, case_lambda_sfs, case_lambda_validate,
00311                       case_lambda_execute, case_lambda_jit, 
00312                       NULL, case_lambda_shift, -1);
00313   scheme_register_syntax(BEGIN0_EXPD, 
00314                       begin0_optimize,
00315                       begin0_resolve, begin0_sfs, begin0_validate,
00316                       begin0_execute, begin0_jit, 
00317                       begin0_clone, begin0_shift, -1);
00318 
00319   scheme_register_syntax(APPVALS_EXPD,
00320                       apply_values_optimize,
00321                       apply_values_resolve, apply_values_sfs, apply_values_validate,
00322                       apply_values_execute, apply_values_jit, 
00323                       apply_values_clone, apply_values_shift, 1);
00324 
00325   scheme_register_syntax(SPLICE_EXPD,
00326                       splice_optimize,
00327                       splice_resolve, splice_sfs, splice_validate,
00328                       splice_execute, splice_jit, 
00329                       splice_clone, splice_shift, 0);
00330 
00331   scheme_register_syntax(BOXENV_EXPD, 
00332                       NULL, NULL, bangboxenv_sfs, bangboxenv_validate,
00333                       bangboxenv_execute, bangboxenv_jit, 
00334                       NULL, NULL, 1);
00335 
00336   scheme_install_type_writer(scheme_let_value_type, write_let_value);
00337   scheme_install_type_reader(scheme_let_value_type, read_let_value);
00338   scheme_install_type_writer(scheme_let_void_type, write_let_void);
00339   scheme_install_type_reader(scheme_let_void_type, read_let_void);
00340   scheme_install_type_writer(scheme_letrec_type, write_letrec);
00341   scheme_install_type_reader(scheme_letrec_type, read_letrec);
00342   scheme_install_type_writer(scheme_let_one_type, write_let_one);
00343   scheme_install_type_reader(scheme_let_one_type, read_let_one);
00344   scheme_install_type_writer(scheme_case_lambda_sequence_type, write_case_lambda);
00345   scheme_install_type_reader(scheme_case_lambda_sequence_type, read_case_lambda);
00346 
00347   scheme_install_type_writer(scheme_compilation_top_type, write_top);
00348   scheme_install_type_reader(scheme_compilation_top_type, read_top);
00349 
00350   scheme_define_values_syntax = scheme_make_compiled_syntax(define_values_syntax, 
00351                                                      define_values_expand);
00352   scheme_define_syntaxes_syntax = scheme_make_compiled_syntax(define_syntaxes_syntax, 
00353                                                        define_syntaxes_expand);
00354   scheme_lambda_syntax = scheme_make_compiled_syntax(lambda_syntax,
00355                                                lambda_expand);
00356   scheme_begin_syntax = scheme_make_compiled_syntax(begin_syntax, 
00357                                               begin_expand);
00358   
00359   scheme_add_global_keyword("lambda", 
00360                          scheme_lambda_syntax,
00361                          env);
00362   {
00363     /* Graak lambda binding: */
00364     Scheme_Object *macro, *fn;
00365 
00366     fn = scheme_make_prim_w_arity(expand_lam, "\316\273", 1, 1);
00367     macro = scheme_alloc_small_object();
00368     macro->type = scheme_macro_type;
00369     SCHEME_PTR_VAL(macro) = fn;
00370 
00371     scheme_add_global_keyword("\316\273", macro, env);
00372   }
00373   scheme_add_global_keyword("define-values", scheme_define_values_syntax, env);
00374   scheme_add_global_keyword("quote", 
00375                          scheme_make_compiled_syntax(quote_syntax,
00376                                                  quote_expand), 
00377                          env);
00378   scheme_add_global_keyword("if", 
00379                          scheme_make_compiled_syntax(if_syntax, 
00380                                                  if_expand),
00381                          env);
00382   scheme_add_global_keyword("set!", 
00383                          scheme_make_compiled_syntax(set_syntax, 
00384                                                  set_expand), 
00385                          env);
00386   scheme_add_global_keyword("#%variable-reference", 
00387                          scheme_make_compiled_syntax(ref_syntax,
00388                                                  ref_expand), 
00389                          env);
00390 
00391   scheme_add_global_keyword("#%expression", 
00392                          scheme_make_compiled_syntax(expression_syntax,
00393                                                  expression_expand), 
00394                          env);
00395 
00396   scheme_add_global_keyword("case-lambda", 
00397                          scheme_make_compiled_syntax(case_lambda_syntax, 
00398                                                  case_lambda_expand), 
00399                          env);
00400 
00401   scheme_add_global_keyword("let-values", 
00402                          scheme_make_compiled_syntax(let_values_syntax, 
00403                                                  let_values_expand), 
00404                          env);
00405   scheme_add_global_keyword("let*-values", 
00406                          scheme_make_compiled_syntax(let_star_values_syntax, 
00407                                                  let_star_values_expand), 
00408                          env);
00409   scheme_add_global_keyword("letrec-values", 
00410                          scheme_make_compiled_syntax(letrec_values_syntax, 
00411                                                   letrec_values_expand), 
00412                          env);  
00413   
00414   scheme_add_global_keyword("begin", 
00415                          scheme_begin_syntax, 
00416                          env);
00417 
00418   scheme_add_global_keyword("begin0", 
00419                          scheme_make_compiled_syntax(begin0_syntax, 
00420                                                   begin0_expand), 
00421                          env);
00422 
00423   scheme_add_global_keyword("unquote", 
00424                          scheme_make_compiled_syntax(unquote_syntax, 
00425                                                  unquote_expand), 
00426                          env);
00427   scheme_add_global_keyword("unquote-splicing", 
00428                          scheme_make_compiled_syntax(unquote_syntax, 
00429                                                  unquote_expand), 
00430                          env);
00431 
00432   scheme_add_global_keyword("with-continuation-mark", 
00433                          scheme_make_compiled_syntax(with_cont_mark_syntax, 
00434                                                  with_cont_mark_expand), 
00435                          env);
00436 
00437   scheme_add_global_keyword("quote-syntax", 
00438                          scheme_make_compiled_syntax(quote_syntax_syntax, 
00439                                                  quote_syntax_expand), 
00440                          env);
00441   scheme_add_global_keyword("define-syntaxes", scheme_define_syntaxes_syntax, env);
00442   scheme_add_global_keyword("define-values-for-syntax", 
00443                          scheme_make_compiled_syntax(define_for_syntaxes_syntax, 
00444                                                  define_for_syntaxes_expand),
00445                          env);
00446   scheme_add_global_keyword("letrec-syntaxes+values", 
00447                          scheme_make_compiled_syntax(letrec_syntaxes_syntax, 
00448                                                  letrec_syntaxes_expand), 
00449                          env);
00450 }
00451 
00452 Scheme_Object *
00453 scheme_make_compiled_syntax(Scheme_Syntax *proc, 
00454                          Scheme_Syntax_Expander *eproc)
00455 {
00456   Scheme_Object *syntax;
00457 
00458   syntax = scheme_alloc_eternal_object();
00459   syntax->type = scheme_syntax_compiler_type;
00460   SCHEME_SYNTAX(syntax) = (Scheme_Object *)proc;
00461   SCHEME_SYNTAX_EXP(syntax) = (Scheme_Object *)eproc;
00462 
00463   return syntax;
00464 }
00465 
00466 /**********************************************************************/
00467 /*                            utilities                               */
00468 /**********************************************************************/
00469 
00470 static int check_form(Scheme_Object *form, Scheme_Object *base_form)
00471 {
00472   int i;
00473 
00474   for (i = 0; SCHEME_STX_PAIRP(form); i++) {
00475     form = SCHEME_STX_CDR(form);
00476   }
00477 
00478   if (!SCHEME_STX_NULLP(form)) {
00479     scheme_wrong_syntax(NULL, form, base_form, "bad syntax (" IMPROPER_LIST_FORM ")");
00480   }
00481 
00482   return i;
00483 }
00484 
00485 static void bad_form(Scheme_Object *form, int l)
00486 { 
00487   scheme_wrong_syntax(NULL, NULL, form, 
00488                     "bad syntax (has %d part%s after keyword)", 
00489                     l - 1, (l != 2) ? "s" : "");
00490 }
00491 
00492 Scheme_Object *scheme_check_name_property(Scheme_Object *code, Scheme_Object *current_val)
00493 {
00494   Scheme_Object *name;
00495 
00496   name = scheme_stx_property(code, scheme_inferred_name_symbol, NULL);
00497   if (name && SCHEME_SYMBOLP(name))
00498     return name;
00499   else
00500     return current_val;
00501 }
00502 
00503 /**********************************************************************/
00504 /*                           lambda utils                             */
00505 /**********************************************************************/
00506 
00507 static void lambda_check(Scheme_Object *form)
00508 {
00509   if (SCHEME_STX_PAIRP(form)
00510       && SCHEME_STX_PAIRP(SCHEME_STX_CDR(form))) {
00511     Scheme_Object *rest;
00512     rest = SCHEME_STX_CDR(form);
00513     if (SCHEME_STX_PAIRP(SCHEME_STX_CDR(rest)))
00514       return;
00515   }
00516 
00517   scheme_wrong_syntax(NULL, NULL, form, NULL);
00518 }
00519 
00520 static void lambda_check_args(Scheme_Object *args, Scheme_Object *form, Scheme_Comp_Env *env)
00521 {
00522   Scheme_Object *v, *a;
00523   DupCheckRecord r;
00524 
00525   if (!SCHEME_STX_SYMBOLP(args)) {
00526     for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
00527       a = SCHEME_STX_CAR(v);
00528       scheme_check_identifier(NULL, a, NULL, env, form);
00529     }
00530 
00531     if (!SCHEME_STX_NULLP(v)) {
00532       if (!SCHEME_STX_SYMBOLP(v)) {
00533        scheme_check_identifier(NULL, v, NULL, env, form);
00534       }
00535     }
00536 
00537     /* Check for duplicate names: */
00538     scheme_begin_dup_symbol_check(&r, env);
00539     for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
00540       Scheme_Object *name;
00541 
00542       name = SCHEME_STX_CAR(v);
00543       scheme_dup_symbol_check(&r, NULL, name, "argument", form);
00544     }
00545     if (!SCHEME_STX_NULLP(v)) {
00546       scheme_dup_symbol_check(&r, NULL, v, "argument", form);
00547     }
00548   }
00549 }
00550 
00551 static Scheme_Object *
00552 lambda_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
00553 {
00554   Scheme_Object *args;
00555 
00556   lambda_check(form);
00557 
00558   args = SCHEME_STX_CDR(form);
00559   args = SCHEME_STX_CAR(args);
00560   lambda_check_args(args, form, env);
00561 
00562   scheme_rec_add_certs(rec, drec, form);
00563 
00564   return scheme_make_closure_compilation(env, form, rec, drec);
00565 }
00566 
00567 static Scheme_Object *
00568 lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
00569 {
00570   Scheme_Object *args, *body, *fn;
00571   Scheme_Comp_Env *newenv;
00572 
00573   SCHEME_EXPAND_OBSERVE_PRIM_LAMBDA(erec[drec].observer);
00574 
00575   lambda_check(form);
00576   
00577   args = SCHEME_STX_CDR(form);
00578   args = SCHEME_STX_CAR(args);
00579 
00580   lambda_check_args(args, form, env);
00581 
00582   scheme_rec_add_certs(erec, drec, form);
00583 
00584   newenv = scheme_add_compilation_frame(args, env, 0, erec[drec].certs);
00585 
00586   body = SCHEME_STX_CDR(form);
00587   body = SCHEME_STX_CDR(body);
00588   body = scheme_datum_to_syntax(body, form, form, 0, 0);
00589 
00590   body = scheme_add_env_renames(body, newenv, env);
00591 
00592   args = scheme_add_env_renames(args, newenv, env); /* for re-expansion */
00593   SCHEME_EXPAND_OBSERVE_LAMBDA_RENAMES(erec[drec].observer, args, body);
00594 
00595   fn = SCHEME_STX_CAR(form);
00596 
00597   return scheme_datum_to_syntax(cons(fn,
00598                                   cons(args,
00599                                        scheme_expand_block(body,
00600                                                         newenv,
00601                                                         erec, 
00602                                                         drec))),
00603                             form, form, 
00604                             0, 2);
00605 }
00606 
00607 static Scheme_Object *expand_lam(int argc, Scheme_Object **argv)
00608 {
00609   Scheme_Object *form = argv[0], *args, *fn;
00610   Scheme_Comp_Env *env;
00611 
00612   env = scheme_current_thread->current_local_env;
00613 
00614   lambda_check(form);
00615   
00616   args = SCHEME_STX_CDR(form);
00617   args = SCHEME_STX_CAR(args);
00618 
00619   lambda_check_args(args, form, env);
00620 
00621   fn = SCHEME_STX_CAR(form);
00622   fn = scheme_datum_to_syntax(lambda_symbol, fn, scheme_sys_wraps(env), 0, 0);
00623   
00624   args = SCHEME_STX_CDR(form);
00625   return scheme_datum_to_syntax(cons(fn, args), form, fn, 0, 0);
00626 }
00627 
00628 /**********************************************************************/
00629 /*                           define utils                             */
00630 /**********************************************************************/
00631 
00632 void scheme_set_global_bucket(char *who, Scheme_Bucket *b, Scheme_Object *val,
00633                            int set_undef)
00634 {
00635   if ((b->val || set_undef) 
00636       && ((b->so.type != scheme_variable_type)
00637          || !(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_IMMUTATED)))
00638     b->val = val;
00639   else {
00640     if (((Scheme_Bucket_With_Home *)b)->home->module) {
00641       const char *msg;
00642       int is_set;
00643 
00644       if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC)))
00645        msg = "%s: cannot %s: %S in module: %D";
00646       else
00647        msg = "%s: cannot %s: %S";
00648 
00649       is_set = !strcmp(who, "set!");
00650       
00651       scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, b->key,
00652                      msg,
00653                      who,
00654                      (b->val
00655                      ? (is_set
00656                            ? "modify a constant"
00657                            : "re-define a constant")
00658                      : "set identifier before its definition"),
00659                      (Scheme_Object *)b->key,
00660                      ((Scheme_Bucket_With_Home *)b)->home->module->modname);
00661     } else {
00662       scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, b->key,
00663                      "%s: cannot %s identifier: %S",
00664                      who,
00665                      b->val ? "change constant" : "set undefined",
00666                      (Scheme_Object *)b->key);
00667     }
00668   }
00669 }
00670 
00671 void scheme_install_macro(Scheme_Bucket *b, Scheme_Object *v)
00672 {
00673   Scheme_Object *macro;
00674 
00675   macro = scheme_alloc_small_object();
00676   macro->type = scheme_macro_type;
00677   SCHEME_PTR_VAL(macro) = v;
00678 
00679   b->val = macro;
00680 }
00681 
00682 static Scheme_Object *
00683 define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
00684                                   Resolve_Prefix *rp, Scheme_Env *dm_env, 
00685                                   Scheme_Dynamic_State *dyn_state)
00686 {
00687   Scheme_Object *name, *macro, *vals_expr, *vals, *var;
00688   int i, g, show_any;
00689   Scheme_Bucket *b;
00690   Scheme_Object **save_runstack = NULL;
00691 
00692   vals_expr = SCHEME_VEC_ELS(vec)[0];
00693 
00694   if (dm_env) {
00695     scheme_prepare_exp_env(dm_env);
00696 
00697     save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1);
00698     vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals_expr, dyn_state);
00699     if (defmacro == 2)
00700       dm_env = NULL;
00701     else
00702       scheme_pop_prefix(save_runstack);
00703   } else {
00704     vals = _scheme_eval_linked_expr_multi(vals_expr);
00705     dm_env = NULL;
00706   }
00707 
00708   if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) {
00709     Scheme_Object **values;
00710 
00711     i = SCHEME_VEC_SIZE(vec) - delta;
00712     
00713     g = scheme_current_thread->ku.multiple.count;
00714     if (i == g) {
00715       values = scheme_current_thread->ku.multiple.array;
00716       scheme_current_thread->ku.multiple.array = NULL;
00717       if (SAME_OBJ(values, scheme_current_thread->values_buffer))
00718        scheme_current_thread->values_buffer = NULL;
00719       for (i = 0; i < g; i++) {
00720         var = SCHEME_VEC_ELS(vec)[i+delta];
00721        if (dm_env) {
00722          b = scheme_global_keyword_bucket(var, dm_env);
00723 
00724          macro = scheme_alloc_small_object();
00725          macro->type = scheme_macro_type;
00726          SCHEME_PTR_VAL(macro) = values[i];
00727 
00728          scheme_set_global_bucket("define-syntaxes", b, macro, 1);
00729          scheme_shadow(dm_env, (Scheme_Object *)b->key, 0);
00730        } else {
00731          Scheme_Object **toplevels;
00732          toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
00733          b = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(var)];
00734        
00735          scheme_set_global_bucket("define-values", b, values[i], 1);
00736          scheme_shadow(((Scheme_Bucket_With_Home *)b)->home, (Scheme_Object *)b->key, 1);
00737 
00738          if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) {
00739             ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED;
00740          }
00741        }
00742       }
00743       if (defmacro)
00744        scheme_pop_prefix(save_runstack);
00745        
00746       return scheme_void;
00747     }
00748 
00749     if (SAME_OBJ(scheme_current_thread->ku.multiple.array, scheme_current_thread->values_buffer))
00750       scheme_current_thread->values_buffer = NULL;
00751   } else if (SCHEME_VEC_SIZE(vec) == delta + 1) { /* => single var */
00752     var = SCHEME_VEC_ELS(vec)[delta];
00753     if (dm_env) {
00754       b = scheme_global_keyword_bucket(var, dm_env);
00755 
00756       macro = scheme_alloc_small_object();
00757       macro->type = scheme_macro_type;
00758       SCHEME_PTR_VAL(macro) = vals;
00759       
00760       scheme_set_global_bucket("define-syntaxes", b, macro, 1);
00761       scheme_shadow(dm_env, (Scheme_Object *)b->key, 0);
00762     } else {
00763       Scheme_Object **toplevels;
00764       toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
00765       b = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(var)];
00766 
00767       scheme_set_global_bucket("define-values", b, vals, 1);
00768       scheme_shadow(((Scheme_Bucket_With_Home *)b)->home, (Scheme_Object *)b->key, 1);
00769       
00770       if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) {
00771         int flags = GLOB_IS_IMMUTATED;
00772         if (SCHEME_PROCP(vals_expr) 
00773             || SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_unclosed_procedure_type))
00774           flags |= GLOB_IS_CONSISTENT;
00775         ((Scheme_Bucket_With_Flags *)b)->flags |= flags;
00776       }
00777       
00778       if (defmacro)
00779        scheme_pop_prefix(save_runstack);
00780     }
00781 
00782     return scheme_void;
00783   } else
00784     g = 1;
00785 
00786   /* Special handling of 0 values for define-syntaxes:
00787      do nothing. This makes (define-values (a b c) (values))
00788      a kind of declaration form, which is useful is
00789      a, b, or c is introduced by a macro. */
00790   if (dm_env && !g)
00791     return scheme_void;
00792   
00793   i = SCHEME_VEC_SIZE(vec) - delta;
00794 
00795   show_any = i;
00796 
00797   if (show_any) {
00798     var = SCHEME_VEC_ELS(vec)[delta];
00799     if (dm_env) {
00800       b = scheme_global_keyword_bucket(var, dm_env);
00801       name = (Scheme_Object *)b->key;
00802     } else {
00803       Scheme_Object **toplevels;
00804       toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
00805       b = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(var)];
00806       name = (Scheme_Object *)b->key;
00807     }
00808   } else
00809     name = NULL;
00810   
00811   if (defmacro > 1)
00812     scheme_pop_prefix(save_runstack);
00813 
00814   {
00815     const char *symname;
00816 
00817     symname = (show_any ? scheme_symbol_name(name) : "");
00818 
00819     scheme_wrong_return_arity((defmacro 
00820                             ? (dm_env ? "define-syntaxes" : "define-values-for-syntax")
00821                             : "define-values"),
00822                            i, g,
00823                            (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array,
00824                            "%s%s%s",
00825                            show_any ? "defining \"" : "0 names",
00826                            symname,
00827                            show_any ? ((i == 1) ? "\"" : "\", ...") : "");
00828   }
00829 
00830   return NULL;
00831 }
00832 
00833 static Scheme_Object *
00834 define_values_execute(Scheme_Object *data)
00835 {
00836   return define_execute_with_dynamic_state(data, 1, 0, NULL, NULL, NULL);
00837 }
00838 
00839 static Scheme_Object *clone_vector(Scheme_Object *data, int skip)
00840 {
00841   Scheme_Object *naya;
00842   int i, size;
00843 
00844   size = SCHEME_VEC_SIZE(data);
00845   naya = scheme_make_vector(size - skip, NULL);
00846   for (i = skip; i < size; i++) {
00847     SCHEME_VEC_ELS(naya)[i - skip] = SCHEME_VEC_ELS(data)[i];
00848   }
00849 
00850   return naya;
00851 }
00852 
00853 static Scheme_Object *define_values_jit(Scheme_Object *data)
00854 {
00855   Scheme_Object *orig = SCHEME_VEC_ELS(data)[0], *naya;
00856 
00857   if (SAME_TYPE(SCHEME_TYPE(orig), scheme_unclosed_procedure_type)
00858       && (SCHEME_VEC_SIZE(data) == 2))
00859     naya = scheme_jit_closure(orig, SCHEME_VEC_ELS(data)[1]);
00860   else
00861     naya = scheme_jit_expr(orig);
00862 
00863   if (SAME_OBJ(naya, orig))
00864     return data;
00865   else {
00866     orig = naya;
00867     naya = clone_vector(data, 0);
00868     SCHEME_VEC_ELS(naya)[0] = orig;
00869     return naya;
00870   }
00871 }
00872 
00873 static void define_values_validate(Scheme_Object *data, Mz_CPort *port, 
00874                                char *stack,  Validate_TLS tls,
00875                                    int depth, int letlimit, int delta, 
00876                                    int num_toplevels, int num_stxes, int num_lifts,
00877                                    struct Validate_Clearing *vc, int tailpos)
00878 {
00879   int i, size;
00880   Scheme_Object *val, *only_var;
00881 
00882   if (!SCHEME_VECTORP(data))
00883     scheme_ill_formed_code(port);
00884 
00885   val = SCHEME_VEC_ELS(data)[0];
00886   size = SCHEME_VEC_SIZE(data);
00887 
00888   if (size == 2)
00889     only_var = SCHEME_VEC_ELS(data)[1];
00890   else
00891     only_var = NULL;
00892     
00893   for (i = 1; i < size; i++) {
00894     scheme_validate_toplevel(SCHEME_VEC_ELS(data)[i], port, stack, tls, depth, delta, 
00895                              num_toplevels, num_stxes, num_lifts,
00896                              1);
00897   }
00898 
00899   if (only_var) {
00900     int pos;
00901     pos = SCHEME_TOPLEVEL_POS(only_var);
00902     if (pos >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) {
00903       /* It's a lift. Check whether it needs to take reference arguments
00904          and/or install reference info. */
00905       Scheme_Object *app_rator;
00906       Scheme_Closure_Data *data = NULL;
00907       int tp = pos - (num_toplevels + num_stxes + (num_stxes ? 1 : 0));
00908       mzshort *a, *new_a = NULL;
00909 
00910       /* Make sure that no one has tried to register information. */
00911       a = tls[tp];
00912       if (a && (a != (mzshort *)0x1) && (a[0] < 1))
00913         scheme_ill_formed_code(port);
00914 
00915       /* Convert rator to ref-arg info: */
00916       app_rator = val;
00917       while (1) {
00918         if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_closure_type)) {
00919           data = SCHEME_COMPILED_CLOS_CODE(app_rator);
00920           break;
00921         } else if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_unclosed_procedure_type)) {
00922           data = (Scheme_Closure_Data *)app_rator;
00923           break;
00924         } else if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_toplevel_type)) {
00925           /* Record an indirection */
00926           data = NULL;
00927           new_a = MALLOC_N_ATOMIC(mzshort, 2);
00928           new_a[0] = 0;
00929           new_a[1] = SCHEME_TOPLEVEL_POS(app_rator);
00930           break;
00931         } else {
00932           /* Not a procedure */
00933           data = NULL;
00934           new_a = (mzshort *)0x1;
00935           break;
00936         }
00937       }
00938       if (data) {
00939         if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REF_ARGS) {
00940           int sz;
00941           sz = data->num_params;
00942           a = MALLOC_N_ATOMIC(mzshort, (sz + 1));
00943           a[0] = -sz;
00944           for (i = 0; i < sz; i++) {
00945             int bit = ((mzshort)1 << (i & (BITS_PER_MZSHORT - 1)));
00946             if (data->closure_map[data->closure_size + (i / BITS_PER_MZSHORT)] & bit)
00947               a[i + 1] = 1;
00948             else
00949               a[i + 1] = 0;
00950           }
00951         } else {
00952           new_a = (mzshort *)0x1;
00953         }
00954       }
00955 
00956       /* Install info: */
00957       tls[tp] = new_a;
00958 
00959       /* Check old hopes against actual */
00960       if (a == (mzshort *)0x1) {
00961         if (new_a != (mzshort *)0x1)
00962           scheme_ill_formed_code(port);
00963       } else if (a) {
00964         int cnt = a[0], i;
00965 
00966         for (i = 0; i < cnt; i++) {
00967           if (a[i + 1]) {
00968             int is;
00969             is = scheme_validate_rator_wants_box(val, i, 
00970                                                  a[i + 1] == 2,
00971                                                  tls, num_toplevels, num_stxes, num_lifts);
00972             if ((is && (a[i + 1] == 1))
00973                 || (!is && (a[i + 1] == 2)))
00974               scheme_ill_formed_code(port);
00975           }
00976         }
00977       }
00978     } else
00979       only_var = NULL;
00980   }
00981 
00982   scheme_validate_expr(port, val, stack, tls, 
00983                        depth, letlimit, delta, 
00984                        num_toplevels, num_stxes, num_lifts,
00985                        NULL, !!only_var, 0, vc, 0);
00986 }
00987 
00988 static Scheme_Object *
00989 define_values_optimize(Scheme_Object *data, Optimize_Info *info)
00990 {
00991   Scheme_Object *vars = SCHEME_CAR(data);
00992   Scheme_Object *val = SCHEME_CDR(data);
00993 
00994   scheme_optimize_info_used_top(info);
00995   val = scheme_optimize_expr(val, info);
00996 
00997   return scheme_make_syntax_compiled(DEFINE_VALUES_EXPD, cons(vars, val));
00998 }
00999 
01000 static Scheme_Object *
01001 define_values_resolve(Scheme_Object *data, Resolve_Info *rslv)
01002 {
01003   long cnt = 0;
01004   Scheme_Object *vars = SCHEME_CAR(data), *l, *a;
01005   Scheme_Object *val = SCHEME_CDR(data), *vec;
01006 
01007   /* If this is a module-level definition: for each variable, if the
01008      defined variable doesn't have SCHEME_TOPLEVEL_MUTATED, then
01009      resolve to a top-level reference with SCHEME_TOPLEVEL_CONST, so
01010      that we know to set GLOS_IS_IMMUTATED at run time. */
01011   for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
01012     a = SCHEME_CAR(l);
01013     if (rslv->in_module
01014        && rslv->enforce_const
01015        && (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED))) {
01016       a = scheme_toplevel_to_flagged_toplevel(a, SCHEME_TOPLEVEL_CONST);
01017     }
01018     a = scheme_resolve_toplevel(rslv, a, 0);
01019     SCHEME_CAR(l) = a;
01020     cnt++;
01021   }
01022 
01023   vec = scheme_make_vector(cnt + 1, NULL);
01024   cnt = 1;
01025   for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
01026     SCHEME_VEC_ELS(vec)[cnt++] = SCHEME_CAR(l);
01027   }
01028 
01029   val = scheme_resolve_expr(val, rslv);
01030   SCHEME_VEC_ELS(vec)[0] = val;
01031 
01032   return scheme_make_syntax_resolved(DEFINE_VALUES_EXPD, vec);
01033 }
01034 
01035 static Scheme_Object *
01036 define_values_sfs(Scheme_Object *data, SFS_Info *info)
01037 {
01038   Scheme_Object *e;
01039   scheme_sfs_start_sequence(info, 1, 0);
01040   e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1);
01041   SCHEME_VEC_ELS(data)[0] = e;
01042   return data;
01043 }
01044 
01045 void scheme_resolve_lift_definition(Resolve_Info *info, Scheme_Object *var, Scheme_Object *rhs)
01046 {
01047   Scheme_Object *decl, *vec, *pr;
01048 
01049   vec = scheme_make_vector(2, NULL);
01050   SCHEME_VEC_ELS(vec)[0] = rhs;
01051   SCHEME_VEC_ELS(vec)[1] = var;
01052 
01053   decl = scheme_make_syntax_resolved(DEFINE_VALUES_EXPD, vec);
01054 
01055   vec = info->lifts;
01056   pr = cons(decl, SCHEME_VEC_ELS(vec)[0]);
01057   SCHEME_VEC_ELS(vec)[0] = pr;
01058 }
01059 
01060 void scheme_define_parse(Scheme_Object *form, 
01061                       Scheme_Object **var, Scheme_Object **_stk_val,
01062                       int defmacro,
01063                       Scheme_Comp_Env *env,
01064                          int no_toplevel_check)
01065 {
01066   Scheme_Object *vars, *rest;
01067   int len;
01068   DupCheckRecord r;
01069 
01070   if (!no_toplevel_check && !scheme_is_toplevel(env))
01071     scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)");
01072 
01073   len = check_form(form, form);
01074   if (len != 3)
01075     bad_form(form, len);
01076   
01077   rest = SCHEME_STX_CDR(form);
01078   vars = SCHEME_STX_CAR(rest);
01079   rest = SCHEME_STX_CDR(rest);
01080   *_stk_val = SCHEME_STX_CAR(rest);
01081 
01082   *var = vars;
01083 
01084   scheme_begin_dup_symbol_check(&r, env);
01085 
01086   while (SCHEME_STX_PAIRP(vars)) {
01087     Scheme_Object *name;
01088 
01089     name = SCHEME_STX_CAR(vars);
01090     scheme_check_identifier(NULL, name, NULL, env, form);
01091 
01092     vars = SCHEME_STX_CDR(vars);
01093 
01094     scheme_dup_symbol_check(&r, NULL, name, "binding", form);
01095   }  
01096 
01097   if (!SCHEME_STX_NULLP(vars))
01098     scheme_wrong_syntax(NULL, *var, form, "bad variable list");
01099 }
01100 
01101 static Scheme_Object *
01102 defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
01103 {
01104   Scheme_Object *first = scheme_null, *last = NULL;
01105 
01106   while (SCHEME_STX_PAIRP(var)) {
01107     Scheme_Object *name, *pr, *bucket;
01108 
01109     name = SCHEME_STX_CAR(var);
01110     name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL);
01111 
01112     if (rec[drec].resolve_module_ids || !env->genv->module) {
01113       bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv);
01114     } else {
01115       /* Create a module variable reference, so that idx is preserved: */
01116       bucket = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, 
01117                                       name, env->genv->module->insp, 
01118                                       -1, env->genv->mod_phase);
01119     }
01120     /* Get indirection through the prefix: */
01121     bucket = scheme_register_toplevel_in_prefix(bucket, env, rec, drec);
01122 
01123     pr = cons(bucket, scheme_null);
01124     if (last)
01125       SCHEME_CDR(last) = pr;
01126     else
01127       first = pr;
01128     last = pr;
01129 
01130     var = SCHEME_STX_CDR(var);
01131   }
01132 
01133   return first;
01134 }
01135 
01136 static Scheme_Object *
01137 define_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
01138 {
01139   Scheme_Object *var, *val, *targets, *variables;
01140   
01141   scheme_define_parse(form, &var, &val, 0, env, 0);
01142   variables = var;
01143   
01144   targets = defn_targets_syntax(var, env, rec, drec);
01145 
01146   scheme_compile_rec_done_local(rec, drec);
01147   if (SCHEME_STX_PAIRP(targets) && SCHEME_STX_NULLP(SCHEME_STX_CDR(targets))) {
01148     var = SCHEME_STX_CAR(variables);
01149     rec[drec].value_name = SCHEME_STX_SYM(var);
01150   }
01151 
01152   env = scheme_no_defines(env);
01153 
01154   scheme_rec_add_certs(rec, drec, form);
01155 
01156   val = scheme_compile_expr(val, env, rec, drec);
01157 
01158   /* Note: module_optimize depends on the representation of
01159      DEFINE_VALUES_EXPD's value. */
01160   return scheme_make_syntax_compiled(DEFINE_VALUES_EXPD, cons(targets, val));
01161 }
01162 
01163 static Scheme_Object *
01164 define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
01165 {
01166   Scheme_Object *var, *val, *fn, *boundname;
01167 
01168   SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(erec[drec].observer);
01169 
01170   scheme_define_parse(form, &var, &val, 0, env, 0);
01171 
01172   env = scheme_no_defines(env);
01173 
01174   if (SCHEME_STX_PAIRP(var) && SCHEME_STX_NULLP(SCHEME_STX_CDR(var)))
01175     boundname = SCHEME_STX_CAR(var);
01176   else
01177     boundname = scheme_false;
01178   erec[drec].value_name = boundname;
01179 
01180   scheme_rec_add_certs(erec, drec, form);
01181 
01182   fn = SCHEME_STX_CAR(form);
01183   return scheme_datum_to_syntax(cons(fn,
01184                                   cons(var,
01185                                        cons(scheme_expand_expr(val, env, erec, drec), 
01186                                             scheme_null))),
01187                             form,
01188                             form,
01189                             0, 2);
01190 }
01191 
01192 /**********************************************************************/
01193 /*                               quote                                */
01194 /**********************************************************************/
01195 
01196 static Scheme_Object *
01197 quote_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
01198 {
01199   Scheme_Object *v, *rest;
01200 
01201   rest = SCHEME_STX_CDR(form);
01202   if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))))
01203     scheme_wrong_syntax(NULL, NULL, form, "bad syntax (wrong number of parts)");
01204 
01205   scheme_compile_rec_done_local(rec, drec);
01206   scheme_default_compile_rec(rec, drec);
01207   
01208   v = SCHEME_STX_CAR(rest);
01209 
01210   if (SCHEME_STXP(v))
01211     return scheme_syntax_to_datum(v, 0, NULL);
01212   else
01213     return v;
01214 }
01215 
01216 static Scheme_Object *
01217 quote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
01218 {
01219   Scheme_Object *rest;
01220 
01221   SCHEME_EXPAND_OBSERVE_PRIM_QUOTE(erec[drec].observer);
01222 
01223   rest = SCHEME_STX_CDR(form);
01224 
01225   if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))))
01226     scheme_wrong_syntax(NULL, NULL, form, "bad syntax (wrong number of parts)");
01227 
01228   return form;
01229 }
01230 
01231 /**********************************************************************/
01232 /*                                if                                  */
01233 /**********************************************************************/
01234 
01235 static void check_if_len(Scheme_Object *form, int len)
01236 {
01237   if (len != 4) {
01238     if (len == 3) {
01239       scheme_wrong_syntax(NULL, NULL, form, 
01240                           "bad syntax (must have an \"else\" expression)");
01241     } else {
01242       bad_form(form, len);
01243     }
01244   }
01245 }
01246 
01247 static Scheme_Object *
01248 if_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
01249 {
01250   int len, opt;
01251   Scheme_Object *test, *thenp, *elsep, *name, *rest;
01252   Scheme_Compile_Info recs[3];
01253 
01254   len = check_form(form, form);
01255   check_if_len(form, len);
01256 
01257   name = rec[drec].value_name;
01258   scheme_compile_rec_done_local(rec, drec);
01259 
01260   name = scheme_check_name_property(form, name);
01261 
01262   rest = SCHEME_STX_CDR(form);
01263   test = SCHEME_STX_CAR(rest);
01264   rest = SCHEME_STX_CDR(rest);
01265   thenp = SCHEME_STX_CAR(rest);
01266   if (len == 4) {
01267     rest = SCHEME_STX_CDR(rest);
01268     elsep = SCHEME_STX_CAR(rest);
01269   } else
01270     elsep = scheme_compiled_void();
01271 
01272   scheme_rec_add_certs(rec, drec, form);
01273 
01274   scheme_init_compile_recs(rec, drec, recs, 3);
01275   recs[1].value_name = name;
01276   recs[2].value_name = name;
01277 
01278   env = scheme_no_defines(env);
01279 
01280   test = scheme_compile_expr(test, env, recs, 0);
01281 
01282   if (SCHEME_TYPE(test) > _scheme_compiled_values_types_) {
01283     opt = 1;
01284     
01285     if (SCHEME_FALSEP(test)) {
01286       /* compile other branch only to get syntax checking: */
01287       recs[2].dont_mark_local_use = 1;
01288       scheme_compile_expr(thenp, env, recs, 2);
01289 
01290       if (len == 4)
01291        test = scheme_compile_expr(elsep, env, recs, 1);
01292       else
01293        test = elsep;
01294     } else {
01295       if (len == 4) {
01296        /* compile other branch only to get syntax checking: */
01297        recs[2].dont_mark_local_use = 1;
01298        scheme_compile_expr(elsep, env, recs, 2);
01299       }
01300       
01301       test = scheme_compile_expr(thenp, env, recs, 1);
01302     }
01303   } else {
01304     opt = 0;
01305     thenp = scheme_compile_expr(thenp, env, recs, 1);
01306     if (len == 4)
01307       elsep = scheme_compile_expr(elsep, env, recs, 2);
01308   }
01309 
01310   scheme_merge_compile_recs(rec, drec, recs, (opt || (len == 3)) ? 2 : 3);
01311   
01312   if (opt)
01313     return test;
01314   else
01315     return scheme_make_branch(test, thenp, elsep);
01316 }
01317 
01318 static Scheme_Object *
01319 if_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
01320 {
01321   Scheme_Object *test, *rest, *thenp, *elsep, *fn, *boundname;
01322   int len;
01323   Scheme_Expand_Info recs[3];
01324 
01325   SCHEME_EXPAND_OBSERVE_PRIM_IF(erec[drec].observer);
01326 
01327   len = check_form(form, form);
01328 
01329   check_if_len(form, len);
01330 
01331   if (len == 3) {
01332     SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer);
01333   }
01334 
01335   env = scheme_no_defines(env);
01336 
01337   boundname = scheme_check_name_property(form, erec[drec].value_name);
01338 
01339   scheme_rec_add_certs(erec, drec, form);  
01340 
01341   scheme_init_expand_recs(erec, drec, recs, 3);
01342   recs[0].value_name = scheme_false;
01343   recs[1].value_name = boundname;
01344   recs[2].value_name = boundname;
01345 
01346   rest = SCHEME_STX_CDR(form);
01347   test = SCHEME_STX_CAR(rest);
01348   test = scheme_expand_expr(test, env, recs, 0);
01349 
01350   SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
01351   rest = SCHEME_STX_CDR(rest);
01352   thenp = SCHEME_STX_CAR(rest);
01353   thenp = scheme_expand_expr(thenp, env, recs, 1);
01354 
01355   rest = SCHEME_STX_CDR(rest);
01356   if (!SCHEME_STX_NULLP(rest)) {
01357     SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
01358     elsep = SCHEME_STX_CAR(rest);
01359     elsep = scheme_expand_expr(elsep, env, recs, 2);
01360     rest = cons(elsep, scheme_null);
01361   } else {
01362     rest = scheme_null;
01363   }
01364 
01365   rest = cons(thenp, rest);
01366 
01367   fn = SCHEME_STX_CAR(form);
01368   return scheme_datum_to_syntax(cons(fn, cons(test, rest)),
01369                             form, form, 
01370                             0, 2);
01371 }
01372 
01373 /**********************************************************************/
01374 /*                    with-continuation-mark                          */
01375 /**********************************************************************/
01376 
01377 static Scheme_Object *
01378 with_cont_mark_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
01379 {
01380   Scheme_Object *key, *val, *expr, *name, *orig_form = form;
01381   Scheme_Compile_Info recs[3];
01382   Scheme_With_Continuation_Mark *wcm;
01383   int len;
01384   len = check_form(form, form);
01385 
01386   if (len != 4)
01387     bad_form(form, len);
01388 
01389   env = scheme_no_defines(env);
01390 
01391   form = SCHEME_STX_CDR(form);
01392   key = SCHEME_STX_CAR(form);
01393   form = SCHEME_STX_CDR(form);
01394   val = SCHEME_STX_CAR(form);
01395   form = SCHEME_STX_CDR(form);
01396   expr = SCHEME_STX_CAR(form);
01397 
01398   name = rec[drec].value_name;
01399   scheme_compile_rec_done_local(rec, drec);
01400 
01401   name = scheme_check_name_property(orig_form, name);
01402 
01403   scheme_rec_add_certs(rec, drec, orig_form);
01404 
01405   scheme_init_compile_recs(rec, drec, recs, 3);
01406   recs[2].value_name = name;
01407 
01408   key = scheme_compile_expr(key, env, recs, 0);
01409   val = scheme_compile_expr(val, env, recs, 1);
01410   expr = scheme_compile_expr(expr, env, recs, 2);
01411 
01412   scheme_merge_compile_recs(rec, drec, recs, 3);
01413 
01414   wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
01415   wcm->so.type = scheme_with_cont_mark_type;
01416   wcm->key = key;
01417   wcm->val = val;
01418   wcm->body = expr;
01419   
01420   return (Scheme_Object *)wcm;
01421 }
01422 
01423 static Scheme_Object *
01424 with_cont_mark_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
01425 {
01426   Scheme_Object *key, *val, *expr, *orig_form = form, *fn, *boundname;
01427   int len;
01428   Scheme_Expand_Info recs[3];
01429 
01430   SCHEME_EXPAND_OBSERVE_PRIM_WCM(erec[drec].observer);
01431 
01432   len = check_form(form, form);
01433   if (len != 4)
01434     bad_form(form, len);
01435 
01436   env = scheme_no_defines(env);
01437 
01438   boundname = scheme_check_name_property(form, erec[drec].value_name);
01439 
01440   scheme_rec_add_certs(erec, drec, form);
01441 
01442   scheme_init_expand_recs(erec, drec, recs, 3);
01443   recs[0].value_name = scheme_false;
01444   recs[1].value_name = scheme_false;
01445   recs[2].value_name = boundname;
01446 
01447   form = SCHEME_STX_CDR(form);
01448   key = SCHEME_STX_CAR(form);
01449   form = SCHEME_STX_CDR(form);
01450   val = SCHEME_STX_CAR(form);
01451   form = SCHEME_STX_CDR(form);
01452   expr = SCHEME_STX_CAR(form);
01453 
01454   key = scheme_expand_expr(key, env, recs, 0);
01455   SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
01456   val = scheme_expand_expr(val, env, recs, 1);
01457   SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
01458   expr = scheme_expand_expr(expr, env, recs, 2);
01459 
01460   fn = SCHEME_STX_CAR(orig_form);
01461   return scheme_datum_to_syntax(cons(fn,
01462                                   cons(key,
01463                                        cons(val,
01464                                             cons(expr, scheme_null)))),
01465                             orig_form,
01466                             orig_form, 
01467                             0, 2);
01468 }
01469 
01470 /**********************************************************************/
01471 /*                               set!                                 */
01472 /**********************************************************************/
01473 
01474 static Scheme_Object *
01475 set_execute (Scheme_Object *data)
01476 {
01477   Scheme_Object *val, *set_undef, *tl, **toplevels;
01478   Scheme_Bucket *var;
01479 
01480   set_undef = SCHEME_CAR(data);
01481   data = SCHEME_CDR(data);
01482   
01483   val = SCHEME_CDR(data);
01484   val = _scheme_eval_linked_expr(val);
01485 
01486   tl = SCHEME_CAR(data);
01487   toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)];
01488   var = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(tl)];
01489   
01490   scheme_set_global_bucket("set!", var, val, SCHEME_TRUEP(set_undef));
01491 
01492   return scheme_void;
01493 }
01494 
01495 static Scheme_Object *set_jit(Scheme_Object *data)
01496 {
01497   Scheme_Object *orig_val, *naya_val;
01498 
01499   orig_val = SCHEME_CDR(data);
01500   orig_val = SCHEME_CDR(orig_val);
01501 
01502   naya_val = scheme_jit_expr(orig_val);
01503   
01504   if (SAME_OBJ(naya_val, orig_val))
01505     return data;
01506   else
01507     return scheme_make_pair(SCHEME_CAR(data),
01508                          scheme_make_pair(SCHEME_CADR(data),
01509                                         naya_val));
01510 }
01511 
01512 static void set_validate(Scheme_Object *data, Mz_CPort *port, 
01513                       char *stack, Validate_TLS tls,
01514                          int depth, int letlimit, int delta, 
01515                          int num_toplevels, int num_stxes, int num_lifts,
01516                          struct Validate_Clearing *vc, int tailpos)
01517 {
01518   Scheme_Object *val, *tl;
01519 
01520   if (!SCHEME_PAIRP(data)
01521       || !SCHEME_PAIRP(SCHEME_CDR(data)))
01522     scheme_ill_formed_code(port);
01523   
01524   data = SCHEME_CDR(data);
01525   tl = SCHEME_CAR(data);
01526   val = SCHEME_CDR(data);
01527 
01528   scheme_validate_expr(port, val, stack, tls, depth, letlimit, delta, 
01529                        num_toplevels, num_stxes, num_lifts,
01530                        NULL, 0, 0, vc, 0);
01531   scheme_validate_toplevel(tl, port, stack, tls, depth, delta, 
01532                            num_toplevels, num_stxes, num_lifts,
01533                            0);
01534 }
01535 
01536 static Scheme_Object *
01537 set_optimize(Scheme_Object *data, Optimize_Info *info)
01538 {
01539   Scheme_Object *var, *val, *set_undef;
01540 
01541   set_undef = SCHEME_CAR(data);
01542   data = SCHEME_CDR(data);
01543   var = SCHEME_CAR(data);
01544   val = SCHEME_CDR(data);
01545   
01546   val = scheme_optimize_expr(val, info);
01547 
01548   info->preserves_marks = 1;
01549   info->single_result = 1;
01550 
01551   if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) {
01552     int pos, delta;
01553 
01554     pos = SCHEME_LOCAL_POS(var);
01555 
01556     /* Register that we use this variable: */
01557     scheme_optimize_info_lookup(info, pos, NULL, NULL);
01558 
01559     /* Offset: */
01560     delta = scheme_optimize_info_get_shift(info, pos);
01561     if (delta)
01562       var = scheme_make_local(scheme_local_type, pos + delta, 0);
01563   } else {
01564     scheme_optimize_info_used_top(info);
01565   }
01566   
01567   return scheme_make_syntax_compiled(SET_EXPD, cons(set_undef, cons(var, val)));
01568 }
01569 
01570 static Scheme_Object *
01571 set_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
01572 {
01573   Scheme_Object *var, *val, *set_undef;
01574 
01575   set_undef = SCHEME_CAR(data);
01576   data = SCHEME_CDR(data);
01577   var = SCHEME_CAR(data);
01578   val = SCHEME_CDR(data);
01579   
01580   val = scheme_optimize_clone(dup_ok, val, info, delta, closure_depth);
01581   if (!val) return NULL;
01582   if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) {
01583     var = scheme_optimize_clone(dup_ok, var, info, delta, closure_depth);
01584     if (!var) return NULL;
01585   }
01586   
01587   return scheme_make_syntax_compiled(SET_EXPD, cons(set_undef, cons(var, val)));  
01588 }
01589 
01590 static Scheme_Object *set_shift(Scheme_Object *data, int delta, int after_depth)
01591 {
01592   Scheme_Object *l, *e;
01593 
01594   l = SCHEME_CDR(data);
01595 
01596   e = scheme_optimize_shift(SCHEME_CAR(l), delta, after_depth);
01597   SCHEME_CAR(l) = e;
01598 
01599   e = scheme_optimize_shift(SCHEME_CDR(l), delta, after_depth);
01600   SCHEME_CDR(l) = e;
01601 
01602   return scheme_make_syntax_compiled(SET_EXPD, data);
01603 }
01604 
01605 static Scheme_Object *
01606 set_resolve(Scheme_Object *data, Resolve_Info *rslv)
01607 {
01608   Scheme_Object *var, *val, *set_undef;
01609 
01610   set_undef = SCHEME_CAR(data);
01611   data = SCHEME_CDR(data);
01612   var = SCHEME_CAR(data);
01613   val = SCHEME_CDR(data);
01614   
01615   val = scheme_resolve_expr(val, rslv);
01616 
01617   if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) {
01618     Scheme_Let_Value *lv;
01619     Scheme_Object *cv;
01620     int flags, li;
01621 
01622     cv = scheme_compiled_void();
01623 
01624     lv = MALLOC_ONE_TAGGED(Scheme_Let_Value);
01625     lv->iso.so.type = scheme_let_value_type;
01626     lv->body = cv;
01627     lv->count = 1;
01628     li = scheme_resolve_info_lookup(rslv, SCHEME_LOCAL_POS(var), &flags, NULL, 0);
01629     lv->position = li;
01630     SCHEME_LET_AUTOBOX(lv) = (flags & SCHEME_INFO_BOXED);
01631     lv->value = val;
01632 
01633     if (!(flags & SCHEME_INFO_BOXED))
01634       scheme_signal_error("internal error: set!: set!ed local variable is not boxed");
01635 
01636     return (Scheme_Object *)lv;
01637   }
01638 
01639   var = scheme_resolve_expr(var, rslv);
01640   
01641   return scheme_make_syntax_resolved(SET_EXPD, cons(set_undef, cons(var, val)));
01642 }
01643 
01644 static Scheme_Object *
01645 set_sfs(Scheme_Object *orig_data, SFS_Info *info)
01646 {
01647   Scheme_Object *data, *var, *val;
01648 
01649   data = SCHEME_CDR(orig_data);
01650   var = SCHEME_CAR(data);
01651   val = SCHEME_CDR(data);
01652   
01653   scheme_sfs_start_sequence(info, 2, 0);
01654 
01655   val = scheme_sfs_expr(val, info, -1);
01656   var = scheme_sfs_expr(var, info, -1);
01657 
01658   SCHEME_CAR(data) = var;
01659   SCHEME_CDR(data) = val;
01660 
01661   return orig_data;
01662 }
01663 
01664 static Scheme_Object *
01665 set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
01666 {
01667   Scheme_Env *menv = NULL;
01668   Scheme_Object *var, *val, *name, *body, *rest, *find_name;
01669   int l, set_undef;
01670 
01671   l = check_form(form, form);
01672   if (l != 3)
01673     bad_form(form, l);
01674 
01675   rest = SCHEME_STX_CDR(form);
01676   name = SCHEME_STX_CAR(rest);
01677   rest = SCHEME_STX_CDR(rest);
01678   body = SCHEME_STX_CAR(rest);
01679   
01680   scheme_check_identifier("set!", name, NULL, env, form);
01681 
01682   find_name = name;
01683 
01684   scheme_rec_add_certs(rec, drec, form);
01685 
01686   while (1) {
01687     var = scheme_lookup_binding(find_name, env, 
01688                             SCHEME_SETTING 
01689                             + SCHEME_GLOB_ALWAYS_REFERENCE
01690                             + (rec[drec].dont_mark_local_use 
01691                                ? SCHEME_DONT_MARK_USE 
01692                                : 0)
01693                             + (rec[drec].resolve_module_ids
01694                                ? SCHEME_RESOLVE_MODIDS
01695                                : 0),
01696                             rec[drec].certs, env->in_modidx, 
01697                             &menv, NULL, NULL);
01698     
01699     if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) {
01700       /* Redirect to a macro? */
01701       if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) {
01702        form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, rec, drec, 1);
01703        
01704        return scheme_compile_expr(form, env, rec, drec);
01705       } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
01706        find_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
01707        find_name = scheme_stx_cert(find_name, scheme_false, menv, find_name, NULL, 1);
01708        SCHEME_USE_FUEL(1);
01709        menv = NULL;
01710       } else
01711        break;
01712     } else
01713       break;
01714   }
01715 
01716   if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
01717       || SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) {
01718     scheme_wrong_syntax(NULL, name, form, "cannot mutate syntax identifier");
01719     return NULL;
01720   }
01721 
01722   if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
01723       || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) {
01724     var = scheme_register_toplevel_in_prefix(var, env, rec, drec);
01725     if (env->genv->module)
01726       SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED;
01727   }
01728 
01729   scheme_compile_rec_done_local(rec, drec);
01730   rec[drec].value_name = SCHEME_STX_SYM(name);
01731 
01732   val = scheme_compile_expr(body, scheme_no_defines(env), rec, drec);
01733 
01734   /* check for (set! x x) */
01735   if (SAME_TYPE(SCHEME_TYPE(var), SCHEME_TYPE(val))) {
01736     if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)
01737        || SAME_TYPE(SCHEME_TYPE(var), scheme_local_unbox_type)) {
01738       /* local */
01739       if (SCHEME_LOCAL_POS(var) == SCHEME_LOCAL_POS(val))
01740        return scheme_compiled_void();
01741     } else {
01742       /* global; can't do anything b/c var might be undefined or constant */
01743     }
01744   }
01745   
01746   set_undef = (rec[drec].comp_flags & COMP_ALLOW_SET_UNDEFINED);
01747   
01748   return scheme_make_syntax_compiled(SET_EXPD, 
01749                                  cons(set_undef
01750                                      ? scheme_true
01751                                      : scheme_false,
01752                                      cons(var, val)));
01753 }
01754 
01755 static Scheme_Object *
01756 set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
01757 {
01758   Scheme_Env *menv = NULL;
01759   Scheme_Object *name, *var, *fn, *rhs, *find_name, *lexical_binding_id;
01760   int l;
01761 
01762   SCHEME_EXPAND_OBSERVE_PRIM_SET(erec[drec].observer);
01763 
01764   l = check_form(form, form);
01765   if (l != 3)
01766     bad_form(form, l);
01767 
01768   env = scheme_no_defines(env);
01769 
01770   name = SCHEME_STX_CDR(form);
01771   name = SCHEME_STX_CAR(name);
01772 
01773   scheme_check_identifier("set!", name, NULL, env, form);
01774 
01775   find_name = name;
01776 
01777   scheme_rec_add_certs(erec, drec, form);
01778 
01779   while (1) {
01780     /* Make sure it's mutable, and check for redirects: */
01781     lexical_binding_id = NULL;
01782     var = scheme_lookup_binding(find_name, env, SCHEME_SETTING, 
01783                             erec[drec].certs, env->in_modidx, 
01784                             &menv, NULL, &lexical_binding_id);
01785 
01786     SCHEME_EXPAND_OBSERVE_RESOLVE(erec[drec].observer, find_name);
01787 
01788     if ((erec[drec].depth != 0) && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) {
01789       /* Redirect to a macro? */
01790       if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) {
01791 
01792        SCHEME_EXPAND_OBSERVE_ENTER_MACRO(erec[drec].observer, form);
01793 
01794        form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, erec, drec, 1);
01795 
01796        SCHEME_EXPAND_OBSERVE_EXIT_MACRO(erec[drec].observer, form);
01797 
01798        if (erec[drec].depth > 0)
01799          erec[drec].depth--;
01800 
01801        erec[drec].value_name = name;
01802 
01803        return scheme_expand_expr(form, env, erec, drec);
01804       } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
01805        Scheme_Object *new_name;
01806        new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
01807        new_name = scheme_stx_track(new_name, find_name, find_name);
01808        new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
01809        find_name = new_name;
01810        menv = NULL;
01811       } else
01812         break;
01813     } else {
01814       if (lexical_binding_id) {
01815         find_name = lexical_binding_id;
01816       }
01817       break;
01818     }
01819   }
01820 
01821   if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
01822       || SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) {
01823     scheme_wrong_syntax(NULL, name, form, "cannot mutate syntax identifier");
01824   }
01825 
01826   SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
01827 
01828 
01829   fn = SCHEME_STX_CAR(form);
01830   rhs = SCHEME_STX_CDR(form);
01831   rhs = SCHEME_STX_CDR(rhs);
01832   rhs = SCHEME_STX_CAR(rhs);
01833 
01834   erec[drec].value_name = name;
01835 
01836   rhs = scheme_expand_expr(rhs, env, erec, drec);
01837 
01838   return scheme_datum_to_syntax(cons(fn,
01839                                   cons(find_name,
01840                                        cons(rhs, scheme_null))),
01841                             form,
01842                             form, 
01843                             0, 2);
01844 }
01845 
01846 /**********************************************************************/
01847 /*                     #%variable-reference                           */
01848 /**********************************************************************/
01849 
01850 static Scheme_Object *
01851 ref_execute (Scheme_Object *tl)
01852 {
01853   Scheme_Object **toplevels, *o;
01854   Scheme_Bucket *var;
01855 
01856   toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)];
01857   var = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(tl)];
01858   
01859   o = scheme_alloc_small_object();
01860   o->type = scheme_global_ref_type;
01861   SCHEME_PTR_VAL(o) = (Scheme_Object *)var;
01862 
01863   return o;
01864 }
01865 
01866 static Scheme_Object *ref_jit(Scheme_Object *data)
01867 {
01868   return data;
01869 }
01870 
01871 static void ref_validate(Scheme_Object *tl, Mz_CPort *port, 
01872                       char *stack, Validate_TLS tls,
01873                          int depth, int letlimit, int delta, 
01874                          int num_toplevels, int num_stxes, int num_lifts,
01875                          struct Validate_Clearing *vc, int tailpos)
01876 {
01877   scheme_validate_toplevel(tl,  port, stack, tls, depth, delta, 
01878                            num_toplevels, num_stxes, num_lifts,
01879                            0);
01880 }
01881 
01882 static Scheme_Object *
01883 ref_optimize(Scheme_Object *tl, Optimize_Info *info)
01884 {
01885   scheme_optimize_info_used_top(info);  
01886 
01887   info->preserves_marks = 1;
01888   info->single_result = 1;
01889 
01890   return scheme_make_syntax_compiled(REF_EXPD, tl);
01891 }
01892 
01893 static Scheme_Object *
01894 ref_shift(Scheme_Object *data, int delta, int after_depth)
01895 {
01896   return scheme_make_syntax_compiled(REF_EXPD, 
01897                                      scheme_optimize_shift(data, delta, after_depth));
01898 }
01899 
01900 static Scheme_Object *
01901 ref_resolve(Scheme_Object *tl, Resolve_Info *rslv)
01902 {
01903   return scheme_make_syntax_resolved(REF_EXPD, scheme_resolve_expr(tl, rslv));
01904 }
01905 
01906 static Scheme_Object *
01907 ref_sfs(Scheme_Object *tl, SFS_Info *info)
01908 {
01909   Scheme_Object *naya;
01910   scheme_sfs_start_sequence(info, 1, 0);
01911   naya = scheme_sfs_expr(tl, info, -1);
01912   if (SAME_OBJ(naya, tl))
01913     return tl;
01914   else
01915     return scheme_make_syntax_resolved(REF_EXPD, naya);
01916 }
01917 
01918 static Scheme_Object *
01919 ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
01920 {
01921   Scheme_Env *menv = NULL;
01922   Scheme_Object *var, *name, *rest;
01923   int l, ok;
01924 
01925   l = check_form(form, form);
01926 
01927   if (l == 1) {
01928     if (rec[drec].comp)
01929       var = scheme_make_environment_dummy(env);
01930     else
01931       var = scheme_void;
01932   } else {
01933     if (l != 2)
01934       bad_form(form, l);
01935 
01936     rest = SCHEME_STX_CDR(form);
01937     name = SCHEME_STX_CAR(rest);
01938 
01939     if (SCHEME_STX_PAIRP(name)) {
01940       rest = SCHEME_STX_CAR(name);
01941       if (env->genv->phase == 0) {
01942         var = scheme_top_stx;
01943       } else {
01944         var = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_top_stx), scheme_false, scheme_sys_wraps(env), 0, 0);
01945       }
01946       ok = scheme_stx_module_eq(rest, var, env->genv->phase);
01947     } else 
01948       ok = SCHEME_STX_SYMBOLP(name);
01949 
01950     if (!ok) {
01951       scheme_wrong_syntax("#%variable-reference", name, 
01952                           form, 
01953                           "not an identifier or #%%top form");
01954       return NULL;
01955     }
01956 
01957     if (SCHEME_STX_PAIRP(name)) {
01958       /* FIXME: when using #%top, need to set mutated flag */
01959       if (rec[drec].comp)
01960         var = scheme_compile_expr(name, env, rec, drec);
01961       else
01962         var = scheme_expand_expr(name, env, rec, drec);
01963     } else {
01964       scheme_rec_add_certs(rec, drec, form);
01965 
01966       var = scheme_lookup_binding(name, env, 
01967                                   SCHEME_REFERENCING 
01968                                   + SCHEME_GLOB_ALWAYS_REFERENCE
01969                                   + (rec[drec].dont_mark_local_use 
01970                                      ? SCHEME_DONT_MARK_USE 
01971                                      : 0)
01972                                   + (rec[drec].resolve_module_ids
01973                                      ? SCHEME_RESOLVE_MODIDS
01974                                      : 0),
01975                                   rec[drec].certs, env->in_modidx, 
01976                                   &menv, NULL, NULL);
01977 
01978       if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
01979           || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) {
01980         int imported = 0;
01981         /* It must be in the module being compiled/expanded. */
01982         if (env->genv->module) {
01983           if (SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) {
01984             if (!SAME_OBJ(((Module_Variable *)var)->modidx, env->genv->module->self_modidx))
01985               imported = 1;
01986           } else
01987             imported = 1;
01988         } else {
01989           if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)) {
01990             if (!SAME_OBJ(((Scheme_Bucket_With_Home *)var)->home, env->genv))
01991               imported = 1;
01992           } else
01993             imported = 1;
01994         }
01995 
01996         if (rec[drec].comp) {
01997           var = scheme_register_toplevel_in_prefix(var, env, rec, drec);
01998           if (!imported && env->genv->module)
01999             SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED;
02000         }
02001       } else {
02002         scheme_wrong_syntax(NULL, name, form, "identifier does not refer to a top-level or module variable");
02003       }
02004 
02005       if (rec[drec].comp)
02006         scheme_compile_rec_done_local(rec, drec);
02007     }
02008   }
02009 
02010   if (rec[drec].comp)
02011     return scheme_make_syntax_compiled(REF_EXPD, var);
02012   else
02013     return scheme_void;
02014 }
02015 
02016 static Scheme_Object *
02017 ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
02018 {
02019   SCHEME_EXPAND_OBSERVE_PRIM_VARREF(erec[drec].observer);
02020 
02021   /* Error checking: */
02022   ref_syntax(form, env, erec, drec);
02023 
02024   /* No change: */
02025   return form;
02026 }
02027 
02028 /**********************************************************************/
02029 /*                          apply-values                              */
02030 /**********************************************************************/
02031 
02032 static Scheme_Object *apply_values_execute(Scheme_Object *data)
02033 {
02034   Scheme_Object *f, *v;
02035   
02036   f = SCHEME_CAR(data);
02037 
02038   f = _scheme_eval_linked_expr(f);
02039   if (!SCHEME_PROCP(f)) {
02040     Scheme_Object *a[1];
02041     a[0] = f;
02042     scheme_wrong_type("call-with-values", "procedure", -1, 1, a);    
02043     return NULL;
02044   }
02045 
02046   v = _scheme_eval_linked_expr_multi(SCHEME_CDR(data));
02047   if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
02048     Scheme_Thread *p = scheme_current_thread;
02049     int num_rands = p->ku.multiple.count;
02050 
02051     if (num_rands > p->tail_buffer_size) {
02052       /* scheme_tail_apply will allocate */
02053       if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
02054         p->values_buffer = NULL;
02055     }
02056     return scheme_tail_apply(f, num_rands, p->ku.multiple.array);
02057   } else {
02058     Scheme_Object *a[1];
02059     a[0] = v;
02060     return scheme_tail_apply(f, 1, a);
02061   }
02062 }
02063 
02064 static Scheme_Object *apply_values_jit(Scheme_Object *data)
02065 {
02066   Scheme_Object *f, *e;
02067 
02068   f = scheme_jit_expr(SCHEME_CAR(data));
02069   e = scheme_jit_expr(SCHEME_CDR(data));
02070   
02071   if (SAME_OBJ(f, SCHEME_CAR(data))
02072       && SAME_OBJ(e, SCHEME_CAR(data)))
02073     return data;
02074   else
02075     return scheme_make_pair(f, e);
02076 }
02077 
02078 static Scheme_Object *
02079 apply_values_optimize(Scheme_Object *data, Optimize_Info *info)
02080 {
02081   Scheme_Object *f, *e;
02082 
02083   f = SCHEME_CAR(data);
02084   e = SCHEME_CDR(data);
02085   
02086   f = scheme_optimize_expr(f, info);
02087   e = scheme_optimize_expr(e, info);
02088 
02089   return scheme_optimize_apply_values(f, e, info, info->single_result);
02090 }
02091 
02092 static Scheme_Object *
02093 apply_values_resolve(Scheme_Object *data, Resolve_Info *rslv)
02094 {
02095   Scheme_Object *f, *e;
02096 
02097   f = SCHEME_CAR(data);
02098   e = SCHEME_CDR(data);
02099 
02100   f = scheme_resolve_expr(f, rslv);
02101   e = scheme_resolve_expr(e, rslv);
02102   
02103   return scheme_make_syntax_resolved(APPVALS_EXPD, cons(f, e));
02104 }
02105 
02106 static Scheme_Object *
02107 apply_values_sfs(Scheme_Object *data, SFS_Info *info)
02108 {
02109   Scheme_Object *f, *e;
02110 
02111   f = SCHEME_CAR(data);
02112   e = SCHEME_CDR(data);
02113 
02114   scheme_sfs_start_sequence(info, 2, 0);
02115 
02116   f = scheme_sfs_expr(f, info, -1);
02117   e = scheme_sfs_expr(e, info, -1);
02118 
02119   SCHEME_CAR(data) = f;
02120   SCHEME_CDR(data) = e;
02121 
02122   return data;
02123 }
02124 
02125 static Scheme_Object *
02126 apply_values_shift(Scheme_Object *data, int delta, int after_depth)
02127 {
02128   Scheme_Object *e;
02129 
02130   e = scheme_optimize_shift(SCHEME_CAR(data), delta, after_depth);
02131   SCHEME_CAR(data) = e;
02132 
02133   e = scheme_optimize_shift(SCHEME_CDR(data), delta, after_depth);
02134   SCHEME_CAR(data) = e;
02135 
02136   return scheme_make_syntax_compiled(APPVALS_EXPD, data);
02137 }
02138 
02139 static Scheme_Object *
02140 apply_values_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
02141 {
02142   Scheme_Object *f, *e;
02143 
02144   f = SCHEME_CAR(data);
02145   e = SCHEME_CDR(data);
02146   
02147   f = scheme_optimize_clone(dup_ok, f, info, delta, closure_depth);
02148   if (!f) return NULL;
02149   e = scheme_optimize_clone(dup_ok, e, info, delta, closure_depth);
02150   if (!e) return NULL;  
02151   
02152   return scheme_make_syntax_compiled(APPVALS_EXPD, cons(f, e));
02153 }
02154 
02155 static void apply_values_validate(Scheme_Object *data, Mz_CPort *port, 
02156                                   char *stack, Validate_TLS tls,
02157                                   int depth, int letlimit, int delta, 
02158                                   int num_toplevels, int num_stxes, int num_lifts,
02159                                   struct Validate_Clearing *vc, int tailpos)
02160 {
02161   Scheme_Object *f, *e;
02162 
02163   f = SCHEME_CAR(data);
02164   e = SCHEME_CDR(data);
02165 
02166   scheme_validate_expr(port, f, stack, tls,
02167                        depth, letlimit, delta, 
02168                        num_toplevels, num_stxes, num_lifts,
02169                        NULL, 0, 0, vc, 0);
02170   scheme_validate_expr(port, e, stack, tls,
02171                        depth, letlimit, delta, 
02172                        num_toplevels, num_stxes, num_lifts,
02173                        NULL, 0, 0, vc, 0);
02174 }
02175 
02176 /**********************************************************************/
02177 /*                             case-lambda                            */
02178 /**********************************************************************/
02179 
02180 static Scheme_Object *
02181 case_lambda_execute(Scheme_Object *expr)
02182 {
02183   Scheme_Case_Lambda *seqin, *seqout;
02184   int i, cnt;
02185   Scheme_Thread *p = scheme_current_thread;
02186 
02187   seqin = (Scheme_Case_Lambda *)expr;
02188 
02189 #ifdef MZ_USE_JIT
02190   if (seqin->native_code) {
02191     Scheme_Native_Closure_Data *ndata;
02192     Scheme_Native_Closure *nc, *na;
02193     Scheme_Closure_Data *data;
02194     Scheme_Object *val;
02195     GC_CAN_IGNORE Scheme_Object **runstack;
02196     GC_CAN_IGNORE mzshort *map;
02197     int j, jcnt;
02198 
02199     ndata = seqin->native_code;
02200     nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata);
02201 
02202     cnt = seqin->count;
02203     for (i = 0; i < cnt; i++) {
02204       val = seqin->array[i];
02205       if (!SCHEME_PROCP(val)) {
02206        data = (Scheme_Closure_Data *)val;
02207        na = (Scheme_Native_Closure *)scheme_make_native_closure(data->u.native_code);
02208        runstack = MZ_RUNSTACK;
02209        jcnt = data->closure_size;
02210        map = data->closure_map;
02211        for (j = 0; j < jcnt; j++) {
02212          na->vals[j] = runstack[map[j]];
02213        }
02214        val = (Scheme_Object *)na;
02215       }
02216       nc->vals[i] = val;
02217     }
02218 
02219     return (Scheme_Object *)nc;
02220   }
02221 #endif
02222 
02223   seqout = (Scheme_Case_Lambda *)
02224     scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
02225                       + (seqin->count - 1) * sizeof(Scheme_Object *));
02226   seqout->so.type = scheme_case_closure_type;
02227   seqout->count = seqin->count;
02228   seqout->name = seqin->name;
02229 
02230   cnt = seqin->count;
02231   for (i = 0; i < cnt; i++) {
02232     if (SAME_TYPE(SCHEME_TYPE(seqin->array[i]), scheme_closure_type)) {
02233       /* An empty closure, created at compile time */
02234       seqout->array[i] = seqin->array[i];
02235     } else {
02236       Scheme_Object *lc;
02237       lc = scheme_make_closure(p, seqin->array[i], 1);
02238       seqout->array[i] = lc;
02239     }
02240   }
02241 
02242   return (Scheme_Object *)seqout;
02243 }
02244 
02245 static Scheme_Object *case_lambda_jit(Scheme_Object *expr)
02246 {
02247 #ifdef MZ_USE_JIT
02248   Scheme_Case_Lambda *seqin = (Scheme_Case_Lambda *)expr;
02249 
02250   if (!seqin->native_code) {
02251     Scheme_Case_Lambda *seqout;
02252     Scheme_Native_Closure_Data *ndata;
02253     Scheme_Object *val, *name;
02254     int i, cnt, size, all_closed = 1;
02255 
02256     cnt = seqin->count;
02257     
02258     size = sizeof(Scheme_Case_Lambda) + ((cnt - 1) * sizeof(Scheme_Object *));
02259 
02260     seqout = (Scheme_Case_Lambda *)scheme_malloc_tagged(size);
02261     memcpy(seqout, seqin, size);
02262 
02263     name = seqin->name;
02264     if (name && SCHEME_BOXP(name))
02265       name = SCHEME_BOX_VAL(name);
02266 
02267     for (i = 0; i < cnt; i++) {
02268       val = seqout->array[i];
02269       if (SCHEME_PROCP(val)) {
02270        /* Undo creation of empty closure */
02271        val = (Scheme_Object *)((Scheme_Closure *)val)->code;
02272        seqout->array[i] = val;
02273       }
02274       ((Scheme_Closure_Data *)val)->name = name;
02275       if (((Scheme_Closure_Data *)val)->closure_size)
02276        all_closed = 0;
02277     }
02278 
02279     /* Generating the code may cause empty closures to be formed: */
02280     ndata = scheme_generate_case_lambda(seqout);
02281     seqout->native_code = ndata;
02282 
02283     if (all_closed) {
02284       /* Native closures do not refer back to the original bytecode,
02285         so no need to worry about clearing the reference. */
02286       Scheme_Native_Closure *nc;
02287       nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata);
02288       for (i = 0; i < cnt; i++) {
02289        val = seqout->array[i];
02290        if (!SCHEME_PROCP(val)) {
02291          val = scheme_make_native_closure(((Scheme_Closure_Data *)val)->u.native_code);
02292        }
02293        nc->vals[i] = val;
02294       }
02295       return (Scheme_Object *)nc;
02296     } else {
02297       /* The case-lambda data must point to the original closure-data
02298         record, because that's where the closure maps are kept. But
02299         we don't need the bytecode, anymore. So clone the
02300         closure-data record and drop the bytecode in thte clone. */
02301       for (i = 0; i < cnt; i++) {
02302        val = seqout->array[i];
02303        if (!SCHEME_PROCP(val)) {
02304          Scheme_Closure_Data *data;
02305          data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
02306          memcpy(data, val, sizeof(Scheme_Closure_Data));
02307          data->code = NULL;
02308          seqout->array[i] = (Scheme_Object *)data;
02309        }
02310       }
02311     }
02312 
02313     return (Scheme_Object *)seqout;
02314   }
02315 #endif
02316  
02317   return expr;
02318 }
02319 
02320 static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls,
02321                              int depth, int letlimit, int delta, 
02322                                  int num_toplevels, int num_stxes, int num_lifts,
02323                                  struct Validate_Clearing *vc, int tailpos)
02324 {
02325   Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data;
02326   Scheme_Object *e;
02327   int i;
02328 
02329   if (!SAME_TYPE(SCHEME_TYPE(data), scheme_case_lambda_sequence_type))
02330     scheme_ill_formed_code(port);
02331 
02332   for (i = 0; i < seq->count; i++) { 
02333     e = seq->array[i];
02334     if (!SAME_TYPE(SCHEME_TYPE(e), scheme_unclosed_procedure_type)
02335         && !SAME_TYPE(SCHEME_TYPE(e), scheme_closure_type))
02336       scheme_ill_formed_code(port);
02337     scheme_validate_expr(port, e, stack, tls, depth, letlimit, delta, 
02338                          num_toplevels, num_stxes, num_lifts,
02339                          NULL, 0, 0, vc, 0);
02340   }
02341 }
02342 
02343 static Scheme_Object *
02344 case_lambda_resolve(Scheme_Object *expr, Resolve_Info *rslv)
02345 {
02346   int i, all_closed = 1;
02347   Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;
02348 
02349   for (i = 0; i < seq->count; i++) {
02350     Scheme_Object *le;
02351     le = seq->array[i];
02352     le = scheme_resolve_closure_compilation(le, rslv, 0, 0, 0, NULL);
02353     seq->array[i] = le;
02354     if (!SCHEME_PROCP(le))
02355       all_closed = 0;
02356   }
02357 
02358   if (all_closed) {
02359     /* Produce closure directly */
02360     return case_lambda_execute(expr);
02361   }
02362 
02363   return scheme_make_syntax_resolved(CASE_LAMBDA_EXPD, expr);
02364 }
02365 
02366 static Scheme_Object *
02367 case_lambda_sfs(Scheme_Object *expr, SFS_Info *info)
02368 {
02369   Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;
02370   Scheme_Object *le, *clears = scheme_null;
02371   int i;
02372 
02373   scheme_sfs_start_sequence(info, seq->count, 0);
02374 
02375   for (i = 0; i < seq->count; i++) {
02376     le = seq->array[i];
02377     le = scheme_sfs_expr(le, info, -1);
02378     if (SAME_TYPE(SCHEME_TYPE(le), scheme_syntax_type)
02379         && (SCHEME_PINT_VAL(le) == BEGIN0_EXPD)) {
02380       /* Some clearing actions were added to the closure.
02381          Lift them out. */
02382       int j;
02383       Scheme_Sequence *cseq = (Scheme_Sequence *)SCHEME_IPTR_VAL(le);
02384       if (!cseq->count)
02385         scheme_signal_error("internal error: empty sequence");
02386       for (j = 1; j < cseq->count; j++) {
02387         int pos;
02388         pos = SCHEME_LOCAL_POS(cseq->array[j]);
02389         clears = scheme_make_pair(scheme_make_integer(pos), clears);
02390       }
02391       le = cseq->array[0];
02392     }
02393     if (!SAME_TYPE(SCHEME_TYPE(le), scheme_unclosed_procedure_type)
02394         && !SAME_TYPE(SCHEME_TYPE(le), scheme_closure_type)) {
02395       scheme_signal_error("internal error: not a lambda for case-lambda: %d",
02396                           SCHEME_TYPE(le));
02397     }
02398     seq->array[i] = le;
02399   }
02400 
02401   if (!SCHEME_NULLP(clears)) {
02402     expr = scheme_make_syntax_resolved(CASE_LAMBDA_EXPD, expr);
02403     return scheme_sfs_add_clears(expr, clears, 0);
02404   } else
02405     return expr;
02406 }
02407 
02408 static Scheme_Object *
02409 case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info)
02410 {
02411   Scheme_Object *le;
02412   int i;
02413   Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;
02414 
02415   for (i = 0; i < seq->count; i++) {
02416     le = seq->array[i];
02417     le = scheme_optimize_expr(le, info);
02418     seq->array[i] = le;
02419   }
02420 
02421   info->preserves_marks = 1;
02422   info->single_result = 1;
02423 
02424   return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, expr);
02425 }
02426 
02427 static Scheme_Object *
02428 case_lambda_shift(Scheme_Object *data, int delta, int after_depth)
02429 {
02430   Scheme_Object *le;
02431   int i;
02432   Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data;
02433 
02434   for (i = 0; i < seq->count; i++) {
02435     le = seq->array[i];
02436     le = scheme_optimize_shift(le, delta, after_depth);
02437     seq->array[i] = le;
02438   }
02439   
02440   return data;
02441 }
02442 
02443 Scheme_Object *scheme_unclose_case_lambda(Scheme_Object *expr, int mode)
02444 {
02445   Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)expr;
02446   Scheme_Closure *c;
02447   int i;
02448 
02449   for (i = cl->count; i--; ) {
02450     c = (Scheme_Closure *)cl->array[i];
02451     if (!ZERO_SIZED_CLOSUREP(c)) {
02452       break;
02453     }
02454   }
02455 
02456   if (i < 0) {
02457     /* We can reconstruct a case-lambda syntactic form. */
02458     Scheme_Case_Lambda *cl2;
02459 
02460     cl2 = (Scheme_Case_Lambda *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
02461                                                + ((cl->count - 1) * sizeof(Scheme_Object*)));
02462     
02463     cl2->so.type = scheme_case_lambda_sequence_type;
02464     cl2->count = cl->count;
02465     cl2->name = cl->name;
02466 
02467     for (i = cl->count; i--; ) {
02468       c = (Scheme_Closure *)cl->array[i];
02469       cl2->array[i] = (Scheme_Object *)c->code;
02470     }
02471 
02472     if (mode == 2) {
02473       /* sfs */
02474       return scheme_make_syntax_resolved(CASE_LAMBDA_EXPD, (Scheme_Object *)cl2);
02475     } else if (mode == 1) {
02476       /* JIT */
02477       return case_lambda_jit((Scheme_Object *)cl2);
02478     } else
02479       return (Scheme_Object *)cl2;
02480   }
02481   
02482   return expr;
02483 }
02484 
02485 static void case_lambda_check_line(Scheme_Object *line, Scheme_Object *form, Scheme_Comp_Env *env)
02486 {
02487   Scheme_Object *body, *args;
02488 
02489   if (!SCHEME_STX_PAIRP(line))
02490     scheme_wrong_syntax(NULL, line, form, NULL);
02491   
02492   body = SCHEME_STX_CDR(line);
02493   args = SCHEME_STX_CAR(line);
02494   
02495   lambda_check_args(args, form, env);
02496   
02497   if (!SCHEME_STX_PAIRP(body))
02498     scheme_wrong_syntax(NULL, line, form, "bad syntax (%s)",
02499                      SCHEME_STX_NULLP(body) ? "empty body" : IMPROPER_LIST_FORM);
02500 }
02501 
02502 static Scheme_Object *
02503 case_lambda_syntax (Scheme_Object *form, Scheme_Comp_Env *env, 
02504                   Scheme_Compile_Info *rec, int drec)
02505 {
02506   Scheme_Object *list, *last, *c, *orig_form = form, *name;
02507   Scheme_Case_Lambda *cl;
02508   int i, count = 0;
02509   Scheme_Compile_Info *recs;
02510   
02511   form = SCHEME_STX_CDR(form);
02512 
02513   name = scheme_build_closure_name(orig_form, rec, drec);
02514   
02515   if (SCHEME_STX_NULLP(form)) {
02516     /* Case where there are no cases... */
02517     form = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
02518                                            - sizeof(Scheme_Object*));
02519 
02520     form->type = scheme_case_lambda_sequence_type;
02521     ((Scheme_Case_Lambda *)form)->count = 0;
02522     ((Scheme_Case_Lambda *)form)->name = name;
02523 
02524     scheme_compile_rec_done_local(rec, drec);
02525     scheme_default_compile_rec(rec, drec);
02526 
02527     if (scheme_has_method_property(orig_form)) {
02528       /* See note in schpriv.h about the IS_METHOD hack */
02529       if (!name)
02530        name = scheme_false;
02531       name = scheme_box(name);
02532       ((Scheme_Case_Lambda *)form)->name = name;
02533     }
02534 
02535     return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, form);
02536   }
02537 
02538   if (!SCHEME_STX_PAIRP(form))
02539     scheme_wrong_syntax(NULL, form, orig_form, NULL);
02540   if (SCHEME_STX_NULLP(SCHEME_STX_CDR(form))) {
02541     c = SCHEME_STX_CAR(form);
02542 
02543     case_lambda_check_line(c, orig_form, env);
02544 
02545     c = cons(scheme_datum_to_syntax(lambda_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
02546              c);
02547     c = scheme_datum_to_syntax(c, orig_form, orig_form, 0, 2);
02548     
02549     return lambda_syntax(c, env, rec, drec);
02550   }
02551 
02552   scheme_compile_rec_done_local(rec, drec);
02553 
02554   scheme_rec_add_certs(rec, drec, orig_form);
02555 
02556   list = last = NULL;
02557   while (SCHEME_STX_PAIRP(form)) {
02558     Scheme_Object *clause;
02559     clause = SCHEME_STX_CAR(form);
02560     case_lambda_check_line(clause, orig_form, env);
02561 
02562     c = cons(lambda_symbol, clause);
02563 
02564     c = scheme_datum_to_syntax(c, clause, scheme_sys_wraps(env), 0, 0);
02565 
02566     c = cons(c, scheme_null);
02567 
02568     if (list)
02569       SCHEME_CDR(last) = c;
02570     else
02571       list = c;
02572 
02573     last = c;
02574     form = SCHEME_STX_CDR(form);
02575 
02576     count++;
02577   }
02578 
02579   if (!SCHEME_STX_NULLP(form))
02580     scheme_wrong_syntax(NULL, form, orig_form, NULL);
02581 
02582   cl = (Scheme_Case_Lambda *)
02583     scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
02584                       + (count - 1) * sizeof(Scheme_Object *));
02585   cl->so.type = scheme_case_lambda_sequence_type;
02586   cl->count = count;
02587   cl->name = SCHEME_TRUEP(name) ? name : NULL;
02588 
02589   scheme_compile_rec_done_local(rec, drec);
02590   recs = MALLOC_N_RT(Scheme_Compile_Info, count);
02591   scheme_init_compile_recs(rec, drec, recs, count);
02592 
02593   for (i = 0; i < count; i++) {
02594     Scheme_Object *ce;
02595     ce = SCHEME_CAR(list);
02596     ce = scheme_compile_expr(ce, env, recs, i);
02597     cl->array[i] = ce;
02598     list = SCHEME_CDR(list);
02599   }
02600 
02601   scheme_merge_compile_recs(rec, drec, recs, count);
02602 
02603   if (scheme_has_method_property(orig_form)) {
02604     Scheme_Closure_Data *data;
02605     /* Make sure no branch has 0 arguments: */
02606     for (i = 0; i < count; i++) {
02607       data = (Scheme_Closure_Data *)cl->array[i];
02608       if (!data->num_params)
02609        break;
02610     }
02611     if (i >= count) {
02612       data = (Scheme_Closure_Data *)cl->array[0];
02613       SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_IS_METHOD;
02614     }
02615   }
02616 
02617   return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, (Scheme_Object *)cl);
02618 }
02619 
02620 static Scheme_Object *
02621 case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
02622 {
02623   Scheme_Object *first, *last, *args, *body, *c, *new_line, *orig_form = form;
02624 
02625   SCHEME_EXPAND_OBSERVE_PRIM_CASE_LAMBDA(erec[drec].observer);
02626 
02627   first = SCHEME_STX_CAR(form);
02628   first = cons(first, scheme_null);
02629   last = first;
02630   form = SCHEME_STX_CDR(form);
02631 
02632   scheme_rec_add_certs(erec, drec, orig_form);
02633 
02634   while (SCHEME_STX_PAIRP(form)) {
02635     Scheme_Object *line_form;
02636     Scheme_Comp_Env *newenv;
02637     
02638     SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
02639 
02640     line_form = SCHEME_STX_CAR(form);
02641 
02642     case_lambda_check_line(line_form, orig_form, env);
02643     
02644     body = SCHEME_STX_CDR(line_form);
02645     args = SCHEME_STX_CAR(line_form);
02646 
02647     body = scheme_datum_to_syntax(body, line_form, line_form, 0, 0);
02648     
02649     newenv = scheme_add_compilation_frame(args, env, 0, erec[drec].certs);
02650     
02651     body = scheme_add_env_renames(body, newenv, env);
02652     args = scheme_add_env_renames(args, newenv, env);
02653     SCHEME_EXPAND_OBSERVE_CASE_LAMBDA_RENAMES(erec[drec].observer, args, body);
02654 
02655     {
02656       Scheme_Expand_Info erec1;
02657       scheme_init_expand_recs(erec, drec, &erec1, 1);
02658       erec1.value_name = scheme_false;
02659       new_line = cons(args, scheme_expand_block(body, newenv, &erec1, 0));
02660     }
02661     new_line = scheme_datum_to_syntax(new_line, line_form, line_form, 0, 1);
02662 
02663     c = cons(new_line, scheme_null);
02664 
02665     SCHEME_CDR(last) = c;
02666     last = c;
02667 
02668     form = SCHEME_STX_CDR(form);
02669   }
02670 
02671   if (!SCHEME_STX_NULLP(form))
02672     scheme_wrong_syntax(NULL, form, orig_form, NULL);
02673   
02674   return scheme_datum_to_syntax(first, orig_form, orig_form, 0, 2);
02675 }
02676 
02677 /**********************************************************************/
02678 /*                          implicit set!s                            */
02679 /**********************************************************************/
02680 
02681 /* A bangboxenv step is inserted by the compilation of `lambda' and
02682    `let' forms where an argument or bindings is set!ed in the body. */
02683 
02684 Scheme_Object *bangboxenv_execute(Scheme_Object *data)
02685 {
02686   int pos = SCHEME_INT_VAL(SCHEME_CAR(data));
02687   Scheme_Object *bb;
02688 
02689   data = SCHEME_CDR(data);
02690   
02691   bb = scheme_make_envunbox(MZ_RUNSTACK[pos]);
02692   MZ_RUNSTACK[pos] = bb;
02693 
02694   return _scheme_tail_eval(data);
02695 }
02696 
02697 static Scheme_Object *bangboxenv_sfs(Scheme_Object *data, SFS_Info *info)
02698 {
02699   Scheme_Object *e;
02700   e = scheme_sfs_expr(SCHEME_CDR(data), info, -1);
02701   SCHEME_CDR(data) = e;
02702   return data;
02703 }
02704 
02705 static Scheme_Object *bangboxenv_jit(Scheme_Object *data)
02706 {
02707   Scheme_Object *orig, *naya;
02708 
02709   orig = SCHEME_CDR(data);
02710   naya = scheme_jit_expr(orig);
02711   if (SAME_OBJ(naya, orig))
02712     return data;
02713   else
02714     return cons(SCHEME_CAR(data), naya);
02715 }
02716 
02717 static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, 
02718                             char *stack, Validate_TLS tls,
02719                                 int depth, int letlimit, int delta, 
02720                                 int num_toplevels, int num_stxes, int num_lifts,
02721                                 struct Validate_Clearing *vc, int tailpos)
02722 {
02723   if (!SCHEME_PAIRP(data))
02724     scheme_ill_formed_code(port);
02725     
02726   scheme_validate_boxenv(SCHEME_INT_VAL(SCHEME_CAR(data)), port, stack, depth, delta);
02727 
02728   scheme_validate_expr(port, SCHEME_CDR(data), stack, tls, depth, letlimit, delta, 
02729                        num_toplevels, num_stxes, num_lifts,
02730                        NULL, 0, 0, vc, tailpos);
02731 }
02732 
02733 /**********************************************************************/
02734 /*                  let, let-values, letrec, etc.                     */
02735 /**********************************************************************/
02736 
02737 static int is_liftable_prim(Scheme_Object *v)
02738 {
02739   if (SCHEME_PRIMP(v)) {
02740     if ((((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OPT_MASK)
02741         >= SCHEME_PRIM_OPT_IMMEDIATE)
02742       return 1;
02743   }
02744 
02745   return 0;
02746 }
02747 
02748 static int is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator)
02749 {
02750   Scheme_Type t = SCHEME_TYPE(o);
02751 
02752   switch (t) {
02753   case scheme_compiled_unclosed_procedure_type:
02754     return !as_rator;
02755   case scheme_compiled_toplevel_type:
02756     return 1;
02757   case scheme_local_type:
02758     if (SCHEME_LOCAL_POS(o) > bind_count)
02759       return 1;
02760     break;
02761   case scheme_branch_type:
02762     if (fuel) {
02763       Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)o;
02764       if (is_liftable(b->test, bind_count, fuel - 1, 0)
02765          && is_liftable(b->tbranch, bind_count, fuel - 1, as_rator)
02766          && is_liftable(b->fbranch, bind_count, fuel - 1, as_rator))
02767        return 1;
02768     }
02769     break;
02770   case scheme_application_type:
02771     {
02772       Scheme_App_Rec *app = (Scheme_App_Rec *)o;
02773       int i;
02774       if (!is_liftable_prim(app->args[0]))
02775         return 0;
02776       if (bind_count >= 0)
02777         bind_count += app->num_args;
02778       for (i = app->num_args + 1; i--; ) {
02779        if (!is_liftable(app->args[i], bind_count, fuel - 1, 1))
02780          return 0;
02781       }
02782       return 1;
02783     }
02784   case scheme_application2_type:
02785     {
02786       Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
02787       if (!is_liftable_prim(app->rator))
02788         return 0;
02789       if (bind_count >= 0)
02790         bind_count += 1;
02791       if (is_liftable(app->rator, bind_count, fuel - 1, 1)
02792          && is_liftable(app->rand, bind_count, fuel - 1, 1))
02793        return 1;
02794     }
02795   case scheme_application3_type:
02796     {
02797       Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
02798       if (!is_liftable_prim(app->rator))
02799         return 0;
02800       if (bind_count >= 0)
02801         bind_count += 2;
02802       if (is_liftable(app->rator, bind_count, fuel - 1, 1)
02803          && is_liftable(app->rand1, bind_count, fuel - 1, 1)
02804          && is_liftable(app->rand2, bind_count, fuel - 1, 1))
02805        return 1;
02806     }
02807   default:
02808     if (t > _scheme_compiled_values_types_)
02809       return 1;
02810   }
02811 
02812   return 0;
02813 }
02814 
02815 int scheme_compiled_propagate_ok(Scheme_Object *value, Optimize_Info *info)
02816 {
02817   if (scheme_compiled_duplicate_ok(value))
02818     return 1;
02819 
02820   if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)) {
02821     int sz;
02822     sz = scheme_closure_body_size((Scheme_Closure_Data *)value, 1);
02823     if ((sz >= 0) && (sz <= MAX_PROC_INLINE_SIZE))
02824       return 1;
02825   }
02826 
02827   if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_toplevel_type)) {
02828     if (info->top_level_consts) {
02829       int pos;
02830       pos = SCHEME_TOPLEVEL_POS(value);
02831       value = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
02832       if (value)
02833         return 1;
02834     }
02835   }
02836 
02837   return 0;
02838 }
02839 
02840 int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info)
02841 {
02842   while (1) {
02843     if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type))
02844       return 1;
02845     else if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_syntax_type)) {
02846       if (SCHEME_PINT_VAL(value) == CASE_LAMBDA_EXPD)
02847         return 1;
02848       else
02849         break;
02850     } else if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_let_void_type)) {
02851       /* Look for (let ([x <proc>]) <proc>), which is generated for optional arguments. */
02852       Scheme_Let_Header *lh = (Scheme_Let_Header *)value;
02853       if (lh->num_clauses == 1) {
02854         Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
02855         if (scheme_omittable_expr(lv->value, lv->count, 20, 0, NULL)) {
02856           value = lv->body;
02857           info = NULL;
02858         } else
02859           break;
02860       } else
02861         break;
02862     } else
02863       break;
02864   }
02865    
02866   return 0;
02867 }
02868 
02869 Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e)
02870 {
02871   Scheme_Object *ni;
02872 
02873   ni = scheme_alloc_small_object();
02874   ni->type = scheme_noninline_proc_type;
02875   SCHEME_PTR_VAL(ni) = e;
02876   
02877   return ni;
02878 }
02879 
02880 static int is_values_apply(Scheme_Object *e)
02881 {
02882   if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
02883     Scheme_App_Rec *app = (Scheme_App_Rec *)e;
02884     return SAME_OBJ(scheme_values_func, app->args[0]);
02885   } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) {
02886     Scheme_App2_Rec *app = (Scheme_App2_Rec *)e;
02887     return SAME_OBJ(scheme_values_func, app->rator);
02888   } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) {
02889     Scheme_App3_Rec *app = (Scheme_App3_Rec *)e;
02890     return SAME_OBJ(scheme_values_func, app->rator);
02891   }
02892 
02893   return 0;
02894 }
02895 
02896 static void unpack_values_application(Scheme_Object *e, Scheme_Compiled_Let_Value *naya)
02897 {
02898   if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
02899     Scheme_App_Rec *app = (Scheme_App_Rec *)e;
02900     int i;
02901     for (i = 0; i < app->num_args; i++) {
02902       naya->value = app->args[i + 1];
02903       naya = (Scheme_Compiled_Let_Value *)naya->body;
02904     }
02905   } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) {
02906     Scheme_App2_Rec *app = (Scheme_App2_Rec *)e;
02907     naya->value = app->rand;
02908   } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) {
02909     Scheme_App3_Rec *app = (Scheme_App3_Rec *)e;
02910     naya->value = app->rand1;
02911     naya = (Scheme_Compiled_Let_Value *)naya->body;
02912     naya->value = app->rand2;
02913   }
02914 }
02915 
02916 static Scheme_Object *make_clones(Scheme_Compiled_Let_Value *retry_start,
02917                                   Scheme_Compiled_Let_Value *pre_body,
02918                                   Optimize_Info *body_info)
02919 {
02920   Scheme_Compiled_Let_Value *clv;
02921   Scheme_Object *value, *clone, *pr;
02922   Scheme_Object *last = NULL, *first = NULL;
02923 
02924   clv = retry_start;
02925   while (1) {
02926     value = clv->value;
02927     if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)) {
02928       clone = scheme_optimize_clone(1, value, body_info, 0, 0);
02929       if (clone) {
02930         pr = scheme_make_raw_pair(scheme_make_raw_pair(value, clone), NULL);
02931         if (last)
02932           SCHEME_CDR(last) = pr;
02933         else
02934           first = pr;
02935         last = pr;
02936       }
02937     }
02938     if (clv == pre_body)
02939       break;
02940     clv = (Scheme_Compiled_Let_Value *)clv->body;
02941   }
02942 
02943   return first;
02944 }
02945 
02946 static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
02947                           Scheme_Compiled_Let_Value *pre_body,
02948                           Scheme_Object *clones,
02949                           int set_flags, int mask_flags, int just_tentative)
02950 {
02951   Scheme_Compiled_Let_Value *clv;
02952   Scheme_Object *value, *first;
02953   int flags = CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS;
02954   Scheme_Closure_Data *data;
02955 
02956   /* The first in a clone pair is the one that is consulted for
02957      references. The second one is the clone, and its the one whose
02958      flags are updated by optimization. So consult the clone, and set
02959      flags in both. */
02960 
02961   clv = retry_start;
02962   while (clones) {
02963     value = retry_start->value;
02964 
02965     if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) {
02966       data = (Scheme_Closure_Data *)value;
02967       
02968       if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) {
02969         flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data));
02970         
02971         first = SCHEME_CAR(clones);
02972         
02973         data = (Scheme_Closure_Data *)SCHEME_CDR(first);
02974         SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
02975         data = (Scheme_Closure_Data *)SCHEME_CAR(first);
02976         SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
02977       }
02978 
02979       clones = SCHEME_CDR(clones);
02980     }
02981 
02982     if (clv == pre_body)
02983       break;
02984     clv = (Scheme_Compiled_Let_Value *)clv->body;
02985   }
02986 
02987   return flags;
02988 }
02989 
02990 static int expr_size(Scheme_Object *o)
02991 {
02992   if (SAME_TYPE(SCHEME_TYPE(o), scheme_compiled_unclosed_procedure_type))
02993     return scheme_closure_body_size((Scheme_Closure_Data *)o, 0);
02994   else
02995     return 1;
02996 }
02997 
02998 static int might_invoke_call_cc(Scheme_Object *value)
02999 {
03000   return !is_liftable(value, -1, 10, 0);
03001 }
03002 
03003 static int worth_lifting(Scheme_Object *v)
03004 {
03005   Scheme_Type lhs;
03006   lhs = SCHEME_TYPE(v);
03007   if ((lhs == scheme_compiled_unclosed_procedure_type)
03008       || (lhs == scheme_local_type)
03009       || (lhs == scheme_compiled_toplevel_type)
03010       || (lhs == scheme_compiled_quote_syntax_type)
03011       || (lhs > _scheme_compiled_values_types_))
03012     return 1;
03013   return 0;
03014 }
03015 
03016 Scheme_Object *
03017 scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
03018 {
03019   Optimize_Info *body_info, *rhs_info;
03020   Scheme_Let_Header *head = (Scheme_Let_Header *)form;
03021   Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body;
03022   Scheme_Object *body, *value, *ready_pairs = NULL, *rp_last = NULL, *ready_pairs_start;
03023   int i, j, pos, is_rec, not_simply_let_star = 0;
03024   int size_before_opt, did_set_value;
03025   int remove_last_one = 0;
03026 
03027   /* Special case: (let ([x E]) x) where E is lambda, case-lambda, or
03028      a constant. (If we allowed arbitrary E here, it would affect the
03029      tailness of E.) */
03030   if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) {
03031     clv = (Scheme_Compiled_Let_Value *)head->body;
03032     if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type)
03033         && (((Scheme_Local *)clv->body)->position == 0)) {
03034       if (worth_lifting(clv->value)) {
03035         if (for_inline) {
03036          /* Just drop the inline-introduced let */
03037          return scheme_optimize_expr(clv->value, info);
03038        } else {
03039          info = scheme_optimize_info_add_frame(info, 1, 0, 0);
03040          body = scheme_optimize_expr(clv->value, info);
03041           info->next->single_result = info->single_result;
03042           info->next->preserves_marks = info->preserves_marks;
03043          scheme_optimize_info_done(info);
03044          return body;
03045        }
03046       }
03047     }
03048   }
03049 
03050   body_info = scheme_optimize_info_add_frame(info, head->count, head->count, 0);
03051   if (for_inline) {
03052     rhs_info = scheme_optimize_info_add_frame(info, 0, head->count, 0);
03053     body_info->inline_fuel >>= 1;
03054   } else
03055     rhs_info = body_info;
03056 
03057   is_rec = (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE);
03058 
03059   body = head->body;
03060   pos = 0;
03061   for (i = head->num_clauses; i--; ) {
03062     pre_body = (Scheme_Compiled_Let_Value *)body;
03063     for (j = pre_body->count; j--; ) {
03064       if (pre_body->flags[j] & SCHEME_WAS_SET_BANGED) {
03065        scheme_optimize_mutated(body_info, pos + j);
03066       } else if (is_rec) {
03067         /* Indicate that it's not yet ready, so it cannot be inlined: */
03068         Scheme_Object *rp;
03069         rp = scheme_make_raw_pair(scheme_false, NULL);
03070         if (rp_last)
03071           SCHEME_CDR(rp_last) = rp;
03072         else
03073           ready_pairs = rp;
03074         rp_last = rp;
03075         scheme_optimize_propagate(body_info, pos+j, rp_last, 0);
03076       }
03077     }
03078     pos += pre_body->count;
03079     body = pre_body->body;
03080   }
03081 
03082   prev_body = NULL;
03083   body = head->body;
03084   pre_body = NULL;
03085   retry_start = NULL;
03086   ready_pairs_start = NULL;
03087   did_set_value = 0;
03088   pos = 0;
03089   for (i = head->num_clauses; i--; ) {
03090     pre_body = (Scheme_Compiled_Let_Value *)body;
03091 
03092     size_before_opt = body_info->size;
03093 
03094     if ((pre_body->count == 1)
03095         && SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(pre_body->value))
03096         && !scheme_optimize_is_used(body_info, pos)) {
03097       if (!body_info->transitive_use) {
03098         mzshort **tu;
03099         int *tu_len;
03100         tu = (mzshort **)scheme_malloc(sizeof(mzshort *) * head->count);
03101         tu_len = (int *)scheme_malloc_atomic(sizeof(int) * head->count);        
03102         memset(tu_len, 0, sizeof(int) * head->count);
03103         body_info->transitive_use = tu;
03104         body_info->transitive_use_len = tu_len;
03105       }
03106       body_info->transitive_use_pos = pos + 1;
03107     }
03108 
03109     value = scheme_optimize_expr(pre_body->value, rhs_info);
03110     pre_body->value = value;
03111 
03112     body_info->transitive_use_pos = 0;
03113 
03114     if (is_rec && !not_simply_let_star) {
03115       /* Keep track of whether we can simplify to let*: */
03116       if (might_invoke_call_cc(value)
03117           || scheme_optimize_any_uses(rhs_info, pos, head->count))
03118         not_simply_let_star = 1;
03119     }
03120 
03121     /* Change (let-values ([(id ...) (values e ...)]) body)
03122        to (let-values ([id e] ...) body) for simple e. */
03123     if ((pre_body->count != 1)
03124         && is_values_apply(value)
03125         && scheme_omittable_expr(value, pre_body->count, -1, 0, info)) {
03126       if (!pre_body->count && !i) {
03127         /* We want to drop the clause entirely, but doing it
03128            here messes up the loop for letrec. So wait and 
03129            remove it at the end. */
03130         remove_last_one = 1;
03131       } else {
03132         Scheme_Compiled_Let_Value *naya;
03133         Scheme_Object *rest = pre_body->body;
03134         int *new_flags;
03135         int cnt = pre_body->count;
03136 
03137         while (cnt--) {
03138           naya = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
03139           naya->so.type = scheme_compiled_let_value_type;
03140           naya->body = rest;
03141           naya->count = 1;
03142           naya->position = pre_body->position + cnt;
03143           new_flags = (int *)scheme_malloc_atomic(sizeof(int));
03144           new_flags[0] = pre_body->flags[cnt];
03145           naya->flags = new_flags;
03146           rest = (Scheme_Object *)naya;
03147         }
03148 
03149         naya = (Scheme_Compiled_Let_Value *)rest;
03150         unpack_values_application(value, naya);
03151         if (prev_body)
03152           prev_body->body = (Scheme_Object *)naya;
03153         else
03154           head->body = (Scheme_Object *)naya;
03155         head->num_clauses += (pre_body->count - 1);
03156         i += (pre_body->count - 1);
03157         if (pre_body->count) {
03158           pre_body = naya;
03159           body = (Scheme_Object *)naya;
03160           value = pre_body->value;
03161         } else {
03162           /* We've dropped this clause entirely. */
03163           i++;
03164           if (i > 0) {
03165             body = (Scheme_Object *)naya;
03166             continue;
03167           } else
03168             break;
03169         }
03170       }
03171     }
03172 
03173     if ((pre_body->count == 1)
03174        && !(pre_body->flags[0] & SCHEME_WAS_SET_BANGED)) {
03175 
03176       if (SAME_TYPE(SCHEME_TYPE(value), scheme_local_type)) {
03177        /* Don't optimize reference to a local binding
03178           that's not available yet, or that's mutable. */
03179        int vpos;
03180        vpos = SCHEME_LOCAL_POS(value);
03181        if ((vpos < head->count) && (vpos >= pos))
03182          value = NULL;
03183        else {
03184          /* Convert value back to a pre-optimized local coordinates.
03185             This must be done with respect to body_info, not
03186             rhs_info, because we attach the value to body_info: */
03187          value = scheme_optimize_reverse(body_info, vpos, 1);
03188           
03189           /* Double-check that the value is ready, because we might be
03190              nested in the RHS of a `letrec': */
03191           if (value)
03192             if (!scheme_optimize_info_is_ready(body_info, SCHEME_LOCAL_POS(value)))
03193               value = NULL;
03194        }
03195       }
03196 
03197       if (value && (scheme_compiled_propagate_ok(value, body_info))) {
03198         int cnt;
03199         if (is_rec)
03200           cnt = 2;
03201         else
03202           cnt = ((pre_body->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT);
03203         scheme_optimize_propagate(body_info, pos, value, cnt == 1);
03204        did_set_value = 1;
03205       }
03206     }
03207 
03208     if (!retry_start) {
03209       retry_start = pre_body;
03210       ready_pairs_start = ready_pairs;
03211     }
03212 
03213     /* Re-optimize to inline letrec bindings? */
03214     if (is_rec
03215        && !body_info->letrec_not_twice
03216        && ((i < 1) 
03217            || (!scheme_is_compiled_procedure(((Scheme_Compiled_Let_Value *)pre_body->body)->value, 1, 1)
03218               && !is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5, 1)))) {
03219       if (did_set_value) {
03220        /* Next RHS ends a reorderable sequence. 
03221           Re-optimize from retry_start to pre_body, inclusive.
03222            For procedures, assume CLOS_SINGLE_RESULT and CLOS_PRESERVES_MARKS for all,
03223            but then assume not for all if any turn out not (i.e., approximate fix point). */
03224         int flags;
03225         Scheme_Object *clones, *cl, *cl_first;
03226         /* Reset "ready" flags: */
03227         for (rp_last = ready_pairs_start; !SAME_OBJ(rp_last, ready_pairs); rp_last = SCHEME_CDR(rp_last)) {
03228           SCHEME_CAR(rp_last) = scheme_false;
03229         }
03230         /* Set-flags loop: */
03231         clones = make_clones(retry_start, pre_body, body_info);
03232         (void)set_code_flags(retry_start, pre_body, clones,
03233                              CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE, 
03234                              0xFFFF,
03235                              0);
03236         /* Re-optimize loop: */
03237         clv = retry_start;
03238         cl = clones;
03239        while (1) {
03240          value = clv->value;
03241           if (cl)
03242             cl_first = SCHEME_CAR(cl);
03243           else
03244             cl_first = NULL;
03245          if (cl_first && SAME_OBJ(value, SCHEME_CAR(cl_first))) {
03246             /* Try optimization. */
03247            Scheme_Object *self_value;
03248             int sz;
03249 
03250             if ((clv->count == 1)
03251                 && body_info->transitive_use
03252                 && !scheme_optimize_is_used(body_info, clv->position)) {
03253               body_info->transitive_use[clv->position] = NULL;
03254               body_info->transitive_use_pos = clv->position + 1;
03255             }
03256 
03257             cl = SCHEME_CDR(cl);
03258            self_value = SCHEME_CDR(cl_first);
03259 
03260             /* Drop old size, and remove old inline fuel: */
03261             sz = scheme_closure_body_size((Scheme_Closure_Data *)value, 0);
03262             body_info->size -= (sz + 1);
03263             
03264             /* Setting letrec_not_twice prevents inlinining
03265                of letrec bindings in this RHS. There's a small
03266                chance that we miss some optimizations, but we
03267                avoid the possibility of N^2 behavior. */
03268             body_info->letrec_not_twice = 1;
03269             
03270             value = scheme_optimize_expr(self_value, body_info);
03271 
03272             body_info->letrec_not_twice = 0;
03273             
03274             clv->value = value;
03275 
03276             if (!(clv->flags[0] & SCHEME_WAS_SET_BANGED)) {
03277               scheme_optimize_propagate(body_info, clv->position, value, 0);
03278             }
03279 
03280             body_info->transitive_use_pos = 0;
03281          }
03282          if (clv == pre_body)
03283            break;
03284           {
03285             /* Since letrec is really letrec*, the variables 
03286                for this binding are now ready: */
03287             int i;
03288             for (i = clv->count; i--; ) {
03289               if (!(clv->flags[i] & SCHEME_WAS_SET_BANGED)) {
03290                 SCHEME_CAR(ready_pairs_start) = scheme_true;
03291                 ready_pairs_start = SCHEME_CDR(ready_pairs_start);
03292               }
03293             }
03294           }
03295          clv = (Scheme_Compiled_Let_Value *)clv->body;
03296        }
03297         /* Check flags loop: */
03298         flags = set_code_flags(retry_start, pre_body, clones, 0, 0xFFFF, 0);
03299         /* Reset-flags loop: */
03300         (void)set_code_flags(retry_start, pre_body, clones,
03301                              (flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)), 
03302                              ~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE),
03303                              1);
03304       }
03305       retry_start = NULL;
03306       ready_pairs_start = NULL;
03307       did_set_value = 0;
03308     }
03309 
03310     if (is_rec) {
03311       /* Since letrec is really letrec*, the variables 
03312          for this binding are now ready: */
03313       int i;
03314       for (i = pre_body->count; i--; ) {
03315         if (!(pre_body->flags[i] & SCHEME_WAS_SET_BANGED)) {
03316           SCHEME_CAR(ready_pairs) = scheme_true;
03317           ready_pairs = SCHEME_CDR(ready_pairs);
03318         }
03319       }
03320     }
03321 
03322     if (remove_last_one) {
03323       head->num_clauses -= 1;
03324       body = (Scheme_Object *)pre_body->body;
03325       if (prev_body) {
03326         prev_body->body = body;
03327         pre_body = prev_body;
03328       } else {
03329         head->body = body;
03330         pre_body = NULL;
03331       }
03332       break;
03333     }
03334 
03335     pos += pre_body->count;
03336     prev_body = pre_body;
03337     body = pre_body->body;
03338     info->size += 1;
03339   }
03340 
03341   if (for_inline) {
03342     body_info->size = rhs_info->size;
03343   }
03344 
03345   body = scheme_optimize_expr(body, body_info);
03346   if (head->num_clauses)
03347     pre_body->body = body;
03348   else
03349     head->body = body;
03350   info->size += 1;
03351 
03352   info->single_result = body_info->single_result;
03353   info->preserves_marks = body_info->preserves_marks;
03354 
03355   /* Clear used flags where possible */
03356   body = head->body;
03357   pos = 0;
03358   for (i = head->num_clauses; i--; ) {
03359     int used = 0, j;
03360     pre_body = (Scheme_Compiled_Let_Value *)body;
03361     for (j = pre_body->count; j--; ) {
03362       if (scheme_optimize_is_used(body_info, pos+j)) {
03363         used = 1;
03364         break;
03365       }
03366     }
03367     if (!used
03368         && scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info)) {
03369       for (j = pre_body->count; j--; ) {
03370         if (pre_body->flags[j] & SCHEME_WAS_USED) {
03371           pre_body->flags[j] -= SCHEME_WAS_USED;
03372         }
03373       }
03374       if (pre_body->count == 1) {
03375         /* Drop expr and deduct from size to aid further inlining. */
03376         int sz;
03377         sz = expr_size(pre_body->value);
03378         pre_body->value = scheme_false;
03379         info->size -= (sz + 1);
03380       }
03381     } else {
03382       for (j = pre_body->count; j--; ) {
03383         pre_body->flags[j] |= SCHEME_WAS_USED;
03384       }
03385     }
03386     pos += pre_body->count;
03387     body = pre_body->body;
03388   }
03389 
03390   /* Optimized away all clauses? */
03391   if (!head->num_clauses) {
03392     scheme_optimize_info_done(body_info);
03393     return head->body;
03394   }
03395   
03396   if (is_rec && !not_simply_let_star) {
03397     /* We can simplify letrec to let* */
03398     SCHEME_LET_FLAGS(head) -= SCHEME_LET_RECURSIVE;
03399     SCHEME_LET_FLAGS(head) |= SCHEME_LET_STAR;
03400   }
03401 
03402   {
03403     int extract_depth = 0;
03404 
03405     value = NULL;
03406     
03407     /* Check again for (let ([x <proc>]) x). */
03408     if (!is_rec && (head->count == 1) && (head->num_clauses == 1)) {
03409       clv = (Scheme_Compiled_Let_Value *)head->body;
03410       if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type)
03411           && (((Scheme_Local *)clv->body)->position == 0)) {
03412         if (worth_lifting(clv->value)) {
03413           value = clv->value;
03414           extract_depth = 1;
03415         }
03416       }
03417     }
03418 
03419     /* Check for (let ([unused #f] ...) <proc>) */
03420     if (!value) {
03421       if (head->count == head->num_clauses) {
03422         body = head->body;
03423         pos = 0;
03424         for (i = head->num_clauses; i--; ) {
03425           pre_body = (Scheme_Compiled_Let_Value *)body;
03426           if ((pre_body->count != 1)
03427               || !SCHEME_FALSEP(pre_body->value)
03428               || (pre_body->flags[0] & SCHEME_WAS_USED))
03429             break;
03430           body = pre_body->body;
03431         }
03432         if (i < 0) {
03433           if (worth_lifting(body)) {
03434             value = body;
03435             extract_depth = head->count;
03436             rhs_info = body_info;
03437           }
03438         }
03439       }
03440     }
03441     
03442     if (value) {
03443       value = scheme_optimize_clone(1, value, rhs_info, 0, 0);
03444 
03445       if (value) {
03446         info = scheme_optimize_info_add_frame(info, extract_depth, 0, 0);
03447         info->inline_fuel = 0;
03448         value = scheme_optimize_expr(value, info);
03449         info->next->single_result = info->single_result;
03450         info->next->preserves_marks = info->preserves_marks;
03451         scheme_optimize_info_done(info);
03452         return value;
03453       }
03454     }
03455   }
03456 
03457   scheme_optimize_info_done(body_info);
03458 
03459   return form;
03460 }
03461 
03462 Scheme_Object *
03463 scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info)
03464 /* Special case for when the `let' expression appears in an `if' test */
03465 {
03466   Scheme_Let_Header *head = (Scheme_Let_Header *)form;
03467 
03468   /* Special case: (let ([x M]) (if x x N)), where x is not in N,
03469      to (if M #t #f), since we're in a test position. */
03470   if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) {
03471     Scheme_Compiled_Let_Value *clv;
03472     clv = (Scheme_Compiled_Let_Value *)head->body;
03473     if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_branch_type)
03474        && (((clv->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT)
03475            == 2)) {
03476       Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)clv->body;
03477       if (SAME_TYPE(SCHEME_TYPE(b->test), scheme_local_type)
03478          && SAME_TYPE(SCHEME_TYPE(b->tbranch), scheme_local_type)
03479          && !SCHEME_LOCAL_POS(b->test)
03480          && !SCHEME_LOCAL_POS(b->tbranch)) {
03481        Scheme_Branch_Rec *b3;
03482        Optimize_Info *sub_info;
03483 
03484        b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
03485        b3->so.type = scheme_branch_type;
03486        b3->test = clv->value;
03487        b3->tbranch = scheme_true;
03488        b3->fbranch = b->fbranch;
03489 
03490        sub_info = scheme_optimize_info_add_frame(info, 1, 0, 0);
03491        
03492        form = scheme_optimize_expr((Scheme_Object *)b3, sub_info);
03493 
03494         info->single_result = sub_info->single_result;
03495         info->preserves_marks = sub_info->preserves_marks;
03496 
03497        scheme_optimize_info_done(sub_info);
03498 
03499        return form;
03500       }
03501     }
03502   }
03503 
03504 
03505   return scheme_optimize_lets(form, info, 0);
03506 }
03507 
03508 static int is_lifted_reference(Scheme_Object *v)
03509 {
03510   if (SCHEME_RPAIRP(v))
03511     return 1;
03512 
03513   return (SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type)
03514           && (SCHEME_TOPLEVEL_FLAGS(v) & SCHEME_TOPLEVEL_CONST));
03515 }
03516 
03517 static int is_closed_reference(Scheme_Object *v)
03518 {
03519   /* Look for a converted function (possibly with no new arguments)
03520      that is accessed directly as a closure, instead of through a
03521      top-level reference. */
03522   if (SCHEME_RPAIRP(v)) {
03523     v = SCHEME_CAR(v);
03524     return SCHEME_PROCP(v);
03525   }
03526 
03527   return 0;
03528 }
03529 
03530 static Scheme_Object *scheme_resolve_generate_stub_closure()
03531 {
03532   Scheme_Closure *cl;
03533   Scheme_Object **ca;
03534 
03535   cl = scheme_malloc_empty_closure();
03536 
03537   ca = MALLOC_N(Scheme_Object*, 4);
03538   ca[0] = scheme_make_integer(0);
03539   ca[1] = NULL;
03540   ca[2] = scheme_make_integer(0);
03541   ca[3] = NULL;
03542 
03543   return scheme_make_raw_pair((Scheme_Object *)cl, (Scheme_Object *)ca);
03544 }
03545 
03546 static void shift_lift(Scheme_Object *lifted, int frame_size, int lifted_frame_size)
03547 {
03548   int i, cnt;
03549   Scheme_Object **ca;
03550   mzshort *map;
03551 
03552   if (!lifted) return;
03553   if (!SCHEME_RPAIRP(lifted)) return;
03554 
03555   ca = (Scheme_Object **)SCHEME_CDR(lifted);
03556   cnt = SCHEME_INT_VAL(ca[0]);
03557   map = (mzshort *)ca[1];
03558 
03559   for (i = 0; i < cnt; i++) {
03560     map[i] += (frame_size - lifted_frame_size);
03561   }
03562 }
03563 
03564 static int get_convert_arg_count(Scheme_Object *lift)
03565 {
03566   if (!lift)
03567     return 0;
03568   else if (SCHEME_RPAIRP(lift)) {
03569     Scheme_Object **ca;
03570     ca = (Scheme_Object **)SCHEME_CDR(lift);
03571     return SCHEME_INT_VAL(ca[0]);
03572   } else
03573     return 0;
03574 }
03575 
03576 Scheme_Object *
03577 scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
03578 {
03579   Resolve_Info *linfo, *val_linfo;
03580   Scheme_Let_Header *head = (Scheme_Let_Header *)form;
03581   Scheme_Compiled_Let_Value *clv, *pre_body;
03582   Scheme_Let_Value *lv, *last = NULL;
03583   Scheme_Object *first = NULL, *body, *last_body = NULL;
03584   Scheme_Letrec *letrec;
03585   mzshort *skips, skips_fast[5];
03586   Scheme_Object **lifted, *lifted_fast[5], *boxes;
03587   int i, pos, opos, rpos, recbox, num_rec_procs = 0, extra_alloc;
03588   int rec_proc_nonapply = 0;
03589   int max_let_depth = 0;
03590   int resolve_phase, num_skips;
03591   Scheme_Object **lifted_recs;
03592 
03593   /* Find body: */
03594   body = head->body;
03595   pre_body = NULL;
03596   for (i = head->num_clauses; i--; ) {
03597     pre_body = (Scheme_Compiled_Let_Value *)body;
03598     body = pre_body->body;
03599   }
03600 
03601   recbox = 0;
03602   if (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) {
03603     /* Do we need to box vars in a letrec? */
03604     clv = (Scheme_Compiled_Let_Value *)head->body;
03605     for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
03606       int is_proc, is_lift;
03607 
03608       if ((clv->count == 1) 
03609           && !(clv->flags[0] & SCHEME_WAS_USED)) {
03610         /* skip */
03611       } else {
03612         if (clv->count == 1) 
03613           is_proc = scheme_is_compiled_procedure(clv->value, 1, 1);
03614         else
03615           is_proc = 0;
03616 
03617         if (is_proc)
03618           is_lift = 0;
03619         else
03620           is_lift = is_liftable(clv->value, head->count, 5, 1);
03621       
03622         if (!is_proc && !is_lift) {
03623           recbox = 1;
03624           break;
03625         } else {
03626           if (!is_lift) {
03627             /* is_proc must be true ... */
03628             int j;
03629 
03630             for (j = 0; j < clv->count; j++) {
03631               if (clv->flags[j] & SCHEME_WAS_SET_BANGED) {
03632                 recbox = 1;
03633                 break;
03634               }
03635             }
03636             if (recbox)
03637               break;
03638 
03639             if (scheme_is_compiled_procedure(clv->value, 0, 0)) {
03640               num_rec_procs++;
03641               if (!(clv->flags[0] & SCHEME_WAS_ONLY_APPLIED))
03642                 rec_proc_nonapply = 1;
03643             }
03644           }
03645         }
03646       }
03647     }
03648 
03649     if (recbox)
03650       num_rec_procs = 0;
03651   } else {
03652     /* Sequence of single-value, non-assigned lets? */
03653     clv = (Scheme_Compiled_Let_Value *)head->body;
03654     for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
03655       if (clv->count != 1)
03656        break;
03657       if (clv->flags[0] & SCHEME_WAS_SET_BANGED)
03658        break;
03659     }
03660     if (i < 0) {
03661       /* Yes - build chain of Scheme_Let_Ones and we're done: */
03662       int skip_count = 0, frame_size, lifts_frame_size = 0;
03663       int j, k;
03664 
03665       j = head->num_clauses;
03666       if (j <= 5) {
03667        skips = skips_fast; 
03668         lifted = lifted_fast;
03669       } else {
03670        skips = MALLOC_N_ATOMIC(mzshort, j);
03671        lifted = MALLOC_N(Scheme_Object*, j);
03672       }
03673 
03674       clv = (Scheme_Compiled_Let_Value *)head->body;
03675       for (i = 0; i < j; i++, clv = (Scheme_Compiled_Let_Value *)clv->body) {
03676        if (!(clv->flags[0] & SCHEME_WAS_USED))
03677          skips[i] = 1;
03678        else
03679          skips[i] = 0;
03680         lifted[i] = NULL;
03681       }
03682 
03683       clv = (Scheme_Compiled_Let_Value *)head->body;
03684       for (i = 0; i < head->num_clauses; i++, clv = (Scheme_Compiled_Let_Value *)clv->body) {
03685        Scheme_Object *le;
03686 
03687        if (!(clv->flags[0] & SCHEME_WAS_USED)) {
03688          skip_count++;
03689        }
03690 
03691        /* First `i+1' bindings now exist "at runtime", except those skipped. */
03692        /* The mapping is complicated because we now push in the order of 
03693           the variables, but it was compiled using the inverse order. */
03694        frame_size = i + 1 - skip_count;
03695        linfo = scheme_resolve_info_extend(info, frame_size, head->count, i + 1);
03696        for (j = i, k = 0; j >= 0; j--) {
03697           if (lifts_frame_size != frame_size) {
03698             /* We need to shift coordinates for any lifted[j] that is a
03699                converted procedure. */
03700             shift_lift(lifted[j], frame_size, lifts_frame_size);
03701           }
03702          if (skips[j])
03703            scheme_resolve_info_add_mapping(linfo, j, 0, 0, lifted[j]);
03704          else
03705            scheme_resolve_info_add_mapping(linfo, j, k++, 0, lifted[j]);
03706        }
03707         lifts_frame_size = frame_size;
03708 
03709         if (skips[i]) {
03710           le = scheme_void;
03711         } else {
03712           if ((clv->flags[0] & SCHEME_WAS_ONLY_APPLIED)
03713               && SAME_TYPE(SCHEME_TYPE(clv->value), scheme_compiled_unclosed_procedure_type))
03714             le = scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 0, NULL);
03715           else
03716             le = scheme_resolve_expr(clv->value, linfo);
03717         }
03718 
03719         if (max_let_depth < linfo->max_let_depth + frame_size)
03720           max_let_depth = linfo->max_let_depth + frame_size;
03721 
03722         if (is_lifted_reference(le)) {
03723           lifted[i] = le;
03724 
03725           /* At this point, it's ok to change our mind
03726              about skipping, because compilation for previous
03727              RHSs did not look at this one. */
03728           if (!skips[i]) {
03729             skips[i] = 1;
03730             skip_count++;
03731           }
03732         }
03733 
03734        if (skips[i]) {
03735          /* Unused binding, so drop it. */
03736        } else {
03737          Scheme_Let_One *lo;
03738          int et;
03739 
03740          lo = MALLOC_ONE_TAGGED(Scheme_Let_One);
03741          lo->iso.so.type = scheme_let_one_type;
03742          lo->value = le;
03743 
03744          et = scheme_get_eval_type(lo->value);
03745          SCHEME_LET_EVAL_TYPE(lo) = et;
03746 
03747          if (last)
03748            ((Scheme_Let_One *)last)->body = (Scheme_Object *)lo;
03749          else
03750            first = (Scheme_Object *)lo;
03751          last = (Scheme_Let_Value *)lo;
03752        }
03753       }
03754 
03755       frame_size = head->count - skip_count;
03756       linfo = scheme_resolve_info_extend(info, frame_size, head->count, head->count);
03757 
03758       if (lifts_frame_size != frame_size) {
03759         for (i = head->count; i--; ) {
03760           /* We need to shift coordinates for any lifted[j] that is a
03761              converted procedure. */
03762           shift_lift(lifted[i], frame_size, lifts_frame_size);
03763         }
03764       }
03765 
03766       for (k = 0, i = head->count; i--; ) {
03767        if (skips[i])
03768          scheme_resolve_info_add_mapping(linfo, i, ((skips[i] < 0)
03769                                                ? (k - skips[i] - 1)
03770                                                : (skips[i] - 1 + frame_size)), 
03771                                           0, lifted[i]);
03772        else
03773          scheme_resolve_info_add_mapping(linfo, i, k++, 0, lifted[i]);
03774       }
03775       
03776       body = scheme_resolve_expr(body, linfo);
03777       if (last)
03778        ((Scheme_Let_One *)last)->body = body;
03779       else {
03780        first = body;
03781       }
03782 
03783       if (max_let_depth < linfo->max_let_depth + frame_size)
03784         max_let_depth = linfo->max_let_depth + frame_size;
03785 
03786       if (info->max_let_depth < max_let_depth)
03787         info->max_let_depth = max_let_depth;
03788 
03789       /* Check for (let ([x <expr>]) (<simple> x)) at end, and change to
03790          (<simple> <expr>). This is easy because the local-variable
03791          offsets in <expr> do not change (as long as <simple> doesn't
03792          access the stack). */
03793       last_body = NULL;
03794       body = first;
03795       while (1) {
03796         if (!SAME_TYPE(SCHEME_TYPE(body), scheme_let_one_type))
03797           break;
03798         if (!SAME_TYPE(SCHEME_TYPE(((Scheme_Let_One *)body)->body), scheme_let_one_type))
03799           break;
03800         last_body = body;
03801         body = ((Scheme_Let_One *)body)->body;
03802       }
03803       if (SAME_TYPE(SCHEME_TYPE(body), scheme_let_one_type)) {
03804         if (SAME_TYPE(SCHEME_TYPE(((Scheme_Let_One *)body)->body), scheme_application2_type)) {
03805           Scheme_App2_Rec *app = (Scheme_App2_Rec *)((Scheme_Let_One *)body)->body;
03806           if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type)
03807               && (SCHEME_LOCAL_POS(app->rand) == 1)) {
03808             if (SCHEME_TYPE(app->rator) > _scheme_values_types_) {
03809               /* Move <expr> to app, and drop let-one: */
03810               app->rand = ((Scheme_Let_One *)body)->value;
03811               scheme_reset_app2_eval_type(app);
03812               if (last_body)
03813                 ((Scheme_Let_One *)last_body)->body = (Scheme_Object *)app;
03814               else
03815                 first = (Scheme_Object *)app;
03816             }
03817           }
03818         }
03819       }
03820 
03821       return first;
03822     } else {
03823       /* Maybe some multi-binding lets, but all of them are unused
03824          and the RHSes are omittable? This can happen with auto-generated
03825          code. */
03826       int total = 0, j;
03827       clv = (Scheme_Compiled_Let_Value *)head->body;
03828       for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
03829         total += clv->count;
03830         for (j = clv->count; j--; ) {
03831           if (clv->flags[j] & SCHEME_WAS_USED)
03832             break;
03833         }
03834         if (j >= 0)
03835           break;
03836         if (!scheme_omittable_expr(clv->value, clv->count, -1, 0, NULL))
03837           break;
03838       }
03839       if (i < 0) {
03840         /* All unused and omittable */
03841         linfo = scheme_resolve_info_extend(info, 0, total, 0);
03842         first = scheme_resolve_expr((Scheme_Object *)clv, linfo);
03843         if (info->max_let_depth < linfo->max_let_depth)
03844           info->max_let_depth = linfo->max_let_depth;
03845         return first;
03846       }
03847     }
03848   }
03849 
03850   num_skips = 0;
03851   clv = (Scheme_Compiled_Let_Value *)head->body;
03852   for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
03853     if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED))
03854       num_skips++;
03855   }
03856 
03857   /* First assume that all letrec-bound procedures can be lifted to empty closures.
03858      Then try assuming that all letrec-bound procedures can be at least lifted.
03859      Then fall back to assuming no lifts. */
03860   
03861   linfo = 0;
03862   for (resolve_phase = ((num_rec_procs && !rec_proc_nonapply) ? 0 : 2); resolve_phase < 3; resolve_phase++) {
03863 
03864     /* Don't try plain lifting if top level is not available: */
03865     if ((resolve_phase == 1) && !scheme_resolve_is_toplevel_available(info))
03866       resolve_phase = 2;
03867 
03868     if (resolve_phase < 2) {
03869       linfo = scheme_resolve_info_extend(info, head->count - num_rec_procs - num_skips, head->count, head->count);
03870       lifted_recs = MALLOC_N(Scheme_Object *, num_rec_procs);
03871     } else {
03872       linfo = scheme_resolve_info_extend(info, head->count - num_skips, head->count, head->count);
03873       lifted_recs = NULL;
03874     }
03875 
03876     /* Build mapping of compile-time indices to run-time indices, shuffling
03877        letrecs to fall together in the shallowest part. Also determine
03878        and initialize lifts for recursive procedures. Generating lift information
03879        requires an iteration. */
03880     clv = (Scheme_Compiled_Let_Value *)head->body;
03881     pos = ((resolve_phase < 2) ? 0 : num_rec_procs);
03882     rpos = 0; opos = 0;
03883     for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
03884       int j;
03885 
03886       if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) {
03887         /* skipped */
03888         scheme_resolve_info_add_mapping(linfo, opos, 0, 0, NULL);
03889         opos++;
03890       } else {
03891         for (j = 0; j < clv->count; j++) {
03892           int p, skip;
03893           Scheme_Object *lift;
03894 
03895           skip = 0;
03896           if (num_rec_procs 
03897               && (clv->count == 1)
03898               && scheme_is_compiled_procedure(clv->value, 0, 0)) {
03899             if (resolve_phase == 0) {
03900               lift = scheme_resolve_generate_stub_closure();
03901               lifted_recs[rpos] = lift;
03902               p = 0;
03903             } else if (resolve_phase == 1) {
03904               lift = scheme_resolve_generate_stub_lift();
03905               lifted_recs[rpos] = lift;
03906               p = 0;
03907             } else {
03908               lift = NULL;
03909               p = rpos;
03910             }
03911             rpos++;
03912           } else {
03913             p = pos++;
03914             lift = NULL;
03915           }
03916       
03917           scheme_resolve_info_add_mapping(linfo, opos, p,
03918                                           ((recbox 
03919                                             || (clv->flags[j] & SCHEME_WAS_SET_BANGED))
03920                                            ? SCHEME_INFO_BOXED
03921                                            : 0),
03922                                           lift);
03923 
03924           opos++;
03925         }
03926       }
03927     }
03928 
03929     if (resolve_phase < 2) {
03930       /* Given the assumption that all are closed/lifted, compute
03931          actual lift info. We have to iterate if there are
03932          conversions, because a conversion can trigger another 
03933          conversion. If the conversion changes for an item, it's
03934          always by adding more conversion arguments. */
03935       int converted;
03936       do {
03937         clv = (Scheme_Compiled_Let_Value *)head->body;
03938         rpos = 0; opos = 0;
03939         converted = 0;
03940         for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
03941           if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) {
03942             /* skipped */
03943           } else if ((clv->count == 1)
03944                      && scheme_is_compiled_procedure(clv->value, 0, 0)) {
03945             Scheme_Object *lift, *old_lift;
03946             int old_convert_count;
03947 
03948             old_lift = lifted_recs[rpos];
03949             old_convert_count = get_convert_arg_count(old_lift);
03950 
03951             lift = scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 1, 
03952                                                       (resolve_phase ? NULL : old_lift));
03953 
03954             if (is_closed_reference(lift)
03955                 || (is_lifted_reference(lift) && resolve_phase)) {
03956               if (!SAME_OBJ(old_lift, lift))
03957                 scheme_resolve_info_adjust_mapping(linfo, opos, rpos, 0, lift);
03958               lifted_recs[rpos] = lift;
03959               if (get_convert_arg_count(lift) != old_convert_count)
03960                 converted = 1;
03961             } else {
03962               lifted_recs = NULL;
03963               converted = 0;
03964               break;
03965             }
03966             rpos++;
03967           }
03968           opos += clv->count;
03969         }
03970       } while (converted);
03971 
03972       if (lifted_recs) {
03973         /* All can be closed or lifted --- and some may be converted.
03974            For the converted ones, the argument conversion is right. For
03975            lifted ones, we need to generate the actual offset. For fully
03976            closed ones, we need the actual closure. 
03977 
03978            If we succeeded with resolve_phase == 0, then all can be
03979            fully closed. We need to resolve again with the stub
03980            closures in place, and the mutate the stub closures with
03981            the actual closure info.
03982 
03983            If we succeeded with resolve_phase == 1, then we need
03984            actual lift offsets before resolving procedure bodies.
03985            Also, we need to fix up the stub closures. */
03986         clv = (Scheme_Compiled_Let_Value *)head->body;
03987         rpos = 0; opos = 0;
03988         for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
03989           if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) {
03990             /* skipped */
03991           } else if ((clv->count == 1) && scheme_is_compiled_procedure(clv->value, 0, 0)) {
03992             Scheme_Object *lift;
03993             lift = lifted_recs[rpos];
03994             if (is_closed_reference(lift)) {
03995               (void)scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 0, lift);
03996               /* lift is the final result; this result might be
03997                  referenced in the body of closures already, or in
03998                  not-yet-closed functions.  If no one uses the result
03999                  via linfo, then the code was dead and it will get
04000                  GCed. */
04001               clv->value = NULL; /* inidicates that there's nothing more to do with the expr */
04002             } else {
04003               lift = scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 2, NULL);
04004               /* need to resolve one more time for the body of the lifted function */
04005             }
04006             scheme_resolve_info_adjust_mapping(linfo, opos, rpos, 0, lift);
04007             lifted_recs[rpos] = lift;
04008             rpos++;
04009           }
04010           opos += clv->count;
04011         }
04012 
04013         break; /* don't need to iterate */
04014       }
04015     }
04016   }
04017 
04018   extra_alloc = 0;
04019   val_linfo = linfo;
04020 
04021   if (num_rec_procs) {
04022     if (!lifted_recs) {
04023       Scheme_Object **sa;
04024       letrec = MALLOC_ONE_TAGGED(Scheme_Letrec);
04025       letrec->so.type = scheme_letrec_type;
04026       letrec->count = num_rec_procs;
04027       sa = MALLOC_N(Scheme_Object *, num_rec_procs);
04028       letrec->procs = sa;
04029     } else {
04030       extra_alloc = -num_rec_procs;
04031       letrec = NULL;
04032     }
04033   } else
04034     letrec = NULL;
04035 
04036   /* Resolve values: */
04037   boxes = scheme_null;
04038   clv = (Scheme_Compiled_Let_Value *)head->body;
04039   rpos = 0; opos = 0;
04040   for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
04041     if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) {
04042       /* skipped */
04043     } else {
04044       int isproc;
04045       Scheme_Object *expr;
04046       if (!clv->value)
04047         isproc = 1;
04048       else if (clv->count == 1)
04049         isproc = scheme_is_compiled_procedure(clv->value, 0, 0);
04050       else
04051         isproc = 0;
04052       if (num_rec_procs && isproc) {
04053         if (!lifted_recs) {
04054           expr = scheme_resolve_closure_compilation(clv->value, val_linfo, 0, 0, 0, NULL);
04055           letrec->procs[rpos++] = expr;
04056         } else {
04057           if (!is_closed_reference(lifted_recs[rpos])) {
04058             /* Side-effect is to install lifted function: */
04059             (void)scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 0, lifted_recs[rpos]);
04060           }
04061           rpos++;
04062         }
04063       } else {
04064         int j;
04065         Scheme_Object *one_lifted;
04066 
04067         expr = scheme_resolve_expr(clv->value, val_linfo);
04068 
04069         lv = MALLOC_ONE_TAGGED(Scheme_Let_Value);
04070         if (last)
04071           last->body = (Scheme_Object *)lv;
04072         else if (last_body)
04073           SCHEME_CDR(last_body) = (Scheme_Object *)lv;
04074         else
04075           first = (Scheme_Object *)lv;
04076         last = lv;
04077         last_body = NULL;
04078       
04079         lv->iso.so.type = scheme_let_value_type;
04080         lv->value = expr;
04081         if (clv->count) {
04082           int li;
04083           li = scheme_resolve_info_lookup(linfo, clv->position, NULL, NULL, 0);
04084           lv->position = li;
04085         } else
04086           lv->position = 0;
04087         lv->count = clv->count;
04088         SCHEME_LET_AUTOBOX(lv) = recbox;
04089 
04090         for (j = lv->count; j--; ) {
04091           if (!recbox
04092               && (scheme_resolve_info_flags(linfo, opos + j, &one_lifted) & SCHEME_INFO_BOXED)) {
04093             GC_CAN_IGNORE Scheme_Object *pos;
04094             pos = scheme_make_integer(lv->position + j);
04095             if (SCHEME_LET_FLAGS(head) & (SCHEME_LET_STAR | SCHEME_LET_RECURSIVE)) {
04096               /* For let* or a let*-like letrec, we need to insert the boxes after each evaluation. */
04097               Scheme_Object *boxenv, *pr;
04098               pr = scheme_make_pair(pos, scheme_false);
04099               boxenv = scheme_make_syntax_resolved(BOXENV_EXPD, pr);
04100               if (last)
04101                 last->body = boxenv;
04102               else
04103                 SCHEME_CDR(last_body) = boxenv;
04104               last = NULL;
04105               last_body = pr;
04106             } else {
04107               /* For regular let, delay the boxing until all RHSs are
04108                  evaluated. */
04109               boxes = scheme_make_pair(pos, boxes);
04110             }
04111           }
04112         }
04113       }
04114     }
04115     opos += clv->count;
04116   }
04117 
04118   /* Resolve body: */
04119   body = scheme_resolve_expr(body, linfo);
04120 
04121   while (SCHEME_PAIRP(boxes)) {
04122     /* See bangboxenv... */
04123     body = scheme_make_syntax_resolved(BOXENV_EXPD, 
04124                                        scheme_make_pair(SCHEME_CAR(boxes),
04125                                                         body));
04126     boxes = SCHEME_CDR(boxes);
04127   }
04128 
04129   if (letrec) {
04130     letrec->body = body;
04131     if (last)
04132       last->body = (Scheme_Object *)letrec;
04133     else if (last_body)
04134       SCHEME_CDR(last_body) = (Scheme_Object *)letrec;
04135     else
04136       first = (Scheme_Object *)letrec;
04137   } else if (last)
04138     last->body = body;
04139   else if (last_body)
04140     SCHEME_CDR(last_body) = body;
04141   else
04142     first = body;
04143 
04144   if (head->count + extra_alloc - num_skips) {
04145     Scheme_Let_Void *lvd;
04146 
04147     lvd = MALLOC_ONE_TAGGED(Scheme_Let_Void);
04148     lvd->iso.so.type = scheme_let_void_type;
04149     lvd->body = first;
04150     lvd->count = head->count + extra_alloc - num_skips;
04151     SCHEME_LET_AUTOBOX(lvd) = recbox;
04152 
04153     first = (Scheme_Object *)lvd;
04154   }
04155 
04156   if (info->max_let_depth < linfo->max_let_depth + head->count - num_skips + extra_alloc)
04157     info->max_let_depth = linfo->max_let_depth + head->count - num_skips + extra_alloc;
04158   
04159   return first;
04160 }
04161 
04162 static Scheme_Object *
04163 gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
04164               int star, int recursive, int multi, Scheme_Compile_Info *rec, int drec,
04165               Scheme_Comp_Env *frame_already)
04166 {
04167   Scheme_Object *bindings, *l, *binding, *name, **names, *forms, *defname;
04168   int num_clauses, num_bindings, i, j, k, m, pre_k;
04169   Scheme_Comp_Env *frame, *env;
04170   Scheme_Compile_Info *recs;
04171   Scheme_Object *first = NULL;
04172   Scheme_Compiled_Let_Value *last = NULL, *lv;
04173   DupCheckRecord r;
04174   int rec_env_already = rec[drec].env_already;
04175 
04176   i = scheme_stx_proper_list_length(form);
04177   if (i < 3)
04178     scheme_wrong_syntax(NULL, NULL, form, (!i ? "bad syntax (empty body)" : NULL));
04179 
04180   bindings = SCHEME_STX_CDR(form);
04181   bindings = SCHEME_STX_CAR(bindings);
04182   num_clauses = scheme_stx_proper_list_length(bindings);
04183 
04184   if (num_clauses < 0)
04185     scheme_wrong_syntax(NULL, bindings, form, NULL);
04186 
04187   scheme_rec_add_certs(rec, drec, form);
04188 
04189   forms = SCHEME_STX_CDR(form);
04190   forms = SCHEME_STX_CDR(forms);
04191   forms = scheme_datum_to_syntax(forms, form, form, 0, 0);
04192 
04193   if (!num_clauses) {
04194     env = scheme_no_defines(origenv);
04195 
04196     name = scheme_check_name_property(form, rec[drec].value_name);
04197     rec[drec].value_name = name;
04198 
04199     return scheme_compile_sequence(forms, env, rec, drec);
04200   }
04201   
04202   if (multi) {
04203     num_bindings = 0;
04204     l = bindings;
04205     while (!SCHEME_STX_NULLP(l)) {
04206       Scheme_Object *clause, *names, *rest;
04207       int num_names;
04208 
04209       clause = SCHEME_STX_CAR(l);
04210       
04211       if (!SCHEME_STX_PAIRP(clause))
04212        rest = NULL;
04213       else {
04214        rest = SCHEME_STX_CDR(clause);
04215        if (!SCHEME_STX_PAIRP(rest))
04216          rest = NULL;
04217        else {
04218          rest = SCHEME_STX_CDR(rest);
04219          if (!SCHEME_STX_NULLP(rest))
04220            rest = NULL;
04221        }
04222       }
04223       if (!rest)
04224        scheme_wrong_syntax(NULL, clause, form, NULL);
04225       
04226       names = SCHEME_STX_CAR(clause);
04227       
04228       num_names = scheme_stx_proper_list_length(names);
04229       if (num_names < 0)
04230        scheme_wrong_syntax(NULL, names, form, NULL);
04231      
04232       num_bindings += num_names;
04233  
04234       l = SCHEME_STX_CDR(l);
04235     }
04236   } else
04237     num_bindings = num_clauses;
04238 
04239 
04240   names = MALLOC_N(Scheme_Object *, num_bindings);
04241   if (frame_already)
04242     frame = frame_already;
04243   else {
04244     frame = scheme_new_compilation_frame(num_bindings, 
04245                                          (rec_env_already ? SCHEME_INTDEF_SHADOW : 0),
04246                                          origenv, 
04247                                          rec[drec].certs);
04248     if (rec_env_already)
04249       frame_already = frame;
04250   }
04251   env = frame;
04252 
04253   recs = MALLOC_N_RT(Scheme_Compile_Info, (num_clauses + 1));
04254 
04255   defname = rec[drec].value_name;
04256   scheme_compile_rec_done_local(rec, drec);
04257   scheme_init_compile_recs(rec, drec, recs, num_clauses + 1);
04258 
04259   defname = scheme_check_name_property(form, defname);
04260   
04261   if (!star && !frame_already) {
04262     scheme_begin_dup_symbol_check(&r, env);
04263   }
04264 
04265   for (i = 0, k = 0; i < num_clauses; i++) {
04266     if (!SCHEME_STX_PAIRP(bindings))
04267       scheme_wrong_syntax(NULL, bindings, form, NULL);
04268     binding = SCHEME_STX_CAR(bindings);
04269     if (!SCHEME_STX_PAIRP(binding) || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(binding)))
04270       scheme_wrong_syntax(NULL, binding, form, NULL);
04271 
04272     {
04273       Scheme_Object *rest;
04274       rest = SCHEME_STX_CDR(binding);
04275       if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))
04276        scheme_wrong_syntax(NULL, binding, form, NULL);
04277     }
04278     
04279     pre_k = k;
04280 
04281     name = SCHEME_STX_CAR(binding);
04282     if (multi) {
04283       while (!SCHEME_STX_NULLP(name)) {
04284        Scheme_Object *n;
04285        n = SCHEME_STX_CAR(name);
04286        names[k] = n;
04287        scheme_check_identifier(NULL, names[k], NULL, env, form);
04288        k++;
04289        name = SCHEME_STX_CDR(name);
04290       }
04291 
04292       for (j = pre_k; j < k; j++) {
04293        for (m = j + 1; m < k; m++) {
04294          if (scheme_stx_bound_eq(names[m], names[j], scheme_make_integer(env->genv->phase)))
04295            scheme_wrong_syntax(NULL, NULL, form,
04296                             "multiple bindings of `%S' in the same clause", 
04297                             SCHEME_STX_SYM(names[m]));
04298        }
04299       }
04300     } else {
04301       scheme_check_identifier(NULL, name, NULL, env, form);
04302       names[k++] = name;
04303     }
04304     
04305     if (!star && !frame_already) {
04306       for (m = pre_k; m < k; m++) {
04307        scheme_dup_symbol_check(&r, NULL, names[m], "binding", form);
04308       }
04309     }
04310 
04311     lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
04312     lv->so.type = scheme_compiled_let_value_type;
04313     if (!last)
04314       first = (Scheme_Object *)lv;
04315     else
04316       last->body = (Scheme_Object *)lv;
04317     last = lv;
04318     lv->count = (k - pre_k);
04319     lv->position = pre_k;
04320 
04321     if (lv->count == 1)
04322       recs[i].value_name = SCHEME_STX_SYM(names[pre_k]);
04323 
04324     if (!recursive) {
04325       Scheme_Object *ce, *rhs;
04326       rhs = SCHEME_STX_CDR(binding);
04327       rhs = SCHEME_STX_CAR(rhs);
04328       rhs = scheme_add_env_renames(rhs, env, origenv);
04329       ce = scheme_compile_expr(rhs, env, recs, i);
04330       lv->value = ce;
04331     } else {
04332       Scheme_Object *rhs;
04333       rhs = SCHEME_STX_CDR(binding);
04334       rhs = SCHEME_STX_CAR(rhs);
04335       lv->value = rhs;
04336     }
04337     
04338     if (star || recursive) {
04339       for (m = pre_k; m < k; m++) {
04340        scheme_add_compilation_binding(m, names[m], frame);
04341       }
04342     }
04343     
04344     bindings = SCHEME_STX_CDR(bindings);
04345   }
04346   
04347   if (!star && !recursive) {
04348     for (i = 0; i < num_bindings; i++) {
04349       scheme_add_compilation_binding(i, names[i], frame);
04350     }
04351   }
04352 
04353   if (recursive) {
04354     lv = (Scheme_Compiled_Let_Value *)first;
04355     for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) {
04356       Scheme_Object *ce, *rhs;
04357       rhs = lv->value;
04358       rhs = scheme_add_env_renames(rhs, env, origenv);
04359       ce = scheme_compile_expr(rhs, env, recs, i);
04360       lv->value = ce;
04361     }
04362   }
04363 
04364   recs[num_clauses].value_name = defname ? SCHEME_STX_SYM(defname) : NULL;
04365   {
04366     Scheme_Object *cs;
04367     forms = scheme_add_env_renames(forms, env, origenv);
04368     cs = scheme_compile_sequence(forms, env, recs, num_clauses);
04369     last->body = cs;
04370   }
04371 
04372   /* Save flags: */
04373   lv = (Scheme_Compiled_Let_Value *)first;
04374   for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) {
04375     int *flags;
04376     flags = scheme_env_get_flags(env, lv->position, lv->count);
04377     lv->flags = flags;
04378   }
04379 
04380   {
04381     Scheme_Let_Header *head;
04382     
04383     head = MALLOC_ONE_TAGGED(Scheme_Let_Header);
04384     head->iso.so.type = scheme_compiled_let_void_type;
04385     head->body = first;
04386     head->count = num_bindings;
04387     head->num_clauses = num_clauses;
04388     SCHEME_LET_FLAGS(head) = ((recursive ? SCHEME_LET_RECURSIVE : 0)
04389                               | (star ? SCHEME_LET_STAR : 0));
04390 
04391     first = (Scheme_Object *)head;
04392   }
04393   
04394   scheme_merge_compile_recs(rec, drec, recs, num_clauses + 1);
04395 
04396   return first;
04397 }
04398 
04399 static Scheme_Object *
04400 do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info *erec, int drec,
04401              const char *formname, int letrec, int multi, int letstar,
04402              Scheme_Comp_Env *env_already)
04403 {
04404   Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *vlist, *boundname;
04405   Scheme_Comp_Env *use_env, *env;
04406   Scheme_Expand_Info erec1;
04407   DupCheckRecord r;
04408   int rec_env_already = erec[drec].env_already;
04409 
04410   vars = SCHEME_STX_CDR(form);
04411 
04412   if (!SCHEME_STX_PAIRP(vars))
04413     scheme_wrong_syntax(NULL, NULL, form, NULL);
04414 
04415   body = SCHEME_STX_CDR(vars);
04416   vars = SCHEME_STX_CAR(vars);
04417 
04418   if (!SCHEME_STX_PAIRP(body))
04419     scheme_wrong_syntax(NULL, NULL, form, (SCHEME_STX_NULLP(body) 
04420                                       ? "bad syntax (empty body)" 
04421                                       : NULL));
04422 
04423   boundname = scheme_check_name_property(form, erec[drec].value_name);
04424   erec[drec].value_name = boundname;
04425 
04426   scheme_rec_add_certs(erec, drec, form);
04427   
04428   if (letstar) {
04429     if (!SCHEME_STX_NULLP(vars)) {
04430       Scheme_Object *a, *vr;
04431 
04432       if (!SCHEME_STX_PAIRP(vars))
04433        scheme_wrong_syntax(NULL, vars, form, NULL);
04434 
04435       a = SCHEME_STX_CAR(vars);
04436       vr = SCHEME_STX_CDR(vars);
04437       
04438       first = let_values_symbol;
04439       first = scheme_datum_to_syntax(first, form, scheme_sys_wraps(origenv), 0, 0);
04440       
04441       if (SCHEME_STX_NULLP(vr)) {
04442        /* Don't create redundant empty let form */
04443       } else {
04444        last = let_star_values_symbol;
04445        last = scheme_datum_to_syntax(last, form, scheme_sys_wraps(origenv), 0, 0);
04446        body = cons(cons(last, cons(vr, body)),
04447                    scheme_null);
04448       }
04449       
04450       body = cons(first,
04451                  cons(cons(a, scheme_null),
04452                       body));
04453     } else {
04454       first = scheme_datum_to_syntax(let_values_symbol, form, scheme_sys_wraps(origenv), 0, 0);
04455       body = cons(first, cons(scheme_null, body));
04456     }
04457     
04458     body = scheme_datum_to_syntax(body, form, form, 0, -1);
04459 
04460     first = SCHEME_STX_CAR(form);
04461     body = scheme_stx_track(body, form, first);
04462     
04463     if (erec[drec].depth > 0)
04464       --erec[drec].depth;
04465     
04466     if (!erec[drec].depth)
04467       return body;
04468     else {
04469       env = scheme_no_defines(origenv);
04470       return scheme_expand_expr(body, env, erec, drec);
04471     }
04472   }
04473   
04474   /* Note: no more letstar handling needed after this point */
04475   if (!env_already && !rec_env_already)
04476     scheme_begin_dup_symbol_check(&r, origenv);
04477 
04478   vlist = scheme_null;
04479   vs = vars;
04480   while (SCHEME_STX_PAIRP(vs)) {
04481     Scheme_Object *v2;
04482     v = SCHEME_STX_CAR(vs);
04483     if (SCHEME_STX_PAIRP(v))
04484       v2 = SCHEME_STX_CDR(v);
04485     else
04486       v2 = scheme_false;
04487     if (!SCHEME_STX_PAIRP(v2) || !SCHEME_STX_NULLP(SCHEME_STX_CDR(v2)))
04488       scheme_wrong_syntax(NULL, v, form, NULL);
04489 
04490     name = SCHEME_STX_CAR(v);
04491   
04492     {
04493       DupCheckRecord r2;
04494       Scheme_Object *names = name;
04495       if (!env_already && !rec_env_already)
04496         scheme_begin_dup_symbol_check(&r2, origenv);
04497       while (SCHEME_STX_PAIRP(names)) {
04498        name = SCHEME_STX_CAR(names);
04499 
04500        scheme_check_identifier(NULL, name, NULL, origenv, form);
04501        vlist = cons(name, vlist);
04502 
04503         if (!env_already && !rec_env_already) {
04504           scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form);
04505           scheme_dup_symbol_check(&r, NULL, name, "binding", form);
04506         }
04507        
04508        names = SCHEME_STX_CDR(names);
04509       }
04510       if (!SCHEME_STX_NULLP(names))
04511        scheme_wrong_syntax(NULL, names, form, NULL);
04512     }
04513 
04514     vs = SCHEME_STX_CDR(vs);
04515   }
04516 
04517   if (!SCHEME_STX_NULLP(vs))
04518     scheme_wrong_syntax(NULL, vs, form, NULL);
04519 
04520   if (env_already)
04521     env = env_already;
04522   else
04523     env = scheme_add_compilation_frame(vlist, 
04524                                        origenv, 
04525                                        (rec_env_already ? SCHEME_INTDEF_SHADOW : 0),
04526                                        erec[drec].certs);
04527 
04528   if (letrec)
04529     use_env = env;
04530   else
04531     use_env = scheme_no_defines(origenv);
04532 
04533   /* Pass 1: Rename */
04534 
04535   first = last = NULL;
04536   vs = vars;
04537   while (SCHEME_STX_PAIRP(vars)) {
04538     Scheme_Object *rhs;
04539 
04540     v = SCHEME_STX_CAR(vars);
04541 
04542     /* Make sure names gets their own renames: */
04543     name = SCHEME_STX_CAR(v);
04544     name = scheme_add_env_renames(name, env, origenv);
04545 
04546     rhs = SCHEME_STX_CDR(v);
04547     rhs = SCHEME_STX_CAR(rhs);
04548     rhs = scheme_add_env_renames(rhs, use_env, origenv);
04549     
04550     v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1);
04551     v = cons(v, scheme_null);
04552 
04553     if (!first)
04554       first = v;
04555     else
04556       SCHEME_CDR(last) = v;
04557 
04558     last = v;
04559     vars = SCHEME_STX_CDR(vars);
04560   }
04561   if (!first) {
04562     first = scheme_null;
04563   }
04564   vars = first;
04565 
04566   body = scheme_datum_to_syntax(body, form, form, 0, 0);
04567   body = scheme_add_env_renames(body, env, origenv);
04568   SCHEME_EXPAND_OBSERVE_LET_RENAMES(erec[drec].observer, vars, body);
04569 
04570   /* Pass 2: Expand */
04571 
04572   first = last = NULL;
04573   while (SCHEME_STX_PAIRP(vars)) {
04574     Scheme_Object *rhs, *rhs_name;
04575 
04576     SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
04577 
04578     v = SCHEME_STX_CAR(vars);
04579 
04580     name = SCHEME_STX_CAR(v);
04581     rhs = SCHEME_STX_CDR(v);
04582     rhs = SCHEME_STX_CAR(rhs);
04583     
04584     if (SCHEME_STX_PAIRP(name) && SCHEME_STX_NULLP(SCHEME_STX_CDR(name))) {
04585       rhs_name = SCHEME_STX_CAR(name);
04586     } else {
04587       rhs_name = scheme_false;
04588     }
04589 
04590     scheme_init_expand_recs(erec, drec, &erec1, 1);
04591     erec1.value_name = rhs_name;
04592     rhs = scheme_expand_expr(rhs, use_env, &erec1, 0);
04593 
04594     v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1);
04595     v = cons(v, scheme_null);
04596 
04597     if (!first)
04598       first = v;
04599     else
04600       SCHEME_CDR(last) = v;
04601 
04602     last = v;
04603 
04604     vars = SCHEME_STX_CDR(vars);
04605   }
04606 
04607   /* End Pass 2 */
04608 
04609   if (!SCHEME_STX_NULLP(vars))
04610     scheme_wrong_syntax(NULL, vars, form, NULL);
04611   
04612   if (!first)
04613     first = scheme_null;
04614 
04615   first = scheme_datum_to_syntax(first, vs, vs, 0, 1);
04616   
04617   SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer);
04618   scheme_init_expand_recs(erec, drec, &erec1, 1);
04619   erec1.value_name = erec[drec].value_name;
04620   body = scheme_expand_block(body, env, &erec1, 0);
04621   
04622   v = SCHEME_STX_CAR(form);
04623   v = cons(v, cons(first, body));
04624   v = scheme_datum_to_syntax(v, form, form, 0, 2);
04625 
04626   return v;
04627 }
04628 
04629 static Scheme_Object *
04630 let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
04631 {
04632   SCHEME_EXPAND_OBSERVE_PRIM_LET_VALUES(erec[drec].observer);
04633   return do_let_expand(form, env, erec, drec, "let-values", 0, 1, 0, NULL);
04634 }
04635 
04636 static Scheme_Object *
04637 let_star_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
04638 {
04639   SCHEME_EXPAND_OBSERVE_PRIM_LETSTAR_VALUES(erec[drec].observer);
04640   return do_let_expand(form, env, erec, drec, "let*-values", 0, 1, 1, NULL);
04641 }
04642 
04643 static Scheme_Object *
04644 letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
04645 {
04646   SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(erec[drec].observer);
04647   return do_let_expand(form, env, erec, drec, "letrec-values", 1, 1, 0, NULL);
04648 }
04649 
04650 
04651 static Scheme_Object *
04652 let_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, 
04653                  Scheme_Compile_Info *rec, int drec)
04654 {
04655   return gen_let_syntax(form, env, "let-values", 0, 0, 1, rec, drec, NULL);
04656 }
04657 
04658 static Scheme_Object *
04659 let_star_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, 
04660                Scheme_Compile_Info *rec, int drec)
04661 {
04662   return gen_let_syntax(form, env, "let*-values", 1, 0, 1, rec, drec, NULL);
04663 }
04664 
04665 static Scheme_Object *
04666 letrec_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
04667 {
04668   return gen_let_syntax(form, env, "letrec-values", 0, 1, 1, rec, drec, NULL);
04669 }
04670 
04671 /**********************************************************************/
04672 /*                   begin, begin0, implicit begins                   */
04673 /**********************************************************************/
04674 
04675 Scheme_Object *scheme_compile_sequence(Scheme_Object *forms,
04676                                    Scheme_Comp_Env *env, 
04677                                    Scheme_Compile_Info *rec, int drec)
04678 {
04679 #if 0
04680   /* This attempt at a shortcut is wrong, because the sole expression might expand
04681      to a `begin' that needs to be spliced into an internal-definition context. */
04682  try_again:
04683 
04684   if (SCHEME_STX_PAIRP(forms) && SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) {
04685     /* If it's a begin, we have to check some more... */
04686     Scheme_Object *first, *val;
04687 
04688     first = SCHEME_STX_CAR(forms);
04689     first = scheme_check_immediate_macro(first, env, rec, drec, 1, &val, NULL, NULL);
04690 
04691     if (SAME_OBJ(val, scheme_begin_syntax) && SCHEME_STX_PAIRP(first)) {      
04692       /* Flatten begin: */
04693       if (scheme_stx_proper_list_length(first) > 1) {
04694         Scheme_Object *rest;
04695         rest = scheme_flatten_begin(first, scheme_null);
04696         first = scheme_datum_to_syntax(rest, first, first, 0, 2);
04697         forms = first;
04698         goto try_again;
04699       }
04700     }
04701 
04702     return scheme_compile_expr(first, env, rec, drec);
04703   }
04704 #endif
04705 
04706   if (scheme_stx_proper_list_length(forms) < 0) {
04707     scheme_wrong_syntax(scheme_begin_stx_string, NULL, 
04708                         scheme_datum_to_syntax(cons(begin_symbol, forms), forms, forms, 0, 0),
04709                         "bad syntax (" IMPROPER_LIST_FORM ")");
04710     return NULL;
04711   } else {
04712     Scheme_Object *body;
04713     body = scheme_compile_block(forms, env, rec, drec);
04714     return scheme_make_sequence_compilation(body, 1);
04715   }
04716 }
04717 
04718 Scheme_Object *scheme_compiled_void()
04719 {
04720   return scheme_void;
04721 }
04722 
04723 static Scheme_Object *
04724 begin0_execute(Scheme_Object *obj)
04725 {
04726   Scheme_Object *v, **mv;
04727   int i, mc, apos;
04728   
04729   i = ((Scheme_Sequence *)obj)->count;
04730 
04731   v = _scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[0]);
04732   i--;
04733   if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
04734     Scheme_Thread *p = scheme_current_thread;
04735     mv = p->ku.multiple.array;
04736     mc = p->ku.multiple.count;
04737     if (SAME_OBJ(mv, p->values_buffer))
04738       p->values_buffer = NULL;
04739   } else {
04740     mv = NULL;
04741     mc = 0; /* makes compilers happy */
04742   }
04743 
04744   apos = 1;
04745   while (i--) {
04746     (void)_scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[apos++]);
04747   }
04748 
04749   if (mv) {
04750     Scheme_Thread *p = scheme_current_thread;
04751     p->ku.multiple.array = mv;
04752     p->ku.multiple.count = mc;
04753   }
04754 
04755   return v;
04756 }
04757 
04758 static Scheme_Object *begin0_jit(Scheme_Object *data)
04759 {
04760   Scheme_Sequence *seq = (Scheme_Sequence *)data, *seq2;
04761   Scheme_Object *old, *naya = NULL;
04762   int i, j, count;
04763 
04764   count = seq->count;
04765   for (i = 0; i < count; i++) {
04766     old = seq->array[i];
04767     naya = scheme_jit_expr(old);
04768     if (!SAME_OBJ(old, naya))
04769       break;
04770   }
04771 
04772   if (i >= count)
04773     return data;
04774 
04775   seq2 = (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence)
04776                                            + (count - 1) 
04777                                            * sizeof(Scheme_Object *));
04778   seq2->so.type = scheme_begin0_sequence_type;
04779   seq2->count = count;
04780   for (j = 0; j < i; j++) {
04781     seq2->array[j] = seq->array[j];
04782   }
04783   seq2->array[i] = naya;
04784   for (i++; i < count; i++) {
04785     old = seq->array[i];
04786     naya = scheme_jit_expr(old);
04787     seq2->array[i] = naya;
04788   }
04789   
04790   return (Scheme_Object *)seq2;
04791 }
04792 
04793 static void begin0_validate(Scheme_Object *data, Mz_CPort *port, 
04794                             char *stack, Validate_TLS tls,
04795                          int depth, int letlimit, int delta, 
04796                             int num_toplevels, int num_stxes, int num_lifts,
04797                             struct Validate_Clearing *vc, int tailpos)
04798 {
04799   Scheme_Sequence *seq = (Scheme_Sequence *)data;
04800   int i;
04801 
04802   if (!SAME_TYPE(SCHEME_TYPE(seq), scheme_begin0_sequence_type)
04803       && !SAME_TYPE(SCHEME_TYPE(seq), scheme_sequence_type))
04804     scheme_ill_formed_code(port);
04805 
04806   for (i = 0; i < seq->count; i++) { 
04807     scheme_validate_expr(port, seq->array[i], stack, tls,
04808                          depth, letlimit, delta, 
04809                          num_toplevels, num_stxes, num_lifts,
04810                          NULL, 0, i > 0, vc, 0);
04811   }
04812 }
04813 
04814 static Scheme_Object *
04815 begin0_optimize(Scheme_Object *obj, Optimize_Info *info)
04816 {
04817   int i;
04818   
04819   i = ((Scheme_Sequence *)obj)->count;
04820 
04821   while (i--) {
04822     Scheme_Object *le;
04823     le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info);
04824     ((Scheme_Sequence *)obj)->array[i] = le;
04825   }
04826 
04827   /* Optimization of expression 0 has already set single_result */
04828   info->preserves_marks = 1;
04829 
04830   return scheme_make_syntax_compiled(BEGIN0_EXPD, obj);
04831 }
04832 
04833 static Scheme_Object *
04834 begin0_clone(int dup_ok, Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth)
04835 {
04836   obj = scheme_optimize_clone(dup_ok, obj, info, delta, closure_depth);
04837   if (!obj) return NULL;
04838   return scheme_make_syntax_compiled(BEGIN0_EXPD, obj);
04839 }
04840 
04841 static Scheme_Object *begin0_shift(Scheme_Object *obj, int delta, int after_depth)
04842 {
04843   int i;
04844   
04845   i = ((Scheme_Sequence *)obj)->count;
04846 
04847   while (i--) {
04848     Scheme_Object *le;
04849     le = scheme_optimize_shift(((Scheme_Sequence *)obj)->array[i], delta, after_depth);
04850     ((Scheme_Sequence *)obj)->array[i] = le;
04851   }
04852 
04853   return scheme_make_syntax_compiled(BEGIN0_EXPD, obj);
04854 }
04855 
04856 static Scheme_Object *
04857 begin0_resolve(Scheme_Object *obj, Resolve_Info *info)
04858 {
04859   int i;
04860   
04861   i = ((Scheme_Sequence *)obj)->count;
04862 
04863   while (i--) {
04864     Scheme_Object *le;
04865     le = scheme_resolve_expr(((Scheme_Sequence *)obj)->array[i], info);
04866     ((Scheme_Sequence *)obj)->array[i] = le;
04867   }
04868 
04869   return scheme_make_syntax_resolved(BEGIN0_EXPD, obj);
04870 }
04871 
04872 static Scheme_Object *
04873 begin0_sfs(Scheme_Object *obj, SFS_Info *info)
04874 {
04875   int i, cnt;
04876   
04877   cnt = ((Scheme_Sequence *)obj)->count;
04878 
04879   scheme_sfs_start_sequence(info, cnt, 0);
04880 
04881   for (i = 0; i < cnt; i++) {
04882     Scheme_Object *le;
04883     le = scheme_sfs_expr(((Scheme_Sequence *)obj)->array[i], info, -1);
04884     ((Scheme_Sequence *)obj)->array[i] = le;
04885   }
04886 
04887   return obj;
04888 }
04889 
04890 static Scheme_Object *
04891 do_begin_syntax(char *name,
04892               Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, 
04893               int zero)
04894 {
04895   Scheme_Object *forms, *body;
04896 
04897   forms = SCHEME_STX_CDR(form);
04898   
04899   if (SCHEME_STX_NULLP(forms)) {
04900     if (!zero && scheme_is_toplevel(env))
04901       return scheme_compiled_void();
04902     scheme_wrong_syntax(NULL, NULL, form, "bad syntax (empty form)");
04903     return NULL;
04904   }
04905 
04906   check_form(form, form);
04907 
04908   if (zero)
04909     env = scheme_no_defines(env);
04910 
04911   if (SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) {
04912     scheme_rec_add_certs(rec, drec, form);
04913     forms = SCHEME_STX_CAR(forms);
04914     return scheme_compile_expr(forms, env, rec, drec);
04915   }
04916 
04917   if (!scheme_is_toplevel(env)) {
04918     /* Not at top-level */
04919     if (zero) {
04920       /* First expression is not part of the block: */
04921       Scheme_Compile_Info recs[2];
04922       Scheme_Object *first, *rest, *vname;
04923 
04924       vname = rec[drec].value_name;
04925       scheme_compile_rec_done_local(rec, drec);
04926 
04927       vname = scheme_check_name_property(form, vname);
04928 
04929       scheme_rec_add_certs(rec, drec, form);
04930 
04931       scheme_init_compile_recs(rec, drec, recs, 2);
04932       recs[0].value_name = vname;
04933 
04934       first = SCHEME_STX_CAR(forms);
04935       first = scheme_compile_expr(first, env, recs, 0);
04936       rest = SCHEME_STX_CDR(forms);
04937       rest = scheme_compile_list(rest, env, recs, 1);
04938       
04939       scheme_merge_compile_recs(rec, drec, recs, 2);
04940 
04941       body = cons(first, rest);
04942     } else {
04943       Scheme_Object *v;
04944       v = scheme_check_name_property(form, rec[drec].value_name);
04945       rec[drec].value_name = v;
04946       scheme_rec_add_certs(rec, drec, form);
04947 
04948       body = scheme_compile_list(forms, env, rec, drec);
04949     }
04950   } else {
04951     /* Top level */
04952     scheme_rec_add_certs(rec, drec, form);
04953     body = scheme_compile_list(forms, env, rec, drec);
04954   }
04955 
04956   forms = scheme_make_sequence_compilation(body, zero ? -1 : 1);
04957 
04958   if (!zero
04959       && SAME_TYPE(SCHEME_TYPE(forms), scheme_sequence_type)
04960       && scheme_is_toplevel(env)) {
04961     return scheme_make_syntax_compiled(SPLICE_EXPD, forms);
04962   }
04963 
04964   if (!zero || (NOT_SAME_TYPE(SCHEME_TYPE(forms), scheme_begin0_sequence_type)))
04965     return forms;
04966 
04967   return scheme_make_syntax_compiled(BEGIN0_EXPD, forms);
04968 }
04969 
04970 static Scheme_Object *
04971 begin_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
04972 {
04973   return do_begin_syntax("begin", form, env, rec, drec, 0);
04974 }
04975 
04976 static Scheme_Object *
04977 begin0_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
04978 {
04979   return do_begin_syntax("begin0", form, env, rec, drec, 1);
04980 }
04981 
04982 static Scheme_Object *
04983 do_begin_expand(char *name,
04984               Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec,
04985               int zero)
04986 {
04987   Scheme_Object *form_name;
04988   Scheme_Object *rest;
04989   Scheme_Object *orig_form = form;
04990 
04991   check_form(form, form);
04992 
04993   form_name = SCHEME_STX_CAR(form);
04994 
04995   rest = SCHEME_STX_CDR(form);
04996 
04997   if (SCHEME_STX_NULLP(rest)) {
04998     if (!zero && scheme_is_toplevel(env)) {
04999       SCHEME_EXPAND_OBSERVE_ENTER_LIST(erec[drec].observer, form);
05000       SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form);
05001       return form;
05002     }
05003     scheme_wrong_syntax(NULL, NULL, form, "bad syntax (empty form)");
05004     return NULL;
05005   }
05006 
05007   if (zero)
05008     env = scheme_no_defines(env);
05009 
05010   if (!scheme_is_toplevel(env)) {
05011     /* Not at top-level: */
05012     if (zero) {
05013       Scheme_Object *fst, *boundname;
05014       Scheme_Expand_Info erec1;
05015       scheme_rec_add_certs(erec, drec, form);
05016       scheme_init_expand_recs(erec, drec, &erec1, 1);
05017       boundname = scheme_check_name_property(form, erec[drec].value_name);
05018       erec1.value_name = boundname;
05019       erec[drec].value_name = scheme_false;
05020       fst = SCHEME_STX_CAR(rest);
05021       rest = SCHEME_STX_CDR(rest);
05022 
05023       SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
05024       fst = scheme_expand_expr(fst, env, &erec1, 0);
05025       rest = scheme_datum_to_syntax(rest, form, form, 0, 0);
05026       SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
05027       rest = scheme_expand_list(rest, env, erec, drec);
05028 
05029       form = cons(fst, rest);
05030     } else {
05031       Scheme_Object *boundname;
05032       boundname = scheme_check_name_property(form, erec[drec].value_name);
05033       erec[drec].value_name = boundname;
05034       scheme_rec_add_certs(erec, drec, form);
05035       
05036       form = scheme_expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0),
05037                             env, erec, drec);
05038 #if 0
05039       if (SCHEME_STX_NULLP(SCHEME_STX_CDR(form)))
05040        return SCHEME_STX_CAR(form);
05041 #endif
05042     }
05043   } else {
05044     /* Top level */
05045     scheme_rec_add_certs(erec, drec, form);
05046     form =  scheme_expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0),
05047                             env, erec, drec);
05048   }
05049 
05050   return scheme_datum_to_syntax(cons(form_name, form), 
05051                             orig_form, orig_form, 
05052                             0, 2);
05053 }
05054 
05055 static Scheme_Object *
05056 begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
05057 {
05058   SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(erec[drec].observer);
05059   return do_begin_expand("begin", form, env, erec, drec, 0);
05060 }
05061 
05062 static Scheme_Object *
05063 begin0_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
05064 {
05065   SCHEME_EXPAND_OBSERVE_PRIM_BEGIN0(erec[drec].observer);
05066   return do_begin_expand("begin0", form, env, erec, drec, 1);
05067 }
05068 
05069 /**********************************************************************/
05070 /*                    top-level splicing begin                        */
05071 /**********************************************************************/
05072 
05073 static Scheme_Object *splice_one_expr(void *expr, int argc, Scheme_Object **argv)
05074 {
05075   return _scheme_eval_linked_expr_multi((Scheme_Object *)expr);
05076 }
05077 
05078 static Scheme_Object *splice_execute(Scheme_Object *data)
05079 {
05080   if (SAME_TYPE(SCHEME_TYPE(data), scheme_sequence_type)) {
05081     Scheme_Sequence *seq = (Scheme_Sequence *)data;
05082     int i, cnt = seq->count - 1;
05083     
05084     for (i = 0; i < cnt; i++) {
05085       (void)_scheme_call_with_prompt_multi(splice_one_expr, seq->array[i]);
05086     }
05087     
05088     return _scheme_eval_linked_expr_multi(seq->array[cnt]);
05089   } else {
05090     /* sequence was optimized on read? */
05091     return _scheme_eval_linked_expr_multi(data);
05092   }
05093 }
05094 
05095 static Scheme_Object *splice_jit(Scheme_Object *data)
05096 {
05097   return scheme_jit_expr(data);
05098 }
05099 
05100 static Scheme_Object *
05101 splice_optimize(Scheme_Object *data, Optimize_Info *info)
05102 {
05103   data = scheme_optimize_expr(data, info);
05104   
05105   if (SCHEME_TYPE(data) != scheme_sequence_type)
05106     return data;
05107 
05108   return scheme_make_syntax_compiled(SPLICE_EXPD, data);
05109 }
05110 
05111 static Scheme_Object *
05112 splice_resolve(Scheme_Object *data, Resolve_Info *rslv)
05113 {
05114   return scheme_make_syntax_resolved(SPLICE_EXPD, 
05115                                      scheme_resolve_expr(data, rslv));
05116 }
05117 
05118 static Scheme_Object *
05119 splice_sfs(Scheme_Object *data, SFS_Info *info)
05120 {
05121   Scheme_Object *naya;
05122   naya = scheme_sfs_expr(data, info, -1);
05123   if (SAME_OBJ(naya, data))
05124     return data;
05125   else
05126     return scheme_make_syntax_resolved(SPLICE_EXPD, data);
05127 }
05128 
05129 static Scheme_Object *
05130 splice_shift(Scheme_Object *data, int delta, int after_depth)
05131 {
05132   return scheme_make_syntax_compiled(SPLICE_EXPD,
05133                                      scheme_optimize_shift(data, delta, after_depth));
05134 }
05135 
05136 static Scheme_Object *
05137 splice_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
05138 {
05139   data = scheme_optimize_clone(dup_ok, data, info, delta, closure_depth);
05140   if (!data) return NULL;
05141   return scheme_make_syntax_compiled(SPLICE_EXPD, data);
05142 }
05143 
05144 static void splice_validate(Scheme_Object *data, Mz_CPort *port, 
05145                             char *stack, Validate_TLS tls,
05146                             int depth, int letlimit, int delta, 
05147                             int num_toplevels, int num_stxes, int num_lifts,
05148                             struct Validate_Clearing *vc, int tailpos)
05149 {
05150   scheme_validate_expr(port, data, stack, tls,
05151                        depth, letlimit, delta, 
05152                        num_toplevels, num_stxes, num_lifts,
05153                        NULL, 0, 0, vc, 0);
05154 }
05155 
05156 /**********************************************************************/
05157 /*                    #%non-module and #%expression                   */
05158 /**********************************************************************/
05159 
05160 static Scheme_Object *check_single(Scheme_Object *form, Scheme_Comp_Env *top_only)
05161 {
05162   Scheme_Object *rest;
05163 
05164   check_form(form, form);
05165 
05166   rest = SCHEME_STX_CDR(form);
05167   if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))))
05168     scheme_wrong_syntax(NULL, NULL, form, "bad syntax (wrong number of parts)");
05169 
05170   if (top_only && !scheme_is_toplevel(top_only))
05171     scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)");
05172 
05173   return SCHEME_STX_CAR(rest);
05174 }
05175 
05176 static Scheme_Object *
05177 single_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int top_only)
05178 {
05179   scheme_rec_add_certs(rec, drec, form);
05180   return scheme_compile_expr(check_single(form, top_only ? env: NULL), env, rec, drec);
05181 }
05182 
05183 static Scheme_Object *
05184 single_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec, 
05185               int top_only, int simplify)
05186 {
05187   Scheme_Object *expr, *form_name;
05188 
05189   scheme_rec_add_certs(erec, drec, form);
05190 
05191   expr = check_single(form, top_only ? env : NULL);
05192   expr = scheme_expand_expr(expr, env, erec, drec);
05193 
05194   form_name = SCHEME_STX_CAR(form);
05195 
05196   if (simplify && (erec[drec].depth == -1)) {
05197     /* FIXME: this needs EXPAND_OBSERVE callbacks. */
05198     expr = scheme_stx_track(expr, form, form_name);
05199     expr = scheme_stx_cert(expr, scheme_false, NULL, form, NULL, 1);
05200     SCHEME_EXPAND_OBSERVE_TAG(erec[drec].observer,expr);
05201     return expr;
05202   }
05203 
05204   return scheme_datum_to_syntax(cons(form_name, cons(expr, scheme_null)), 
05205                             form, form,
05206                             0, 2);
05207 }
05208 
05209 static Scheme_Object *expression_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
05210 {
05211   return single_syntax(form, scheme_no_defines(env), rec, drec, 0);
05212 }
05213 
05214 static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
05215 {
05216   SCHEME_EXPAND_OBSERVE_PRIM_EXPRESSION(erec[drec].observer);
05217   return single_expand(form, scheme_no_defines(env), erec, drec, 0,
05218                        !(env->flags & SCHEME_TOPLEVEL_FRAME));
05219 }
05220 
05221 
05222 /**********************************************************************/
05223 /*                      unquote, unquote-splicing                     */
05224 /**********************************************************************/
05225 
05226 static Scheme_Object *
05227 unquote_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
05228 {
05229   int len;
05230 
05231   if (rec[drec].comp)
05232     scheme_compile_rec_done_local(rec, drec);
05233 
05234   len = check_form(form, form);
05235   if (len != 2)
05236     bad_form(form, len);
05237 
05238   scheme_wrong_syntax(NULL, NULL, form, "not in quasiquote");
05239   return NULL;
05240 }
05241 
05242 static Scheme_Object *
05243 unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
05244 {
05245   return unquote_syntax(form, env, erec, drec);
05246 }
05247 
05248 /**********************************************************************/
05249 /*                            quote-syntax                            */
05250 /**********************************************************************/
05251 
05252 static Scheme_Object *
05253 quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
05254 {
05255   int len;
05256   Scheme_Object *stx;
05257 
05258   if (rec[drec].comp)
05259     scheme_compile_rec_done_local(rec, drec);
05260 
05261   len = check_form(form, form);
05262   if (len != 2)
05263     bad_form(form, len);
05264 
05265   scheme_rec_add_certs(rec, drec, form);
05266 
05267   stx = SCHEME_STX_CDR(form);
05268   stx = SCHEME_STX_CAR(stx);
05269 
05270   /* Push all certificates in the environment down to the syntax object. */
05271   stx = scheme_stx_add_inactive_certs(stx, rec[drec].certs);
05272   if (env->genv->module && !rec[drec].no_module_cert) {
05273     /* Also certify access to the enclosing module: */
05274     stx = scheme_stx_cert(stx, scheme_false, env->genv, NULL, NULL, 0);
05275   }
05276   
05277   if (rec[drec].comp) {
05278     return scheme_register_stx_in_prefix(stx, env, rec, drec);
05279   } else {
05280     Scheme_Object *fn;
05281     fn = SCHEME_STX_CAR(form);
05282     return scheme_datum_to_syntax(cons(fn, cons(stx, scheme_null)),
05283                               form,
05284                               form, 
05285                               0, 2);
05286   }
05287 }
05288 
05289 static Scheme_Object *
05290 quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
05291 {
05292   SCHEME_EXPAND_OBSERVE_PRIM_QUOTE_SYNTAX(erec[drec].observer);
05293   return quote_syntax_syntax(form, env, erec, drec);
05294 }
05295 
05296 
05297 /**********************************************************************/
05298 /*                          define-syntaxes                           */
05299 /**********************************************************************/
05300 
05301 static Scheme_Object *do_define_syntaxes_execute(Scheme_Object *expr, Scheme_Env *dm_env, int for_stx);
05302 
05303 static void *define_syntaxes_execute_k(void)
05304 {
05305   Scheme_Thread *p = scheme_current_thread;
05306   Scheme_Object *form = p->ku.k.p1;
05307   Scheme_Env *dm_env = (Scheme_Env *)p->ku.k.p2;
05308   p->ku.k.p1 = NULL;
05309   p->ku.k.p2 = NULL;
05310   return do_define_syntaxes_execute(form, dm_env, p->ku.k.i1);
05311 }
05312 
05313 static Scheme_Object *
05314 do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx)
05315 {
05316   Scheme_Thread *p = scheme_current_thread;
05317   Resolve_Prefix *rp;
05318   Scheme_Object *base_stack_depth, *dummy;
05319   int depth;
05320   Scheme_Comp_Env *rhs_env;
05321 
05322   rp = (Resolve_Prefix *)SCHEME_VEC_ELS(form)[1];
05323   base_stack_depth = SCHEME_VEC_ELS(form)[2];
05324 
05325   depth = SCHEME_INT_VAL(base_stack_depth) + rp->num_stxes + 1;
05326   if (!scheme_check_runstack(depth)) {
05327     p->ku.k.p1 = form;
05328 
05329     if (!dm_env) {
05330       /* Need to get env before we enlarge the runstack: */
05331       dummy = SCHEME_VEC_ELS(form)[3];
05332       dm_env = scheme_environment_from_dummy(dummy);
05333     }
05334     p->ku.k.p2 = (Scheme_Object *)dm_env;
05335     p->ku.k.i1 = for_stx;
05336 
05337     return (Scheme_Object *)scheme_enlarge_runstack(depth, define_syntaxes_execute_k);
05338   }
05339 
05340   dummy = SCHEME_VEC_ELS(form)[3];
05341 
05342   rhs_env = scheme_new_comp_env(scheme_get_env(NULL), NULL, SCHEME_TOPLEVEL_FRAME);
05343 
05344   if (!dm_env)
05345     dm_env = scheme_environment_from_dummy(dummy);
05346 
05347   {
05348     Scheme_Dynamic_State dyn_state;
05349     Scheme_Cont_Frame_Data cframe;
05350     Scheme_Config *config;
05351     Scheme_Object *result;
05352 
05353     scheme_prepare_exp_env(dm_env);
05354 
05355     config = scheme_extend_config(scheme_current_config(),
05356                               MZCONFIG_ENV,
05357                               (Scheme_Object *)dm_env->exp_env);
05358     scheme_push_continuation_frame(&cframe);
05359     scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
05360 
05361     scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, NULL, dm_env, dm_env->link_midx);
05362     result = define_execute_with_dynamic_state(form, 4, for_stx ? 2 : 1, rp, dm_env, &dyn_state);
05363 
05364     scheme_pop_continuation_frame(&cframe);
05365 
05366     return result;
05367   }
05368 }
05369 
05370 static Scheme_Object *
05371 define_syntaxes_execute(Scheme_Object *form)
05372 {
05373   return do_define_syntaxes_execute(form, NULL, 0);
05374 }
05375 
05376 static Scheme_Object *
05377 define_for_syntaxes_execute(Scheme_Object *form)
05378 {
05379   return do_define_syntaxes_execute(form, NULL, 1);
05380 }
05381 
05382 static Scheme_Object *do_define_syntaxes_jit(Scheme_Object *expr, int jit)
05383 {
05384   Resolve_Prefix *rp, *orig_rp;
05385   Scheme_Object *naya, *rhs;
05386   
05387   rhs = SCHEME_VEC_ELS(expr)[0];
05388   if (jit)
05389     naya = scheme_jit_expr(rhs);
05390   else
05391     naya = rhs;
05392 
05393   orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1];
05394   rp = scheme_prefix_eval_clone(orig_rp);
05395   
05396   if (SAME_OBJ(naya, rhs)
05397       && SAME_OBJ(orig_rp, rp))
05398     return expr;
05399   else {
05400     expr = clone_vector(expr, 0);
05401     SCHEME_VEC_ELS(expr)[0] = naya;
05402     SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp;
05403     return expr;
05404   }
05405 }
05406 
05407 static Scheme_Object *define_syntaxes_jit(Scheme_Object *expr)
05408 {
05409   return do_define_syntaxes_jit(expr, 1);
05410 }
05411 
05412 static Scheme_Object *define_for_syntaxes_jit(Scheme_Object *expr)
05413 {
05414   return do_define_syntaxes_jit(expr, 1);
05415 }
05416 
05417 Scheme_Object *scheme_syntaxes_eval_clone(Scheme_Object *expr)
05418 {
05419   return do_define_syntaxes_jit(expr, 0);
05420 }
05421 
05422 static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, 
05423                                    char *stack, Validate_TLS tls,
05424                                         int depth, int letlimit, int delta, 
05425                                    int num_toplevels, int num_stxes, int num_lifts,
05426                                    int for_stx)
05427 {
05428   Resolve_Prefix *rp;
05429   Scheme_Object *name, *val, *base_stack_depth, *dummy;
05430   int sdepth;
05431 
05432   if (!SCHEME_VECTORP(data)
05433       || (SCHEME_VEC_SIZE(data) < 4))
05434     scheme_ill_formed_code(port);
05435 
05436   rp = (Resolve_Prefix *)SCHEME_VEC_ELS(data)[1];
05437   base_stack_depth = SCHEME_VEC_ELS(data)[2];
05438   sdepth = SCHEME_INT_VAL(base_stack_depth);
05439 
05440   if (!SAME_TYPE(rp->so.type, scheme_resolve_prefix_type)
05441       || (sdepth < 0))
05442     scheme_ill_formed_code(port);
05443 
05444   dummy = SCHEME_VEC_ELS(data)[3];
05445 
05446   if (!for_stx) {
05447     int i, size;
05448     size = SCHEME_VEC_SIZE(data);
05449     for (i = 4; i < size; i++) {
05450       name = SCHEME_VEC_ELS(data)[i];
05451       if (!SCHEME_SYMBOLP(name)) {
05452        scheme_ill_formed_code(port);
05453       }
05454     }
05455   }
05456 
05457   scheme_validate_toplevel(dummy, port, stack, tls, depth, delta, 
05458                            num_toplevels, num_stxes, num_lifts,
05459                            0);
05460   
05461   if (!for_stx) {
05462     scheme_validate_code(port, SCHEME_VEC_ELS(data)[0], sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, 0);
05463   } else {
05464     /* Make a fake `define-values' to check with respect to the exp-time stack */
05465     val = clone_vector(data, 3);
05466     SCHEME_VEC_ELS(val)[0] = SCHEME_VEC_ELS(data)[0];
05467     val = scheme_make_syntax_resolved(DEFINE_VALUES_EXPD, val);
05468     scheme_validate_code(port, val, sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, 0);
05469   }
05470 }
05471 
05472 static void define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, 
05473                                  char *stack, Validate_TLS tls,
05474                                      int depth, int letlimit, int delta, 
05475                                  int num_toplevels, int num_stxes, int num_lifts,
05476                                      struct Validate_Clearing *vc, int tailpos)
05477 {
05478   do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, 
05479                               num_toplevels, num_stxes, num_lifts, 0);
05480 }
05481 
05482 static void define_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, 
05483                                     char *stack, Validate_TLS tls,
05484                                          int depth, int letlimit, int delta, 
05485                                     int num_toplevels, int num_stxes, int num_lifts,
05486                                          struct Validate_Clearing *vc, int tailpos)
05487 {
05488   do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, 
05489                               num_toplevels, num_stxes, num_lifts, 1);
05490 }
05491 
05492 static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int for_stx)
05493 {
05494   Scheme_Object *cp, *names, *val, *dummy;
05495   Optimize_Info *einfo;
05496 
05497   cp = SCHEME_CAR(data);
05498   data = SCHEME_CDDR(data);
05499   dummy = SCHEME_CAR(data);
05500   data = SCHEME_CDR(data);
05501 
05502   names = SCHEME_CAR(data);
05503   val = SCHEME_CDR(data);
05504 
05505   einfo = scheme_optimize_info_create();
05506   if (info->inline_fuel < 0)
05507     einfo->inline_fuel = -1;
05508 
05509   val = scheme_optimize_expr(val, einfo);
05510 
05511   return scheme_make_syntax_compiled((for_stx ? DEFINE_FOR_SYNTAX_EXPD : DEFINE_SYNTAX_EXPD), 
05512                                  cons(cp,
05513                                           cons(dummy,
05514                                                cons(names, val))));
05515 }
05516 
05517 static Scheme_Object *define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info)
05518 {
05519   return do_define_syntaxes_optimize(data, info, 0);
05520 }
05521 
05522 static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info)
05523 {
05524   return do_define_syntaxes_optimize(data, info, 1);
05525 }
05526 
05527 static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info, int for_stx)
05528 {
05529   Comp_Prefix *cp;
05530   Resolve_Prefix *rp;
05531   Scheme_Object *names, *val, *base_stack_depth, *dummy, *vec;
05532   Resolve_Info *einfo;
05533   int len;
05534 
05535   cp = (Comp_Prefix *)SCHEME_CAR(data);
05536   data = SCHEME_CDR(data);
05537   dummy = SCHEME_CAR(data);
05538   data = SCHEME_CDR(data);
05539 
05540   names = SCHEME_CAR(data);
05541   val = SCHEME_CDR(data);
05542 
05543   rp = scheme_resolve_prefix(1, cp, 1);
05544 
05545   dummy = scheme_resolve_expr(dummy, info);
05546 
05547   einfo = scheme_resolve_info_create(rp);
05548 
05549   if (for_stx)
05550     names = scheme_resolve_list(names, einfo);
05551   val = scheme_resolve_expr(val, einfo);
05552 
05553   rp = scheme_remap_prefix(rp, einfo);
05554 
05555   base_stack_depth = scheme_make_integer(einfo->max_let_depth);
05556 
05557   len = scheme_list_length(names);
05558   
05559   vec = scheme_make_vector(len + 4, NULL);
05560   SCHEME_VEC_ELS(vec)[0] = val;
05561   SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)rp;
05562   SCHEME_VEC_ELS(vec)[2] = base_stack_depth;
05563   SCHEME_VEC_ELS(vec)[3] = dummy;
05564 
05565   len = 4;
05566   while (SCHEME_PAIRP(names)) {
05567     SCHEME_VEC_ELS(vec)[len++] = SCHEME_CAR(names);
05568     names = SCHEME_CDR(names);
05569   }
05570 
05571   return scheme_make_syntax_resolved((for_stx ? DEFINE_FOR_SYNTAX_EXPD : DEFINE_SYNTAX_EXPD), 
05572                                  vec);
05573 }
05574 
05575 static Scheme_Object *define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info)
05576 {
05577   return do_define_syntaxes_resolve(data, info, 0);
05578 }
05579 
05580 static Scheme_Object *define_for_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info)
05581 {
05582   return do_define_syntaxes_resolve(data, info, 1);
05583 }
05584 
05585 static Scheme_Object *do_define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info)
05586 {
05587   Scheme_Object *e;
05588 
05589   if (!info->pass) {
05590     int depth;
05591     depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]);
05592     info = scheme_new_sfs_info(depth);
05593     e = scheme_sfs(SCHEME_VEC_ELS(data)[0], info, depth);
05594     SCHEME_VEC_ELS(data)[0] = e;
05595   }
05596 
05597   return data;
05598 }
05599 
05600 static Scheme_Object *define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info)
05601 {
05602   return do_define_syntaxes_sfs(data, info);
05603 }
05604 
05605 static Scheme_Object *define_for_syntaxes_sfs(Scheme_Object *data, SFS_Info *info)
05606 {
05607   return do_define_syntaxes_sfs(data, info);
05608 }
05609 
05610 static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env)
05611 {
05612   Scheme_Env *env = (Scheme_Env *)_env;
05613 
05614   return scheme_tl_id_sym(env, name, NULL, 2, NULL, NULL);
05615 }
05616 
05617 static Scheme_Object *
05618 do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, 
05619                        Scheme_Compile_Info *rec, int drec, int for_stx)
05620 {
05621   Scheme_Object *names, *code, *dummy;
05622   Scheme_Object *val;
05623   Scheme_Comp_Env *exp_env;
05624   Scheme_Compile_Info rec1;
05625 
05626   scheme_compile_rec_done_local(rec, drec);
05627   scheme_default_compile_rec(rec, drec);
05628   scheme_rec_add_certs(rec, drec, form);
05629       
05630   scheme_define_parse(form, &names, &code, 1, env, 0);
05631 
05632   scheme_prepare_exp_env(env->genv);
05633   scheme_prepare_compile_env(env->genv->exp_env);
05634 
05635   if (!for_stx)
05636     names = scheme_named_map_1(NULL, stx_val, names, (Scheme_Object *)env->genv);
05637 
05638   exp_env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
05639 
05640   dummy = scheme_make_environment_dummy(env);
05641   
05642   rec1.comp = 1;
05643   rec1.dont_mark_local_use = 0;
05644   rec1.resolve_module_ids = 0;
05645   rec1.no_module_cert = 0;
05646   rec1.value_name = NULL;
05647   rec1.certs = rec[drec].certs;
05648   rec1.observer = NULL;
05649   rec1.pre_unwrapped = 0;
05650   rec1.env_already = 0;
05651   rec1.comp_flags = rec[drec].comp_flags;
05652 
05653   if (for_stx) {
05654     names = defn_targets_syntax(names, exp_env, &rec1, 0);
05655     scheme_compile_rec_done_local(&rec1, 0);
05656   }
05657 
05658   val = scheme_compile_expr_lift_to_let(code, exp_env, &rec1, 0);
05659 
05660   return scheme_make_syntax_compiled((for_stx ? DEFINE_FOR_SYNTAX_EXPD : DEFINE_SYNTAX_EXPD), 
05661                                  cons((Scheme_Object *)exp_env->prefix, 
05662                                      cons(scheme_make_integer(0),
05663                                           cons(dummy,
05664                                               cons(names, val)))));
05665 }
05666 
05667 static Scheme_Object *
05668 define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, 
05669                      Scheme_Compile_Info *rec, int drec)
05670 {
05671   return do_define_syntaxes_syntax(form, env, rec, drec, 0);
05672 }
05673 
05674 static Scheme_Object *
05675 define_for_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, 
05676                         Scheme_Compile_Info *rec, int drec)
05677 {
05678   return do_define_syntaxes_syntax(form, env, rec, drec, 1);
05679 }
05680 
05681 static Scheme_Object *
05682 define_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
05683 {
05684   Scheme_Object *names, *code, *fpart, *fn;
05685 
05686   SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(erec[drec].observer);
05687 
05688   scheme_prepare_exp_env(env->genv);
05689   scheme_prepare_compile_env(env->genv->exp_env);
05690 
05691   scheme_define_parse(form, &names, &code, 1, env, 0);
05692   
05693   env = scheme_new_expand_env(env->genv->exp_env, env->insp, 0);
05694 
05695   scheme_rec_add_certs(erec, drec, form);
05696   erec[drec].value_name = names;
05697   fpart = scheme_expand_expr_lift_to_let(code, env, erec, drec);
05698   
05699   code = cons(fpart, scheme_null);
05700   code = cons(names, code);
05701 
05702   fn = SCHEME_STX_CAR(form);
05703   return scheme_datum_to_syntax(cons(fn, code), 
05704                             form, form, 
05705                             0, 2);
05706 }
05707 
05708 static Scheme_Object *
05709 define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
05710 {
05711   return define_syntaxes_expand(form, env, erec, drec);
05712 }
05713 
05714 Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env)
05715 { 
05716   /* Get a prefixed-based accessor for a dummy top-level bucket. It's
05717      used to "link" to the right environment at run time. The #f as
05718      a toplevel is handled in the prefix linker specially. */
05719   return scheme_register_toplevel_in_prefix(scheme_false, env, NULL, 0);
05720 }
05721 
05722 Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy)
05723 {
05724   Scheme_Object **toplevels;
05725   Scheme_Bucket_With_Home *b;
05726 
05727   toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(dummy)];
05728   b = (Scheme_Bucket_With_Home *)toplevels[SCHEME_TOPLEVEL_POS(dummy)];
05729   return b->home;
05730 }
05731 
05732 /**********************************************************************/
05733 /*                           letrec-syntaxes                          */
05734 /**********************************************************************/
05735 
05736 static void *eval_letmacro_rhs_k(void);
05737 
05738 static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Comp_Env *rhs_env, 
05739                                    int max_let_depth, Resolve_Prefix *rp,
05740                                    int phase, Scheme_Object *certs)
05741 {
05742   Scheme_Object **save_runstack;
05743   int depth;
05744 
05745   depth = max_let_depth + scheme_prefix_depth(rp);
05746   if (!scheme_check_runstack(depth)) {
05747     Scheme_Thread *p = scheme_current_thread;
05748     p->ku.k.p1 = a;
05749     p->ku.k.p2 = rhs_env;
05750     p->ku.k.p3 = rp;
05751     p->ku.k.p4 = certs;
05752     p->ku.k.i1 = max_let_depth;
05753     p->ku.k.i2 = phase;
05754     return (Scheme_Object *)scheme_enlarge_runstack(depth, eval_letmacro_rhs_k);
05755   }
05756 
05757   save_runstack = scheme_push_prefix(NULL, rp, NULL, NULL, phase, phase);
05758 
05759   if (scheme_omittable_expr(a, 1, -1, 0, NULL)) {
05760     /* short cut */
05761     a = _scheme_eval_linked_expr_multi(a);
05762   } else {
05763     Scheme_Cont_Frame_Data cframe;
05764     Scheme_Config *config;
05765     Scheme_Dynamic_State dyn_state;
05766 
05767     scheme_prepare_exp_env(rhs_env->genv);
05768     scheme_prepare_compile_env(rhs_env->genv->exp_env);
05769 
05770     config = scheme_extend_config(scheme_current_config(),
05771                                   MZCONFIG_ENV,
05772                                   (Scheme_Object *)rhs_env->genv->exp_env);
05773     scheme_push_continuation_frame(&cframe);
05774     scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
05775   
05776     scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, certs, rhs_env->genv, rhs_env->genv->link_midx);
05777     a = scheme_eval_linked_expr_multi_with_dynamic_state(a, &dyn_state);
05778     
05779     scheme_pop_continuation_frame(&cframe);
05780   }
05781 
05782   scheme_pop_prefix(save_runstack);
05783 
05784   return a;
05785 }
05786 
05787 static void *eval_letmacro_rhs_k(void)
05788 {
05789   Scheme_Thread *p = scheme_current_thread;
05790   Scheme_Object *a, *certs; 
05791   Scheme_Comp_Env *rhs_env;
05792   int max_let_depth, phase;
05793   Resolve_Prefix *rp;
05794 
05795   a = (Scheme_Object *)p->ku.k.p1;
05796   rhs_env = (Scheme_Comp_Env *)p->ku.k.p2;
05797   rp = (Resolve_Prefix *)p->ku.k.p3;
05798   certs = (Scheme_Object *)p->ku.k.p4;
05799   max_let_depth = p->ku.k.i1;
05800   phase = p->ku.k.i2;
05801 
05802   p->ku.k.p1 = NULL;
05803   p->ku.k.p2 = NULL;
05804   p->ku.k.p3 = NULL;
05805   p->ku.k.p4 = NULL;
05806 
05807   return (void *)eval_letmacro_rhs(a, rhs_env, max_let_depth, rp, phase, certs);
05808 }
05809 
05810 void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, 
05811                           Scheme_Env *exp_env, Scheme_Object *insp, 
05812                           Scheme_Compile_Expand_Info *rec, int drec,
05813                           Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env,
05814                           int *_pos, Scheme_Object *rename_rib)
05815 {
05816   Scheme_Object **results, *l, *a_expr;
05817   Scheme_Comp_Env *eenv;
05818   Scheme_Object *certs;
05819   Resolve_Prefix *rp;
05820   Resolve_Info *ri;
05821   Optimize_Info *oi;
05822   int vc, nc, j, i;
05823   Scheme_Compile_Expand_Info mrec;
05824 
05825   certs = rec[drec].certs;
05826   eenv = scheme_new_comp_env(exp_env, insp, 0);
05827 
05828   /* First expand for expansion-observation */
05829   if (!rec[drec].comp) {
05830     scheme_init_expand_recs(rec, drec, &mrec, 1);
05831     SCHEME_EXPAND_OBSERVE_ENTER_BIND(rec[drec].observer);
05832     a = scheme_expand_expr_lift_to_let(a, eenv, &mrec, 0);
05833   }
05834 
05835   /* Then compile */
05836   mrec.comp = 1;
05837   mrec.dont_mark_local_use = 0;
05838   mrec.resolve_module_ids = 1;
05839   mrec.no_module_cert = 1;
05840   mrec.value_name = NULL;
05841   mrec.certs = certs;
05842   mrec.observer = NULL;
05843   mrec.pre_unwrapped = 0;
05844   mrec.env_already = 0;
05845   mrec.comp_flags = rec[drec].comp_flags;
05846 
05847   a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0);
05848 
05849   /* For internal defn, don't simplify as resolving, because the
05850        expression may have syntax objects with a lexical rename that
05851        is still being extended. 
05852      For letrec-syntaxes+values, don't simplify because it's too expensive. */
05853   rp = scheme_resolve_prefix(eenv->genv->phase, eenv->prefix, 0);
05854 
05855   oi = scheme_optimize_info_create();
05856   if (!(rec[drec].comp_flags & COMP_CAN_INLINE))
05857     oi->inline_fuel = -1;
05858   a = scheme_optimize_expr(a, oi);
05859 
05860   ri = scheme_resolve_info_create(rp);
05861   a = scheme_resolve_expr(a, ri);
05862 
05863   rp = scheme_remap_prefix(rp, ri);
05864 
05865   /* To JIT:
05866        if (ri->use_jit) a = scheme_jit_expr(a);
05867      but it's not likely that a let-syntax-bound macro is going
05868      to run lots of times, so JITting is probably not worth it. */
05869 
05870   SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
05871 
05872   a_expr = a;
05873   a = eval_letmacro_rhs(a_expr, rhs_env, ri->max_let_depth, rp, eenv->genv->phase, certs);
05874 
05875   if (SAME_OBJ(a, SCHEME_MULTIPLE_VALUES)) {
05876     vc = scheme_current_thread->ku.multiple.count;
05877     results = scheme_current_thread->ku.multiple.array;
05878     scheme_current_thread->ku.multiple.array = NULL;
05879     if (SAME_OBJ(results, scheme_current_thread->values_buffer))
05880       scheme_current_thread->values_buffer = NULL;
05881   } else {
05882     vc = 1;
05883     results = NULL;
05884   }
05885 
05886   for (nc = 0, l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
05887     nc++;
05888   }
05889 
05890   if (vc != nc) {
05891     Scheme_Object *name;
05892     const char *symname;
05893     
05894     if (nc >= 1) {
05895       name = SCHEME_STX_CAR(names);
05896       name = SCHEME_STX_VAL(name);
05897     } else
05898       name = NULL;
05899     symname = (name ? scheme_symbol_name(name) : "");
05900     
05901     scheme_wrong_return_arity(where,
05902                            nc, vc,
05903                            (vc == 1) ? (Scheme_Object **)a : results, 
05904                            "%s%s%s",
05905                            name ? "defining \"" : "0 names",
05906                            symname,
05907                            name ? ((nc == 1) ? "\"" : "\", ...") : "");
05908   }
05909 
05910   i = *_pos;
05911   for (j = 0, l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l), j++) {
05912     Scheme_Object *name, *macro;
05913     name = SCHEME_STX_CAR(l);
05914     
05915     macro = scheme_alloc_small_object();
05916     macro->type = scheme_macro_type;
05917     if (vc == 1)
05918       SCHEME_PTR_VAL(macro) = a;
05919     else 
05920       SCHEME_PTR_VAL(macro) = results[j];
05921     
05922     scheme_set_local_syntax(i++, name, macro, stx_env);
05923 
05924     if (scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(macro))) {
05925       /* Install a free-id=? rename */
05926       scheme_install_free_id_rename(name, scheme_rename_transformer_id(SCHEME_PTR_VAL(macro)), rename_rib,
05927                                     scheme_make_integer(rhs_env->genv->phase));
05928     }
05929   }
05930   *_pos = i;
05931 
05932   SCHEME_EXPAND_OBSERVE_EXIT_BIND(rec[drec].observer);
05933 }
05934 
05935 static Scheme_Object *
05936 do_letrec_syntaxes(const char *where,
05937                  Scheme_Object *forms, Scheme_Comp_Env *origenv, 
05938                  Scheme_Compile_Info *rec, int drec)
05939 {
05940   Scheme_Object *form, *bindings, *var_bindings, *body, *v;
05941   Scheme_Object *names_to_disappear;
05942   Scheme_Comp_Env *stx_env, *var_env, *rhs_env;
05943   int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already;
05944   DupCheckRecord r;
05945 
05946   env_already = rec[drec].env_already;
05947 
05948   form = SCHEME_STX_CDR(forms);
05949   if (!SCHEME_STX_PAIRP(form))
05950     scheme_wrong_syntax(NULL, NULL, forms, NULL);
05951   bindings = SCHEME_STX_CAR(form);
05952   form = SCHEME_STX_CDR(form);
05953   if (!SCHEME_STX_PAIRP(form))
05954     scheme_wrong_syntax(NULL, NULL, forms, NULL);
05955   var_bindings = SCHEME_STX_CAR(form);
05956   form = SCHEME_STX_CDR(form);
05957   if (!SCHEME_STX_PAIRP(form))
05958     scheme_wrong_syntax(NULL, NULL, forms, NULL);
05959   body = scheme_datum_to_syntax(form, forms, forms, 0, 0);
05960 
05961   scheme_rec_add_certs(rec, drec, forms);
05962 
05963   if (env_already)
05964     stx_env = origenv;
05965   else
05966     stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs);
05967 
05968   rhs_env = stx_env;
05969 
05970   if (!SCHEME_STX_NULLP(bindings) && !SCHEME_STX_PAIRP(bindings)) {
05971     scheme_wrong_syntax(NULL, bindings, forms, "bad syntax (not a binding sequence)");
05972   } else
05973     check_form(bindings, forms);
05974   if (!SCHEME_STX_NULLP(var_bindings) && !SCHEME_STX_PAIRP(var_bindings)) {
05975     scheme_wrong_syntax(NULL, var_bindings, forms, "bad syntax (not a binding sequence)");
05976   } else
05977     check_form(var_bindings, forms);
05978 
05979   cnt = stx_cnt = var_cnt = 0;
05980   saw_var = 0;
05981 
05982   depth = rec[drec].depth;
05983 
05984   if (!rec[drec].comp && (depth <= 0) && (depth > -2))
05985     names_to_disappear = scheme_null;
05986   else
05987     names_to_disappear = NULL;
05988 
05989   if (!env_already)
05990     scheme_begin_dup_symbol_check(&r, stx_env);
05991 
05992   /* Pass 1: Check and Rename */
05993 
05994   for (i = 0; i < 2 ; i++) {
05995     for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
05996       Scheme_Object *a, *l;
05997 
05998       a = SCHEME_STX_CAR(v);
05999       if (!SCHEME_STX_PAIRP(a)
06000          || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(a)))
06001        v = NULL;
06002       else {
06003        for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
06004          if (!SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(l)))
06005            break;
06006        }
06007        if (!SCHEME_STX_NULLP(l))
06008          v = NULL;
06009       }
06010 
06011       if (v) {
06012        Scheme_Object *rest;
06013        rest = SCHEME_STX_CDR(a);
06014        if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))
06015          v = NULL;
06016       }
06017 
06018       if (!v)
06019        scheme_wrong_syntax(NULL, a, forms, 
06020                          "bad syntax (binding clause not an identifier sequence and expression)");
06021 
06022       for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
06023        a = SCHEME_STX_CAR(l);
06024         if (!env_already) {
06025           scheme_check_identifier(where, a, NULL, stx_env, forms);
06026           scheme_dup_symbol_check(&r, where, a, "binding", forms);
06027         }
06028        cnt++;
06029       }
06030       if (i)
06031        saw_var = 1;
06032     }
06033 
06034     if (!i)
06035       stx_cnt = cnt;
06036     else
06037       var_cnt = cnt - stx_cnt;
06038   }
06039 
06040   if (!env_already)
06041     scheme_add_local_syntax(stx_cnt, stx_env);
06042   
06043   if (saw_var) {
06044     var_env = scheme_new_compilation_frame(var_cnt, 
06045                                            (env_already ? SCHEME_INTDEF_SHADOW : 0), 
06046                                            stx_env, 
06047                                            rec[drec].certs);
06048   } else
06049     var_env = NULL;
06050 
06051   for (i = (env_already ? 1 : 0); i < (var_env ? 2 : 1) ; i++) {
06052     cnt = (i ? var_cnt : stx_cnt);
06053     if (cnt > 0) {
06054       /* Add new syntax/variable names to the environment: */
06055       j = 0;
06056       for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
06057         Scheme_Object *a, *l;
06058        
06059         a = SCHEME_STX_CAR(v);
06060         for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
06061           a = SCHEME_STX_CAR(l);
06062           if (i) {
06063             /* In compile mode, this will get re-written by the letrec compiler.
06064                But that's ok. We need it now for env_renames. */
06065             scheme_add_compilation_binding(j++, a, var_env);
06066           } else
06067             scheme_set_local_syntax(j++, a, NULL, stx_env);
06068         }
06069       }
06070     }
06071   }
06072 
06073   if (names_to_disappear) {
06074     for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
06075       Scheme_Object *a, *names;
06076 
06077       a = SCHEME_STX_CAR(v);
06078       names = SCHEME_STX_CAR(a);
06079       while (!SCHEME_STX_NULLP(names)) {
06080         a = SCHEME_STX_CAR(names);
06081         if (names_to_disappear)
06082           names_to_disappear = cons(a, names_to_disappear);
06083         names = SCHEME_STX_CDR(names);
06084       }
06085     }
06086   }
06087   
06088   bindings = scheme_add_env_renames(bindings, stx_env, origenv);
06089   if (var_env)
06090     bindings = scheme_add_env_renames(bindings, var_env, origenv);
06091   if (var_env)
06092     var_bindings = scheme_add_env_renames(var_bindings, stx_env, origenv);
06093 
06094   body = scheme_add_env_renames(body, stx_env, origenv);
06095   SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(rec[drec].observer, bindings, var_bindings, body);
06096   
06097   scheme_prepare_exp_env(stx_env->genv);
06098   scheme_prepare_compile_env(stx_env->genv->exp_env);
06099 
06100   if (!env_already) {
06101     i = 0;
06102 
06103     for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
06104       Scheme_Object *a, *names;
06105 
06106       SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
06107 
06108       a = SCHEME_STX_CAR(v);
06109       names = SCHEME_STX_CAR(a);
06110       a = SCHEME_STX_CDR(a);
06111       a = SCHEME_STX_CAR(a);
06112 
06113       scheme_bind_syntaxes(where, names, a,
06114                            stx_env->genv->exp_env,
06115                            stx_env->insp,
06116                            rec, drec,
06117                            stx_env, rhs_env, 
06118                            &i, NULL);
06119     }
06120   }
06121 
06122   SCHEME_EXPAND_OBSERVE_NEXT_GROUP(rec[drec].observer);
06123 
06124   if (!env_already && names_to_disappear) {
06125     /* Need to add renaming for disappeared bindings. If they
06126        originated for internal definitions, then we need both
06127        pre-renamed and renamed, since some might have been
06128        expanded to determine definitions. */
06129     Scheme_Object *l, *a, *pf = NULL, *pl = NULL;
06130 
06131     if (origenv->flags & SCHEME_FOR_INTDEF) {
06132       for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
06133         a = SCHEME_CAR(l);
06134         a = cons(a, scheme_null);
06135         if (pl)
06136           SCHEME_CDR(pl) = a;
06137         else
06138           pf = a;
06139         pl = a;
06140       }
06141     }
06142 
06143     for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
06144       a = SCHEME_CAR(l);
06145       a = scheme_add_env_renames(a, stx_env, origenv);
06146       SCHEME_CAR(l) = a;
06147     }
06148 
06149     if (pf) {
06150       SCHEME_CDR(pl) = names_to_disappear;
06151       names_to_disappear = pf;
06152     }
06153   }
06154 
06155   if (!var_env) {
06156     var_env = scheme_require_renames(stx_env);
06157     if (rec[drec].comp) {
06158       v = scheme_check_name_property(forms, rec[drec].value_name);
06159       rec[drec].value_name = v;
06160       v = scheme_compile_block(body, var_env, rec, drec);
06161       v = scheme_make_sequence_compilation(v, 1);
06162     } else {
06163       v = scheme_expand_block(body, var_env, rec, drec);
06164       if ((depth >= 0) || (depth == -2)) {
06165        Scheme_Object *formname;
06166        formname = SCHEME_STX_CAR(forms);
06167        v = cons(formname, cons(bindings, cons(var_bindings, v)));
06168       } else {
06169        v = cons(let_values_symbol, cons(scheme_null, v));
06170       }
06171 
06172       if (SCHEME_PAIRP(v))
06173        v = scheme_datum_to_syntax(v, forms, scheme_sys_wraps(origenv), 
06174                                0, 2);
06175 
06176       if (!((depth >= 0) || (depth == -2))) {
06177         SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer,v);
06178       }
06179     }
06180   } else {
06181     /* Construct letrec-values expression: */
06182     v = cons(letrec_values_symbol, cons(var_bindings, body));
06183     v = scheme_datum_to_syntax(v, forms, scheme_sys_wraps(origenv), 0, 2);
06184     
06185     if (rec[drec].comp) {
06186       v = gen_let_syntax(v, stx_env, "letrec-values", 0, 1, 1, rec, drec, var_env);
06187     } else {
06188       SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(rec[drec].observer);
06189       v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, 0, var_env);
06190       
06191       if ((depth >= 0) || (depth == -2)) {
06192        /* Pull back out the pieces we want: */
06193        Scheme_Object *formname;
06194        formname = SCHEME_STX_CAR(forms);
06195        v = SCHEME_STX_CDR(v);
06196        v = cons(formname, cons(bindings, v));
06197        v = scheme_datum_to_syntax(v, forms, scheme_sys_wraps(origenv), 0, 2);
06198       } else {
06199         SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer,v);
06200       }
06201     }
06202   }
06203 
06204   /* Add the 'disappeared-binding property */
06205   if (names_to_disappear)
06206     v = scheme_stx_property(v, disappeared_binding_symbol, names_to_disappear);
06207 
06208   return v;
06209 }
06210 
06211 static Scheme_Object *
06212 letrec_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, 
06213                      Scheme_Compile_Info *rec, int drec)
06214 {
06215   return do_letrec_syntaxes("letrec-syntaxes+values", form, env, rec, drec);
06216 }
06217 
06218 static Scheme_Object *
06219 letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
06220 {
06221   SCHEME_EXPAND_OBSERVE_PRIM_LETREC_SYNTAXES_VALUES(erec[drec].observer);
06222 
06223   return do_letrec_syntaxes("letrec-syntaxes+values", form, env, erec, drec);
06224 }
06225 
06226 /**********************************************************************/
06227 /*                        marshal/unmarshal                           */
06228 /**********************************************************************/
06229 
06230 static Scheme_Object *write_let_value(Scheme_Object *obj)
06231 {
06232   Scheme_Let_Value *lv;
06233  
06234   lv = (Scheme_Let_Value *)obj;
06235 
06236   return cons(scheme_make_integer(lv->count),
06237              cons(scheme_make_integer(lv->position),
06238                  cons(SCHEME_LET_AUTOBOX(lv) ? scheme_true : scheme_false,
06239                      cons(scheme_protect_quote(lv->value), 
06240                           scheme_protect_quote(lv->body)))));
06241 }
06242 
06243 static Scheme_Object *read_let_value(Scheme_Object *obj)
06244 {
06245   Scheme_Let_Value *lv;
06246  
06247   lv = (Scheme_Let_Value *)scheme_malloc_tagged(sizeof(Scheme_Let_Value));
06248   lv->iso.so.type = scheme_let_value_type;
06249 
06250   if (!SCHEME_PAIRP(obj)) return NULL;
06251   lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
06252   obj = SCHEME_CDR(obj);
06253   if (!SCHEME_PAIRP(obj)) return NULL;
06254   lv->position = SCHEME_INT_VAL(SCHEME_CAR(obj));
06255   obj = SCHEME_CDR(obj);
06256   if (!SCHEME_PAIRP(obj)) return NULL;
06257   SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj));
06258   obj = SCHEME_CDR(obj);
06259   if (!SCHEME_PAIRP(obj)) return NULL;
06260   lv->value = SCHEME_CAR(obj);
06261   lv->body = SCHEME_CDR(obj);
06262 
06263   return (Scheme_Object *)lv;
06264 }
06265 
06266 static Scheme_Object *write_let_void(Scheme_Object *obj)
06267 {
06268   Scheme_Let_Void *lv;
06269  
06270   lv = (Scheme_Let_Void *)obj;
06271 
06272   return cons(scheme_make_integer(lv->count), 
06273              cons(SCHEME_LET_AUTOBOX(lv) ? scheme_true : scheme_false,
06274                  scheme_protect_quote(lv->body)));
06275 }
06276 
06277 static Scheme_Object *read_let_void(Scheme_Object *obj)
06278 {
06279   Scheme_Let_Void *lv;
06280  
06281   lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void));
06282   lv->iso.so.type = scheme_let_void_type;
06283   
06284   if (!SCHEME_PAIRP(obj)) return NULL;
06285   lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
06286   obj = SCHEME_CDR(obj);
06287   if (!SCHEME_PAIRP(obj)) return NULL;
06288   SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj));
06289   lv->body = SCHEME_CDR(obj);
06290 
06291   return (Scheme_Object *)lv;
06292 }
06293 
06294 static Scheme_Object *write_let_one(Scheme_Object *obj)
06295 {
06296   scheme_signal_error("let-one writer shouldn't be used");
06297   return NULL;
06298 }
06299 
06300 static Scheme_Object *read_let_one(Scheme_Object *obj)
06301 {
06302   return NULL;
06303 }
06304 
06305 static Scheme_Object *write_letrec(Scheme_Object *obj)
06306 {
06307   Scheme_Letrec *lr = (Scheme_Letrec *)obj;
06308   Scheme_Object *l = scheme_null;
06309   int i = lr->count;
06310   
06311   while (i--) {
06312     l = cons(scheme_protect_quote(lr->procs[i]), l);
06313   }
06314 
06315   return cons(scheme_make_integer(lr->count), 
06316              cons(scheme_protect_quote(lr->body), l));
06317 }
06318 
06319 static Scheme_Object *read_letrec(Scheme_Object *obj)
06320 {
06321   Scheme_Letrec *lr;
06322   int i, c;
06323   Scheme_Object **sa;
06324 
06325   lr = MALLOC_ONE_TAGGED(Scheme_Letrec);
06326 
06327   lr->so.type = scheme_letrec_type;
06328 
06329   if (!SCHEME_PAIRP(obj)) return NULL;
06330   c = lr->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
06331   obj = SCHEME_CDR(obj);
06332 
06333   if (!SCHEME_PAIRP(obj)) return NULL;
06334   lr->body = SCHEME_CAR(obj);
06335   obj = SCHEME_CDR(obj);
06336 
06337   sa = MALLOC_N(Scheme_Object*, c);
06338   lr->procs = sa;
06339   for (i = 0; i < c; i++) {
06340     if (!SCHEME_PAIRP(obj)) return NULL;
06341     lr->procs[i] = SCHEME_CAR(obj);
06342     obj = SCHEME_CDR(obj);
06343   }
06344 
06345   return (Scheme_Object *)lr;
06346 }
06347 
06348 static Scheme_Object *write_top(Scheme_Object *obj)
06349 {
06350   Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)obj;
06351 
06352   return cons(scheme_make_integer(top->max_let_depth),
06353              cons((Scheme_Object *)top->prefix,
06354                  scheme_protect_quote(top->code)));
06355 }
06356 
06357 static Scheme_Object *read_top(Scheme_Object *obj)
06358 {
06359   Scheme_Compilation_Top *top;
06360 
06361   top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top);
06362   top->so.type = scheme_compilation_top_type;
06363   if (!SCHEME_PAIRP(obj)) return NULL;
06364   top->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj));
06365   obj = SCHEME_CDR(obj);
06366   if (!SCHEME_PAIRP(obj)) return NULL;
06367   top->prefix = (Resolve_Prefix *)SCHEME_CAR(obj);
06368   top->code = SCHEME_CDR(obj);
06369 
06370   return (Scheme_Object *)top;
06371 }
06372 
06373 static Scheme_Object *write_case_lambda(Scheme_Object *obj)
06374 {
06375   Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)obj;
06376   int i;
06377   Scheme_Object *l;
06378 
06379   i = cl->count;
06380 
06381   l = scheme_null;
06382   for (; i--; ) {
06383     l = cons(cl->array[i], l);
06384   }
06385   
06386   return cons((cl->name ? cl->name : scheme_null),
06387              l);
06388 }
06389 
06390 static Scheme_Object *read_case_lambda(Scheme_Object *obj)
06391 {
06392   Scheme_Object *s, *a;
06393   int count, i, all_closed = 1;
06394   Scheme_Case_Lambda *cl;
06395 
06396   if (!SCHEME_PAIRP(obj)) return NULL;
06397   s = SCHEME_CDR(obj);
06398   for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) {
06399     count++;
06400   }
06401 
06402   cl = (Scheme_Case_Lambda *)
06403     scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
06404                       + (count - 1) * sizeof(Scheme_Object *));
06405 
06406   cl->so.type = scheme_case_lambda_sequence_type;
06407   cl->count = count;
06408   cl->name = SCHEME_CAR(obj);
06409   if (SCHEME_NULLP(cl->name))
06410     cl->name = NULL;
06411 
06412   s = SCHEME_CDR(obj);
06413   for (i = 0; i < count; i++, s = SCHEME_CDR(s)) {
06414     a = SCHEME_CAR(s);
06415     cl->array[i] = a;
06416     if (!SCHEME_PROCP(a)) {
06417       if (!SAME_TYPE(SCHEME_TYPE(a), scheme_unclosed_procedure_type))
06418         return NULL;
06419       all_closed = 0;
06420     }
06421   }
06422 
06423   if (all_closed) {
06424     /* Empty closure: produce procedure value directly.
06425        (We assume that this was generated by a direct write of
06426         a case-lambda data record in print.c, and that it's not
06427        in a CASE_LAMBDA_EXPD syntax record.) */
06428     return case_lambda_execute((Scheme_Object *)cl);
06429   }
06430 
06431   return (Scheme_Object *)cl;
06432 }
06433 
06434 /**********************************************************************/
06435 /*                        expansion observer                          */
06436 /**********************************************************************/
06437 
06438 /* RMC
06439  * - Defines #%expobs module
06440  *   - current-expand-observe
06441  *   - ??? (other syntax observations)
06442  */
06443 
06444 void scheme_call_expand_observe(Scheme_Object *obs, int tag, Scheme_Object *obj) 
06445 {
06446   if (!SCHEME_PROCP(obs)) {
06447     scheme_signal_error("internal error: expand-observer should never be non-procedure");
06448   } else {
06449     Scheme_Object *buf[2];
06450     buf[0] = scheme_make_integer(tag);
06451     if (obj) {
06452       buf[1] = obj;
06453     } else {
06454       buf[1] = scheme_false;
06455     }
06456     scheme_apply(obs, 2, buf);
06457   }
06458 }
06459 
06460 static Scheme_Object *
06461 current_expand_observe(int argc, Scheme_Object **argv)
06462 {
06463   return scheme_param_config("current-expand-observe",
06464                           scheme_make_integer(MZCONFIG_EXPAND_OBSERVE),
06465                           argc, argv,
06466                           2, NULL, NULL, 0);
06467 }
06468 
06469 /* always returns either procedure or NULL */
06470 Scheme_Object *scheme_get_expand_observe() 
06471 {
06472   Scheme_Object *obs;
06473   obs = scheme_get_param(scheme_current_config(),
06474                          MZCONFIG_EXPAND_OBSERVE);
06475   if (SCHEME_PROCP(obs)) {
06476     return obs;
06477   } else {
06478     return NULL;
06479   }
06480 }
06481 
06482 void scheme_init_expand_observe(Scheme_Env *env) 
06483 {
06484   Scheme_Env *newenv;
06485   Scheme_Object *modname;
06486 
06487   modname = scheme_intern_symbol("#%expobs");
06488   newenv = scheme_primitive_module(modname, env);
06489 
06490   scheme_add_global_constant
06491     ("current-expand-observe",
06492      scheme_register_parameter(current_expand_observe,
06493                                "current-expand-observe",
06494                                MZCONFIG_EXPAND_OBSERVE),
06495      newenv);
06496   scheme_finish_primitive_module(newenv);
06497 
06498 }
06499 
06500 /**********************************************************************/
06501 /*                            precise GC                              */
06502 /**********************************************************************/
06503 
06504 #ifdef MZ_PRECISE_GC
06505 
06506 START_XFORM_SKIP;
06507 
06508 #define MARKS_FOR_SYNTAX_C
06509 #include "mzmark.c"
06510 
06511 static void register_traversers(void)
06512 {
06513 }
06514 
06515 END_XFORM_SKIP;
06516 
06517 #endif