Back to index

plt-scheme  4.2.1
struct.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 #include "schpriv.h"
00023 #include "schmach.h"
00024 
00025 #define PROP_USE_HT_COUNT 5
00026 
00027 /* globals */
00028 Scheme_Object *scheme_arity_at_least, *scheme_date;
00029 Scheme_Object *scheme_make_arity_at_least;
00030 Scheme_Object *scheme_source_property;
00031 Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
00032 Scheme_Object *scheme_equal_property;
00033 Scheme_Object *scheme_make_struct_type_proc;
00034 Scheme_Object *scheme_current_inspector_proc;
00035 
00036 /* locals */
00037 
00038 Scheme_Object *location_struct;
00039 
00040 typedef enum {
00041   SCHEME_CONSTR = 1, 
00042   SCHEME_PRED, 
00043   SCHEME_GETTER, 
00044   SCHEME_SETTER,
00045   SCHEME_GEN_GETTER, 
00046   SCHEME_GEN_SETTER
00047 } Scheme_ProcT;
00048 
00049 typedef struct {
00050   Scheme_Object so;
00051   Scheme_Object *evt;
00052   Scheme_Object *wrapper;
00053 } Wrapped_Evt;
00054 
00055 typedef struct {
00056   Scheme_Object so;
00057   Scheme_Object *maker;
00058 } Nack_Guard_Evt;
00059 
00060 static Scheme_Object *make_inspector(int argc, Scheme_Object *argv[]);
00061 static Scheme_Object *make_sibling_inspector(int argc, Scheme_Object *argv[]);
00062 static Scheme_Object *inspector_p(int argc, Scheme_Object *argv[]);
00063 static Scheme_Object *current_inspector(int argc, Scheme_Object *argv[]);
00064 static Scheme_Object *current_code_inspector(int argc, Scheme_Object *argv[]);
00065 
00066 static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[]);
00067 static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[]);
00068 static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[]);
00069 static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *argv[]);
00070 static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *argv[]);
00071 static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]);
00072 static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Object *argv[]);
00073 static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[]);
00074 static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[]);
00075 static Scheme_Object *check_checked_proc_property_value_ok(int argc, Scheme_Object *argv[]);
00076 
00077 static Scheme_Object *make_struct_type(int argc, Scheme_Object *argv[]);
00078 
00079 static Scheme_Object *make_struct_field_accessor(int argc, Scheme_Object *argv[]);
00080 static Scheme_Object *make_struct_field_mutator(int argc, Scheme_Object *argv[]);
00081 
00082 static Scheme_Object *nack_evt(int argc, Scheme_Object *argv[]);
00083 static Scheme_Object *handle_evt(int argc, Scheme_Object *argv[]);
00084 static Scheme_Object *handle_evt_p(int argc, Scheme_Object *argv[]);
00085 
00086 static Scheme_Object *struct_p(int argc, Scheme_Object *argv[]);
00087 static Scheme_Object *struct_type_p(int argc, Scheme_Object *argv[]);
00088 static Scheme_Object *proc_struct_type_p(int argc, Scheme_Object *argv[]);
00089 
00090 static Scheme_Object *struct_info(int argc, Scheme_Object *argv[]);
00091 static Scheme_Object *struct_type_info(int argc, Scheme_Object *argv[]);
00092 static Scheme_Object *struct_type_pred(int argc, Scheme_Object *argv[]);
00093 static Scheme_Object *struct_type_constr(int argc, Scheme_Object *argv[]);
00094 static Scheme_Object *struct_to_vector(int argc, Scheme_Object *argv[]);
00095 static Scheme_Object *prefab_struct_key(int argc, Scheme_Object *argv[]);
00096 static Scheme_Object *make_prefab_struct(int argc, Scheme_Object *argv[]);
00097 static Scheme_Object *prefab_key_struct_type(int argc, Scheme_Object *argv[]);
00098 
00099 static Scheme_Object *struct_setter_p(int argc, Scheme_Object *argv[]);
00100 static Scheme_Object *struct_getter_p(int argc, Scheme_Object *argv[]);
00101 static Scheme_Object *struct_pred_p(int argc, Scheme_Object *argv[]);
00102 static Scheme_Object *struct_constr_p(int argc, Scheme_Object *argv[]);
00103 
00104 static Scheme_Object *make_struct_proc(Scheme_Struct_Type *struct_type, char *func_name, 
00105                                    Scheme_ProcT proc_type, int field_num);
00106 
00107 static Scheme_Object *make_name(const char *pre, const char *tn, int tnl, const char *post1, 
00108                             const char *fn, int fnl, const char *post2, int sym);
00109 
00110 static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object **a, int always);
00111 
00112 static Scheme_Object *write_property;
00113 Scheme_Object *scheme_recur_symbol, *scheme_display_symbol, *scheme_write_special_symbol;
00114 
00115 static Scheme_Object *evt_property;
00116 static int evt_struct_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
00117 static int is_evt_struct(Scheme_Object *);
00118 
00119 static Scheme_Object *proc_property;
00120 
00121 static int wrapped_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
00122 static int nack_guard_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
00123 static int nack_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
00124 static int poll_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
00125 
00126 Scheme_Object *make_special_comment(int argc, Scheme_Object **argv);
00127 Scheme_Object *special_comment_value(int argc, Scheme_Object **argv);
00128 Scheme_Object *special_comment_p(int argc, Scheme_Object **argv);
00129 
00130 static Scheme_Object *check_arity_at_least_fields(int argc, Scheme_Object **argv);
00131 static Scheme_Object *check_date_fields(int argc, Scheme_Object **argv);
00132 static Scheme_Object *check_location_fields(int argc, Scheme_Object **argv);
00133 
00134 static Scheme_Object *check_exn_source_property_value_ok(int argc, Scheme_Object *argv[]);
00135 static Scheme_Object *exn_source_p(int argc, Scheme_Object **argv);
00136 static Scheme_Object *exn_source_get(int argc, Scheme_Object **argv);
00137 
00138 static Scheme_Object *procedure_extract_target(int argc, Scheme_Object **argv);
00139 
00140 static Scheme_Object *rename_transformer_property;
00141 static Scheme_Object *set_transformer_property;
00142 static Scheme_Object *not_free_id_symbol;
00143 static Scheme_Object *scheme_checked_proc_property;
00144 
00145 #ifdef MZ_PRECISE_GC
00146 static void register_traversers(void);
00147 #endif
00148 
00149 static Scheme_Bucket_Table *prefab_table;
00150 static Scheme_Object *make_prefab_key(Scheme_Struct_Type *type);
00151 
00152 #define cons scheme_make_pair
00153 #define icons scheme_make_pair
00154 #define _intern scheme_intern_symbol
00155 
00156 #define BUILTIN_STRUCT_FLAGS SCHEME_STRUCT_EXPTIME | SCHEME_STRUCT_NO_SET
00157 #define LOC_STRUCT_FLAGS BUILTIN_STRUCT_FLAGS | SCHEME_STRUCT_NO_SET
00158 
00159 static Scheme_Object *ellipses_symbol, *prefab_symbol;
00160 
00161 #define TYPE_NAME(base, blen) make_name("struct:", base, blen, "", NULL, 0, "", 1)
00162 #define CSTR_NAME(base, blen) make_name("make-", base, blen, "", NULL, 0, "", 1)
00163 #define PRED_NAME(base, blen) make_name("", base, blen, "?", NULL, 0, "", 1)
00164 #define GET_NAME(base, blen, field, flen, sym) make_name("", base, blen, "-", field, flen, "", sym)
00165 #define SET_NAME(base, blen, field, flen, sym) make_name("set-", base, blen, "-", field, flen, "!", sym)
00166 #define GENGET_NAME(base, blen, sym) make_name("", base, blen, "-ref", NULL, 0, "", sym)
00167 #define GENSET_NAME(base, blen, sym) make_name("", base, blen, "-set!", NULL, 0, "", sym)
00168 #define EXPTIME_NAME(base, blen, sym) make_name("", base, blen, "", NULL, 0, "", sym)
00169 
00170 #define TYPE_NAME_STR(sym) (char *)make_name("struct:", (char *)sym, -1, "", NULL, 0, "", 0)
00171 
00172 #define mzNUM_ST_INFO 8
00173 
00174 void
00175 scheme_init_struct (Scheme_Env *env)
00176 {
00177   Scheme_Object **as_names;
00178   Scheme_Object **as_values, *as_et;
00179   int as_count;
00180 #ifdef TIME_SYNTAX
00181   Scheme_Object **ts_names;
00182   Scheme_Object **ts_values, *ts_et;
00183   int ts_count;
00184 #endif
00185   Scheme_Object **loc_names;
00186   Scheme_Object **loc_values, *loc_et;
00187   int loc_count;
00188   int i;
00189   Scheme_Object *guard;
00190 
00191   static const char *arity_fields[1] = { "value" };
00192 #ifdef TIME_SYNTAX
00193   static const char *date_fields[10] = { "second", "minute", "hour",
00194                                     "day", "month", "year",
00195                                     "week-day", "year-day", "dst?", "time-zone-offset" };
00196 #endif
00197   static const char *location_fields[10] = { "source", "line", "column", "position", "span" };
00198   
00199 #ifdef MZ_PRECISE_GC
00200   register_traversers();
00201 #endif
00202 
00203   /* Add arity structure */
00204   REGISTER_SO(scheme_arity_at_least);
00205   REGISTER_SO(scheme_make_arity_at_least);
00206   scheme_arity_at_least = scheme_make_struct_type_from_string("arity-at-least", NULL, 1, NULL, 
00207                                                               scheme_make_prim(check_arity_at_least_fields), 1);
00208   as_names = scheme_make_struct_names_from_array("arity-at-least",
00209                                            1, arity_fields,
00210                                            BUILTIN_STRUCT_FLAGS, 
00211                                            &as_count);
00212   as_values = scheme_make_struct_values(scheme_arity_at_least, as_names, as_count, 
00213                                    BUILTIN_STRUCT_FLAGS);
00214   scheme_make_arity_at_least = as_values[1];
00215   for (i = 0; i < as_count - 1; i++) {
00216     scheme_add_global_constant(scheme_symbol_val(as_names[i]), as_values[i],
00217                             env);
00218   }
00219 
00220   as_et = scheme_make_struct_exptime(as_names, as_count, NULL, NULL, BUILTIN_STRUCT_FLAGS);
00221   scheme_add_global_keyword_symbol(as_names[as_count - 1], as_et, env);
00222 
00223 #ifdef TIME_SYNTAX
00224   /* Add date structure: */
00225   REGISTER_SO(scheme_date);
00226   scheme_date = scheme_make_struct_type_from_string("date", NULL, 10, NULL,
00227                                                     scheme_make_prim(check_date_fields), 1);
00228   
00229   ts_names = scheme_make_struct_names_from_array("date",
00230                                            10, date_fields,
00231                                            BUILTIN_STRUCT_FLAGS, &ts_count);
00232 
00233   ts_values = scheme_make_struct_values(scheme_date, ts_names, ts_count, 
00234                                    BUILTIN_STRUCT_FLAGS);
00235   for (i = 0; i < ts_count - 1; i++) {
00236     scheme_add_global_constant(scheme_symbol_val(ts_names[i]), ts_values[i], 
00237                             env);
00238   }
00239 
00240   ts_et = scheme_make_struct_exptime(ts_names, ts_count, NULL, NULL, BUILTIN_STRUCT_FLAGS);
00241   scheme_add_global_keyword_symbol(ts_names[ts_count - 1], ts_et, env);
00242 #endif
00243 
00244   /* Add location structure: */
00245   REGISTER_SO(location_struct);
00246   location_struct = scheme_make_struct_type_from_string("srcloc", NULL, 5, NULL, 
00247                                                         scheme_make_prim(check_location_fields), 1);
00248   
00249   loc_names = scheme_make_struct_names_from_array("srcloc",
00250                                             5, location_fields,
00251                                             LOC_STRUCT_FLAGS, &loc_count);
00252   
00253   loc_values = scheme_make_struct_values(location_struct, loc_names, loc_count, 
00254                                     LOC_STRUCT_FLAGS);
00255   for (i = 0; i < loc_count - 1; i++) {
00256     scheme_add_global_constant(scheme_symbol_val(loc_names[i]), loc_values[i], 
00257                             env);
00258   }
00259 
00260   loc_et = scheme_make_struct_exptime(loc_names, loc_count, NULL, NULL, LOC_STRUCT_FLAGS);
00261   scheme_add_global_keyword_symbol(loc_names[loc_count - 1], loc_et, env);
00262 
00263   REGISTER_SO(write_property);
00264   {
00265     Scheme_Object *a[2], *pred, *access;
00266     guard = scheme_make_prim_w_arity(check_write_property_value_ok,
00267                                  "guard-for-prop:custom-write",
00268                                  2, 2);
00269 
00270     a[0] = scheme_intern_symbol("custom-write");
00271     a[1] = guard;
00272     make_struct_type_property(2, a);
00273     write_property = scheme_current_thread->ku.multiple.array[0];
00274     pred = scheme_current_thread->ku.multiple.array[1];
00275     access = scheme_current_thread->ku.multiple.array[2];
00276     scheme_add_global_constant("prop:custom-write", write_property, env);
00277     scheme_add_global_constant("custom-write?", pred, env);
00278     scheme_add_global_constant("custom-write-accessor", access, env);
00279   }
00280   
00281   REGISTER_SO(evt_property);
00282   {
00283     guard = scheme_make_prim_w_arity(check_evt_property_value_ok,
00284                                  "guard-for-prop:evt",
00285                                  2, 2);
00286     evt_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("evt"),
00287                                                             guard);
00288     scheme_add_global_constant("prop:evt", evt_property, env);
00289 
00290     scheme_add_evt(scheme_structure_type,
00291                  (Scheme_Ready_Fun)evt_struct_is_ready,
00292                  NULL,
00293                  is_evt_struct, 1);
00294   }
00295 
00296   {
00297     REGISTER_SO(proc_property);
00298     proc_property = scheme_make_struct_type_property(scheme_intern_symbol("procedure"));
00299     scheme_add_global_constant("prop:procedure", proc_property, env);
00300   }
00301 
00302   {
00303     guard = scheme_make_prim_w_arity(check_equal_property_value_ok,
00304                                  "guard-for-prop:equal+hash",
00305                                  2, 2);
00306     REGISTER_SO(scheme_equal_property);
00307     scheme_equal_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("equal+hash"),
00308                                                                      guard);
00309     scheme_add_global_constant("prop:equal+hash", scheme_equal_property, env);
00310   }
00311 
00312   {
00313     REGISTER_SO(scheme_input_port_property);
00314     REGISTER_SO(scheme_output_port_property);
00315 
00316     guard = scheme_make_prim_w_arity(check_input_port_property_value_ok,
00317                                  "guard-for-prop:input-port",
00318                                  2, 2);
00319     scheme_input_port_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("input-port"),
00320                                                                           guard);
00321     
00322     guard = scheme_make_prim_w_arity(check_output_port_property_value_ok,
00323                                  "guard-for-prop:output-port",
00324                                  2, 2);
00325     scheme_output_port_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("output-port"),
00326                                                                            guard);
00327     
00328     scheme_add_global_constant("prop:input-port", scheme_input_port_property, env);
00329     scheme_add_global_constant("prop:output-port", scheme_output_port_property, env);
00330   }
00331 
00332   {
00333     REGISTER_SO(rename_transformer_property);
00334 
00335     guard = scheme_make_prim_w_arity(check_rename_transformer_property_value_ok,
00336                                  "guard-for-prop:rename-transformer",
00337                                  2, 2);
00338     rename_transformer_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("rename-transformer"),
00339                                                                           guard);
00340     
00341     scheme_add_global_constant("prop:rename-transformer", rename_transformer_property, env);
00342   }
00343 
00344   {
00345     REGISTER_SO(set_transformer_property);
00346 
00347     guard = scheme_make_prim_w_arity(check_set_transformer_property_value_ok,
00348                                  "guard-for-prop:set!-transformer",
00349                                  2, 2);
00350     set_transformer_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("set!-transformer"),
00351                                                                         guard);
00352     
00353     scheme_add_global_constant("prop:set!-transformer", set_transformer_property, env);
00354   }
00355 
00356 
00357   {
00358     guard = scheme_make_prim_w_arity(check_checked_proc_property_value_ok,
00359                                  "guard-for-prop:checked-procedure",
00360                                  2, 2);
00361     REGISTER_SO(scheme_checked_proc_property);
00362     scheme_checked_proc_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("checked-procedure"),
00363                                                                              guard);
00364     scheme_add_global_constant("prop:checked-procedure", scheme_checked_proc_property, env);
00365   }
00366 
00367   REGISTER_SO(not_free_id_symbol);
00368   not_free_id_symbol = scheme_intern_symbol("not-free-identifier=?");
00369 
00370   REGISTER_SO(scheme_recur_symbol);
00371   REGISTER_SO(scheme_display_symbol);
00372   REGISTER_SO(scheme_write_special_symbol);
00373   scheme_recur_symbol = scheme_intern_symbol("recur");
00374   scheme_display_symbol = scheme_intern_symbol("display");
00375   scheme_write_special_symbol = scheme_intern_symbol("write-special");
00376 
00377   scheme_add_evt(scheme_wrap_evt_type,
00378                (Scheme_Ready_Fun)wrapped_evt_is_ready,
00379                NULL, NULL, 1);
00380   scheme_add_evt(scheme_handle_evt_type,
00381                (Scheme_Ready_Fun)wrapped_evt_is_ready,
00382                NULL, NULL, 1);
00383   scheme_add_evt(scheme_nack_guard_evt_type,
00384                (Scheme_Ready_Fun)nack_guard_evt_is_ready,
00385                NULL, NULL, 1);
00386   scheme_add_evt(scheme_nack_evt_type,
00387                (Scheme_Ready_Fun)nack_evt_is_ready,
00388                NULL, NULL, 1);
00389   scheme_add_evt(scheme_poll_evt_type,
00390                (Scheme_Ready_Fun)poll_evt_is_ready,
00391                NULL, NULL, 1);
00392 
00393   /*** basic interface ****/
00394 
00395   REGISTER_SO(scheme_make_struct_type_proc);
00396   scheme_make_struct_type_proc = scheme_make_prim_w_arity2(make_struct_type,
00397                                                            "make-struct-type",
00398                                                            4, 10,
00399                                                            5, 5);
00400 
00401   scheme_add_global_constant("make-struct-type", 
00402                              scheme_make_struct_type_proc,
00403                          env);
00404 
00405   scheme_add_global_constant("make-struct-type-property", 
00406                          scheme_make_prim_w_arity2(make_struct_type_property,
00407                                                 "make-struct-type-property",
00408                                                 1, 3,
00409                                                 3, 3),
00410                          env);
00411 
00412   scheme_add_global_constant("make-struct-field-accessor",
00413                           scheme_make_prim_w_arity(make_struct_field_accessor,
00414                                                 "make-struct-field-accessor",
00415                                                 2, 3),
00416                           env);
00417   scheme_add_global_constant("make-struct-field-mutator",
00418                           scheme_make_prim_w_arity(make_struct_field_mutator,
00419                                                 "make-struct-field-mutator",
00420                                                 2, 3),
00421                           env);
00422 
00423   scheme_add_global_constant("wrap-evt",
00424                           scheme_make_prim_w_arity(scheme_wrap_evt,
00425                                                 "wrap-evt",
00426                                                 2, 2),
00427                           env);
00428   scheme_add_global_constant("handle-evt",
00429                           scheme_make_prim_w_arity(handle_evt,
00430                                                 "handle-evt",
00431                                                 2, 2),
00432                           env);
00433   scheme_add_global_constant("nack-guard-evt",
00434                           scheme_make_prim_w_arity(nack_evt,
00435                                                 "nack-guard-evt",
00436                                                 1, 1),
00437                           env);
00438   scheme_add_global_constant("poll-guard-evt",
00439                           scheme_make_prim_w_arity(scheme_poll_evt,
00440                                                 "poll-guard-evt",
00441                                                 1, 1),
00442                           env);
00443   scheme_add_global_constant("handle-evt?",
00444                           scheme_make_folding_prim(handle_evt_p,
00445                                                 "handle-evt?",
00446                                                 1, 1, 1),
00447                           env);
00448 
00449   scheme_add_global_constant("struct?",
00450                           scheme_make_folding_prim(struct_p,
00451                                                 "struct?",
00452                                                 1, 1, 1),
00453                           env);
00454   scheme_add_global_constant("struct-type?",
00455                           scheme_make_folding_prim(struct_type_p,
00456                                                "struct-type?",
00457                                                1, 1, 1),
00458                          env);
00459   scheme_add_global_constant("struct-type-property?",
00460                           scheme_make_folding_prim(struct_type_property_p,
00461                                                "struct-type-property?",
00462                                                1, 1, 1),
00463                          env);
00464   scheme_add_global_constant("procedure-struct-type?",
00465                           scheme_make_folding_prim(proc_struct_type_p,
00466                                                "procedure-struct-type?",
00467                                                1, 1, 1),
00468                          env);
00469   scheme_add_global_constant("procedure-extract-target",
00470                              scheme_make_prim_w_arity(procedure_extract_target,
00471                                                       "procedure-extract-target",
00472                                                       1, 1),
00473                              env);
00474 
00475   /*** Debugging ****/
00476 
00477   scheme_add_global_constant("struct-info",
00478                           scheme_make_prim_w_arity2(struct_info,
00479                                                  "struct-info",
00480                                                  1, 1,
00481                                                  2, 2),
00482                           env);
00483   scheme_add_global_constant("struct-type-info",
00484                           scheme_make_prim_w_arity2(struct_type_info,
00485                                                  "struct-type-info",
00486                                                  1, 1,
00487                                                  mzNUM_ST_INFO, mzNUM_ST_INFO),
00488                           env);
00489   scheme_add_global_constant("struct-type-make-predicate",
00490                           scheme_make_prim_w_arity(struct_type_pred,
00491                                                 "struct-type-make-predicate",
00492                                                 1, 1),
00493                           env);
00494   scheme_add_global_constant("struct-type-make-constructor",
00495                           scheme_make_prim_w_arity(struct_type_constr,
00496                                                 "struct-type-make-constructor",
00497                                                 1, 1),
00498                           env);
00499   scheme_add_global_constant("struct->vector",
00500                           scheme_make_prim_w_arity(struct_to_vector,
00501                                                 "struct->vector",
00502                                                 1, 2),
00503                           env);
00504   scheme_add_global_constant("prefab-struct-key",
00505                           scheme_make_prim_w_arity(prefab_struct_key,
00506                                                 "prefab-struct-key",
00507                                                 1, 1),
00508                           env);
00509   scheme_add_global_constant("make-prefab-struct",
00510                           scheme_make_prim_w_arity(make_prefab_struct,
00511                                                 "make-prefab-struct",
00512                                                 1, -1),
00513                           env);
00514   scheme_add_global_constant("prefab-key->struct-type",
00515                           scheme_make_prim_w_arity(prefab_key_struct_type,
00516                                                 "prefab-key->struct-type",
00517                                                 2, 2),
00518                           env);
00519 
00520   /*** Predicates ****/
00521 
00522   scheme_add_global_constant("struct-mutator-procedure?",
00523                           scheme_make_prim_w_arity(struct_setter_p,
00524                                                 "struct-mutator-procedure?",
00525                                                 1, 1),
00526                          env);
00527   scheme_add_global_constant("struct-accessor-procedure?",
00528                           scheme_make_prim_w_arity(struct_getter_p,
00529                                                 "struct-accessor-procedure?",
00530                                                 1, 1),
00531                          env);
00532   scheme_add_global_constant("struct-predicate-procedure?",
00533                           scheme_make_prim_w_arity(struct_pred_p,
00534                                                 "struct-predicate-procedure?",
00535                                                 1, 1),
00536                           env);
00537   scheme_add_global_constant("struct-constructor-procedure?",
00538                           scheme_make_prim_w_arity(struct_constr_p,
00539                                                 "struct-constructor-procedure?",
00540                                                 1, 1),
00541                           env);
00542   
00543   /*** Inspectors ****/
00544 
00545   scheme_add_global_constant("make-inspector",
00546                           scheme_make_prim_w_arity(make_inspector,
00547                                                 "make-inspector",
00548                                                 0, 1),
00549                           env);
00550   scheme_add_global_constant("make-sibling-inspector",
00551                           scheme_make_prim_w_arity(make_sibling_inspector,
00552                                                 "make-sibling-inspector",
00553                                                 0, 1),
00554                           env);
00555   scheme_add_global_constant("inspector?",
00556                           scheme_make_prim_w_arity(inspector_p,
00557                                                 "inspector?",
00558                                                 1, 1),
00559                           env);
00560   
00561   REGISTER_SO(scheme_current_inspector_proc);
00562   scheme_current_inspector_proc = scheme_register_parameter(current_inspector,
00563                                                             "current-inspector",
00564                                                             MZCONFIG_INSPECTOR);
00565   scheme_add_global_constant("current-inspector", 
00566                           scheme_current_inspector_proc,
00567                           env);
00568   scheme_add_global_constant("current-code-inspector", 
00569                           scheme_register_parameter(current_code_inspector,
00570                                                  "current-code-inspector",
00571                                                  MZCONFIG_CODE_INSPECTOR),
00572                           env);
00573 
00574 
00575   scheme_add_global_constant("make-special-comment", 
00576                           scheme_make_prim_w_arity(make_special_comment,
00577                                                 "make-special-comment",
00578                                                 1, 1),
00579                           env);
00580   scheme_add_global_constant("special-comment-value", 
00581                           scheme_make_prim_w_arity(special_comment_value,
00582                                                 "special-comment-value",
00583                                                 1, 1),
00584                           env);
00585   scheme_add_global_constant("special-comment?", 
00586                           scheme_make_folding_prim(special_comment_p,
00587                                                 "special-comment?",
00588                                                 1, 1, 1),
00589                           env);
00590 
00591   REGISTER_SO(ellipses_symbol);
00592   ellipses_symbol = scheme_intern_symbol("...");
00593 
00594   REGISTER_SO(prefab_symbol);
00595   prefab_symbol = scheme_intern_symbol("prefab");
00596 
00597   REGISTER_SO(scheme_source_property);
00598   {
00599     guard = scheme_make_prim_w_arity(check_exn_source_property_value_ok,
00600                                  "guard-for-prop:exn:srclocs",
00601                                  2, 2);
00602     scheme_source_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("prop:exn:srclocs"),
00603                                                               guard);
00604   }
00605   scheme_add_global_constant("prop:exn:srclocs", scheme_source_property, env);
00606   scheme_add_global_constant("exn:srclocs?", 
00607                           scheme_make_folding_prim(exn_source_p,
00608                                                 "exn:srclocs?",
00609                                                 1, 1, 1),
00610                           env);
00611   scheme_add_global_constant("exn:srclocs-accessor", 
00612                           scheme_make_folding_prim(exn_source_get,
00613                                                 "exn:srclocs-accessor",
00614                                                 1, 1, 1),
00615                           env);
00616 
00617   {
00618     Scheme_Object *p;
00619     p = scheme_make_prim_w_arity(scheme_extract_checked_procedure,
00620                                  "checked-procedure-check-and-extract",
00621                                  5, 5);
00622     SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
00623     scheme_add_global_constant("checked-procedure-check-and-extract", p, env);
00624   }
00625 }
00626 
00627 /*========================================================================*/
00628 /*                             inspectors                                 */
00629 /*========================================================================*/
00630 
00631 Scheme_Object *scheme_make_initial_inspectors(void)
00632 {
00633   Scheme_Inspector *superior, *root;
00634 
00635   superior = MALLOC_ONE_TAGGED(Scheme_Inspector);
00636   superior->so.type = scheme_inspector_type;
00637   superior->depth = 0;
00638   
00639   root = MALLOC_ONE_TAGGED(Scheme_Inspector);
00640   root->so.type = scheme_inspector_type;
00641   root->depth = 1;
00642   root->superior = superior;
00643 
00644   return (Scheme_Object *)root;
00645 }
00646 
00647 Scheme_Object *scheme_make_inspector(Scheme_Object *superior)
00648 {
00649   Scheme_Inspector *naya;
00650 
00651   naya = MALLOC_ONE_TAGGED(Scheme_Inspector);
00652   naya->so.type = scheme_inspector_type;
00653   naya->depth = ((Scheme_Inspector *)superior)->depth + 1;
00654   naya->superior = (Scheme_Inspector *)superior;
00655 
00656   return (Scheme_Object *)naya;
00657 }
00658 
00659 static Scheme_Object *make_inspector(int argc, Scheme_Object **argv)
00660 {
00661   Scheme_Object *superior;
00662 
00663   if (argc) {
00664     superior = argv[0];
00665     if (!SAME_TYPE(SCHEME_TYPE(superior), scheme_inspector_type))
00666       scheme_wrong_type("make-inspector", "inspector", 0, argc, argv);
00667   } else
00668     superior = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
00669 
00670   return scheme_make_inspector(superior);
00671 }
00672 
00673 static Scheme_Object *make_sibling_inspector(int argc, Scheme_Object **argv)
00674 {
00675   Scheme_Object *superior;
00676 
00677   if (argc) {
00678     superior = argv[0];
00679     if (!SAME_TYPE(SCHEME_TYPE(superior), scheme_inspector_type))
00680       scheme_wrong_type("make-sibling-inspector", "inspector", 0, argc, argv);
00681   } else
00682     superior = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
00683 
00684   superior = (Scheme_Object *)((Scheme_Inspector *)superior)->superior;
00685 
00686   return scheme_make_inspector(superior);
00687 }
00688 
00689 static Scheme_Object *inspector_p(int argc, Scheme_Object **argv)
00690 {
00691   return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_inspector_type)
00692          ? scheme_true
00693          : scheme_false);
00694 }
00695 
00696 int scheme_is_subinspector(Scheme_Object *i, Scheme_Object *sup)
00697 {
00698   Scheme_Inspector *ins, *superior;
00699 
00700   if (SCHEME_FALSEP(i))
00701     return 1;
00702 
00703   ins = (Scheme_Inspector *)i;
00704   superior = (Scheme_Inspector *)sup;
00705 
00706   while (ins->depth > superior->depth) {
00707     if (ins->superior == superior)
00708       return 1;
00709     ins = ins->superior;
00710   }
00711    
00712   return 0;
00713 }
00714 
00715 static Scheme_Object *current_inspector(int argc, Scheme_Object *argv[])
00716 {
00717   return scheme_param_config("current-inspector", 
00718                           scheme_make_integer(MZCONFIG_INSPECTOR),
00719                           argc, argv,
00720                           -1, inspector_p, "inspector", 0);
00721 }
00722 
00723 static Scheme_Object *current_code_inspector(int argc, Scheme_Object *argv[])
00724 {
00725   return scheme_param_config("current-code-inspector", 
00726                           scheme_make_integer(MZCONFIG_CODE_INSPECTOR),
00727                           argc, argv,
00728                           -1, inspector_p, "inspector", 0);
00729 }
00730 
00731 /*========================================================================*/
00732 /*                             properties                                 */
00733 /*========================================================================*/
00734 
00735 static Scheme_Object *prop_pred(int argc, Scheme_Object **args, Scheme_Object *prim)
00736 {
00737   Scheme_Struct_Type *stype;
00738   Scheme_Object *prop = SCHEME_PRIM_CLOSURE_ELS(prim)[0];
00739 
00740   if (SCHEME_STRUCTP(args[0]))
00741     stype = ((Scheme_Structure *)args[0])->stype;
00742   else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_struct_type_type))
00743     stype = (Scheme_Struct_Type *)args[0];
00744   else
00745     return scheme_false;
00746 
00747   if (stype->num_props < 0) {
00748     if (scheme_hash_get((Scheme_Hash_Table *)stype->props, prop))
00749       return scheme_true;
00750   } else {
00751     int i;
00752     for (i = stype->num_props; i--; ) {
00753       if (SAME_OBJ(SCHEME_CAR(stype->props[i]), prop))
00754        return scheme_true;
00755     }
00756   }
00757    
00758   return scheme_false;
00759 }
00760 
00761 XFORM_NONGCING static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg)
00762 {
00763   Scheme_Struct_Type *stype;
00764 
00765   if (SCHEME_STRUCTP(arg))
00766     stype = ((Scheme_Structure *)arg)->stype;
00767   else if (SAME_TYPE(SCHEME_TYPE(arg), scheme_struct_type_type))
00768     stype = (Scheme_Struct_Type *)arg;
00769   else
00770     stype = NULL;
00771 
00772   if (stype) {
00773     if (stype->num_props < 0) {
00774       Scheme_Object *v;
00775       v = (Scheme_Object *)scheme_eq_hash_get((Scheme_Hash_Table *)stype->props, prop);
00776       if (v)
00777        return v;
00778     } else {
00779       int i;
00780       for (i = stype->num_props; i--; ) {
00781        if (SAME_OBJ(SCHEME_CAR(stype->props[i]), prop))
00782          return SCHEME_CDR(stype->props[i]);
00783       }
00784     }
00785   }
00786   
00787   return NULL;
00788 }
00789 
00790 static Scheme_Object *prop_accessor(int argc, Scheme_Object **args, Scheme_Object *prim)
00791 {
00792   Scheme_Object *v;
00793 
00794   v = do_prop_accessor(SCHEME_PRIM_CLOSURE_ELS(prim)[0], args[0]);
00795   
00796   if (!v)
00797     scheme_wrong_type(((Scheme_Primitive_Proc *)prim)->name, 
00798                     "struct or struct-type with property",
00799                       0, 1, args);
00800   
00801   return v;
00802 }
00803 
00804 static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[])
00805 {
00806   Scheme_Struct_Property *p;
00807   Scheme_Object *a[3], *v, *supers = scheme_null;
00808   char *name;
00809   int len;
00810 
00811   if (!SCHEME_SYMBOLP(argv[0]))
00812     scheme_wrong_type("make-struct-type-property", "symbol", 0, argc, argv);
00813   if (argc > 1) {
00814     if (SCHEME_TRUEP(argv[1])
00815         && !scheme_check_proc_arity(NULL, 2, 1, argc, argv))
00816       scheme_wrong_type("make-struct-type-property", "procedure (arity 2) or #f", 1, argc, argv);
00817 
00818     if (argc > 2) {
00819       supers = argv[2];
00820       if (scheme_proper_list_length(supers) < 0)
00821         supers = NULL;
00822       else {
00823         Scheme_Object *pr;
00824         for (pr = supers; supers && SCHEME_PAIRP(pr); pr = SCHEME_CDR(pr)) {
00825           v = SCHEME_CAR(pr);
00826           if (!SCHEME_PAIRP(v)) {
00827             supers = NULL;
00828           } else {
00829             if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(v)), scheme_struct_property_type))
00830               supers = NULL;
00831             a[0] = SCHEME_CDR(v);
00832             if (!scheme_check_proc_arity(NULL, 1, 0, 1, a))
00833               supers = NULL;
00834           }
00835         }
00836       }
00837 
00838       if (!supers) {
00839         scheme_wrong_type("make-struct-type-property", 
00840                           "list of pairs of structure type properties and procedures (arity 1)", 
00841                           2, argc, argv);
00842       }
00843     }
00844   }
00845 
00846   p = MALLOC_ONE_TAGGED(Scheme_Struct_Property);
00847   p->so.type = scheme_struct_property_type;
00848   p->name = argv[0];
00849   if ((argc > 1) && SCHEME_TRUEP(argv[1]))
00850     p->guard = argv[1];
00851   p->supers = supers;
00852 
00853   a[0] = (Scheme_Object *)p;
00854 
00855   len = SCHEME_SYM_LEN(argv[0]);
00856   name = MALLOC_N_ATOMIC(char, len + 2);
00857   memcpy(name, SCHEME_SYM_VAL(argv[0]), len);
00858   name[len] = '?';
00859   name[len+1] = 0;
00860 
00861   v = scheme_make_folding_prim_closure(prop_pred,
00862                                    1, a,
00863                                    name,
00864                                    1, 1, 0);
00865   a[1] = v;
00866 
00867   name = MALLOC_N_ATOMIC(char, len + 10);
00868   memcpy(name, SCHEME_SYM_VAL(argv[0]), len);
00869   memcpy(name + len, "-accessor", 10);
00870 
00871   v = scheme_make_folding_prim_closure(prop_accessor,
00872                                    1, a,
00873                                    name,
00874                                    1, 1, 0);
00875   a[2] = v;
00876 
00877   return scheme_values(3, a);
00878 }
00879 
00880 Scheme_Object *scheme_make_struct_type_property_w_guard(Scheme_Object *name, Scheme_Object *guard)
00881 {
00882   Scheme_Thread *p = scheme_current_thread;
00883   Scheme_Object *a[2];
00884 
00885   a[0] = name;
00886   a[1] = guard;
00887 
00888   (void)make_struct_type_property(2, a);
00889   return p->ku.multiple.array[0];
00890 }
00891 
00892 Scheme_Object *scheme_make_struct_type_property(Scheme_Object *name)
00893 {
00894   return scheme_make_struct_type_property_w_guard(name, scheme_false);
00895 }
00896 
00897 Scheme_Object *scheme_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s)
00898 {
00899   return do_prop_accessor(prop, s);
00900 }
00901 
00902 static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[])
00903 {
00904   return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_struct_property_type)
00905          ? scheme_true : scheme_false);
00906 }
00907 
00908 static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Scheme_Struct_Type *t)
00909 {
00910   Scheme_Struct_Property *p = (Scheme_Struct_Property *)prop;
00911 
00912   if (SAME_OBJ(prop, proc_property)) {
00913     /* prop:procedure guard: */
00914     Scheme_Object *orig_v = v;
00915     if (SCHEME_INTP(v) || SCHEME_BIGNUMP(v)) {
00916       long pos;
00917 
00918       if (SCHEME_INTP(v))
00919        pos = SCHEME_INT_VAL(v);
00920       else if (SCHEME_BIGPOS(v))
00921        pos = t->num_slots; /* too big */
00922       else
00923         pos = -1; /* negative bignum */
00924 
00925       if (pos >= 0) {
00926         Scheme_Struct_Type *parent_type;
00927 
00928         if (t->name_pos > 0)
00929           parent_type = t->parent_types[t->name_pos - 1];
00930         else
00931           parent_type = NULL;
00932 
00933         if (pos >= (t->num_islots - (parent_type ? parent_type->num_islots : 0))) {
00934           scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", v);
00935           return NULL;
00936         }
00937 
00938         if (parent_type) {
00939           /* proc_attr needs to be in terms of the whole field array */
00940           pos += parent_type->num_slots;
00941           v = scheme_make_integer(pos);
00942         }
00943       } else
00944         v = scheme_false; /* complain below */
00945     }
00946 
00947     if (SCHEME_INTP(v) || SCHEME_PROCP(v)) {
00948       /* ok */
00949     } else {
00950       scheme_arg_mismatch("make-struct-type", 
00951                           "prop:procedure value is not a procedure or exact non-negative integer: ", 
00952                           orig_v);
00953     }
00954 
00955     t->proc_attr = v;
00956 
00957     if (SCHEME_INTP(v)) {
00958       long pos;
00959       pos = SCHEME_INT_VAL(orig_v);
00960       if (!t->immutables || !t->immutables[pos]) {
00961         scheme_arg_mismatch("make-struct-type", 
00962                             "field is not specified as immutable for a prop:procedure index: ", 
00963                             orig_v);
00964       }
00965     }
00966 
00967     return orig_v;
00968   } else {
00969     /* Normal guard handling: */
00970     if (p->guard) {
00971       Scheme_Object *a[2], *info[mzNUM_ST_INFO], *l;
00972 
00973       a[0] = (Scheme_Object *)t;
00974       get_struct_type_info(1, a, info, 1);
00975 
00976       l = scheme_build_list(mzNUM_ST_INFO, info);
00977 
00978       a[0] = v;
00979       a[1] = l;
00980     
00981       return _scheme_apply(p->guard, 2, a);
00982     } else
00983       return v;
00984   }
00985 }
00986 
00987 /*========================================================================*/
00988 /*                            evt structs                                 */
00989 /*========================================================================*/
00990 
00991 static int extract_accessor_offset(Scheme_Object *acc)
00992 {
00993   Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(acc)[0];
00994 
00995   if (i->struct_type->name_pos)
00996     return i->struct_type->parent_types[i->struct_type->name_pos - 1]->num_slots;
00997   else
00998     return 0;
00999 }
01000 
01001 static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[])
01002 /* This is the guard for prop:evt */
01003 {
01004   Scheme_Object *v, *l, *acc;
01005   int pos, num_islots;
01006 
01007   v = argv[0];
01008 
01009   if (scheme_is_evt(v))
01010     return v;
01011 
01012   if (scheme_check_proc_arity(NULL, 1, 0, 1, &v))
01013     return v;
01014   
01015   if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0))
01016        || (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v))))
01017     scheme_arg_mismatch("guard-for-prop:evt",
01018                      "property value is not a evt, procedure (arity 1), or exact non-negative integer: ",
01019                      v);
01020 
01021   l = argv[1];
01022   l = SCHEME_CDR(l);
01023   num_islots = SCHEME_INT_VAL(SCHEME_CAR(l));
01024   l = SCHEME_CDR(l);
01025   l = SCHEME_CDR(l);
01026   acc = SCHEME_CAR(l);
01027   l = SCHEME_CDR(l);
01028   l = SCHEME_CDR(l);
01029   l = SCHEME_CAR(l);
01030 
01031   if (SCHEME_BIGNUMP(v))
01032     pos = num_islots; /* too big */
01033   else
01034     pos = SCHEME_INT_VAL(v);
01035 
01036   if (pos >= num_islots) {
01037     scheme_arg_mismatch("guard-for-prop:evt",
01038                      "field index >= initialized-field count for structure type: ",
01039                      v);
01040   }
01041 
01042   for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
01043     if (SCHEME_INT_VAL(SCHEME_CAR(l)) == pos)
01044       break;
01045   }
01046 
01047   if (!SCHEME_PAIRP(l)) {
01048     scheme_arg_mismatch("guard-for-prop:evt",
01049                      "field index not declared immutable: ",
01050                      v);
01051   }
01052 
01053   pos += extract_accessor_offset(acc);
01054   v = scheme_make_integer(pos);
01055 
01056   return v;
01057 }
01058 
01059 static int evt_struct_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo)
01060 {
01061   Scheme_Object *v;
01062 
01063   v = scheme_struct_type_property_ref(evt_property, o);
01064 
01065   if (!v) {
01066     /* Must be an input or output port: */
01067     if (SCHEME_INPUT_PORTP(o)) {
01068       v = (Scheme_Object *)scheme_input_port_record(o);
01069     } else {
01070       v = (Scheme_Object *)scheme_output_port_record(o);
01071     }
01072     scheme_set_sync_target(sinfo, v, NULL, NULL, 0, 1, NULL);
01073     return 0;
01074   }
01075 
01076   if (SCHEME_INTP(v))
01077     v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)];
01078 
01079   if (scheme_is_evt(v)) {
01080     scheme_set_sync_target(sinfo, v, NULL, NULL, 0, 1, NULL);
01081     return 0;
01082   }
01083 
01084   if (SCHEME_PROCP(v)) {
01085     if (sinfo->false_positive_ok) {
01086       sinfo->potentially_false_positive = 1;
01087       return 1;
01088     }
01089 
01090     if (scheme_check_proc_arity(NULL, 1, 0, 1, &v)) {
01091       Scheme_Object *f = v, *result, *a[1];
01092 
01093       a[0] = o;
01094       result = scheme_apply(f, 1, a);
01095 
01096       if (scheme_is_evt(result)) {
01097        SCHEME_USE_FUEL(1); /* Needed beause an apply of a mzc-generated function
01098                             might not check for breaks. */
01099        scheme_set_sync_target(sinfo, result, NULL, NULL, 0, 1, NULL);
01100        return 0;
01101       }
01102 
01103       /* non-evt => ready and result is self */
01104       scheme_set_sync_target(sinfo, o, o, NULL, 0, 0, NULL);
01105 
01106       return 1;
01107     }
01108   }
01109 
01110   return 0;
01111 }
01112 
01113 static int is_evt_struct(Scheme_Object *o)
01114 {
01115   if (scheme_struct_type_property_ref(evt_property, o))
01116     return 1;
01117   if (scheme_struct_type_property_ref(scheme_input_port_property, o))
01118     return 1;
01119   if (scheme_struct_type_property_ref(scheme_output_port_property, o))
01120     return 1;
01121   return 0;
01122 }
01123 
01124 /*========================================================================*/
01125 /*                            port structs                                */
01126 /*========================================================================*/
01127 
01128 typedef int (*Check_Val_Proc)(Scheme_Object *);
01129 
01130 static Scheme_Object *check_indirect_property_value_ok(const char *name, Check_Val_Proc ck, const char *complain,
01131                                                        int argc, Scheme_Object *argv[])
01132 {
01133   Scheme_Object *v, *l, *acc;
01134   int pos, num_islots;
01135 
01136   v = argv[0];
01137   
01138   if (ck(v))
01139     return v;
01140 
01141   if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0))
01142        || (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v))))
01143     scheme_arg_mismatch(name, complain, v);
01144   
01145   l = argv[1];
01146   l = SCHEME_CDR(l);
01147   num_islots = SCHEME_INT_VAL(SCHEME_CAR(l));
01148   l = SCHEME_CDR(l);
01149   l = SCHEME_CDR(l);
01150   acc = SCHEME_CAR(l);
01151   l = SCHEME_CDR(l);
01152   l = SCHEME_CDR(l);
01153   l = SCHEME_CAR(l);
01154 
01155   if (SCHEME_BIGNUMP(v))
01156     pos = num_islots; /* too big */
01157   else
01158     pos = SCHEME_INT_VAL(v);
01159 
01160   if (pos >= num_islots) {
01161     scheme_arg_mismatch(name,
01162                      "field index >= initialized-field count for structure type: ",
01163                      v);
01164   }
01165 
01166   for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
01167     if (SCHEME_INT_VAL(SCHEME_CAR(l)) == pos)
01168       break;
01169   }
01170 
01171   if (!SCHEME_PAIRP(l)) {
01172     scheme_arg_mismatch(name,
01173                      "field index not declared immutable: ",
01174                      v);
01175   }
01176 
01177   pos += extract_accessor_offset(acc);
01178   v = scheme_make_integer(pos);
01179 
01180   return v;
01181 }
01182 
01183 static int is_input_port(Scheme_Object *v) {  return SCHEME_INPUT_PORTP(v); }
01184 static int is_output_port(Scheme_Object *v) {  return SCHEME_OUTPUT_PORTP(v); }
01185 
01186 static Scheme_Object *check_port_property_value_ok(const char *name, int input, int argc, Scheme_Object *argv[])
01187 /* This is the guard for prop:input-port and prop:output-port */
01188 {
01189   return check_indirect_property_value_ok(name, 
01190                                           input ? is_input_port : is_output_port, 
01191                                           (input
01192                                            ? "property value is not an input port or exact non-negative integer: "
01193                                            : "property value is not an output port or exact non-negative integer: "),
01194                                           argc, argv);
01195 }
01196 
01197 static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[])
01198 {
01199   return check_port_property_value_ok("guard-for-prop:input-port", 1, argc, argv);
01200 }
01201 
01202 static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Object *argv[])
01203 {
01204   return check_port_property_value_ok("guard-for-prop:output-port", 0, argc, argv);
01205 }
01206 
01207 /*========================================================================*/
01208 /*                         equal+hash property                            */
01209 /*========================================================================*/
01210 
01211 static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *argv[])
01212 /* This is the guard for prop:equal+hash */
01213 {
01214   Scheme_Object *v, *p;
01215 
01216   v = argv[0];
01217 
01218   if (scheme_proper_list_length(v) != 3) {
01219     v = NULL;
01220   } else {
01221     v = scheme_make_pair(scheme_make_symbol("tag"), v);
01222     v = scheme_list_to_vector(v);
01223     p = SCHEME_VEC_ELS(v)[1];
01224     if (!scheme_check_proc_arity(NULL, 3, 0, 1, &p)) {
01225       v = NULL;
01226     } else {
01227       p = SCHEME_VEC_ELS(v)[2];
01228       if (!scheme_check_proc_arity(NULL, 2, 0, 1, &p)) {
01229         v = NULL;
01230       } else {
01231         p = SCHEME_VEC_ELS(v)[3];
01232         if (!scheme_check_proc_arity(NULL, 2, 0, 1, &p)) {
01233           v = NULL;
01234         }
01235       }
01236     }
01237   }
01238 
01239   if (!v) {
01240     scheme_arg_mismatch("guard-for-prop:equal+hash",
01241                         "expected a list containing a recursive-equality procedure (arity 2)"
01242                         " and two recursive hash-code procedures (arity 2), given: ",
01243                         argv[0]);
01244   }
01245 
01246   return v;
01247 }
01248 
01249 /*========================================================================*/
01250 /*                          writeable structs                             */
01251 /*========================================================================*/
01252 
01253 static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *argv[])
01254 {
01255   Scheme_Object *v;
01256 
01257   v = argv[0];
01258 
01259   if (!scheme_check_proc_arity(NULL, 3, 0, argc, argv)) {
01260     scheme_arg_mismatch("guard-for-prop:custom-write",
01261                      "not a procedure of arity 3: ",
01262                      v); 
01263   }
01264 
01265   return v;
01266 }
01267 
01268 Scheme_Object *scheme_is_writable_struct(Scheme_Object *s)
01269 {
01270   return scheme_struct_type_property_ref(write_property, s);
01271 }
01272 
01273 /*========================================================================*/
01274 /*                  rename and set! transformer properties                */
01275 /*========================================================================*/
01276 
01277 int scheme_is_rename_transformer(Scheme_Object *o)
01278 {
01279   if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type))
01280     return 1;
01281   if (SCHEME_STRUCTP(o)
01282       && scheme_struct_type_property_ref(rename_transformer_property, o))
01283     return 1;
01284   return 0;
01285 }
01286 
01287 int scheme_is_binding_rename_transformer(Scheme_Object *o)
01288 {
01289   if (scheme_is_rename_transformer(o)) {
01290     o = scheme_rename_transformer_id(o);
01291     o = scheme_stx_property(o, not_free_id_symbol, NULL);
01292     if (o && SCHEME_TRUEP(o))
01293       return 0;
01294     return 1;
01295   }
01296   return 0;
01297 }
01298 
01299 static int is_stx_id(Scheme_Object *o) { return (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))); }
01300 
01301 Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o)
01302 {
01303   if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type))
01304     return SCHEME_PTR1_VAL(o);
01305   if (SCHEME_STRUCTP(o)) {
01306     Scheme_Object *v;
01307     v = scheme_struct_type_property_ref(rename_transformer_property, o);
01308     if (SCHEME_BOXP(v)) v = SCHEME_BOX_VAL(v);
01309     if (SCHEME_INTP(v)) {
01310       v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)];
01311       if (!is_stx_id(v)) {
01312         v = scheme_datum_to_syntax(scheme_intern_symbol("?"), scheme_false, scheme_false, 0, 0);
01313       }
01314     }
01315     return v;
01316   }
01317   return NULL;
01318 }
01319 
01320 static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[])
01321 {
01322   return check_indirect_property_value_ok("guard-for-prop:rename-transformer", 
01323                                           is_stx_id, 
01324                                           "property value is not an identifier or exact non-negative integer, optionaly boxed: ",
01325                                           argc, argv);
01326 }
01327 
01328 int scheme_is_set_transformer(Scheme_Object *o)
01329 {
01330   if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type))
01331     return 1;
01332   if (SCHEME_STRUCTP(o)
01333       && scheme_struct_type_property_ref(set_transformer_property, o))
01334     return 1;
01335   return 0;
01336 }
01337 
01338 static int is_proc_1(Scheme_Object *o) { return (SCHEME_PROCP(o) && scheme_check_proc_arity(NULL, 1, -1, 0, &o)); } 
01339 
01340 Scheme_Object *signal_bad_syntax(int argc, Scheme_Object **argv)
01341 {
01342   scheme_wrong_syntax(NULL, NULL, argv[0], "bad syntax");
01343   return NULL;
01344 }
01345 
01346 Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o)
01347 {
01348   if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type))
01349     return SCHEME_PTR_VAL(o);
01350   if (SCHEME_STRUCTP(o)) {
01351     Scheme_Object *v;
01352     v = scheme_struct_type_property_ref(set_transformer_property, o);
01353     if (SCHEME_INTP(v)) {
01354       v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)];
01355       if (!is_proc_1(v)) {
01356         v = scheme_make_prim_w_arity(signal_bad_syntax,
01357                                      "bad-syntax-set!-transformer",
01358                                      1, 1);
01359       }
01360     }
01361     return v;
01362   }
01363   return NULL;
01364 }
01365 
01366 static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[])
01367 {
01368   return check_indirect_property_value_ok("guard-for-prop:set!-transformer", 
01369                                           is_proc_1, 
01370                                           "property value is not an procedure (arity 1) or exact non-negative integer: ",
01371                                           argc, argv);
01372 }
01373 
01374 /*========================================================================*/
01375 /*                           checked-proc property                        */
01376 /*========================================================================*/
01377 
01378 static Scheme_Object *check_checked_proc_property_value_ok(int argc, Scheme_Object *argv[])
01379 {
01380   Scheme_Object *parent, *l;
01381   int num_islots, num_aslots;
01382 
01383   l = argv[1];
01384   l = SCHEME_CDR(l);
01385   num_islots = SCHEME_INT_VAL(SCHEME_CAR(l));
01386   l = SCHEME_CDR(l);
01387   num_aslots = SCHEME_INT_VAL(SCHEME_CAR(l));
01388   l = SCHEME_CDR(l);
01389   l = SCHEME_CDR(l);
01390   l = SCHEME_CDR(l);
01391   l = SCHEME_CDR(l);
01392   parent = SCHEME_CAR(l);
01393 
01394   if (SCHEME_TRUEP(parent)) {
01395     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01396                      "prop:checked-procedure: not allowed on a structure type with a supertype");
01397   }
01398 
01399   if (num_islots + num_aslots < 2) {
01400     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01401                      "prop:checked-procedure: need at least two fields in the structure type");
01402   }
01403 
01404   return scheme_true;
01405 }
01406 
01407 Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv)
01408 {
01409   Scheme_Struct_Type *stype;
01410   Scheme_Object *v, *checker, *proc, *a[3];
01411   
01412   v = argv[1];
01413 
01414   if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_struct_type_type))
01415     stype = (Scheme_Struct_Type *)argv[0];  
01416   else
01417     stype = NULL;
01418 
01419   if (!stype || !(MZ_OPT_HASH_KEY(&stype->iso) & STRUCT_TYPE_CHECKED_PROC)) {
01420     scheme_wrong_type("checked-procedure-check-and-extract", "structure type with prop:checked-procedure property",
01421                       0, argc, argv);
01422     return NULL;
01423   }
01424 
01425   if (SCHEME_STRUCTP(v) && scheme_is_struct_instance((Scheme_Object *)stype, v)) {
01426     checker = ((Scheme_Structure *)v)->slots[0];
01427     proc = ((Scheme_Structure *)v)->slots[1];
01428     
01429     a[0] = argv[3];
01430     a[1] = argv[4];
01431     v = _scheme_apply(checker, 2, a);
01432     
01433     if (SCHEME_TRUEP(v))
01434       return proc;
01435   }
01436 
01437   a[0] = argv[1];
01438   a[1] = argv[3];
01439   a[2] = argv[4];
01440   return _scheme_apply(argv[2], 3, a);
01441 }
01442 
01443 /*========================================================================*/
01444 /*                             struct ops                                 */
01445 /*========================================================================*/
01446 
01447 static char *type_name_string(Scheme_Object *sym)
01448 {
01449   return TYPE_NAME_STR(sym);
01450 }
01451 
01452 static void wrong_struct_type(char *name, 
01453                            Scheme_Object *expected,
01454                            Scheme_Object *received,
01455                            int which, int argc,
01456                            Scheme_Object **argv)
01457 {
01458   if (SAME_OBJ(expected, received))
01459     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01460                    "%s: expects args of type <%s>; "
01461                    "given instance of a different <%s>",
01462                    name,
01463                    type_name_string(expected), 
01464                    type_name_string(received));
01465   else
01466     scheme_wrong_type(name,
01467                     type_name_string(expected), 
01468                     which, argc, argv);
01469 }
01470 
01471 #define STRUCT_TYPEP(st, v) \
01472         ((st->name_pos <= v->stype->name_pos) \
01473         && (st == v->stype->parent_types[st->name_pos]))
01474 
01475 int scheme_is_struct_instance(Scheme_Object *type, Scheme_Object *v)
01476 {
01477   Scheme_Struct_Type *stype = (Scheme_Struct_Type *)type;
01478   Scheme_Structure *s = (Scheme_Structure *)v;
01479 
01480   return STRUCT_TYPEP(stype, s);
01481 }
01482 
01483 Scheme_Object *scheme_struct_ref(Scheme_Object *sv, int pos)
01484 {
01485   Scheme_Structure *s = (Scheme_Structure *)sv;
01486   
01487   return s->slots[pos];
01488 }
01489 
01490 void scheme_struct_set(Scheme_Object *sv, int pos, Scheme_Object *v)
01491 {
01492   Scheme_Structure *s = (Scheme_Structure *)sv;  
01493  
01494   s->slots[pos] = v;
01495 }
01496 
01497 
01498 Scheme_Object *
01499 scheme_make_struct_instance(Scheme_Object *_stype, int argc, Scheme_Object **args)
01500 {
01501   Scheme_Structure *inst;
01502   Scheme_Struct_Type *stype;
01503   Scheme_Object **guard_argv = NULL, *v;
01504   int p, i, j, nis, ns, c, gcount;
01505 
01506   stype = (Scheme_Struct_Type *)_stype;
01507 
01508   c = stype->num_slots;
01509   inst = (Scheme_Structure *)
01510     scheme_malloc_tagged(sizeof(Scheme_Structure) 
01511                       + ((c - 1) * sizeof(Scheme_Object *)));
01512   
01513   inst->so.type = (stype->proc_attr ? scheme_proc_struct_type : scheme_structure_type);
01514   inst->stype = stype;
01515 
01516   /* Apply guards, if any: */
01517   for (p = stype->name_pos; p >= 0; p--) {
01518     if (stype->parent_types[p]->guard) {
01519       int got;
01520       if (!guard_argv) {
01521        guard_argv = MALLOC_N(Scheme_Object *, argc + 1);
01522        memcpy(guard_argv, args, sizeof(Scheme_Object *) * argc);
01523        args = guard_argv;
01524       }
01525       gcount = stype->parent_types[p]->num_islots;      
01526       guard_argv[argc] = guard_argv[gcount];
01527       guard_argv[gcount] = stype->name;
01528       v = _scheme_apply_multi(stype->parent_types[p]->guard, gcount + 1, guard_argv);
01529       got = (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES) ? scheme_multiple_count : 1);
01530       if (gcount != got) {
01531        scheme_wrong_return_arity("constructor",
01532                               gcount, got, 
01533                               (got == 1) ? (Scheme_Object **)v : scheme_multiple_array,
01534                               "calling guard procedure");
01535        return NULL;
01536       }
01537       if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES))
01538        memcpy(guard_argv, scheme_multiple_array, gcount * sizeof(Scheme_Object *));
01539       else
01540        guard_argv[0] = v;
01541       guard_argv[gcount] = guard_argv[argc];
01542     }
01543   }
01544   
01545   /* Fill in fields: */
01546   j = c;
01547   i = argc;
01548   for (p = stype->name_pos; p >= 0; p--) {
01549     /* Determine which fields are automatic: */
01550     if (p) {
01551       ns = stype->parent_types[p]->num_slots - stype->parent_types[p - 1]->num_slots;
01552       nis = stype->parent_types[p]->num_islots - stype->parent_types[p - 1]->num_islots;
01553     } else {
01554       ns = stype->parent_types[0]->num_slots;
01555       nis = stype->parent_types[0]->num_islots;
01556     }
01557 
01558     ns -= nis;
01559 
01560     /* Fill in automatics: */
01561     while (ns--) {
01562       inst->slots[--j] = stype->parent_types[p]->uninit_val;
01563     }
01564 
01565     /* Fill in supplied: */
01566     while (nis--) {
01567       inst->slots[--j] = args[--i];
01568     }
01569   }
01570   
01571   return (Scheme_Object *)inst;
01572 }
01573 
01574 Scheme_Object *scheme_make_prefab_struct_instance(Scheme_Struct_Type *stype,
01575                                                          Scheme_Object *vec)
01576 {
01577   Scheme_Structure *inst;
01578   int i, c;
01579 
01580   c = stype->num_slots;
01581   inst = (Scheme_Structure *)
01582     scheme_malloc_tagged(sizeof(Scheme_Structure) 
01583                       + ((c - 1) * sizeof(Scheme_Object *)));
01584   
01585   inst->so.type = scheme_structure_type;
01586   inst->stype = stype;
01587   
01588   for (i = 0; i < c; i++) {
01589     inst->slots[i] = SCHEME_VEC_ELS(vec)[i + 1];
01590   }
01591 
01592   return (Scheme_Object *)inst;
01593 }
01594 
01595 Scheme_Object *scheme_clone_prefab_struct_instance(Scheme_Structure *s)
01596 {
01597   Scheme_Structure *inst;
01598   int c, sz;
01599 
01600   c = s->stype->num_slots;
01601   sz = (sizeof(Scheme_Structure) 
01602         + ((c - 1) * sizeof(Scheme_Object *)));
01603   inst = (Scheme_Structure *)scheme_malloc_tagged(sz);
01604   memcpy(inst, s, sz);
01605   
01606   return (Scheme_Object *)inst;
01607 }
01608 
01609 static Scheme_Object *
01610 make_struct_instance(int argc, Scheme_Object **args, Scheme_Object *prim)
01611 {
01612   return scheme_make_struct_instance(SCHEME_PRIM_CLOSURE_ELS(prim)[0], argc, args);
01613 }
01614 
01615 static Scheme_Object *
01616 make_simple_struct_instance(int argc, Scheme_Object **args, Scheme_Object *prim)
01617 /* No guards, uninitialized slots, or proc type */
01618 {
01619   Scheme_Structure *inst;
01620   Scheme_Struct_Type *stype = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
01621   int i, c;
01622 
01623   c = stype->num_slots;
01624   inst = (Scheme_Structure *)
01625     scheme_malloc_tagged(sizeof(Scheme_Structure) 
01626                       + ((c - 1) * sizeof(Scheme_Object *)));
01627   
01628   inst->so.type = scheme_structure_type;
01629   inst->stype = stype;
01630 
01631   for (i = 0; i < argc; i++) {
01632     inst->slots[i] = args[i];
01633   }
01634   
01635   return (Scheme_Object *)inst;
01636 }
01637 
01638 static int is_simple_struct_type(Scheme_Struct_Type *stype)
01639 {
01640   int p;
01641 
01642   if (stype->proc_attr)
01643     return 0;
01644 
01645   for (p = stype->name_pos; p >= 0; p--) {
01646     if (stype->parent_types[p]->guard)
01647       return 0;
01648     if (stype->parent_types[p]->num_slots != stype->parent_types[p]->num_islots)
01649       return 0;
01650   }
01651 
01652   return 1;
01653 }
01654 
01655 static Scheme_Object *struct_pred(int argc, Scheme_Object **args, Scheme_Object *prim)
01656 {
01657   if (SCHEME_STRUCTP(args[0])) {
01658     Scheme_Struct_Type *stype = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
01659     if (STRUCT_TYPEP(stype, ((Scheme_Structure *)args[0])))
01660       return scheme_true;
01661   }
01662   return scheme_false;
01663 }
01664 
01665 static int parse_pos(const char *who, Struct_Proc_Info *i, Scheme_Object **args, int argc)
01666 {
01667   int pos;
01668 
01669   if (!SCHEME_INTP(args[1]) || (SCHEME_INT_VAL(args[1]) < 0)) {
01670     if (SCHEME_BIGNUMP(args[1]) && SCHEME_BIGPOS(args[1])) {
01671       pos = 32769; /* greater than max field count */
01672     } else {
01673       if (!who)
01674        who = i->func_name;
01675       scheme_wrong_type(who, 
01676                      "non-negative exact integer", 
01677                      1, argc, args);
01678       return 0;
01679     }
01680   } else
01681     pos = SCHEME_INT_VAL(args[1]);
01682   
01683   if ((pos < i->struct_type->num_slots)
01684       && i->struct_type->name_pos)
01685     pos += i->struct_type->parent_types[i->struct_type->name_pos - 1]->num_slots;
01686   
01687   if (pos >= i->struct_type->num_slots) {
01688     int sc;
01689 
01690     if (!who)
01691       who = i->func_name;
01692 
01693     sc = (i->struct_type->name_pos
01694          ? (i->struct_type->num_slots
01695             - i->struct_type->parent_types[i->struct_type->name_pos - 1]->num_slots)
01696          : i->struct_type->num_slots);
01697 
01698     if (!sc) {
01699       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01700                      "%s: no slots in <struct:%S>; given index: %V",
01701                      who,
01702                      i->struct_type->name,
01703                      args[1]);
01704     } else {
01705       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01706                      "%s: slot index for <struct:%S> not in [0, %d]: %V",
01707                      who,
01708                      i->struct_type->name,
01709                      sc - 1,
01710                      args[1]);
01711     }
01712 
01713     return 0;
01714   }
01715 
01716   return pos;
01717 }
01718 
01719 static Scheme_Object *struct_getter(int argc, Scheme_Object **args, Scheme_Object *prim)
01720 {
01721   Scheme_Structure *inst;
01722   int pos;
01723   Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
01724 
01725   inst = (Scheme_Structure *)args[0];
01726 
01727   if (!SCHEME_STRUCTP(args[0])) {
01728     scheme_wrong_type(i->func_name, 
01729                     type_name_string(i->struct_type->name), 
01730                     0, argc, args);
01731     return NULL;
01732   } else if (!STRUCT_TYPEP(i->struct_type, inst)) {
01733     wrong_struct_type(i->func_name, 
01734                     i->struct_type->name, 
01735                     SCHEME_STRUCT_NAME_SYM(inst), 
01736                     0, argc, args);
01737     return NULL;
01738   }
01739   
01740   if (argc == 2)
01741     pos = parse_pos(NULL, i, args, argc);
01742   else
01743     pos = i->field;
01744 
01745   return inst->slots[pos];
01746 }
01747 
01748 static Scheme_Object *struct_setter(int argc, Scheme_Object **args, Scheme_Object *prim)
01749 {
01750   Scheme_Structure *inst;
01751   int pos;
01752   Scheme_Object *v;
01753   Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
01754 
01755   if (!SCHEME_STRUCTP(args[0])) {
01756     scheme_wrong_type(i->func_name, 
01757                     type_name_string(i->struct_type->name), 
01758                     0, argc, args);
01759     return NULL;
01760   }
01761        
01762   inst = (Scheme_Structure *)args[0];
01763   if (!STRUCT_TYPEP(i->struct_type, inst)) {
01764     wrong_struct_type(i->func_name, 
01765                     i->struct_type->name, 
01766                     SCHEME_STRUCT_NAME_SYM(inst),
01767                     0, argc, args);
01768     return NULL;
01769   }
01770        
01771   if (argc == 3) {
01772     pos = parse_pos(NULL, i, args, argc);
01773     v = args[2];
01774   } else {
01775     pos = i->field;
01776     v = args[1];
01777   }
01778 
01779   if (i->struct_type->immutables) {
01780     Scheme_Struct_Type *t = i->struct_type;
01781     int p = pos;
01782 
01783     if (t->name_pos)
01784       p -= t->parent_types[t->name_pos - 1]->num_slots;
01785     
01786     if (t->immutables[p]) {
01787       scheme_arg_mismatch(i->func_name, 
01788                        "cannot modify value of immutable field in structure: ", 
01789                        args[0]);
01790       return NULL;
01791     }
01792   }
01793 
01794   inst->slots[pos] = v;
01795   
01796   return scheme_void;
01797 }
01798 
01799 static Scheme_Object *
01800 struct_p(int argc, Scheme_Object *argv[])
01801 {
01802   if (SCHEME_STRUCTP(argv[0])) {
01803     Scheme_Object *insp;
01804     insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
01805     if (scheme_inspector_sees_part(argv[0], insp, -1))
01806       return scheme_true;
01807     else
01808       return scheme_false;
01809   } else 
01810     return scheme_false;
01811 }
01812 
01813 static Scheme_Object *
01814 struct_type_p(int argc, Scheme_Object *argv[])
01815 {
01816   return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_struct_type_type)
01817          ? scheme_true : scheme_false);
01818 }
01819 
01820 static Scheme_Object *proc_struct_type_p(int argc, Scheme_Object *argv[])
01821 {
01822   if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_struct_type_type)) {
01823     if (((Scheme_Struct_Type *)argv[0])->proc_attr)
01824       return scheme_true;
01825     else
01826       return scheme_false;
01827   }
01828   scheme_wrong_type("procedure-struct-type?", "struct-type", 0, argc, argv);
01829   return NULL;
01830 }
01831 
01832 static Scheme_Object *struct_info(int argc, Scheme_Object *argv[])
01833 {
01834   Scheme_Structure *s;
01835   Scheme_Struct_Type *stype;
01836   int p;
01837   Scheme_Object *insp, *a[2];
01838 
01839   if (SCHEME_STRUCTP(argv[0])) {
01840     s = (Scheme_Structure *)argv[0];
01841 
01842     insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
01843     
01844     stype = s->stype;
01845     p = stype->name_pos + 1;
01846     
01847     while (p--) {
01848       stype = stype->parent_types[p];
01849       if (scheme_is_subinspector(stype->inspector, insp)) {
01850        a[0] = (Scheme_Object *)stype;
01851        a[1] = ((SAME_OBJ(stype, s->stype)) ? scheme_false : scheme_true);
01852        
01853        return scheme_values(2, a);
01854       }
01855     }
01856   }
01857   
01858   a[0] = scheme_false;
01859   a[1] = scheme_true;
01860 
01861   return scheme_values(2, a);
01862 }
01863 
01864 static Scheme_Object *check_type_and_inspector(const char *who, int always, int argc, Scheme_Object *argv[])
01865 {
01866   Scheme_Object *insp;
01867   Scheme_Struct_Type *stype;
01868 
01869   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_struct_type_type))
01870     scheme_wrong_type(who, "struct-type", 0, argc, argv);
01871 
01872   stype = (Scheme_Struct_Type *)argv[0];
01873 
01874   insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
01875 
01876   if (!always && !scheme_is_subinspector(stype->inspector, insp)) {
01877     scheme_arg_mismatch(who, 
01878                      "current inspector cannot extract info for struct-type: ",
01879                      argv[0]);
01880     return NULL;
01881   }
01882 
01883   return insp;
01884 }
01885 
01886 static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object **a, int always)
01887 {
01888   Scheme_Struct_Type *stype, *parent;
01889   Scheme_Object *insp, *ims;
01890   int p, cnt;
01891 
01892   insp = check_type_and_inspector("struct-type-info", always, argc, argv);
01893   stype = (Scheme_Struct_Type *)argv[0];
01894 
01895   /* Make sure generic accessor and mutator are created: */
01896   if (!stype->accessor) {
01897     Scheme_Object *p;
01898     char *fn;
01899     
01900     fn = (char *)GENGET_NAME((char *)stype->name, -1, 0);
01901     p = make_struct_proc(stype, fn, SCHEME_GEN_GETTER, 0);
01902     stype->accessor = p;
01903     fn = (char *)GENSET_NAME((char *)stype->name, -1, 0);
01904     p = make_struct_proc(stype, fn, SCHEME_GEN_SETTER, 0);
01905     stype->mutator = p;
01906   }
01907 
01908   if (stype->name_pos)
01909     parent = stype->parent_types[stype->name_pos - 1];
01910   else
01911     parent = NULL;
01912 
01913   a[0] = stype->name;
01914   cnt = stype->num_islots - (parent ? parent->num_islots : 0);
01915   a[1] = scheme_make_integer(cnt);
01916   a[2] = scheme_make_integer(stype->num_slots - (parent ? parent->num_slots : 0) - cnt);
01917   a[3] = stype->accessor;
01918   a[4] = stype->mutator;
01919 
01920   p = stype->name_pos;
01921   while (--p >= 0) {
01922     if (scheme_is_subinspector(stype->parent_types[p]->inspector, insp)) {
01923       break;
01924     }
01925   }
01926 
01927   ims = scheme_null;
01928   if (stype->immutables) {
01929     int i;
01930     for (i = stype->num_islots - (parent ? parent->num_islots : 0); i--; ) {
01931       if (stype->immutables[i])
01932        ims = scheme_make_pair(scheme_make_integer(i), ims);
01933     }
01934   }
01935   a[5] = ims;
01936 
01937   a[6] = ((p >= 0) ? (Scheme_Object *)stype->parent_types[p] : scheme_false);
01938   a[7] = ((p == stype->name_pos - 1) ? scheme_false : scheme_true);
01939 }
01940 
01941 static Scheme_Object *struct_type_info(int argc, Scheme_Object *argv[])
01942 {
01943   Scheme_Object *a[mzNUM_ST_INFO];
01944 
01945   get_struct_type_info(argc, argv, a, 0);
01946 
01947   return scheme_values(mzNUM_ST_INFO, a);
01948 }
01949 
01950 static Scheme_Object *struct_type_pred(int argc, Scheme_Object *argv[])
01951 {
01952   Scheme_Struct_Type *stype;
01953 
01954   check_type_and_inspector("struct-type-make-predicate", 0, argc, argv);
01955   stype = (Scheme_Struct_Type *)argv[0];
01956 
01957   return make_struct_proc(stype, 
01958                        scheme_symbol_val(PRED_NAME(scheme_symbol_val(stype->name),
01959                                                 SCHEME_SYM_LEN(stype->name))),
01960                        SCHEME_PRED,
01961                        stype->num_slots);
01962 }
01963 
01964 static Scheme_Object *struct_type_constr(int argc, Scheme_Object *argv[])
01965 {
01966   Scheme_Struct_Type *stype;
01967 
01968   check_type_and_inspector("struct-type-make-constructor", 0, argc, argv);
01969   stype = (Scheme_Struct_Type *)argv[0];
01970 
01971   return make_struct_proc(stype, 
01972                        scheme_symbol_val(CSTR_NAME(scheme_symbol_val(stype->name),
01973                                                 SCHEME_SYM_LEN(stype->name))),
01974                        SCHEME_CONSTR,
01975                        stype->num_slots);
01976 }
01977 
01978 Scheme_Object *scheme_struct_to_vector(Scheme_Object *_s, Scheme_Object *unknown_val, Scheme_Object *insp)
01979 {
01980   Scheme_Structure *s;
01981   Scheme_Struct_Type *stype;
01982   Scheme_Object *v, *name;
01983   GC_CAN_IGNORE Scheme_Object **array;
01984   int i, m, p, n, last_is_unknown;
01985 
01986   if (!unknown_val)
01987     unknown_val = ellipses_symbol;
01988 
01989   s = (Scheme_Structure *)_s;
01990 
01991   stype = s->stype;
01992   p = stype->name_pos + 1;
01993   m = 0;
01994   last_is_unknown = 0;
01995   while (p--) {
01996     stype = stype->parent_types[p];
01997     if (!scheme_is_subinspector(stype->inspector, insp)) {
01998       if (!last_is_unknown)
01999        m++;
02000       last_is_unknown = 1;
02001     } else {
02002       last_is_unknown = 0;
02003       if (p)
02004        m += stype->num_slots - stype->parent_types[p-1]->num_slots;
02005       else
02006        m += stype->num_slots;
02007     }
02008   }
02009 
02010   stype = s->stype;
02011   p = stype->name_pos + 1;
02012   i = stype->num_slots;
02013   last_is_unknown = 0;
02014  
02015   name = TYPE_NAME((char *)SCHEME_STRUCT_NAME_SYM(s), -1);
02016 
02017   /* Precise GC >>> BEWARE <<<, array is not GC_aligned,
02018      and is therefore marked with GC_CAN_IGNORE. */
02019 
02020   v = scheme_make_vector(m + 1, NULL);
02021   array = SCHEME_VEC_ELS(v);
02022   array[0] = name;
02023   while (p--) {
02024     stype = stype->parent_types[p];
02025     if (p)
02026       n = stype->num_slots - stype->parent_types[p-1]->num_slots;
02027     else
02028       n = stype->num_slots;
02029       
02030     if (!scheme_is_subinspector(stype->inspector, insp)) {
02031       if (!last_is_unknown)
02032        array[1 + (--m)] = unknown_val;
02033       i -= n;
02034       last_is_unknown = 1;
02035     } else {
02036       while (n--) {
02037        array[1 + (--m)] = s->slots[--i];
02038       }
02039       last_is_unknown = 0;
02040     }
02041   }
02042 
02043   return v;
02044 }
02045 
02046 static Scheme_Object *struct_to_vector(int argc, Scheme_Object *argv[])
02047 {
02048   if (!SCHEME_STRUCTP(argv[0])) {
02049     char *tn, *s;
02050     int l;
02051     Scheme_Object *v;
02052 
02053     tn = scheme_get_type_name(SCHEME_TYPE(argv[0]));
02054     l = strlen(tn) - 2; /* drop < ... > */
02055     s = scheme_malloc_atomic(l + 8);
02056     strcpy(s, "struct:");
02057     memcpy(s + 7, tn + 1, l);
02058     s[7 + l] = 0;
02059     
02060     v = scheme_intern_symbol(s);
02061     v = scheme_make_vector(2, v);
02062     SCHEME_VEC_ELS(v)[1] = (argc > 1) ? argv[1] : ellipses_symbol;
02063 
02064     return v;
02065   }
02066 
02067   return scheme_struct_to_vector(argv[0], 
02068                              (argc > 1) ? argv[1] : NULL, 
02069                              scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR));
02070 }
02071 
02072 static Scheme_Object *prefab_struct_key(int argc, Scheme_Object *argv[])
02073 {
02074   Scheme_Structure *s = (Scheme_Structure *)argv[0];
02075 
02076   if (SCHEME_STRUCTP(argv[0])
02077       && s->stype->prefab_key)
02078     return SCHEME_CDR(s->stype->prefab_key);
02079   
02080   return scheme_false;
02081 }
02082 
02083 static Scheme_Object *make_prefab_struct(int argc, Scheme_Object *argv[])
02084 {
02085   Scheme_Struct_Type *stype;
02086   Scheme_Object *vec;
02087   int i;
02088   
02089   stype = scheme_lookup_prefab_type(argv[0], argc - 1);
02090 
02091   if (!stype)
02092     scheme_wrong_type("make-prefab-struct", "prefab key", 0, argc, argv);
02093 
02094   if (stype->num_slots != (argc - 1)) {
02095     scheme_arg_mismatch("make-struct-type", 
02096                         "mismatch between argument count and prefab key: ", 
02097                         argv[0]);
02098   }
02099 
02100   vec = scheme_make_vector(argc, 0);
02101   for (i = 0; i < argc ; i++) {
02102     SCHEME_VEC_ELS(vec)[i] = argv[i];
02103   }
02104 
02105   return scheme_make_prefab_struct_instance(stype, vec);
02106 }
02107 
02108 #define MAX_STRUCT_FIELD_COUNT 32768
02109 #define MAX_STRUCT_FIELD_COUNT_STR "32768"
02110 
02111 static Scheme_Object *prefab_key_struct_type(int argc, Scheme_Object *argv[])
02112 {
02113   Scheme_Struct_Type *stype;
02114   int v;
02115 
02116   if (SCHEME_INTP(argv[1])) {
02117     v = SCHEME_INT_VAL(argv[1]);
02118     if (v > MAX_STRUCT_FIELD_COUNT)
02119       v = -1;
02120   } else
02121     v = -1;
02122 
02123   stype = scheme_lookup_prefab_type(argv[0], (v >= 0) ? v : -1);
02124 
02125   if (!stype)
02126     scheme_wrong_type("make-prefab-struct", "prefab key", 0, argc, argv);
02127 
02128   if (v < 0)
02129     scheme_wrong_type("make-prefab-struct", 
02130                       "integer in [0, " MAX_STRUCT_FIELD_COUNT_STR "]", 
02131                       1, argc, argv);
02132 
02133   if (stype->num_slots != v) {
02134     scheme_arg_mismatch("make-prefab-struct", 
02135                         "prefab key field count does not match supplied count: ",
02136                         argv[1]);
02137   }
02138 
02139   return (Scheme_Object *)stype;
02140 }
02141 
02142 int scheme_inspector_sees_part(Scheme_Object *s, Scheme_Object *insp, int pos)
02143      /* pos == -1 => sees any part
02144        pos == -2 => sees all parts */
02145 {
02146   Scheme_Struct_Type *stype = ((Scheme_Structure *)s)->stype;
02147   int p;
02148 
02149   p = stype->name_pos;  
02150 
02151   if (pos == -1) {
02152     /* Check for any visible field */
02153     Scheme_Object *prev = NULL;
02154     while (p > -1) {
02155       if (!SAME_OBJ(stype->parent_types[p]->inspector, prev)) {
02156        prev = stype->parent_types[p]->inspector;
02157        if (scheme_is_subinspector(prev, insp))
02158          return 1;
02159       }
02160       p--;
02161     }
02162 
02163     return 0;
02164   } else if (pos == -2) {
02165     /* Check for all visible fields */
02166     Scheme_Object *prev = NULL;
02167     while (p > -1) {
02168       if (!SAME_OBJ(stype->parent_types[p]->inspector, prev)) {
02169        prev = stype->parent_types[p]->inspector;
02170        if (!scheme_is_subinspector(prev, insp))
02171          return 0;
02172       }
02173       p--;
02174     }
02175 
02176     return 1;
02177   } else {
02178     /* Find struct containing position. */
02179     while (p && (stype->parent_types[p - 1]->num_slots > pos)) {
02180       p--;
02181     }
02182 
02183     return scheme_is_subinspector(stype->parent_types[p]->inspector, insp);
02184   }
02185 }
02186 
02187 
02188 #define STRUCT_mPROCP(o, t, v)                                        \
02189   (SCHEME_PRIMP(o) && ((((Scheme_Primitive_Proc *)o)->pp.flags & (t)) == (v)))
02190 
02191 #define STRUCT_PROCP(o, t) STRUCT_mPROCP(o, t, t)
02192 
02193 static Scheme_Object *
02194 struct_setter_p(int argc, Scheme_Object *argv[])
02195 {
02196   return ((STRUCT_mPROCP(argv[0], 
02197                       SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK,
02198                       SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER)
02199           || STRUCT_mPROCP(argv[0], 
02200                          SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK,
02201                          SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER))
02202          ? scheme_true : scheme_false);
02203 }
02204 
02205 static Scheme_Object *
02206 struct_getter_p(int argc, Scheme_Object *argv[])
02207 {
02208   return ((STRUCT_PROCP(argv[0], SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)
02209           || STRUCT_mPROCP(argv[0], 
02210                          SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK,
02211                          SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER))
02212          ? scheme_true : scheme_false);
02213 }
02214 
02215 static Scheme_Object *
02216 struct_pred_p(int argc, Scheme_Object *argv[])
02217 {
02218   return (STRUCT_PROCP(argv[0], SCHEME_PRIM_IS_STRUCT_PRED)
02219          ? scheme_true : scheme_false);
02220 }
02221 
02222 static Scheme_Object *
02223 struct_constr_p(int argc, Scheme_Object *argv[])
02224 {
02225   return (STRUCT_mPROCP(argv[0], 
02226                      SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK,
02227                      SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_CONSTR)
02228          ? scheme_true : scheme_false);
02229 }
02230 
02231 static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
02232                                          int argc, Scheme_Object *argv[])
02233 {
02234   Struct_Proc_Info *i;
02235   int pos;  
02236   char *name;
02237   const char *fieldstr;
02238   char digitbuf[20];
02239   int fieldstrlen;
02240 
02241   if (!STRUCT_mPROCP(argv[0], 
02242                    SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK,
02243                    SCHEME_PRIM_IS_STRUCT_OTHER | (getter 
02244                                               ? SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER
02245                                               : SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER))) {
02246     scheme_wrong_type(who, (getter 
02247                          ? "accessor procedure that requires a field index"
02248                          : "mutator procedure that requires a field index"),
02249                     0, argc, argv);
02250     return NULL;
02251   }
02252 
02253   i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(argv[0])[0];
02254 
02255   pos = parse_pos(who, i, argv, argc);
02256   
02257   if (argc > 2) {
02258     if (SCHEME_FALSEP(argv[2])) {
02259       fieldstr = NULL;
02260       fieldstrlen = 0;
02261     } else {
02262       if (!SCHEME_SYMBOLP(argv[2])) {
02263         scheme_wrong_type(who, "symbol or #f", 2, argc, argv);
02264         return NULL;
02265       }
02266       fieldstr = scheme_symbol_val(argv[2]);
02267       fieldstrlen = SCHEME_SYM_LEN(argv[2]);
02268     }
02269   } else {
02270     sprintf(digitbuf, "field%d", (int)SCHEME_INT_VAL(argv[1]));
02271     fieldstr = digitbuf;
02272     fieldstrlen = strlen(fieldstr);
02273   }
02274 
02275   if (!fieldstr) {
02276     if (getter)
02277       name = "accessor";
02278     else
02279       name = "mutator";
02280   } else if (getter) {
02281     name = (char *)GET_NAME((char *)i->struct_type->name, -1,
02282                          fieldstr, fieldstrlen, 0);
02283   } else {
02284     name = (char *)SET_NAME((char *)i->struct_type->name, -1,
02285                          fieldstr, fieldstrlen, 0);
02286   }
02287 
02288   return make_struct_proc(i->struct_type, 
02289                        name, 
02290                        (getter ? SCHEME_GETTER : SCHEME_SETTER), pos);
02291 }
02292 
02293 static Scheme_Object *make_struct_field_accessor(int argc, Scheme_Object *argv[])
02294 {
02295   return make_struct_field_xxor("make-struct-field-accessor", 1, argc, argv);
02296                             
02297 }
02298 
02299 static Scheme_Object *make_struct_field_mutator(int argc, Scheme_Object *argv[])
02300 {
02301   return make_struct_field_xxor("make-struct-field-mutator", 0, argc, argv);
02302 }
02303 
02304 /*========================================================================*/
02305 /*                           wraps and nacks                              */
02306 /*========================================================================*/
02307 
02308 static Scheme_Object *wrap_evt(const char *who, int wrap, int argc, Scheme_Object *argv[])
02309 {
02310   Wrapped_Evt *ww;
02311 
02312   if (!scheme_is_evt(argv[0]) || (wrap && handle_evt_p(0, argv)))
02313     scheme_wrong_type(who, wrap ? "non-handle evt" : "evt", 0, argc, argv);
02314   scheme_check_proc_arity(who, 1, 1, argc, argv);
02315 
02316   ww = MALLOC_ONE_TAGGED(Wrapped_Evt);
02317   ww->so.type = (wrap ? scheme_wrap_evt_type : scheme_handle_evt_type);
02318   ww->evt = argv[0];
02319   ww->wrapper = argv[1];
02320 
02321   return (Scheme_Object *)ww;
02322 }
02323 
02324 Scheme_Object *scheme_wrap_evt(int argc, Scheme_Object *argv[])
02325 {
02326   return wrap_evt("wrap-evt", 1, argc, argv);
02327 }
02328 
02329 Scheme_Object *handle_evt(int argc, Scheme_Object *argv[])
02330 {
02331   return wrap_evt("handle-evt", 0, argc, argv);
02332 }
02333 
02334 Scheme_Object *handle_evt_p(int argc, Scheme_Object *argv[])
02335 {
02336   if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_handle_evt_type))
02337     return scheme_true;
02338 
02339   if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_evt_set_type)) {
02340     Evt_Set *es = (Evt_Set *)argv[0];
02341     int i;
02342     for (i = es->argc; i--; ) {
02343       if (SAME_TYPE(SCHEME_TYPE(es->argv[i]), scheme_handle_evt_type)) {
02344        return scheme_true;
02345       }
02346     }
02347   }
02348 
02349   if (argc)
02350     return scheme_false;
02351   else
02352     return NULL;
02353 }
02354 
02355 static Scheme_Object *nack_evt(int argc, Scheme_Object *argv[])
02356 {
02357   Nack_Guard_Evt *nw;
02358 
02359   scheme_check_proc_arity("nack-guard-evt", 1, 0, argc, argv);
02360 
02361   nw = MALLOC_ONE_TAGGED(Nack_Guard_Evt);
02362   nw->so.type = scheme_nack_guard_evt_type;
02363   nw->maker = argv[0];
02364 
02365   return (Scheme_Object *)nw;
02366 }
02367 
02368 Scheme_Object *scheme_poll_evt(int argc, Scheme_Object *argv[])
02369 {
02370   Nack_Guard_Evt *nw;
02371 
02372   scheme_check_proc_arity("poll-guard-evt", 1, 0, argc, argv);
02373 
02374   nw = MALLOC_ONE_TAGGED(Nack_Guard_Evt);
02375   nw->so.type = scheme_poll_evt_type;
02376   nw->maker = argv[0];
02377 
02378   return (Scheme_Object *)nw;
02379 }
02380 
02381 static int wrapped_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo)
02382 {
02383   Wrapped_Evt *ww = (Wrapped_Evt *)o;
02384   Scheme_Object *wrapper;
02385 
02386   if (ww->so.type == scheme_wrap_evt_type) {
02387     wrapper = ww->wrapper;
02388   } else {
02389     /* A box around the proc means that it's a cont wrapper: */
02390     wrapper = scheme_box(ww->wrapper);
02391   }
02392 
02393   scheme_set_sync_target(sinfo, ww->evt, wrapper, NULL, 0, 1, NULL);
02394   return 0;
02395 }
02396 
02397 static int nack_guard_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo)
02398 {
02399   Nack_Guard_Evt *nw = (Nack_Guard_Evt *)o;
02400   Scheme_Object *sema, *a[1], *result;
02401   Scheme_Object *nack;
02402 
02403   if (sinfo->false_positive_ok) {
02404     sinfo->potentially_false_positive = 1;
02405     return 1;
02406   }
02407 
02408   sema = scheme_make_sema(0);
02409 
02410   /* Install the semaphore immediately, so that it's posted on
02411      exceptions (e.g., breaks) even if they happen while trying
02412      to run the maker. */
02413   scheme_set_sync_target(sinfo, o, NULL, sema, 0, 0, NULL);
02414 
02415   /* Remember both the sema and the current thread's dead evt: */
02416   nack = scheme_alloc_object();
02417   nack->type = scheme_nack_evt_type;
02418   SCHEME_PTR1_VAL(nack) = sema;
02419   result = scheme_get_thread_dead(scheme_current_thread);
02420   SCHEME_PTR2_VAL(nack) = result;
02421 
02422   a[0] = nack;
02423   result = scheme_apply(nw->maker, 1, a);
02424 
02425   if (scheme_is_evt(result)) {
02426     scheme_set_sync_target(sinfo, result, NULL, NULL, 0, 1, NULL);
02427     return 0;
02428   } else
02429     return 1; /* Non-evt => ready */
02430 }
02431 
02432 static int nack_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo)
02433 {
02434   Scheme_Object *a[2], *wset;
02435 
02436   wset = SCHEME_PTR1_VAL(o);
02437   /* Lazily construct a evt set: */
02438   if (SCHEME_SEMAP(wset)) {
02439     a[0] = wset;
02440     a[1] = SCHEME_PTR2_VAL(o);
02441     wset = scheme_make_evt_set(2, a);
02442     SCHEME_PTR1_VAL(o) = wset;
02443   }
02444 
02445   /* Redirect to the set, and wrap with void: */
02446   scheme_set_sync_target(sinfo, wset, scheme_void, NULL, 0, 1, NULL);
02447 
02448   return 0;
02449 }
02450 
02451 static int poll_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo)
02452 {
02453   Nack_Guard_Evt *nw = (Nack_Guard_Evt *)o;
02454   Scheme_Object *a[1], *result;
02455 
02456   if (sinfo->false_positive_ok) {
02457     sinfo->potentially_false_positive = 1;
02458     return 1;
02459   }
02460 
02461   a[0] = (sinfo->is_poll ? scheme_true : scheme_false);
02462   result = scheme_apply(nw->maker, 1, a);
02463 
02464   if (scheme_is_evt(result)) {
02465     scheme_set_sync_target(sinfo, result, NULL, NULL, 0, 1, NULL);
02466     return 0;
02467   } else
02468     return 1; /* Non-evt => ready */
02469 }
02470 
02471 /*========================================================================*/
02472 /*                          struct op maker                               */
02473 /*========================================================================*/
02474 
02475 #define NUM_BASE_VALUES 3
02476 #define NUM_VALUES_PER_FIELD 2
02477 
02478 Scheme_Object **scheme_make_struct_values(Scheme_Object *type,
02479                                      Scheme_Object **names,
02480                                      int count,
02481                                      int flags)
02482 {
02483   Scheme_Struct_Type *struct_type;
02484   Scheme_Object **values;
02485   int slot_num, pos;
02486 
02487   struct_type = (Scheme_Struct_Type *)type;
02488 
02489   if (flags & SCHEME_STRUCT_EXPTIME)
02490     --count;
02491 
02492   values = MALLOC_N(Scheme_Object *, count);
02493  
02494 #ifdef MEMORY_COUNTING_ON
02495   if (scheme_starting_up) {
02496     /* We know that these values will be kept (exns, arity-at-least, etc.). */
02497     scheme_misc_count += count * sizeof(Scheme_Object *);
02498   }
02499 #endif
02500 
02501   pos = 0;
02502   if (!(flags & SCHEME_STRUCT_NO_TYPE))
02503     values[pos++] = (Scheme_Object *)struct_type;
02504   if (!(flags & SCHEME_STRUCT_NO_CONSTR)) {
02505     Scheme_Object *vi;
02506     vi = make_struct_proc(struct_type,
02507                        scheme_symbol_val(names[pos]),
02508                        SCHEME_CONSTR, 
02509                        struct_type->num_slots);
02510     values[pos] = vi;
02511     pos++;
02512   }
02513   if (!(flags & SCHEME_STRUCT_NO_PRED)) {
02514     Scheme_Object *vi;
02515     vi = make_struct_proc(struct_type,
02516                        scheme_symbol_val(names[pos]),
02517                        SCHEME_PRED,
02518                        0);
02519     values[pos] = vi;
02520     pos++;
02521   }
02522 
02523   if (flags & SCHEME_STRUCT_GEN_GET)
02524     --count;
02525   if (flags & SCHEME_STRUCT_GEN_SET)
02526     --count;
02527 
02528   slot_num = (struct_type->name_pos
02529              ? struct_type->parent_types[struct_type->name_pos - 1]->num_slots 
02530              : 0);
02531   while (pos < count) {
02532     if (!(flags & SCHEME_STRUCT_NO_GET)) {
02533       Scheme_Object *vi;
02534       vi = make_struct_proc(struct_type,
02535                          scheme_symbol_val(names[pos]),
02536                          SCHEME_GETTER,
02537                          slot_num);
02538       values[pos] = vi;
02539       pos++;
02540     }
02541     
02542     if (!(flags & SCHEME_STRUCT_NO_SET)) {
02543       Scheme_Object *vi;
02544       vi = make_struct_proc(struct_type,
02545                          scheme_symbol_val(names[pos]),
02546                          SCHEME_SETTER,
02547                          slot_num);
02548       values[pos] = vi;
02549       pos++;
02550     }
02551 
02552     slot_num++;
02553   }
02554 
02555   if (flags & SCHEME_STRUCT_GEN_GET) {
02556     Scheme_Object *vi;
02557     vi = make_struct_proc(struct_type,
02558                        scheme_symbol_val(names[pos]),
02559                        SCHEME_GEN_GETTER,
02560                        slot_num);
02561     values[pos] = vi;
02562     pos++;
02563   }
02564   if (flags & SCHEME_STRUCT_GEN_SET) {
02565     Scheme_Object *vi;
02566     vi = make_struct_proc(struct_type,
02567                        scheme_symbol_val(names[pos]),
02568                        SCHEME_GEN_SETTER,
02569                        slot_num);
02570     values[pos] = vi;
02571     pos++;
02572   }
02573   
02574   return values;
02575 }
02576 
02577 static Scheme_Object **_make_struct_names(const char *base, int blen,
02578                                      int fcount,
02579                                      Scheme_Object *field_symbols,
02580                                      const char **field_strings,
02581                                      int flags, int *count_out)
02582 {
02583   Scheme_Object **names;
02584   const char *field_name;
02585   int count, fnlen;
02586   int slot_num, pos;
02587 
02588   count = 0;
02589 
02590   if (!(flags & SCHEME_STRUCT_NO_TYPE))
02591     count++;
02592   if (!(flags & SCHEME_STRUCT_NO_CONSTR))
02593     count++;
02594   if (!(flags & SCHEME_STRUCT_NO_PRED))
02595     count++;
02596   if (!(flags & SCHEME_STRUCT_NO_GET))
02597     count += fcount;
02598   if (!(flags & SCHEME_STRUCT_NO_SET))
02599     count += fcount;
02600   if (flags & SCHEME_STRUCT_GEN_GET)
02601     count++;
02602   if (flags & SCHEME_STRUCT_GEN_SET)
02603     count++;
02604   if (flags & SCHEME_STRUCT_EXPTIME)
02605     count++;
02606 
02607   if (count_out) {
02608     *count_out = count;
02609     count_out = NULL; /* Might be an interior pointer. */
02610   }
02611 
02612   names = MALLOC_N(Scheme_Object *, count);
02613 
02614 #ifdef MEMORY_COUNTING_ON
02615   if (scheme_starting_up) {
02616     /* We know that these names will be kept (exns, arity-at-least, etc.). */
02617     scheme_misc_count += count * sizeof(Scheme_Object *);
02618   }
02619 #endif
02620 
02621   pos = 0;
02622 
02623   if (!(flags & SCHEME_STRUCT_NO_TYPE)) {
02624     Scheme_Object *nm;
02625     nm = TYPE_NAME(base, blen);
02626     names[pos++] = nm;
02627   }
02628   if (!(flags & SCHEME_STRUCT_NO_CONSTR)) {
02629     Scheme_Object *nm;
02630     nm = CSTR_NAME(base, blen);
02631     names[pos++] = nm;
02632   }
02633   if (!(flags & SCHEME_STRUCT_NO_PRED)) {
02634     Scheme_Object *nm;
02635     nm = PRED_NAME(base, blen);
02636     names[pos++] = nm;
02637   }
02638 
02639   if (fcount) {
02640     for (slot_num = 0; slot_num < fcount; slot_num++) {
02641       if (field_symbols) {
02642        Scheme_Object *fn = SCHEME_CAR(field_symbols);
02643        field_symbols = SCHEME_CDR(field_symbols);
02644 
02645        field_name = scheme_symbol_val(fn);
02646        fnlen = SCHEME_SYM_LEN(fn);
02647       } else {
02648        field_name = field_strings[slot_num];
02649        fnlen = strlen(field_name);
02650       }
02651 
02652       if (!(flags & SCHEME_STRUCT_NO_GET)) {
02653        Scheme_Object *nm;
02654        nm = GET_NAME(base, blen, field_name, fnlen, 1);
02655        names[pos++] = nm;
02656       }
02657       if (!(flags & SCHEME_STRUCT_NO_SET)) {
02658        Scheme_Object *nm;
02659        nm = SET_NAME(base, blen, field_name, fnlen, 1);
02660        names[pos++] = nm;
02661       }
02662     }
02663   }
02664 
02665   if (flags & SCHEME_STRUCT_GEN_GET) {
02666     Scheme_Object *nm;
02667     nm = GENGET_NAME(base, blen, 1);
02668     names[pos++] = nm;
02669   }
02670   if (flags & SCHEME_STRUCT_GEN_SET) {
02671     Scheme_Object *nm;
02672     nm = GENSET_NAME(base, blen, 1);
02673     names[pos++] = nm;
02674   }
02675 
02676   if (flags & SCHEME_STRUCT_EXPTIME) {
02677     Scheme_Object *nm;
02678     nm = EXPTIME_NAME(base, blen, 1);
02679     names[pos++] = nm;
02680   }
02681 
02682   return names;
02683 }
02684 
02685 Scheme_Object **scheme_make_struct_names(Scheme_Object *base, 
02686                                     Scheme_Object *field_symbols,
02687                                     int flags, int *count_out)
02688 {
02689   int len;
02690   len = field_symbols ? scheme_list_length(field_symbols) : 0;
02691 
02692   return _make_struct_names(scheme_symbol_val(base),
02693                          SCHEME_SYM_LEN(base),
02694                          len,
02695                          field_symbols, NULL,
02696                          flags, count_out);
02697 }
02698 
02699 Scheme_Object **scheme_make_struct_names_from_array(const char *base, 
02700                                               int fcount,
02701                                               const char **fields,
02702                                               int flags, int *count_out)
02703 {
02704   return _make_struct_names(base,
02705                          strlen(base),
02706                          fcount,
02707                          NULL, fields,
02708                          flags, count_out);
02709 }
02710 
02711 static Scheme_Object *
02712 make_struct_proc(Scheme_Struct_Type *struct_type, 
02713                char *func_name, 
02714                Scheme_ProcT proc_type, int field_num)
02715 {
02716   Scheme_Object *p, *a[1];
02717   short flags = 0;
02718 
02719   if (proc_type == SCHEME_CONSTR) {
02720     int simple;
02721     simple = is_simple_struct_type(struct_type);
02722     a[0] = (Scheme_Object *)struct_type;
02723     p = scheme_make_folding_prim_closure((simple 
02724                                      ? make_simple_struct_instance
02725                                      : make_struct_instance),
02726                                     1, a,
02727                                     func_name,
02728                                     struct_type->num_islots,
02729                                     struct_type->num_islots,
02730                                     0);
02731     flags |= SCHEME_PRIM_STRUCT_TYPE_CONSTR | SCHEME_PRIM_IS_STRUCT_OTHER;
02732   } else if (proc_type == SCHEME_PRED) {
02733     a[0] = (Scheme_Object *)struct_type;
02734     p = scheme_make_folding_prim_closure(struct_pred,
02735                                     1, a,
02736                                     func_name,
02737                                     1, 1, 1);
02738     flags |= SCHEME_PRIM_IS_STRUCT_PRED;
02739   } else {
02740     Struct_Proc_Info *i;
02741     int need_pos;
02742 
02743     i = MALLOC_ONE_RT(Struct_Proc_Info);
02744 #ifdef MZTAG_REQUIRED
02745     i->type = scheme_rt_struct_proc_info;
02746 #endif
02747     i->struct_type = struct_type;
02748     i->func_name = func_name;
02749     i->field = field_num;
02750 
02751     if ((proc_type == SCHEME_GEN_GETTER)
02752        || (proc_type == SCHEME_GEN_SETTER))
02753       need_pos = 1;
02754     else
02755       need_pos = 0;
02756 
02757     a[0] = (Scheme_Object *)i;
02758 
02759     if ((proc_type == SCHEME_GETTER) || (proc_type == SCHEME_GEN_GETTER)) {
02760       p = scheme_make_folding_prim_closure(struct_getter,
02761                                       1, a,
02762                                       func_name,
02763                                       1 + need_pos, 1 + need_pos, 0);
02764       if (need_pos)
02765        flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER | SCHEME_PRIM_IS_STRUCT_OTHER;
02766       else
02767        flags |= SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER;
02768       /* Cache the accessor only if `struct_info' is used.
02769         This avoids keep lots of useless accessors.
02770         if (need_pos) struct_type->accessor = p; */
02771     } else {
02772       p = scheme_make_folding_prim_closure(struct_setter,
02773                                       1, a,
02774                                       func_name,
02775                                       2 + need_pos, 2 + need_pos, 0);
02776       if (need_pos)
02777        flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER | SCHEME_PRIM_IS_STRUCT_OTHER;
02778       else
02779        flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER | SCHEME_PRIM_IS_STRUCT_OTHER;
02780       /* See note above:
02781         if (need_pos) struct_type->mutator = p; */
02782     }
02783   }
02784 
02785   ((Scheme_Closed_Primitive_Proc *)p)->pp.flags |= flags;
02786 
02787   return p;
02788 }
02789 
02790 static Scheme_Object *make_name(const char *pre, const char *tn, int ltn,
02791                             const char *post1, const char *fn, int lfn,
02792                             const char *post2, int sym)
02793 {
02794   int total, lp, lp1, lp2, xltn, xlfn;
02795   char *name, buffer[256];
02796 
02797   if (ltn < 0)
02798     xltn = SCHEME_SYM_LEN((Scheme_Object *)tn);
02799   else
02800     xltn = ltn;
02801   
02802   if (lfn < 0)
02803     xlfn = SCHEME_SYM_LEN((Scheme_Object *)fn);
02804   else
02805     xlfn = lfn;
02806   
02807   total = lp = strlen(pre);
02808   total += xltn;
02809   total += (lp1 = strlen(post1));
02810   total += xlfn;
02811   total += (lp2 = strlen(post2));
02812 
02813   if (sym && (total < 256))
02814     name = buffer;
02815   else
02816     name = (char *)scheme_malloc_atomic(sizeof(char)*(total + 1));
02817   
02818   memcpy(name, pre, lp);
02819   total = lp;
02820   memcpy(name + total, (ltn < 0) ? SCHEME_SYM_VAL((Scheme_Object *)tn) : tn, xltn);
02821   total += xltn;
02822   memcpy(name + total, post1, lp1);
02823   total += lp1;
02824   memcpy(name + total, (lfn < 0) ? SCHEME_SYM_VAL((Scheme_Object *)fn) : fn, xlfn);
02825   total += xlfn;
02826   memcpy(name + total, post2, lp2);
02827   total += lp2;
02828 
02829   name[total] = 0;
02830 
02831   if (sym)
02832     return scheme_intern_exact_symbol(name, total);
02833   else
02834     return (Scheme_Object *)name;
02835 }
02836 
02837 static Scheme_Object *get_phase_ids(Scheme_Object *_v, int phase)
02838 {
02839   Scheme_Object **v = (Scheme_Object **)_v;
02840   Scheme_Object *l, **names, *tp, *cns, *prd, *super_exptime, *w, *macro;
02841   Scheme_Hash_Table *ht;
02842   int count, i, flags;
02843 
02844   ht = (Scheme_Hash_Table *)v[3];
02845 
02846   if (!ht) {
02847     ht = scheme_make_hash_table(SCHEME_hash_ptr);
02848     v[3] = (Scheme_Object *)ht;
02849   }
02850 
02851   l = scheme_hash_get(ht, scheme_make_integer(phase));
02852   if (l)
02853     return l;
02854 
02855   names = (Scheme_Object **)v[0];
02856   count = SCHEME_INT_VAL(v[1]);
02857   super_exptime = v[2];
02858 
02859   w = scheme_sys_wraps((Scheme_Comp_Env *)(scheme_make_integer(phase)));
02860 
02861   tp = names[0];
02862   cns = names[1];
02863   prd = names[2];
02864 
02865   tp = scheme_datum_to_syntax(tp, scheme_false, w, 0, 0);
02866   cns = scheme_datum_to_syntax(cns, scheme_false, w, 0, 0);
02867   prd = scheme_datum_to_syntax(prd, scheme_false, w, 0, 0);
02868 
02869   if (super_exptime) {
02870     super_exptime = get_phase_ids(SCHEME_PTR2_VAL(super_exptime), phase);
02871     super_exptime = SCHEME_PTR_VAL(super_exptime);
02872     l = scheme_make_pair(scheme_datum_to_syntax(v[4], scheme_false, w, 0, 0), scheme_null);
02873     super_exptime = SCHEME_CDR(SCHEME_CDR(SCHEME_CDR(super_exptime)));
02874   } else {
02875     l = scheme_make_pair(scheme_true, scheme_null);
02876   }
02877 
02878   if (count > 3) {
02879     Scheme_Object *n, *gets, *sets;
02880 
02881     if (super_exptime) {
02882       gets = SCHEME_CAR(super_exptime);
02883       sets = SCHEME_CADR(super_exptime);
02884     } else {
02885       gets = scheme_null;
02886       sets = scheme_null;
02887     }
02888 
02889     flags = SCHEME_INT_VAL(v[5]);
02890     
02891     for (i = 3; i < count - 1; i++) {
02892       n = names[i];
02893       n = scheme_datum_to_syntax(n, scheme_false, w, 0, 0);
02894       gets = scheme_make_pair(n, gets);
02895 
02896       if (!(flags & SCHEME_STRUCT_NO_SET)) {
02897        i++;
02898        n = names[i];
02899        n = scheme_datum_to_syntax(n, scheme_false, w, 0, 0);
02900        sets = scheme_make_pair(n, sets);
02901       } else
02902        sets = scheme_make_pair(scheme_false, sets);
02903     }
02904 
02905     l = scheme_make_pair(gets, scheme_make_pair(sets, l));
02906   } else {
02907     if (super_exptime)
02908       l = icons(SCHEME_CAR(super_exptime),
02909               icons(SCHEME_CADR(super_exptime),
02910                     l));
02911     else
02912       l = scheme_make_pair(scheme_null, scheme_make_pair(scheme_null, l));
02913   }
02914 
02915   l = scheme_make_pair(prd, l);
02916   l = scheme_make_pair(cns, l);
02917   l = scheme_make_pair(tp, l);
02918 
02919   macro = scheme_alloc_small_object();
02920   macro->type = scheme_macro_type;
02921   SCHEME_PTR_VAL(macro) = l;
02922 
02923   scheme_hash_set(ht, scheme_make_integer(phase), macro);
02924 
02925   return macro;
02926 }
02927 
02928 Scheme_Object *scheme_make_struct_exptime(Scheme_Object **names, int count,
02929                                      Scheme_Object *super_sym,
02930                                      Scheme_Object *super_exptime,
02931                                      int flags)
02932 {
02933   Scheme_Object *macro;
02934   Scheme_Object **v;
02935 
02936   if (!(flags & SCHEME_STRUCT_EXPTIME)) {
02937     scheme_signal_error("struct exptime needs SCHEME_STRUCT_EXPTIME");
02938     return NULL;
02939   }
02940 
02941   v = MALLOC_N(Scheme_Object*, 6);
02942   v[0] = (Scheme_Object *)names;
02943   v[1] = scheme_make_integer(count);
02944   v[2] = super_exptime;
02945   v[3] = NULL; /* hash table, filled in by get_phase_ids */
02946   v[4] = super_sym;
02947   v[5] = scheme_make_integer(flags);
02948 
02949   macro = scheme_alloc_object();
02950   macro->type = scheme_lazy_macro_type;
02951   SCHEME_PTR1_VAL(macro) = (Scheme_Object *)get_phase_ids;
02952   SCHEME_PTR2_VAL(macro) = (Scheme_Object *)v;
02953 
02954   return macro;
02955 }
02956 
02957 /*========================================================================*/
02958 /*                             struct type                                */
02959 /*========================================================================*/
02960 
02961 static Scheme_Object *count_k(void);
02962 
02963 static int count_non_proc_props(Scheme_Object *props)
02964 {
02965   Scheme_Struct_Property *p;
02966   Scheme_Object *v;
02967   int count = 0;
02968 
02969   {
02970 #include "mzstkchk.h"
02971     {
02972       scheme_current_thread->ku.k.p1 = (void *)props;
02973       return SCHEME_INT_VAL(scheme_handle_stack_overflow(count_k));
02974     }
02975   }
02976   SCHEME_USE_FUEL(1);
02977 
02978   for (; SCHEME_PAIRP(props); props = SCHEME_CDR(props)) {
02979     v = SCHEME_CAR(props);
02980     p = (Scheme_Struct_Property *)SCHEME_CAR(v);
02981     if (!SAME_OBJ((Scheme_Object *)p, proc_property))
02982       count++;
02983     if (p->supers) {
02984       count += count_non_proc_props(p->supers);
02985     }
02986   }
02987 
02988   return count;
02989 }
02990 
02991 static Scheme_Object *count_k(void)
02992 {
02993   Scheme_Thread *p = scheme_current_thread;
02994   Scheme_Object *props = (Scheme_Object *)p->ku.k.p1;
02995   int c;
02996 
02997   p->ku.k.p1 = NULL;
02998 
02999   c = count_non_proc_props(props);
03000 
03001   return scheme_make_integer(c);
03002 }
03003 
03004 static Scheme_Object *append_super_props(Scheme_Struct_Property *p, Scheme_Object *arg, Scheme_Object *orig)
03005 {
03006   Scheme_Object *first = NULL, *last = NULL, *props, *pr, *v, *a[1];
03007 
03008   if (p->supers) {
03009     props = p->supers;
03010     for (; SCHEME_PAIRP(props); props = SCHEME_CDR(props)) {
03011       v = SCHEME_CAR(props);
03012 
03013       a[0] = arg;
03014       v = scheme_make_pair(SCHEME_CAR(v), _scheme_apply(SCHEME_CDR(v), 1, a));
03015 
03016       pr = scheme_make_pair(v, scheme_null);
03017       if (last)
03018         SCHEME_CDR(last) = pr;
03019       else
03020         first = pr;
03021       last = pr;
03022     }
03023   }
03024 
03025   if (last) {
03026     SCHEME_CDR(last) = orig;
03027     return first;
03028   } else
03029     return orig;
03030 }
03031 
03032 static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base, int blen,
03033                                    Scheme_Object *parent,
03034                                    Scheme_Object *inspector,
03035                                    int num_fields,
03036                                    int num_uninit_fields,
03037                                    Scheme_Object *uninit_val,
03038                                    Scheme_Object *props,
03039                                    Scheme_Object *proc_attr,
03040                                    Scheme_Object *immutable_pos_list,
03041                                    Scheme_Object *guard)
03042 {
03043   Scheme_Struct_Type *struct_type, *parent_type;
03044   int j, depth, checked_proc = 0;
03045   
03046   parent_type = (Scheme_Struct_Type *)parent;
03047 
03048   depth = parent_type ? (1 + parent_type->name_pos) : 0;
03049 
03050   struct_type = (Scheme_Struct_Type *)scheme_malloc_tagged(sizeof(Scheme_Struct_Type)
03051                                                            + (depth 
03052                                                               * sizeof(Scheme_Struct_Type *)));
03053 
03054   /* defeats optimizer bug in gcc 2.7.2.3: */
03055   depth = parent_type ? (1 + parent_type->name_pos) : 0;
03056 
03057   struct_type->iso.so.type = scheme_struct_type_type;
03058 
03059   struct_type->name_pos = depth;
03060   struct_type->parent_types[depth] = struct_type;
03061   for (j = depth; j--; ) {
03062     struct_type->parent_types[j] = parent_type->parent_types[j];
03063   }
03064 
03065   {
03066     Scheme_Object *tn;
03067     if (basesym)
03068       tn = basesym;
03069     else
03070       tn = scheme_intern_exact_symbol(base, blen);
03071     struct_type->name = tn;
03072   }
03073   struct_type->num_slots = num_fields + num_uninit_fields + (parent_type ? parent_type->num_slots : 0);
03074   struct_type->num_islots = num_fields + (parent_type ? parent_type->num_islots : 0);
03075   if (parent_type)
03076     struct_type->proc_attr = parent_type->proc_attr;
03077 
03078   /* Check for integer overflow or total more than MAX_STRUCT_FIELD_COUNT: */
03079   if ((num_fields < 0) || (num_uninit_fields < 0)
03080       || (num_fields > MAX_STRUCT_FIELD_COUNT)
03081       || (num_uninit_fields > MAX_STRUCT_FIELD_COUNT)
03082       || (num_uninit_fields + num_fields > MAX_STRUCT_FIELD_COUNT)
03083       || (parent_type
03084          && ((struct_type->num_slots < parent_type->num_slots)
03085              || (struct_type->num_islots < parent_type->num_islots)))) {
03086     /* Too many fields. */
03087     scheme_raise_exn(MZEXN_FAIL,
03088                    "too many fields for struct-type; maximum total field count is " MAX_STRUCT_FIELD_COUNT_STR);
03089     return NULL;
03090   }
03091 
03092   if (!inspector) {
03093     if (parent_type) {
03094       inspector = parent_type->inspector;
03095       if (SCHEME_SYMBOLP(inspector))
03096         inspector = scheme_false;
03097     } else {
03098       inspector = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
03099     }
03100   }
03101   struct_type->inspector = inspector;
03102 
03103   if (parent_type) {
03104     struct_type->num_props = parent_type->num_props;
03105     struct_type->props = parent_type->props;
03106     if (MZ_OPT_HASH_KEY(&parent_type->iso) & STRUCT_TYPE_CHECKED_PROC)
03107       checked_proc = 1;
03108   }
03109 
03110   /* In principle, we should check for duplicate properties here
03111      to keep the mismatch exceptions in the right order. */
03112 
03113   if (!uninit_val)
03114     uninit_val = scheme_false;
03115   struct_type->uninit_val = uninit_val;
03116 
03117   if ((struct_type->proc_attr && SCHEME_INTP(struct_type->proc_attr))
03118       || !SCHEME_NULLP(immutable_pos_list)
03119       || (proc_attr && SCHEME_INTP(proc_attr))) {
03120     Scheme_Object *l, *a;
03121     char *ims;
03122     int n, ni, p;
03123 
03124     n = struct_type->num_slots;
03125     ni = struct_type->num_islots;
03126     if (parent_type) {
03127       n -= parent_type->num_slots;
03128       ni -= parent_type->num_islots;
03129     }
03130     ims = (char *)scheme_malloc_atomic(n);
03131     memset(ims, 0, n);
03132 
03133     if (proc_attr && SCHEME_INTP(proc_attr)) {
03134       p = SCHEME_INT_VAL(proc_attr);
03135       if (p < ni)
03136         ims[p] = 1;
03137     }
03138 
03139     for (l = immutable_pos_list; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
03140       a = SCHEME_CAR(l);
03141       if (SCHEME_INTP(a))
03142        p = SCHEME_INT_VAL(a);
03143       else
03144        p = n; /* too big */
03145 
03146       if (p >= n) {
03147        scheme_raise_exn(MZEXN_FAIL_CONTRACT,
03148                       "make-struct-type: index %V for immutable field >= initialized-field count %d in list: %V", 
03149                       a, 
03150                          ni, 
03151                          immutable_pos_list);
03152        return NULL;
03153       }
03154 
03155       if (ims[p]) {
03156        scheme_raise_exn(MZEXN_FAIL_CONTRACT,
03157                       "make-struct-type: redundant immutable field index %V in list: %V", 
03158                       a, immutable_pos_list);
03159        return NULL;
03160       }
03161 
03162       ims[p] = 1;
03163     }
03164     
03165     struct_type->immutables = ims;
03166   }
03167 
03168   /* We add properties last, because a property guard receives a
03169      struct-type descriptor. */
03170 
03171   if (proc_attr)
03172     props = scheme_append(props ? props : scheme_null, 
03173                           scheme_make_pair(scheme_make_pair(proc_property, proc_attr),
03174                                            scheme_null));
03175 
03176   if (props) {
03177     int num_props, i;
03178     Scheme_Object *proc_prop_set = NULL;
03179     Scheme_Hash_Table *can_override;
03180     Scheme_Object *l, *a, *prop, *propv, *oldv;
03181 
03182     can_override = scheme_make_hash_table(SCHEME_hash_ptr);
03183 
03184     num_props = count_non_proc_props(props);
03185     if ((struct_type->num_props < 0) || (struct_type->num_props + num_props > PROP_USE_HT_COUNT)) {
03186       Scheme_Hash_Table *ht;
03187 
03188       ht = scheme_make_hash_table(SCHEME_hash_ptr);
03189     
03190       if (struct_type->num_props >= 0) {
03191        for (i = 0; i < struct_type->num_props; i++) {
03192          prop = SCHEME_CAR(struct_type->props[i]);
03193          scheme_hash_set(ht, prop, SCHEME_CDR(struct_type->props[i]));
03194          scheme_hash_set(can_override, prop, scheme_true);
03195        }
03196       } else {
03197        /* Duplicate the hash table: */
03198        Scheme_Hash_Table *oht = (Scheme_Hash_Table *)struct_type->props;
03199        for (i =  oht->size; i--; ) {
03200          if (oht->vals[i]) {
03201            prop = oht->keys[i];
03202            scheme_hash_set(ht, prop, oht->vals[i]);
03203            scheme_hash_set(can_override, prop, scheme_true);
03204          }
03205        }
03206       }
03207 
03208       /* Add new props: */
03209       for (l = props; SCHEME_PAIRP(l); ) {
03210        a = SCHEME_CAR(l);
03211        prop = SCHEME_CAR(a);
03212 
03213         if (SAME_OBJ(prop, scheme_checked_proc_property))
03214           checked_proc = 1;
03215 
03216         propv = guard_property(prop, SCHEME_CDR(a), struct_type);
03217         
03218         if (SAME_OBJ(prop, proc_property)) {
03219           if (proc_prop_set && !SAME_OBJ(proc_prop_set, propv))
03220             break;
03221         } else {
03222           oldv = scheme_hash_get(ht, prop);
03223           if (oldv) {
03224             /* Property is already in the superstruct_type */
03225             if (!scheme_hash_get(can_override, prop)) {
03226               if (!SAME_OBJ(oldv, propv))
03227                 break;
03228             }
03229             /* otherwise we override */
03230             scheme_hash_set(can_override, prop, NULL);
03231           }
03232         }
03233         
03234         l = SCHEME_CDR(l);
03235         l = append_super_props((Scheme_Struct_Property *)prop, propv, l);
03236         
03237         if (SAME_OBJ(prop, proc_property))
03238           proc_prop_set = propv;
03239         else
03240           scheme_hash_set(ht, prop, propv);
03241       }
03242 
03243       struct_type->props = (Scheme_Object **)ht;
03244       struct_type->num_props = -1;
03245     } else {
03246       /* Make props array: */
03247       Scheme_Object **pa;
03248       int j;
03249       
03250       /* Remember origs, so we can override */
03251       for (i = 0; i < struct_type->num_props; i++) {
03252        prop = SCHEME_CAR(struct_type->props[i]);
03253        scheme_hash_set(can_override, prop, scheme_true);
03254       }
03255       
03256       pa = MALLOC_N(Scheme_Object *, i + num_props);
03257       memcpy(pa, struct_type->props, sizeof(Scheme_Object *) * i);
03258 
03259       num_props = i;
03260 
03261       for (l = props; SCHEME_PAIRP(l); ) {
03262        a = SCHEME_CAR(l);
03263 
03264        prop = SCHEME_CAR(a);
03265 
03266         if (SAME_OBJ(prop, scheme_checked_proc_property))
03267           checked_proc = 1;
03268 
03269         propv = guard_property(prop, SCHEME_CDR(a), struct_type);
03270 
03271         /* Check whether already in table: */
03272         if (SAME_OBJ(prop, proc_property)) {
03273           if (proc_prop_set && !SAME_OBJ(proc_prop_set, propv))
03274             break;
03275           j = 0;
03276         } else {
03277           for (j = 0; j < num_props; j++) {
03278             if (SAME_OBJ(SCHEME_CAR(pa[j]), prop))
03279               break;
03280           }
03281           if (j < num_props) {
03282             /* already there */
03283             if (!scheme_hash_get(can_override, prop)) {
03284               if (!SAME_OBJ(propv, SCHEME_CDR(pa[j])))
03285                 break; 
03286             }
03287             /* overriding it: */
03288             scheme_hash_set(can_override, prop, NULL);
03289           } else
03290             num_props++;
03291         }
03292         
03293         l = SCHEME_CDR(l);
03294         l = append_super_props((Scheme_Struct_Property *)prop, propv, l);
03295         
03296         if (SAME_OBJ(prop, proc_property))
03297           proc_prop_set = propv;
03298         else {
03299           a = scheme_make_pair(prop, propv);
03300           pa[j] = a;
03301         }
03302       }
03303      
03304       if (num_props) {
03305         struct_type->num_props = num_props;
03306         struct_type->props = pa;
03307       }
03308     }
03309 
03310     if (!SCHEME_NULLP(l)) {
03311       /* SCHEME_CAR(l) is a duplicate */
03312       a = SCHEME_CAR(l);
03313       scheme_arg_mismatch("make-struct-type", "duplicate property binding: ", a);
03314     }
03315   }
03316 
03317 
03318   if (guard) {
03319     
03320     if (!scheme_check_proc_arity(NULL, struct_type->num_islots + 1, -1, 0, &guard)) {
03321       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
03322                      "make-struct-type: guard procedure does not accept %d arguments "
03323                      "(one more than the number constructor arguments): %V",
03324                      struct_type->num_islots + 1, guard);
03325     }
03326     
03327     struct_type->guard = guard;
03328   }
03329 
03330   if (checked_proc)
03331     MZ_OPT_HASH_KEY(&struct_type->iso) |= STRUCT_TYPE_CHECKED_PROC;
03332       
03333   return (Scheme_Object *)struct_type;
03334 }
03335 
03336 Scheme_Object *scheme_make_struct_type(Scheme_Object *base,
03337                                    Scheme_Object *parent,
03338                                    Scheme_Object *inspector,
03339                                    int num_fields, int num_uninit,
03340                                    Scheme_Object *uninit_val,
03341                                    Scheme_Object *properties,
03342                                    Scheme_Object *guard)
03343 {
03344   return _make_struct_type(base, NULL, 0,
03345                         parent, inspector, 
03346                         num_fields, num_uninit,
03347                         uninit_val, properties, 
03348                         NULL, scheme_null,
03349                         guard);
03350 }
03351 
03352 Scheme_Object *scheme_make_proc_struct_type(Scheme_Object *base,
03353                                             Scheme_Object *parent,
03354                                             Scheme_Object *inspector,
03355                                             int num_fields, int num_uninit,
03356                                             Scheme_Object *uninit_val,
03357                                             Scheme_Object *proc_attr,
03358                                             Scheme_Object *guard)
03359 {
03360   return _make_struct_type(base, NULL, 0,
03361                         parent, inspector, 
03362                         num_fields, num_uninit,
03363                         uninit_val, scheme_null, 
03364                         proc_attr, scheme_null,
03365                         guard);
03366 }
03367 
03368 Scheme_Object *scheme_make_struct_type_from_string(const char *base,
03369                                              Scheme_Object *parent,
03370                                              int num_fields,
03371                                              Scheme_Object *props,
03372                                              Scheme_Object *guard,
03373                                              int immutable)
03374 {
03375   Scheme_Object *imm = scheme_null;
03376   int i;
03377 
03378   if (immutable) {
03379     for (i = 0; i < num_fields; i++) {
03380       imm = scheme_make_pair(scheme_make_integer(i), imm);
03381     }
03382   }
03383 
03384   return _make_struct_type(NULL, base, strlen(base),
03385                         parent, scheme_false, 
03386                         num_fields, 0, 
03387                         NULL, props, 
03388                         NULL, imm,
03389                         guard);
03390 }
03391 
03392 Scheme_Struct_Type *hash_prefab(Scheme_Struct_Type *type)
03393 {
03394   Scheme_Object *k, *v;
03395   
03396   if (!prefab_table) {
03397     REGISTER_SO(prefab_table);
03398     prefab_table = scheme_make_weak_equal_table();
03399   }
03400   
03401   k = make_prefab_key(type);
03402   type->prefab_key = k;
03403   
03404   v = scheme_lookup_in_table(prefab_table, (const char *)k);
03405   
03406   if (v)
03407     v = SCHEME_WEAK_BOX_VAL(v);
03408   
03409   if (v) {
03410     type = (Scheme_Struct_Type *)v;
03411   } else {
03412     /* Check all immutable */
03413     if (!type->name_pos
03414         || MZ_OPT_HASH_KEY(&type->parent_types[type->name_pos - 1]->iso) & STRUCT_TYPE_ALL_IMMUTABLE) {
03415       int i, size;
03416       size = type->num_islots;
03417       if (type->name_pos)
03418         size -= type->parent_types[type->name_pos - 1]->num_islots;
03419       if (type->immutables) {
03420         for (i = 0; i < size; i++) {
03421           if (!type->immutables[i])
03422             break;
03423         }
03424       } else {
03425         i = 0;
03426       }
03427       if (i == size)
03428         MZ_OPT_HASH_KEY(&type->iso) |= STRUCT_TYPE_ALL_IMMUTABLE;
03429     }
03430 
03431     v = scheme_make_weak_box((Scheme_Object *)type);
03432     scheme_add_to_table(prefab_table, (const char *)k, v, 0);
03433   }
03434 
03435   return type;
03436 }
03437   
03438 static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
03439 {
03440   int initc, uninitc, num_props = 0, i, prefab = 0;
03441   Scheme_Object *props = scheme_null, *l, *a, **r;
03442   Scheme_Object *inspector = NULL, **names, *uninit_val;
03443   Scheme_Struct_Type *type;
03444   Scheme_Object *proc_attr = NULL, *immutable_pos_list = scheme_null, *guard = NULL;
03445 
03446   if (!SCHEME_SYMBOLP(argv[0]))
03447     scheme_wrong_type("make-struct-type", "symbol", 0, argc, argv);
03448   if (!SCHEME_FALSEP(argv[1])
03449       && !SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_struct_type_type))
03450     scheme_wrong_type("make-struct-type", "struct-type or #f", 1, argc, argv);
03451 
03452   if (!SCHEME_INTP(argv[2]) || (SCHEME_INT_VAL(argv[2]) < 0)) {
03453     if (SCHEME_BIGNUMP(argv[2]) && SCHEME_BIGPOS(argv[2]))
03454       initc = -1;
03455     else {
03456       scheme_wrong_type("make-struct-type", "non-negative exact integer", 2, argc, argv);
03457       return NULL;
03458     }
03459   } else
03460     initc = SCHEME_INT_VAL(argv[2]);
03461 
03462   if (!SCHEME_INTP(argv[3]) || (SCHEME_INT_VAL(argv[3]) < 0)) {
03463     if (SCHEME_BIGNUMP(argv[3]) && SCHEME_BIGPOS(argv[3]))
03464       uninitc = -1;
03465     else {
03466       scheme_wrong_type("make-struct-type", "non-negative exact integer", 3, argc, argv);
03467       return NULL;
03468     }
03469   } else
03470     uninitc = SCHEME_INT_VAL(argv[3]);
03471   
03472   if (argc > 4) {
03473     uninit_val = argv[4];
03474 
03475     if (argc > 5) {
03476       props = argv[5];
03477       for (l = props; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
03478        a = SCHEME_CAR(l);
03479        if (!SCHEME_PAIRP(a)
03480            || !SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(a)), scheme_struct_property_type))
03481          break;
03482        num_props++;
03483       }
03484       if (!SCHEME_NULLP(l)) {
03485        scheme_wrong_type("make-struct-type", "list of struct-type-property--value pairs", 5, argc, argv);
03486       }
03487 
03488       if (argc > 6) {
03489         inspector = argv[6];
03490         if (SAME_OBJ(inspector, prefab_symbol)) {
03491           prefab = 1;
03492           inspector = scheme_false;
03493        } else if (!SCHEME_FALSEP(inspector)) {
03494          if (!SAME_TYPE(SCHEME_TYPE(argv[6]), scheme_inspector_type))
03495            scheme_wrong_type("make-struct-type", "inspector, #f, or 'prefab", 6, argc, argv);
03496        }
03497 
03498        if (argc > 7) {
03499          if (!SCHEME_FALSEP(argv[7])) {
03500            proc_attr = argv[7];
03501            
03502            if (!((SCHEME_INTP(proc_attr) && (SCHEME_INT_VAL(proc_attr) >= 0))
03503                 || (SCHEME_BIGNUMP(proc_attr) && SCHEME_BIGPOS(proc_attr))
03504                 || SCHEME_PROCP(proc_attr))) {
03505              scheme_wrong_type("make-struct-type", 
03506                             "exact non-negative integer, procedure, or #f",
03507                             7, argc, argv);
03508              return NULL;
03509            }
03510          }
03511 
03512          if (argc > 8) {
03513            l = immutable_pos_list = argv[8];
03514            
03515            if (scheme_proper_list_length(l) < 0)
03516              l = NULL;
03517            for (; l && SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
03518              a = SCHEME_CAR(l);
03519              if (!((SCHEME_INTP(a) && (SCHEME_INT_VAL(a) >= 0))
03520                   || (SCHEME_BIGNUMP(a) && !SCHEME_BIGPOS(a)))) {
03521               l = NULL;
03522               break;
03523              }
03524            }
03525 
03526            if (!l) {
03527              scheme_wrong_type("make-struct-type", 
03528                             "list of exact non-negative integers",
03529                             8, argc, argv);
03530              return NULL;
03531            }
03532 
03533            if (argc > 9) {
03534              if (SCHEME_TRUEP(argv[9])) {
03535               guard = argv[9];
03536               if (!SCHEME_PROCP(guard))
03537                 scheme_wrong_type("make-struct-type", "procedure or #f", 9, argc, argv);
03538              }
03539            }
03540          }
03541        }
03542       }
03543     }
03544   } else
03545     uninit_val = scheme_false;
03546 
03547   if (!uninitc)
03548     uninit_val = scheme_false;
03549 
03550   if (!inspector)
03551     inspector = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
03552 
03553   if (prefab) {
03554     const char *bad = NULL;
03555     Scheme_Object *parent = argv[1];
03556     if (!SCHEME_FALSEP(parent) && !((Scheme_Struct_Type *)parent)->prefab_key) {
03557       bad = ("make-struct-type: generative supertype disallowed"
03558              " for non-generative structure type with name: %S");
03559     } else if (!SCHEME_NULLP(props)) {
03560       bad = ("make-struct-type: properties disallowed"
03561              " for non-generative structure type with name: %S");
03562     } else if (proc_attr) {
03563       bad = ("make-struct-type: procedure specification disallowed"
03564              " for non-generative structure type with name: %S");
03565     } else if (guard) {
03566       bad = ("make-struct-type: guard disallowed"
03567              " for non-generative structure type with name: %S");
03568     }
03569     if (bad) {
03570       scheme_raise_exn(MZEXN_FAIL_CONTRACT, bad, argv[0]);
03571     }
03572   }
03573 
03574   type = (Scheme_Struct_Type *)_make_struct_type(argv[0], NULL, 0, 
03575                                            SCHEME_FALSEP(argv[1]) ? NULL : argv[1],
03576                                            inspector,
03577                                            initc, uninitc,
03578                                            uninit_val, props,
03579                                            proc_attr,
03580                                            immutable_pos_list,
03581                                            guard);
03582 
03583   if (prefab) {
03584     type = hash_prefab(type);
03585   }
03586 
03587   names = scheme_make_struct_names(argv[0],
03588                                NULL,
03589                                SCHEME_STRUCT_GEN_GET | SCHEME_STRUCT_GEN_SET, 
03590                                &i);
03591   r = scheme_make_struct_values((Scheme_Object *)type, names, i, 
03592                             SCHEME_STRUCT_GEN_GET | SCHEME_STRUCT_GEN_SET);
03593 
03594   return scheme_values(i, r);
03595 }
03596 
03597 static Scheme_Object *make_prefab_key(Scheme_Struct_Type *type)
03598 {
03599   Scheme_Object *key = scheme_null, *stack = scheme_null, *v;
03600   int cnt, icnt, total_cnt;
03601 
03602   total_cnt = type->num_slots;
03603 
03604   while (type->name_pos) {
03605     stack = scheme_make_pair((Scheme_Object *)type, stack);
03606     type = type->parent_types[type->name_pos - 1];
03607   }
03608 
03609   while (type) {
03610     cnt = type->num_slots;
03611     icnt = type->num_islots;
03612     if (type->name_pos) {
03613       cnt -= type->parent_types[type->name_pos - 1]->num_slots;
03614       icnt -= type->parent_types[type->name_pos - 1]->num_islots;
03615     }
03616 
03617     if (cnt) {
03618       int i;
03619       v = scheme_null;
03620       for (i = icnt; i--; ) {
03621         if (!type->immutables || !type->immutables[i]) {
03622           v = scheme_make_pair(scheme_make_integer(i), v);
03623         }
03624       }
03625       if (!SCHEME_NULLP(v)) {
03626         v = scheme_list_to_vector(v);
03627         key = scheme_make_pair(v, key);
03628       }
03629       
03630       if (cnt > icnt) {
03631         key = scheme_make_pair(scheme_make_pair(scheme_make_integer(cnt - icnt),
03632                                                 scheme_make_pair(type->uninit_val, 
03633                                                                  scheme_null)),
03634                                key);
03635       }
03636     }
03637     if (!SCHEME_NULLP(stack))
03638       key = scheme_make_pair(scheme_make_integer(icnt), key);
03639 
03640     key = scheme_make_pair(type->name, key);
03641 
03642     if (SCHEME_PAIRP(stack)) {
03643       type = (Scheme_Struct_Type *)SCHEME_CAR(stack);
03644       stack = SCHEME_CDR(stack);
03645     } else {
03646       type = NULL;
03647     }
03648   }
03649 
03650   if (SCHEME_PAIRP(key)
03651       && SCHEME_NULLP(SCHEME_CDR(key)))
03652     key = SCHEME_CAR(key);
03653 
03654   /* Turn the "external" key into a hashable key by adding the
03655      total field count. */
03656   
03657   key = scheme_make_pair(scheme_make_integer(total_cnt),
03658                          key);
03659 
03660   return key;
03661 }
03662 
03663 Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_count)
03664 {
03665   Scheme_Struct_Type *parent = NULL;
03666   Scheme_Object *a, *uninit_val, *mutables, *immutable_pos_list, *name;
03667   int i, ucnt, icnt, prev;
03668 
03669   if (SCHEME_SYMBOLP(key))
03670     key = scheme_make_pair(key, scheme_null);
03671 
03672   if (scheme_proper_list_length(key) < 0)
03673     return NULL;
03674 
03675   if (field_count > MAX_STRUCT_FIELD_COUNT)
03676     field_count = MAX_STRUCT_FIELD_COUNT;
03677 
03678   if (prefab_table) {
03679     a = scheme_lookup_in_table(prefab_table, (const char *)key);
03680     if (a)
03681       a = SCHEME_WEAK_BOX_VAL(a);
03682     if (a)
03683       return (Scheme_Struct_Type *)a;
03684   }
03685 
03686   key = scheme_reverse(key);
03687 
03688   while (SCHEME_PAIRP(key)) {
03689     /* mutable array? */
03690     a = SCHEME_CAR(key);
03691     if (SCHEME_VECTORP(a)) {
03692       mutables = a;
03693       key = SCHEME_CDR(key);
03694     } else
03695       mutables = NULL;
03696     
03697     /* auto fields? */
03698     if (!SCHEME_PAIRP(key))
03699       return NULL;
03700     a = SCHEME_CAR(key);
03701     if (SCHEME_PAIRP(a)) {
03702       if (scheme_proper_list_length(a) != 2)
03703         return NULL;
03704       if (!SCHEME_INTP(SCHEME_CAR(a)))
03705         return NULL;
03706       ucnt = SCHEME_INT_VAL(SCHEME_CAR(a));
03707       a = SCHEME_CDR(a);
03708       uninit_val = SCHEME_CAR(a);
03709       key = SCHEME_CDR(key);
03710     } else {
03711       ucnt = 0;
03712       uninit_val = scheme_false;
03713     }
03714         
03715     /* field count? */
03716     if (!SCHEME_PAIRP(key))
03717       return NULL;
03718     a = SCHEME_CAR(key);
03719     if (!SCHEME_INTP(a)) {
03720       if (SCHEME_NULLP(SCHEME_CDR(key))) {
03721         /* For last one, size can be inferred */
03722         icnt = field_count - ucnt - (parent
03723                                      ? parent->num_slots
03724                                      : 0);
03725         if (icnt < 0)
03726           icnt = 0;
03727       } else
03728         return NULL;
03729     } else {
03730       icnt = SCHEME_INT_VAL(a);
03731       if (icnt > MAX_STRUCT_FIELD_COUNT)
03732         return NULL;
03733       key = SCHEME_CDR(key);
03734     }
03735     
03736     /* name */
03737     if (!SCHEME_PAIRP(key))
03738       return NULL;
03739     a = SCHEME_CAR(key);
03740     key = SCHEME_CDR(key);
03741 
03742     if (!SCHEME_SYMBOLP(a))
03743       return NULL;
03744     name = a;
03745 
03746     /* convert mutability data to immutability data */
03747     immutable_pos_list = scheme_null;
03748     prev = -1;
03749     if (mutables) {
03750       int len;
03751       len = SCHEME_VEC_SIZE(mutables);
03752       if (len > icnt)
03753         return NULL;
03754       for (i = 0; i < len; i++) {
03755         a = SCHEME_VEC_ELS(mutables)[i];
03756         if (!SCHEME_INTP(a)
03757             || (SCHEME_INT_VAL(a) < 0)
03758             || (SCHEME_INT_VAL(a) >= icnt)
03759             || (SCHEME_INT_VAL(a) <= prev))
03760           return NULL;
03761         while (prev + 1 < SCHEME_INT_VAL(a)) {
03762           immutable_pos_list = scheme_make_pair(scheme_make_integer(prev + 1), 
03763                                                 immutable_pos_list);
03764           prev++;
03765         }
03766         prev++;
03767       }
03768     }
03769     while (prev + 1 < icnt) {
03770       immutable_pos_list = scheme_make_pair(scheme_make_integer(prev + 1), 
03771                                             immutable_pos_list);
03772       prev++;
03773     }
03774 
03775     if (parent && (icnt + parent->num_slots > MAX_STRUCT_FIELD_COUNT))
03776       return NULL;
03777 
03778     parent = (Scheme_Struct_Type *)_make_struct_type(name, NULL, 0, 
03779                                                      (Scheme_Object *)parent,
03780                                                      scheme_false,
03781                                                      icnt, ucnt,
03782                                                      uninit_val, scheme_null,
03783                                                      NULL,
03784                                                      immutable_pos_list,
03785                                                      NULL);
03786     
03787     parent = hash_prefab(parent);
03788   }
03789 
03790   if (!SCHEME_NULLP(key))
03791     return NULL;
03792 
03793   return parent;
03794 }
03795 
03796 /*========================================================================*/
03797 /*                           procedure struct                             */
03798 /*========================================================================*/
03799 
03800 Scheme_Object *scheme_extract_struct_procedure(Scheme_Object *obj, int num_rands, Scheme_Object **rands, int *is_method)
03801 {
03802   Scheme_Struct_Type *stype;
03803   Scheme_Object *a, *proc;
03804 
03805   stype = ((Scheme_Structure *)obj)->stype;
03806   a = stype->proc_attr;
03807 
03808   if (SCHEME_INTP(a)) {
03809     *is_method = 0;
03810     proc = ((Scheme_Structure *)obj)->slots[SCHEME_INT_VAL(a)];
03811   } else {
03812     *is_method = 1;
03813     proc = a;
03814   }
03815 
03816   if (num_rands >= 0) {
03817     /* num_rands is non-negative => do arity check */
03818     if (!SCHEME_PROCP(proc)
03819        || !scheme_check_proc_arity(NULL, num_rands, -1, 0, &obj)) {
03820       scheme_wrong_count_m((char *)obj,
03821                         -1 /* means "name argument is really a proc struct" */, 0,
03822                         num_rands, rands, 0 /* methodness internally handled */);
03823       return NULL;
03824     }
03825   }
03826 
03827   return proc;
03828 }
03829 
03830 static Scheme_Object *procedure_extract_target(int argc, Scheme_Object **argv)
03831 {
03832   Scheme_Object *v;
03833   int is_method;
03834 
03835   if (!SCHEME_PROCP(argv[0]))
03836     scheme_wrong_type("procedure-extract-target", "procedure", 0, argc, argv);
03837   
03838   if (SCHEME_PROC_STRUCTP(argv[0])) {
03839     /* Don't expose arity reducer: */
03840     if (scheme_reduced_procedure_struct
03841         && scheme_is_struct_instance(scheme_reduced_procedure_struct, argv[0]))
03842       return scheme_false;
03843 
03844     v = scheme_extract_struct_procedure(argv[0], -1, NULL, &is_method);
03845     if (v && !is_method && SCHEME_PROCP(v))
03846       return v;
03847   }
03848 
03849   return scheme_false;
03850 }
03851 
03852 /*========================================================================*/
03853 /*                           location struct                              */
03854 /*========================================================================*/
03855 
03856 static int exact_pos_integer(Scheme_Object *o)
03857 {
03858   if (SCHEME_INTP(o))
03859     return SCHEME_INT_VAL(o) > 0;
03860   else if (SCHEME_BIGNUMP(o))
03861     return SCHEME_BIGPOS(o);
03862   else
03863     return 0;
03864 }
03865 
03866 static int exact_nneg_integer(Scheme_Object *o)
03867 {
03868   if (SCHEME_INTP(o))
03869     return SCHEME_INT_VAL(o) >= 0;
03870   else if (SCHEME_BIGNUMP(o))
03871     return SCHEME_BIGPOS(o);
03872   else
03873     return 0;
03874 }
03875 
03876 Scheme_Object *scheme_make_location(Scheme_Object *src,
03877                                 Scheme_Object *line,
03878                                 Scheme_Object *col,
03879                                 Scheme_Object *pos,
03880                                 Scheme_Object *span)
03881 {
03882   Scheme_Object *a[5];
03883   a[0] = src;
03884   a[1] = line;
03885   a[2] = col;
03886   a[3] = pos;
03887   a[4] = span;
03888   return scheme_make_struct_instance(location_struct, 5, a);
03889 }
03890 
03891 int scheme_is_location(Scheme_Object *o)
03892 {
03893   return scheme_is_struct_instance(location_struct, o);
03894 }
03895 
03896 static Scheme_Object *check_location_fields(int argc, Scheme_Object **argv)
03897 {
03898   if (SCHEME_TRUEP(argv[1]) && !exact_pos_integer(argv[1]))
03899     scheme_wrong_field_type(argv[5], "exact positive integer or #f", argv[1]);
03900   if (SCHEME_TRUEP(argv[2]) && !exact_nneg_integer(argv[2]))
03901     scheme_wrong_field_type(argv[5], "exact non-negative integer or #f", argv[2]);
03902   if (SCHEME_TRUEP(argv[3]) && !exact_pos_integer(argv[3]))
03903     scheme_wrong_field_type(argv[5], "exact positive integer or #f", argv[3]);
03904   if (SCHEME_TRUEP(argv[4]) && !exact_nneg_integer(argv[4]))
03905     scheme_wrong_field_type(argv[5], "exact non-negative integer or #f", argv[4]);
03906   
03907   return scheme_values(5, argv);
03908 }
03909 
03910 /*========================================================================*/
03911 /*                        date and arity checkers                         */
03912 /*========================================================================*/
03913 
03914 static Scheme_Object *check_arity_at_least_fields(int argc, Scheme_Object **argv)
03915 {
03916   Scheme_Object *a;
03917 
03918   a = argv[0];
03919   if (SCHEME_INTP(a)) {
03920     if (SCHEME_INT_VAL(a) >= 0)
03921       return a;
03922   } else if (SCHEME_BIGNUMP(a)) {
03923     if (SCHEME_BIGPOS(a))
03924       return a;
03925   }
03926 
03927   scheme_wrong_field_type(argv[1], "exact non-negative integer", a);
03928   return NULL;
03929 }
03930 
03931 static Scheme_Object *check_date_fields(int argc, Scheme_Object **argv)
03932 {
03933   Scheme_Object *a, *args[10];
03934 
03935   a = argv[0];
03936   if (!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 0) || (SCHEME_INT_VAL(a) > 61))
03937     scheme_wrong_field_type(argv[10], "integer in [0, 61]", a);
03938   a = argv[1];
03939   if (!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 0) || (SCHEME_INT_VAL(a) > 59))
03940     scheme_wrong_field_type(argv[10], "integer in [0, 59]", a);
03941   a = argv[2];
03942   if (!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 0) || (SCHEME_INT_VAL(a) > 23))
03943     scheme_wrong_field_type(argv[10], "integer in [0, 23]", a);
03944   a = argv[3];
03945   if (!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 1) || (SCHEME_INT_VAL(a) > 31))
03946     scheme_wrong_field_type(argv[10], "integer in [1, 31]", a);
03947   a = argv[4];
03948   if (!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 1) || (SCHEME_INT_VAL(a) > 12))
03949     scheme_wrong_field_type(argv[10], "integer in [1, 12]", a);
03950   a = argv[5];
03951   if (!SCHEME_INTP(a) && !SCHEME_BIGNUMP(a))
03952     scheme_wrong_field_type(argv[10], "exact integer", a);
03953   a = argv[6];
03954   if (!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 0) || (SCHEME_INT_VAL(a) > 6))
03955     scheme_wrong_field_type(argv[10], "integer in [0, 6]", a);
03956   a = argv[7];
03957   if (!SCHEME_INTP(a) || (SCHEME_INT_VAL(a) < 0) || (SCHEME_INT_VAL(a) > 365))
03958     scheme_wrong_field_type(argv[10], "integer in [0, 365]", a);
03959   a = argv[9];
03960   if (!SCHEME_INTP(a) && !SCHEME_BIGNUMP(a))
03961     scheme_wrong_field_type(argv[10], "exact integer", a);
03962 
03963   /* Normalize dst? boolean: */  
03964   memcpy(args, argv, sizeof(Scheme_Object *) * 10);
03965   args[8] = (SCHEME_TRUEP(argv[8]) ? scheme_true : scheme_false);
03966 
03967   return scheme_values(10, args);
03968 }
03969 
03970 /*========================================================================*/
03971 /*                        special-comment struct                          */
03972 /*========================================================================*/
03973 
03974 Scheme_Object *scheme_special_comment_value(Scheme_Object *o)
03975 {
03976   if (SAME_TYPE(SCHEME_TYPE(o), scheme_special_comment_type))
03977     return ((Scheme_Small_Object *)o)->u.ptr_val;
03978   else
03979     return NULL;
03980 }
03981 
03982 Scheme_Object *make_special_comment(int argc, Scheme_Object **argv)
03983 {
03984   Scheme_Object *o;
03985 
03986   o = scheme_alloc_small_object();
03987   o->type = scheme_special_comment_type;
03988   SCHEME_PTR_VAL(o) = argv[0];
03989 
03990   return o;
03991 }
03992 
03993 Scheme_Object *special_comment_value(int argc, Scheme_Object **argv)
03994 {
03995   Scheme_Object *v;
03996 
03997   v = scheme_special_comment_value(argv[0]);
03998   if (!v)
03999     scheme_wrong_type("special-comment-value", "special comment", 0, argc, argv);
04000   return v;
04001 }
04002 
04003 Scheme_Object *special_comment_p(int argc, Scheme_Object **argv)
04004 {
04005   return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_special_comment_type)
04006          ? scheme_true
04007          : scheme_false);
04008 }
04009 
04010 /**********************************************************************/
04011 
04012 static Scheme_Object *exn_source_p(int argc, Scheme_Object **argv)
04013 {
04014   return (scheme_struct_type_property_ref(scheme_source_property, argv[0])
04015          ? scheme_true
04016          : scheme_false);
04017 }
04018 
04019 static Scheme_Object *exn_source_get(int argc, Scheme_Object **argv)
04020 {
04021   Scheme_Object *v;
04022 
04023   v = scheme_struct_type_property_ref(scheme_source_property, argv[0]);
04024   if (!v)
04025     scheme_wrong_type("exn:srclocs-accessor", "exn:srclocs", 0, argc, argv);
04026   
04027   return v;
04028 }
04029 
04030 static Scheme_Object *check_exn_source_property_value_ok(int argc, Scheme_Object *argv[])
04031      /* This is the guard for prop:exn:srclocs */
04032 {
04033   scheme_check_proc_arity("guard-for-prop:exn:srclocs", 1, 0, argc, argv);
04034 
04035   return argv[0];
04036 }
04037 
04038 /**********************************************************************/
04039 
04040 #if MZ_PRECISE_GC
04041 
04042 START_XFORM_SKIP;
04043 
04044 #define MARKS_FOR_STRUCT_C
04045 #include "mzmark.c"
04046 
04047 static void register_traversers(void)
04048 {
04049   GC_REG_TRAV(scheme_structure_type, mark_struct_val);
04050   GC_REG_TRAV(scheme_proc_struct_type, mark_struct_val);
04051   GC_REG_TRAV(scheme_struct_type_type, mark_struct_type_val);
04052   GC_REG_TRAV(scheme_struct_property_type, mark_struct_property);
04053 
04054   GC_REG_TRAV(scheme_wrap_evt_type, mark_wrapped_evt);
04055   GC_REG_TRAV(scheme_handle_evt_type, mark_wrapped_evt);
04056   GC_REG_TRAV(scheme_nack_guard_evt_type, mark_nack_guard_evt);
04057   GC_REG_TRAV(scheme_poll_evt_type, mark_nack_guard_evt);
04058 
04059   GC_REG_TRAV(scheme_rt_struct_proc_info, mark_struct_proc_info);
04060 }
04061 
04062 END_XFORM_SKIP;
04063 
04064 #endif