diff --git a/src/racket/utils/README b/src/racket/utils/README deleted file mode 100644 index 52f6faef55..0000000000 --- a/src/racket/utils/README +++ /dev/null @@ -1,8 +0,0 @@ - -The utilities in this directory try to help in linking external C++ -code into Racket. The utilities are now deprecated, but they're -still used to build GRacket. - -xctocc is decribed in the manual "PLT xctocc: C++ Glue Generator -Manual" (available on request). xcglue.c and xcglue.h are used by the -code generated by xctocc. diff --git a/src/racket/utils/xcglue.c b/src/racket/utils/xcglue.c deleted file mode 100644 index a9baac5b4b..0000000000 --- a/src/racket/utils/xcglue.c +++ /dev/null @@ -1,1483 +0,0 @@ -#include "xcglue.h" -#include "gc.h" - -/* Set to 1 for experiments needing an extra field: */ -#define EXTRA_PRIM_OBJECT_FIELD 0 - -/* - Glue for the C<->Scheme object interface. - - Scheme side: - ------------ - - This glue provides a new type, #, and several - procedures: - - (initialize-primitive-object prim-obj v ...) - - initializes the primitive object, given initialization - arguments v... - - (primitive-class-prepare-struct-type! prim-class gen-property - gen-value preparer dispatcher unwrap-prop extra-props) - prepares a - class's struct-type for objects generated C-side; returns a - constructor, predicate, and a struct:type for derived classes. - The constructor and struct:type map the given dispatcher to the class. - - The preparer takes a symbol naming the method. It returns a - value to be used in future calls to the dispatcher. - - The dispatcher takes two arguments: an object and a - method-specific value produced by the prepaper. It returns a - method procedure. - - The unwrap-prop takes a property that, if found on an object, - is paired with a function that unwraps the object. - - The extra-props argument is a list of property--value pairs. - - (primitive-class-find-method prim-class sym) - gets the method - for the given symbol. - - (primitive-class->superclass prim-class) - gets the superclass. - - (primitive-class? v) - returns #t if v is a primitive class. - - In addition, the C code generates definitions of classes. - - - If EXTRA_PRIM_OBJECT_FIELD: - - (primitive-object-extra-field-get prim-obj) - obvious - (primitive-object-extra-field-set! prim-obj v) - obvious - - - C side: - ------- - - The C interface is mostly for the output of xctocc. In addition, - there is - - void objscheme_init(Scheme_Env *); - - The argument doesn't really have to be a Scheme_Env* value; see - below. - - The embedding C program must provide - - void scheme_install_xc_global(const char *name, - Scheme_Object *v, - Scheme_Env *env); - void scheme_lookup_xc_global(const char *name, - Scheme_Env *env); - - The Scheme_Env* value doesn't actually have to be an Scheme - environment; it is the value the embedding code provides to - the objscheme_setup_XXX() functions generated by xctocc, and to - objscheme_init(). - -*/ - -/***************************************************************************/ - -int objscheme_something_prepared = 0; - -typedef struct Scheme_Class { - Scheme_Object so; - const char *name; - Scheme_Object *sup; - Scheme_Object *initf; - int num_methods, num_installed; - Scheme_Object **names; - Scheme_Object **methods; - Scheme_Object *base_struct_type; - Scheme_Object *struct_type; - Scheme_Object *unwrap_property; -} Scheme_Class; - -Scheme_Type objscheme_class_type; - -static Scheme_Object *object_struct; -static Scheme_Object *object_property; -static Scheme_Object *dispatcher_property; -static Scheme_Object *preparer_property; - -#ifdef MZ_PRECISE_GC -# include "../gc2/gc2.h" - -START_XFORM_SKIP; - -int gc_class_size(void *_c) -{ - return gcBYTES_TO_WORDS(sizeof(Scheme_Class)); -} - -int gc_class_mark(void *_c) -{ - Scheme_Class *c = (Scheme_Class *)_c; - - gcMARK(c->name); - gcMARK(c->sup); - gcMARK(c->initf); - gcMARK(c->names); - gcMARK(c->methods); - gcMARK(c->base_struct_type); - gcMARK(c->struct_type); - gcMARK(c->unwrap_property); - - return gcBYTES_TO_WORDS(sizeof(Scheme_Class)); -} - -int gc_class_fixup(void *_c) -{ - Scheme_Class *c = (Scheme_Class *)_c; - - gcFIXUP(c->name); - gcFIXUP(c->sup); - gcFIXUP(c->initf); - gcFIXUP(c->names); - gcFIXUP(c->methods); - gcFIXUP(c->base_struct_type); - gcFIXUP(c->struct_type); - gcFIXUP(c->unwrap_property); - - return gcBYTES_TO_WORDS(sizeof(Scheme_Class)); -} - -END_XFORM_SKIP; - -#endif - -/***************************************************************************/ - -static Scheme_Object *init_prim_obj(int argc, Scheme_Object **argv) -{ - Scheme_Class *c; - Scheme_Object *obj = argv[0]; - - if (!SCHEME_STRUCTP(argv[0]) - || !scheme_is_struct_instance(object_struct, argv[0])) - scheme_wrong_type("initialize-primitive-object", "primitive-object", 0, argc, argv); - - c = (Scheme_Class *)scheme_struct_type_property_ref(object_property, obj); - - return _scheme_apply(c->initf, argc, argv); -} - -static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv) -{ - Scheme_Object *name, *base_stype, *stype; - Scheme_Object **names, **vals, *a[3], *props; - Scheme_Class *c; - int flags, count; - - if (SCHEME_TYPE(argv[0]) != objscheme_class_type) - scheme_wrong_type("primitive-class-prepare-struct-type!", "primitive-class", 0, argc, argv); - if (SCHEME_TYPE(argv[1]) != scheme_struct_property_type) - scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 1, argc, argv); - scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 3, argc, argv); - scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv); - if(SCHEME_TYPE(argv[5]) != scheme_struct_property_type) - scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 5, argc, argv); - scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 6, argc, argv); - - props = argv[7]; - while (SCHEME_PAIRP(props)) { - name = SCHEME_CAR(props); - if (!SCHEME_PAIRP(name)) - break; - if (SCHEME_TYPE(SCHEME_CAR(name)) != scheme_struct_property_type) - break; - props = SCHEME_CDR(props); - } - if (!SCHEME_NULLP(props)) - scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 7, argc, argv); - props = argv[7]; - - objscheme_something_prepared = 1; - - c = ((Scheme_Class *)argv[0]); - - stype = c->struct_type; - - name = scheme_intern_symbol(c->name); - - if (stype) { - scheme_arg_mismatch("primitive-class-prepare-struct-type!", - "struct-type already prepared for primitive-class: ", - name); - return NULL; - } - - if (c->sup && !((Scheme_Class *)c->sup)->base_struct_type) { - scheme_arg_mismatch("primitive-class-prepare-struct-type!", - "super struct-type not yet prepared for primitive-class: ", - name); - return NULL; - } - - /* Root for this class. */ - - base_stype = scheme_make_struct_type(name, - (c->sup ? ((Scheme_Class *)c->sup)->base_struct_type : object_struct), - NULL, - 0, 0, NULL, - props, NULL); - c->base_struct_type = base_stype; - - /* Type to use when instantiating from C: */ - - props = scheme_null; - props = scheme_make_pair(scheme_make_pair(object_property, argv[0]), props); - props = scheme_make_pair(scheme_make_pair(argv[5], argv[6]), props); - - stype = scheme_make_struct_type(name, - base_stype, - NULL, - 0, 0, NULL, - scheme_make_pair(scheme_make_pair(argv[1], argv[2]), - props), - NULL); - - c->struct_type = stype; - - /* Type to derive/instantiate from Scheme: */ - - c->unwrap_property = argv[5]; - props = scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]), props); - - props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]), props); - - stype = scheme_make_struct_type(name, - base_stype, - NULL, - 0, 0, NULL, - scheme_make_pair(scheme_make_pair(argv[1], argv[2]), props), - NULL); - - /* Need constructor from instantiate type: */ - flags = (SCHEME_STRUCT_NO_TYPE - | SCHEME_STRUCT_NO_PRED - | SCHEME_STRUCT_NO_GET - | SCHEME_STRUCT_NO_SET); - names = scheme_make_struct_names(name, NULL, flags, &count); - vals = scheme_make_struct_values(stype, names, count, flags); - a[0] = vals[0]; - - /* Need predicate from base type: */ - flags = (SCHEME_STRUCT_NO_TYPE - | SCHEME_STRUCT_NO_CONSTR - | SCHEME_STRUCT_NO_GET - | SCHEME_STRUCT_NO_SET); - names = scheme_make_struct_names(name, NULL, flags, &count); - vals = scheme_make_struct_values(base_stype, names, count, flags); - a[1] = vals[0]; - - /* Derive type == instantiate type: */ - a[2] = stype; - - return scheme_values(3, a); -} - -static Scheme_Object *class_sup(int argc, Scheme_Object **argv) -{ - Scheme_Object *v; - - if (SCHEME_TYPE(argv[0]) != objscheme_class_type) - scheme_wrong_type("primitive-class->superclass", "primitive-class", 0, argc, argv); - - v = ((Scheme_Class *)argv[0])->sup; - return v ? v : scheme_false; -} - -static Scheme_Object *class_find_meth(int argc, Scheme_Object **argv) -{ - Scheme_Class *sclass = (Scheme_Class *)argv[0]; - Scheme_Object *s; - int i; - - if (SCHEME_TYPE(argv[0]) != objscheme_class_type) - scheme_wrong_type("primitive-class-find-method", "primitive-class", 0, argc, argv); - if (!SCHEME_SYMBOLP(argv[1])) - scheme_wrong_type("primitive-class-find-method", "symbol", 1, argc, argv); - - s = argv[1]; - - for (i = sclass->num_installed; i--; ) { - if (SAME_OBJ(sclass->names[i], s)) - return sclass->methods[i]; - } - - return scheme_false; -} - -static Scheme_Object *class_p(int argc, Scheme_Object **argv) -{ - return ((SCHEME_TYPE(argv[0]) == objscheme_class_type) - ? scheme_true - : scheme_false); -} - -Scheme_Object *scheme_make_uninited_object(Scheme_Object *sclass) -{ - Scheme_Object *obj; - Scheme_Object *stype; - - stype = ((Scheme_Class *)sclass)->struct_type; - if (!stype) { - scheme_arg_mismatch("make-primitive-object", - "struct-type not yet prepared: ", - sclass); - return NULL; - } - - obj = scheme_make_struct_instance(stype, 0, NULL); - - return obj; -} - -#if EXTRA_PRIM_OBJECT_FIELD - -static Scheme_Object *extra_get(int argc, Scheme_Object **argv) -{ - Scheme_Object *obj = argv[0]; - - if (!SCHEME_STRUCTP(argv[0]) - || !scheme_is_struct_instance(object_struct, argv[0])) - scheme_wrong_type("primitive-object-extra-get", "primitive-object", 0, argc, argv); - - return scheme_struct_ref(obj, 2); -} - -static Scheme_Object *extra_set(int argc, Scheme_Object **argv) -{ - Scheme_Object *obj = argv[0]; - - if (!SCHEME_STRUCTP(argv[0]) - || !scheme_is_struct_instance(object_struct, argv[0])) - scheme_wrong_type("primitive-object-extra-set!", "primitive-object", 0, argc, argv); - - scheme_struct_set(obj, 2, argv[1]); - - return scheme_void; -} - -#endif - -/***************************************************************************/ - -Scheme_Object *scheme_make_class(const char *name, Scheme_Object *sup, - Scheme_Method_Prim *initf, int num_methods) -{ - Scheme_Class *sclass; - Scheme_Object *f, **methods, **names; - - sclass = (Scheme_Class *)scheme_malloc_tagged(sizeof(Scheme_Class)); - sclass->so.type = objscheme_class_type; - - sclass->name = name; - - if (sup && SCHEME_FALSEP(sup)) - sup = NULL; - sclass->sup = sup; - - f = scheme_make_prim(initf); - sclass->initf = f; - - sclass->num_methods = num_methods; - sclass->num_installed = 0; - - methods = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * num_methods); - names = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * num_methods); - - sclass->methods = methods; - sclass->names = names; - - return (Scheme_Object *)sclass; -} - -void scheme_add_method_w_arity(Scheme_Object *c, const char *name, - Scheme_Method_Prim *f, - int mina, int maxa) -{ - Scheme_Object *s; - Scheme_Class *sclass; - int count; - - sclass = (Scheme_Class *)c; - - s = scheme_make_prim_w_arity(f, name, mina + 1, (maxa < 0) ? -1 : (maxa + 1)); - scheme_prim_is_method(s); - - sclass->methods[sclass->num_installed] = s; - - count = strlen(name); - if ((count > 7) && !strcmp(name + count - 7, " method")) - count -= 7; - s = scheme_intern_exact_symbol(name, count); - - sclass->names[sclass->num_installed] = s; - - sclass->num_installed++; -} - -void scheme_add_method(Scheme_Object *c, const char *name, - Scheme_Method_Prim *f) -{ - scheme_add_method_w_arity(c, name, f, 0, -1); -} - -void scheme_made_class(Scheme_Object *c) -{ - /* done */ -} - -Scheme_Object* scheme_class_to_interface(Scheme_Object *c, char *name) -{ - return scheme_false; -} - -int objscheme_is_subclass(Scheme_Object *a, Scheme_Object *b) -{ - while (a && (a != b)) { - a = ((Scheme_Class *)a)->sup; - } - - return !!a; -} - -int objscheme_is_a(Scheme_Object *o, Scheme_Object *c) -{ - Scheme_Object *a; - - if (!SCHEME_STRUCTP(o) || !scheme_is_struct_instance(object_struct, o)) - return 0; - - a = scheme_struct_type_property_ref(object_property, o); - - while (a && (a != c)) { - a = ((Scheme_Class *)a)->sup; - } - - return !!a; -} - -Scheme_Object *objscheme_unwrap(Scheme_Object *obj, Scheme_Object *c) -{ - Scheme_Object *s[1], *unwrapper, *unwrap_prop; - Scheme_Class *cls = (Scheme_Class *)c; - - if (!obj || !cls) - return NULL; - - unwrap_prop = cls->unwrap_property; - if(!unwrap_prop) - return obj; - - unwrapper = scheme_struct_type_property_ref(unwrap_prop, (Scheme_Object *)obj); - if (!unwrapper) - return obj; - - s[0] = obj; - - return _scheme_apply(unwrapper, 1, s); -} - -/***************************************************************************/ - -#ifdef SUPPORT_ARBITRARY_OBJECTS - -typedef struct { - void *realobj; - Scheme_Object *obj; -} ObjectHash; - -static ObjectHash *hash; -static long hashsize = 100, hashcount = 0; - -#endif - -typedef struct { - long id; - Objscheme_Bundler f; -} BundlerHash; - -static BundlerHash *bhash; -static long bhashsize = 201, bhashcount = 0, bhashstep = 17; - -#ifndef FALSE -#define FALSE 0 -#endif -#ifndef TRUE -#define TRUE 1 -#endif - -static long num_objects_allocated = 0; - -#if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC) || defined(GC_MIGHT_USE_REGISTERED_STATICS) -# define wxREGGLOB(x) scheme_register_extension_global((void *)&x, sizeof(x)) -#else -# define wxREGGLOB(x) /* empty */ -#endif - -void objscheme_init(Scheme_Env *env) -{ - long i; - -#ifdef SUPPORT_ARBITRARY_OBJECTS - wxREGGLOB(hash); - hash = (ObjectHash *)scheme_malloc_atomic(sizeof(ObjectHash) * hashsize); - for (i = 0; i < hashsize; i++) { - hash[i].realobj = NULL; - } -#endif - - wxREGGLOB(bhash); - bhash = (BundlerHash *)scheme_malloc_atomic(sizeof(BundlerHash) - * bhashsize); - for (i = 0; i < bhashsize; i++) { - bhash[i].id = 0; - } - - objscheme_class_type = scheme_make_type(""); - - wxREGGLOB(object_property); - object_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-object")); - - wxREGGLOB(preparer_property); - preparer_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-preparer")); - - wxREGGLOB(dispatcher_property); - dispatcher_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-dispatcher")); - - wxREGGLOB(object_struct); - object_struct = scheme_make_struct_type(scheme_intern_symbol("primitive-object"), - NULL, NULL, - 0, 2 + EXTRA_PRIM_OBJECT_FIELD, NULL, - NULL, NULL); - -#ifdef MZ_PRECISE_GC - GC_register_traversers(objscheme_class_type, gc_class_size, gc_class_mark, gc_class_fixup, 0, 0); -#endif - - scheme_install_xc_global("initialize-primitive-object", - scheme_make_prim_w_arity(init_prim_obj, - "initialize-primitive-object", - 1, -1), - env); - - scheme_install_xc_global("primitive-class-prepare-struct-type!", - scheme_make_prim_w_arity(class_prepare_struct_type, - "primitive-class-prepare-struct-type!", - 8, 8), - env); - - scheme_install_xc_global("primitive-class-find-method", - scheme_make_prim_w_arity(class_find_meth, - "primitive-class-find-method", - 2, 2), - env); - - scheme_install_xc_global("primitive-class->superclass", - scheme_make_prim_w_arity(class_sup, - "primitive-class->superclass", - 1, 1), - env); - - scheme_install_xc_global("primitive-class?", - scheme_make_prim_w_arity(class_p, - "primitive-class?", - 1, 1), - env); - -#if EXTRA_PRIM_OBJECT_FIELD - scheme_install_xc_global("primitive-object-extra-get", - scheme_make_prim_w_arity(extra_get, - "primitive-object-extra-get", - 1, 1), - env); - - scheme_install_xc_global("primitive-object-extra-set!", - scheme_make_prim_w_arity(extra_set, - "primitive-object-extra-set!", - 2, 2), - env); -#endif -} - -Scheme_Object *objscheme_def_prim_class(void *global_env, - char *name, char *superclass, - Scheme_Method_Prim *initf, - int nmethods) -{ - Scheme_Object *obj; - Scheme_Object *sclass; - - if (superclass) - obj = scheme_lookup_xc_global(superclass, (Scheme_Env *) global_env); - else - obj = NULL; - - sclass = scheme_make_class(name, obj, initf, nmethods); - - scheme_install_xc_global(name, sclass, (Scheme_Env *) global_env); - - return sclass; -} - -void objscheme_add_global_class(Scheme_Object *sclass, char *name, void *env) -{ - scheme_install_xc_global(name, sclass, (Scheme_Env *) env); -} - -void objscheme_add_global_interface(Scheme_Object *in, char *name, void *env) -{ - /* do nothing */ -} - -Scheme_Object *objscheme_find_method(Scheme_Object *obj, Scheme_Object *sclass, - char *name, void **cache) -{ - Scheme_Object *s, *p[2], *dispatcher; - - if (!obj) - return NULL; - - dispatcher = scheme_struct_type_property_ref(dispatcher_property, (Scheme_Object *)obj); - if (!dispatcher) - return NULL; - - if (*cache) - s = (Scheme_Object *)*cache; - else { - s = scheme_intern_symbol(name); - p[0] = s; - s = scheme_struct_type_property_ref(preparer_property, (Scheme_Object *)obj); - if (!s) - return NULL; - s = scheme_apply(s, 1, p); - scheme_register_extension_global((void *)cache, sizeof(Scheme_Object*)); - *cache = s; - } - - p[0] = obj; - p[1] = s; - return _scheme_apply(dispatcher, 2, p); -} - -/***************************************************************************/ - -int objscheme_istype_bool(Scheme_Object *obj, const char *where) -{ - return 1; /* Anything can be a boolean */ -} - -int objscheme_istype_integer(Scheme_Object *obj, const char *stopifbad) -{ - if (SCHEME_INTP(obj) || SCHEME_BIGNUMP(obj)) - return 1; - else if (stopifbad) { - scheme_wrong_type(stopifbad, "exact integer", -1, 0, &obj); - } - return 0; -} - -int objscheme_istype_ExactLong(Scheme_Object *obj, const char *stopifbad) -{ - return objscheme_istype_integer(obj, stopifbad); -} - -int objscheme_istype_number(Scheme_Object *obj, const char *stopifbad) -{ - if (SCHEME_INTP(obj) || SCHEME_DBLP(obj) || SCHEME_BIGNUMP(obj) - || SCHEME_RATIONALP(obj)) - return 1; - else if (stopifbad) { - scheme_wrong_type(stopifbad, "real number", -1, 0, &obj); - } - return 0; -} - -int objscheme_istype_double(Scheme_Object *obj, const char *stopifbad) -{ - if (SCHEME_DBLP(obj)) - return 1; - else if (stopifbad) - scheme_wrong_type(stopifbad, "inexact real number", -1, 0, &obj); - return 0; -} - -int objscheme_istype_pair(Scheme_Object *obj, const char *stopifbad) -{ - if (SCHEME_PAIRP(obj)) - return 1; - else if (stopifbad) - scheme_wrong_type(stopifbad, "pair", -1, 0, &obj); - return 0; -} - -int objscheme_istype_string(Scheme_Object *obj, const char *stopifbad) -{ - if (SCHEME_CHAR_STRINGP(obj)) - return 1; - else if (stopifbad) - scheme_wrong_type(stopifbad, "string", -1, 0, &obj); - return 0; -} - -int objscheme_istype_bstring(Scheme_Object *obj, const char *stopifbad) -{ - if (SCHEME_BYTE_STRINGP(obj)) - return 1; - else if (stopifbad) - scheme_wrong_type(stopifbad, "byte string", -1, 0, &obj); - return 0; -} - -int objscheme_istype_pstring(Scheme_Object *obj, const char *stopifbad) -{ - if (SCHEME_BYTE_STRINGP(obj) - || SCHEME_CHAR_STRINGP(obj)) - return 1; - else if (stopifbad) - scheme_wrong_type(stopifbad, "string or byte string", -1, 0, &obj); - return 0; -} - -int objscheme_istype_pathname(Scheme_Object *obj, const char *stopifbad) -{ - if (SCHEME_PATHP(obj) - || SCHEME_CHAR_STRINGP(obj)) - return 1; - else if (stopifbad) - scheme_wrong_type(stopifbad, "path or string", -1, 0, &obj); - return 0; -} - -int objscheme_istype_epathname(Scheme_Object *obj, const char *stopifbad) -{ - if (SCHEME_PATHP(obj)) - return 1; - else if (stopifbad) - scheme_wrong_type(stopifbad, "path", -1, 0, &obj); - return 0; -} - -int objscheme_istype_char(Scheme_Object *obj, const char *stopifbad) -{ - if (SCHEME_CHARP(obj)) - return 1; - else if (stopifbad) - scheme_wrong_type(stopifbad, "character", -1, 0, &obj); - return 0; -} - -int objscheme_istype_closed_prim(Scheme_Object *obj, const char *stopifbad) -{ - if (SAME_TYPE(SCHEME_TYPE(obj), scheme_closed_prim_type)) - return 1; - else if (stopifbad) - scheme_wrong_type(stopifbad, "procedure", -1, 0, &obj); - return 0; -} - -int objscheme_istype_proc2(Scheme_Object *obj, const char *stopifbad) -{ - return scheme_check_proc_arity(stopifbad, 2, -1, 0, &obj); -} - -int objscheme_istype_box(Scheme_Object *obj, const char *stopifbad) -{ - if (SCHEME_BOXP(obj)) - return 1; - else if (stopifbad) - scheme_wrong_type(stopifbad, "box", -1, 0, &obj); - return 0; -} - -int objscheme_istype_nonnegative_symbol_integer(Scheme_Object *obj, const char *sym, const char *where) -{ - if (SCHEME_SYMBOLP(obj)) { - int l; - l = strlen(sym); - if (SCHEME_SYM_LEN(obj) == l) { - if (!strcmp(sym, SCHEME_SYM_VAL(obj))) { - return 1; - } - } - } - - if (objscheme_istype_integer(obj, NULL)) { - long v; - v = objscheme_unbundle_integer(obj, where); - if (v >= 0) - return 1; - } - - if (where) { - char *b; - b = (char *)scheme_malloc_atomic(50); - strcpy(b, "non-negative exact integer or '"); - strcat(b, sym); - scheme_wrong_type(where, b, -1, 0, &obj); - } - - return 0; -} - -int objscheme_istype_nonnegative_symbol_double(Scheme_Object *obj, const char *sym, const char *where) -{ - if (SCHEME_SYMBOLP(obj)) { - int l; - l = strlen(sym); - if (SCHEME_SYM_LEN(obj) == l) { - if (!strcmp(sym, SCHEME_SYM_VAL(obj))) { - return 1; - } - } - } - - if (objscheme_istype_number(obj, NULL)) { - double v; - v = objscheme_unbundle_double(obj, where); - if (v >= 0) - return 1; - } - - if (where) { - char *b; - b = (char *)scheme_malloc_atomic(50); - strcpy(b, "non-negative number or '"); - strcat(b, sym); - scheme_wrong_type(where, b, -1, 0, &obj); - } - - return 0; -} - -/************************************************************************/ - -Scheme_Object *objscheme_box(Scheme_Object *v) -{ - return scheme_box(v); -} - -Scheme_Object *objscheme_bundle_string(char *s) -{ - if (!s) - return XC_SCHEME_NULL; - else - return scheme_make_utf8_string(s); -} - -Scheme_Object *objscheme_bundle_bstring(char *s) -{ - if (!s) - return XC_SCHEME_NULL; - else - return scheme_make_byte_string(s); -} - -Scheme_Object *objscheme_bundle_pathname(char *s) -{ - if (!s) - return XC_SCHEME_NULL; - else - return scheme_make_path(s); -} - -Scheme_Object *objscheme_bundle_mzstring(mzchar *s) -{ - if (!s) - return XC_SCHEME_NULL; - else - return scheme_make_char_string(s); -} - -Scheme_Object *objscheme_bundle_nonnegative_symbol_double(double d, const char *symname) -{ - if (d < 0) - return scheme_intern_symbol(symname); - else - return scheme_make_double(d); -} - -/************************************************************************/ - -long objscheme_unbundle_integer(Scheme_Object *obj, const char *where) -{ - (void)objscheme_istype_integer(obj, where); - if (SCHEME_BIGNUMP(obj)) { - if (SCHEME_PINT_VAL(obj) < 0) - return -0xfffFFFF; - else - return 0xfffFFFF; - } else - return SCHEME_INT_VAL(obj); -} - -long objscheme_unbundle_nonnegative_integer(Scheme_Object *obj, const char *where) -{ - if (objscheme_istype_integer(obj, NULL)) { - long v; - v = objscheme_unbundle_integer(obj, where); - if (v >= 0) - return v; - } - - if (where) - scheme_wrong_type(where, "non-negative exact integer", -1, 0, &obj); - - return -1; -} - -long objscheme_unbundle_integer_in(Scheme_Object *obj, long minv, long maxv, const char *stopifbad) -{ - if (objscheme_istype_integer(obj, NULL)) { - long v; - v = objscheme_unbundle_integer(obj, stopifbad); - if ((v >= minv) && (v <= maxv)) - return v; - } - - if (stopifbad) { - char buffer[100]; - sprintf(buffer, "exact integer in [%ld, %ld]", minv, maxv); - scheme_wrong_type(stopifbad, buffer, -1, 0, &obj); - } - - return 0; -} - - -long objscheme_unbundle_nonnegative_symbol_integer(Scheme_Object *obj, const char *sym, const char *where) -{ - if (SCHEME_SYMBOLP(obj)) { - int l; - l = strlen(sym); - if (SCHEME_SYM_LEN(obj) == l) { - if (!strcmp(sym, SCHEME_SYM_VAL(obj))) { - return -1; - } - } - } - - if (objscheme_istype_number(obj, NULL)) { - long v; - v = objscheme_unbundle_integer(obj, where); - if (v >= 0) - return v; - } - - (void)objscheme_istype_nonnegative_symbol_integer(obj, sym, where); - return -1; -} - -ExactLong objscheme_unbundle_ExactLong(Scheme_Object *obj, const char *where) -{ - long v; - - (void)objscheme_istype_integer(obj, where); - if (!scheme_get_int_val(obj, &v)) { - if (where) - scheme_arg_mismatch(where, "argument integer is out of platform-specific bounds", obj); - } - - return v; -} - - -double objscheme_unbundle_double(Scheme_Object *obj, const char *where) -{ - (void)objscheme_istype_number(obj, where); - if (SCHEME_DBLP(obj)) - return SCHEME_DBL_VAL(obj); - else if (SCHEME_RATIONALP(obj)) - return scheme_rational_to_double(obj); - else if (SCHEME_BIGNUMP(obj)) - return scheme_bignum_to_double(obj); - else - return (double)SCHEME_INT_VAL(obj); -} - -double objscheme_unbundle_nonnegative_symbol_double(Scheme_Object *obj, const char *sym, const char *where) -{ - if (SCHEME_SYMBOLP(obj)) { - int l; - l = strlen(sym); - if (SCHEME_SYM_LEN(obj) == l) { - if (!strcmp(sym, SCHEME_SYM_VAL(obj))) { - return -1; - } - } - } - - if (objscheme_istype_number(obj, NULL)) { - double v; - v = objscheme_unbundle_double(obj, where); - if (v >= 0) - return v; - } - - (void)objscheme_istype_nonnegative_symbol_double(obj, sym, where); - return -1; -} - -double objscheme_unbundle_double_in(Scheme_Object *obj, double minv, double maxv, const char *stopifbad) -{ - if (objscheme_istype_number(obj, NULL)) { - double v; - v = objscheme_unbundle_double(obj, stopifbad); - if ((v >= minv) && (v <= maxv)) - return v; - } - - if (stopifbad) { - char buffer[100]; - sprintf(buffer, "real number in [%f, %f]", minv, maxv); - scheme_wrong_type(stopifbad, buffer, -1, 0, &obj); - } - - return 0; -} - -double objscheme_unbundle_nonnegative_double(Scheme_Object *obj, const char *where) -{ - if (objscheme_istype_number(obj, NULL)) { - double v; - v = objscheme_unbundle_double(obj, where); - if (v >= 0) - return v; - } - - if (where) - scheme_wrong_type(where, "non-negative number", -1, 0, &obj); - - return -1.0; -} - -int objscheme_unbundle_bool(Scheme_Object *obj, const char *where) -{ - (void)objscheme_istype_bool(obj, where); - return NOT_SAME_OBJ(obj, scheme_false); -} - -char *objscheme_unbundle_string(Scheme_Object *obj, const char *where) -{ - (void)objscheme_istype_string(obj, where); - obj = scheme_char_string_to_byte_string(obj); - return SCHEME_BYTE_STR_VAL(obj); -} - -char *objscheme_unbundle_pstring(Scheme_Object *obj, const char *where) -{ - (void)objscheme_istype_pstring(obj, where); - if (SCHEME_CHAR_STRINGP(obj)) - obj = scheme_char_string_to_path(obj); - return SCHEME_PATH_VAL(obj); -} - -mzchar *objscheme_unbundle_mzstring(Scheme_Object *obj, const char *where) -{ - (void)objscheme_istype_string(obj, where); - return SCHEME_CHAR_STR_VAL(obj); -} - -mzchar *objscheme_unbundle_mutable_mzstring(Scheme_Object *obj, const char *where) -{ - if (!SCHEME_MUTABLE_CHAR_STRINGP(obj)) { - scheme_wrong_type(where, "mutable string", -1, 0, &obj); - } - return SCHEME_CHAR_STR_VAL(obj); -} - -char *objscheme_unbundle_bstring(Scheme_Object *obj, const char *where) -{ - (void)objscheme_istype_bstring(obj, where); - return SCHEME_BYTE_STR_VAL(obj); -} - -char *objscheme_unbundle_mutable_bstring(Scheme_Object *obj, const char *where) -{ - if (!SCHEME_MUTABLE_BYTE_STRINGP(obj)) { - scheme_wrong_type(where, "mutable byte string", -1, 0, &obj); - } - return SCHEME_BYTE_STR_VAL(obj); -} - -char *objscheme_unbundle_pathname_guards(Scheme_Object *obj, const char *where, int guards) -{ - (void)objscheme_istype_pathname(obj, where); - return scheme_expand_string_filename(obj, (char *)where, NULL, guards); -} - -char *objscheme_unbundle_pathname(Scheme_Object *obj, const char *where) -{ - return objscheme_unbundle_pathname_guards(obj, where, SCHEME_GUARD_FILE_READ); -} - -char *objscheme_unbundle_epathname(Scheme_Object *obj, const char *where) -{ - (void)objscheme_istype_epathname(obj, where); - return SCHEME_PATH_VAL(obj); -} - -char *objscheme_unbundle_xpathname(Scheme_Object *obj, const char *where) -{ - (void)objscheme_istype_xpathname(obj, where); - if (!SCHEME_PATHP(obj)) - obj = scheme_char_string_to_path(obj); - - return SCHEME_PATH_VAL(obj); -} - -char *objscheme_unbundle_write_pathname(Scheme_Object *obj, const char *where) -{ - return objscheme_unbundle_pathname_guards(obj, where, SCHEME_GUARD_FILE_WRITE); -} - -char *objscheme_unbundle_nullable_string(Scheme_Object *obj, const char *where) -{ - if (XC_SCHEME_NULLP(obj)) - return NULL; - else if (!where || SCHEME_CHAR_STRINGP(obj)) - return objscheme_unbundle_string(obj, where); - else { - scheme_wrong_type(where, "string or " XC_NULL_STR, -1, 0, &obj); - return NULL; - } -} - -char *objscheme_unbundle_nullable_bstring(Scheme_Object *obj, const char *where) -{ - if (XC_SCHEME_NULLP(obj)) - return NULL; - else if (!where || SCHEME_BYTE_STRINGP(obj)) - return objscheme_unbundle_bstring(obj, where); - else { - scheme_wrong_type(where, "byte string or " XC_NULL_STR, -1, 0, &obj); - return NULL; - } -} - -mzchar *objscheme_unbundle_nullable_mzstring(Scheme_Object *obj, const char *where) -{ - if (XC_SCHEME_NULLP(obj)) - return NULL; - else if (!where || SCHEME_CHAR_STRINGP(obj)) - return objscheme_unbundle_mzstring(obj, where); - else { - scheme_wrong_type(where, "string or " XC_NULL_STR, -1, 0, &obj); - return NULL; - } -} - -char *objscheme_unbundle_nullable_pstring(Scheme_Object *obj, const char *where) -{ - if (XC_SCHEME_NULLP(obj)) - return NULL; - else if (!where || SCHEME_PATH_STRINGP(obj)) - return objscheme_unbundle_pstring(obj, where); - else { - scheme_wrong_type(where, SCHEME_PATH_STRING_STR " or " XC_NULL_STR, -1, 0, &obj); - return NULL; - } -} - -char *objscheme_unbundle_nullable_pathname(Scheme_Object *obj, const char *where) -{ - if (XC_SCHEME_NULLP(obj)) - return NULL; - else if (!where || SCHEME_PATHP(obj) || SCHEME_CHAR_STRINGP(obj)) - return objscheme_unbundle_pathname_guards(obj, where, SCHEME_GUARD_FILE_READ); - else { - scheme_wrong_type(where, "path, string, or " XC_NULL_STR, -1, 0, &obj); - return NULL; - } - -} - -char *objscheme_unbundle_nullable_xpathname(Scheme_Object *obj, const char *where) -{ - if (XC_SCHEME_NULLP(obj)) - return NULL; - else if (SCHEME_PATHP(obj) || SCHEME_CHAR_STRINGP(obj)) - return objscheme_unbundle_xpathname(obj, NULL); - else if (where) { - scheme_wrong_type(where, "path, string, or " XC_NULL_STR, -1, 0, &obj); - return NULL; - } else - return NULL; -} - -char *objscheme_unbundle_nullable_epathname(Scheme_Object *obj, const char *where) -{ - if (XC_SCHEME_NULLP(obj)) - return NULL; - else if (!where || SCHEME_PATHP(obj)) - return objscheme_unbundle_epathname(obj, where); - else { - scheme_wrong_type(where, "path or " XC_NULL_STR, -1, 0, &obj); - return NULL; - } - -} - -char *objscheme_unbundle_nullable_write_pathname(Scheme_Object *obj, const char *where) -{ - if (XC_SCHEME_NULLP(obj)) - return NULL; - else if (!where || SCHEME_PATHP(obj) || SCHEME_CHAR_STRINGP(obj)) - return objscheme_unbundle_pathname_guards(obj, where, SCHEME_GUARD_FILE_WRITE); - else { - scheme_wrong_type(where, "path, string, or " XC_NULL_STR, -1, 0, &obj); - return NULL; - } - -} - -mzchar objscheme_unbundle_char(Scheme_Object *obj, const char *where) -{ - (void)objscheme_istype_char(obj, where); - return SCHEME_CHAR_VAL(obj); -} - -Scheme_Object *objscheme_car(Scheme_Object *obj, const char *where) -{ - (void)objscheme_istype_pair(obj, where); - return scheme_car(obj); -} - -Scheme_Object *objscheme_unbox(Scheme_Object *obj, const char *where) -{ - (void)objscheme_istype_box(obj, where); - return scheme_unbox(obj); -} - -Scheme_Object *objscheme_nullable_unbox(Scheme_Object *obj, const char *where) -{ - if (!SCHEME_BOXP(obj)) { - if (where) - scheme_wrong_type(where, "box or " XC_NULL_STR, -1, 0, &obj); - return NULL; - } else - return scheme_unbox(obj); - -} - -/************************************************************************/ - -void objscheme_set_box(Scheme_Object *b, Scheme_Object *v) -{ - (void)objscheme_istype_box(b, "set-box!"); - SCHEME_PTR_VAL(b) = v; -} - -/************************************************************************/ - -#ifdef SUPPORT_ARBITRARY_OBJECTS - -#define HASH(realobj) (((long)realobj >> 2) % hashsize) - -#define GONE ((void *)1) - -void objscheme_save_object(void *realobj, Scheme_Object *obj) -{ - int i; - - if (2 * hashcount > hashsize) { - long oldsize = hashsize; - ObjectHash *old = hash; - - hashsize *= 2; - hash = (ObjectHash *)scheme_malloc_atomic(sizeof(ObjectHash) * hashsize); - - for (i = 0; i < hashsize; i++) { - hash[i].realobj = NULL; - } - - hashcount = 0; - for (i = 0; i < oldsize; i++) { - if (old[i].realobj && NOT_SAME_PTR(old[i].realobj, GONE)) - objscheme_save_object(old[i].realobj, (Scheme_Object *)old[i].obj); - } - } - - i = HASH(realobj); - if (i < 0) - i = -i; - - while (hash[i].realobj && NOT_SAME_PTR(hash[i].realobj, GONE)) { - i++; - if (i >= hashsize) - i = 0; - } - - hash[i].realobj = realobj; - hash[i].obj = obj; - - hashcount++; -} - -Scheme_Object *objscheme_find_object(void *realobj) -{ - int i; - - i = HASH(realobj); - if (i < 0) - i = -i; - - while (NOT_SAME_PTR(hash[i].realobj, realobj) || SAME_PTR(hash[i].realobj, GONE)) { - if (!hash[i].realobj) - return NULL; - i++; - if (i >= hashsize) - i = 0; - } - - return hash[i].obj; -} - -#endif - -void objscheme_check_valid(Scheme_Object *sclass, const char *name, int n, Scheme_Object **argv) -{ - Scheme_Class_Object *obj = (Scheme_Class_Object *)argv[0]; - - if (!SCHEME_STRUCTP((Scheme_Object *)obj) - || !scheme_is_struct_instance(object_struct, (Scheme_Object *)obj)) { - scheme_wrong_type(name ? name : "unbundle", "primitive object", 0, n, argv); - return; - } - - if (sclass) { - Scheme_Object *osclass; - osclass = scheme_struct_type_property_ref(object_property, (Scheme_Object *)obj); - if (!objscheme_is_subclass(osclass, sclass)) { - scheme_wrong_type(name ? name : "unbundle", ((Scheme_Class *)sclass)->name, 0, n, argv); - return; - } - } - - if (SCHEME_FALSEP((Scheme_Object *)obj->primflag)) { - scheme_signal_error("%s: object is not yet initialized: %V", - name ? name : "unbundle", - obj); - } - if (obj->primflag < 0) { - scheme_signal_error("%s: %sobject%s: %V", - name ? name : "unbundle", - (obj->primflag == -1) ? "invalidated " : "", - (obj->primflag == -2) ? " (shutdown by a custodian)" : "", - obj); - return; - } -} - -int objscheme_is_shutdown(Scheme_Object *o) -{ - Scheme_Class_Object *obj = (Scheme_Class_Object *)o; - - return (obj->primflag < 0); -} - -void objscheme_destroy(void *realobj, Scheme_Object *obj_in) -{ -#ifdef SUPPORT_ARBITRARY_OBJECTS - int i; -#endif - Scheme_Class_Object *obj; - - --num_objects_allocated; - - obj = (Scheme_Class_Object *)obj_in; - -#ifdef SUPPORT_ARBITRARY_OBJECTS - if (!obj) { - i = HASH(realobj); - if (i < 0) - i = -i; - - while (NOT_SAME_PTR(hash[i].realobj, realobj) - || SAME_PTR(hash[i].realobj, GONE)) { - if (!hash[i].realobj) - break; - i++; - if (i >= hashsize) - i = 0; - } - - if (hash[i].realobj) { - obj = hash[i].obj; - hash[i].realobj = GONE; - } - } -#endif - - if (obj) { - if (obj->primflag < 0) - return; - - obj->primflag = -1; - obj->primdata = NULL; - } -} - -void objscheme_register_primpointer(void *prim_obj, void *prim_ptr_address) -{ -#ifdef MZ_PRECISE_GC - GC_finalization_weak_ptr((void **)prim_obj, (void **)prim_ptr_address - (void **)prim_obj); -#else - GC_general_register_disappearing_link((void **)prim_ptr_address, NULL); -#endif -} - -/***************************************************************/ - -void objscheme_install_bundler(Objscheme_Bundler f, long id) -{ - long i; - - i = id % bhashsize; - while(bhash[i].id && bhash[i].id != id) { - i = (i + bhashstep) % bhashsize; - } - - bhash[i].id = id; - bhash[i].f = f; - bhashcount++; -} - -Scheme_Object *objscheme_bundle_by_type(void *realobj, long id) -{ - long i; - - i = id % bhashsize; - while(bhash[i].id && bhash[i].id != id) { - i = (i + bhashstep) % bhashsize; - } - - if (!bhash[i].id) - return NULL; - - return bhash[i].f(realobj); -} - -/************************************************************************/ - -#ifdef __cplusplus -extern "C" -{ -#endif - -void objscheme_mark_external_invalid(void *sobj) -{ - Scheme_Class_Object *obj = (Scheme_Class_Object *)sobj; - - obj->primflag = -1; - obj->primdata = NULL; -} - -#ifdef __cplusplus -} -#endif - diff --git a/src/racket/utils/xcglue.h b/src/racket/utils/xcglue.h deleted file mode 100644 index ef5f496ab9..0000000000 --- a/src/racket/utils/xcglue.h +++ /dev/null @@ -1,300 +0,0 @@ - -#ifndef OBJ_SCHEME_H -#define OBJ_SCHEME_H - -#include "scheme.h" - -#ifdef __cplusplus -extern "C" -{ -#endif - -/* Provided by the embedding client: */ -void scheme_install_xc_global(char *name, Scheme_Object *val, Scheme_Env *env); -Scheme_Object *scheme_lookup_xc_global(char *name, Scheme_Env *env); - -/* initialization: */ -void objscheme_init(Scheme_Env *); - -/******************************************************************/ -/* Utilites used by xctocc */ -/******************************************************************/ - - /* >>>>>>>>>>>> WARNING <<<<<<<<<<<<<< - The following struct declaration is crafted to - overlay over a Scheme_Structure. */ -typedef struct Scheme_Class_Object { - Scheme_Object so; /* scheme_structure_type */ - void *__type; /* struct type */ - long primflag; /* field 0 */ - void *primdata; /* field 1 */ - /* ... */ -} Scheme_Class_Object; - -typedef Scheme_Prim Scheme_Method_Prim; - -#define POFFSET 1 -#define THEOBJ p[0] - -typedef long ExactLong; - -void objscheme_init(Scheme_Env *env); - -/* Defining a primitive class: */ -Scheme_Object * -objscheme_def_prim_class(void *env, char *name, char *superclass, - Scheme_Method_Prim *initf, int nmethods); -void objscheme_add_global_class(Scheme_Object *sclass, char *name, - void *env); -void objscheme_add_global_interface(Scheme_Object *sclass, char *name, - void *env); - -void scheme_add_method_w_arity(Scheme_Object *c, const char *name, - Scheme_Method_Prim *f, - int mina, int maxa); -void scheme_add_method(Scheme_Object *c, const char *name, - Scheme_Method_Prim *f); -void scheme_made_class(Scheme_Object *c); -Scheme_Object* scheme_class_to_interface(Scheme_Object *c, char *name); - -Scheme_Object *scheme_make_uninited_object(Scheme_Object *sclass); - -/* Maintaining the Scheme - C++ connection */ -void objscheme_save_object(void *, Scheme_Object *); -Scheme_Class_Object *objscheme_find_object(void *); -void objscheme_check_valid(Scheme_Object *sclass, const char *name, int n, Scheme_Object **argv); -int objscheme_is_shutdown(Scheme_Object *o); - -void objscheme_register_primpointer(void *obj_addr, void *prim_ptr_address); - -void objscheme_destroy(void *, Scheme_Object *obj); - -/* Finding a method: */ -Scheme_Object *objscheme_find_method(Scheme_Object *obj, - Scheme_Object *sclass, - char *name, - void **cache); - -int objscheme_is_subclass(Scheme_Object *a, Scheme_Object *sup); -int objscheme_is_a(Scheme_Object *o, Scheme_Object *c); - -Scheme_Object *objscheme_unwrap(Scheme_Object *, Scheme_Object *); - -Scheme_Object *objscheme_unbox(Scheme_Object *, const char *where); -Scheme_Object *objscheme_nullable_unbox(Scheme_Object *, const char *where); -Scheme_Object *objscheme_box(Scheme_Object *); -void objscheme_set_box(Scheme_Object *, Scheme_Object *); - -int objscheme_istype_bool(Scheme_Object *, const char *stopifbad); -int objscheme_istype_integer(Scheme_Object *, const char *stopifbad); -int objscheme_istype_number(Scheme_Object *, const char *stopifbad); -int objscheme_istype_ExactLong(Scheme_Object *, const char *stopifbad); -int objscheme_istype_double(Scheme_Object *, const char *stopifbad); -int objscheme_istype_pair(Scheme_Object *, const char *stopifbad); -int objscheme_istype_string(Scheme_Object *, const char *stopifbad); -int objscheme_istype_bstring(Scheme_Object *, const char *stopifbad); -int objscheme_istype_pstring(Scheme_Object *, const char *stopifbad); -#define objscheme_istype_mzstring objscheme_istype_string -#define objscheme_istype_mzxstring objscheme_istype_string -int objscheme_istype_pathname(Scheme_Object *, const char *stopifbad); -int objscheme_istype_epathname(Scheme_Object *, const char *stopifbad); -#define objscheme_istype_xpathname objscheme_istype_pathname -int objscheme_istype_char(Scheme_Object *, const char *stopifbad); -int objscheme_istype_closed_prim(Scheme_Object *, const char *stopifbad); -int objscheme_istype_proc2(Scheme_Object *, const char *stopifbad); -int objscheme_istype_box(Scheme_Object *, const char *stopifbad); -int objscheme_istype_nonnegative_symbol_integer(Scheme_Object *, const char *symname, const char *stopifbad); -int objscheme_istype_nonnegative_symbol_double(Scheme_Object *, const char *symname, const char *stopifbad); - -Scheme_Object *objscheme_car(Scheme_Object *, const char *where); -Scheme_Object *objscheme_bundle_string(char *); -Scheme_Object *objscheme_bundle_bstring(char *); -#define objscheme_bundle_pstring objscheme_bundle_bstring -Scheme_Object *objscheme_bundle_mzstring(mzchar *); -Scheme_Object *objscheme_bundle_pathname(char *); -#define objscheme_bundle_epathname objscheme_bundle_pathname -#define objscheme_bundle_xpathname objscheme_bundle_pathname -Scheme_Object *objscheme_bundle_nonnegative_symbol_double(double d, const char *symname); - -long objscheme_unbundle_integer(Scheme_Object *, const char *); -long objscheme_unbundle_integer_in(Scheme_Object *, long, long, const char *); -long objscheme_unbundle_nonnegative_integer(Scheme_Object *, const char *); -long objscheme_unbundle_nonnegative_symbol_integer(Scheme_Object *, const char *symname, const char *); -ExactLong objscheme_unbundle_ExactLong(Scheme_Object *, const char *); -double objscheme_unbundle_double(Scheme_Object *, const char *); -double objscheme_unbundle_double_in(Scheme_Object *, double, double, const char *); -double objscheme_unbundle_nonnegative_double(Scheme_Object *, const char *); -double objscheme_unbundle_nonnegative_symbol_double(Scheme_Object *, const char *symname, const char *); -int objscheme_unbundle_bool(Scheme_Object *, const char *); -char *objscheme_unbundle_string(Scheme_Object *, const char *); -char *objscheme_unbundle_bstring(Scheme_Object *, const char *); -char *objscheme_unbundle_pstring(Scheme_Object *, const char *); -mzchar *objscheme_unbundle_mzstring(Scheme_Object *, const char *); -#define objscheme_unbundle_mzxstring(a, b) (char *)objscheme_unbundle_mzstring(a, b) -mzchar *objscheme_unbundle_mzstring(Scheme_Object *, const char *); -char *objscheme_unbundle_mutable_bstring(Scheme_Object *, const char *); -mzchar *objscheme_unbundle_mutable_mzstring(Scheme_Object *, const char *); -char *objscheme_unbundle_nullable_string(Scheme_Object *, const char *); -char *objscheme_unbundle_nullable_bstring(Scheme_Object *, const char *); -char *objscheme_unbundle_nullable_pstring(Scheme_Object *, const char *); -mzchar *objscheme_unbundle_nullable_mzstring(Scheme_Object *, const char *); -char *objscheme_unbundle_pathname(Scheme_Object *, const char *); -char *objscheme_unbundle_nullable_pathname(Scheme_Object *, const char *); -char *objscheme_unbundle_write_pathname(Scheme_Object *, const char *); -char *objscheme_unbundle_nullable_write_pathname(Scheme_Object *, const char *); -char *objscheme_unbundle_epathname(Scheme_Object *, const char *); -char *objscheme_unbundle_nullable_epathname(Scheme_Object *, const char *); -char *objscheme_unbundle_xpathname(Scheme_Object *, const char *); -char *objscheme_unbundle_nullable_xpathname(Scheme_Object *, const char *); -mzchar objscheme_unbundle_char(Scheme_Object *, const char *); - -#define objscheme_bundle_integer scheme_make_integer -#define objscheme_bundle_long objscheme_bundle_integer -#define objscheme_bundle_int objscheme_bundle_integer -#define objscheme_bundle_ExactLong scheme_make_integer_value -#define objscheme_bundle_double scheme_make_double -#define objscheme_bundle_bool(x) ((x) ? scheme_true : scheme_false) -#define objscheme_bundle_char scheme_make_char -#define objscheme_bundle_pair scheme_make_pair - -#define objscheme_unbundle_long objscheme_unbundle_integer -#define objscheme_unbundle_int objscheme_unbundle_integer - -#define OBJSCHEME_PRIM_METHOD(m, cf) (SCHEME_PRIMP(m) && ((Scheme_Prim *)((Scheme_Primitive_Proc *)m)->prim_val == cf)) - -#define COPY_JMPBUF(dest, src) memcpy(&dest, &src, sizeof(mz_jmp_buf)); - -typedef Scheme_Object *(*Objscheme_Bundler)(void *); -void objscheme_install_bundler(Objscheme_Bundler f, long id); -Scheme_Object *objscheme_bundle_by_type(void *realobj, long type); - -#define METHODNAME(x, y) y" in "x - -#ifndef _MSC_VER -typedef char byte; -#endif -typedef unsigned char ubyte; - -typedef char *xc_string; -typedef char *xc_bstring; -typedef char *xc_pstring; -typedef mzchar *xc_mzstring; -typedef char *xc_mzxstring; -#define string xc_string -#define bstring xc_bstring -#define pstring xc_pstring -#define mzstring xc_mzstring -#define mzxstring xc_mzxstring -typedef const char *cstring, *ncstring; -typedef const char *cpstring, *ncpstring; -typedef const char *cbstring, *ncbstring; -typedef const mzchar *cmzstring, *ncmzstring; -typedef char *nstring; -typedef char *npstring; -typedef char *nbstring; -typedef char *wbstring; -typedef mzchar *wmzstring; - -typedef char *pathname; -typedef char *epathname; -typedef char *npathname; -typedef char *xpathname; -typedef char *nxpathname; -typedef char *nepathname; -typedef const char *cpathname; -typedef const char *cnpathname; -typedef char *wpathname; -typedef char *wnpathname; - -typedef long nnlong; -typedef int nnint; -typedef double nndouble; - -#define XC_SCHEME_NULL scheme_false -#define XC_SCHEME_NULLP(x) SCHEME_FALSEP(x) -#define XC_NULL_STR "#f" - -#ifdef __GNUG__ -# define WXS_USE_ARGUMENT(x) x = x; /* compiler optimizes it away */ -#else -# define WXS_USE_ARGUMENT(x) -#endif - -#ifdef MZ_PRECISE_GC -# ifndef GC_STACK_CALLEE_RESTORE -# define _SETUP_VAR_STACK(var, n, vs) void *var[n + 2]; \ - var[0] = vs; \ - var[1] = (void *)n -# define SETUP_VAR_STACK(n) _SETUP_VAR_STACK(__gc_var_stack__, n, GC_variable_stack) -# define SETUP_VAR_STACK_REMEMBERED(n) _SETUP_VAR_STACK(__gc_var_stack__, n, __remembered_vs__) -# define SETUP_VAR_STACK_PRE_REMEMBERED(n) _SETUP_VAR_STACK(__gc_var_stack__, n, __remembered_vs__[0]) -# define SETUP_PRE_VAR_STACK(n) _SETUP_VAR_STACK(__gc_pre_var_stack__, n, GC_variable_stack); \ - GC_variable_stack = __gc_pre_var_stack__ -# define VAR_STACK_PUSH(p, var) __gc_var_stack__[p+2] = &(var) -# define VAR_STACK_PUSH_ARRAY(p, var, n) __gc_var_stack__[p+2] = 0; \ - __gc_var_stack__[p+3] = &(var); \ - __gc_var_stack__[p+4] = (void *)(n) -# define PRE_VAR_STACK_PUSH(p, var) __gc_pre_var_stack__[p+2] = &(var) -# define SET_VAR_STACK() GC_variable_stack = __gc_var_stack__ -# define WITH_VAR_STACK(x) (SET_VAR_STACK(), x) -# define REMEMBER_VAR_STACK() void **__remembered_vs__ = GC_variable_stack -# define WITH_REMEMBERED_STACK(x) (GC_variable_stack = __remembered_vs__, x) -# define READY_TO_RETURN /* empty */ -# define READY_TO_PRE_RETURN /* empty */ -# else -# define _SETUP_VAR_STACK(var, n, vs) void *var[n + 2]; \ - var[0] = vs; \ - var[1] = (void *)n; \ - GC_variable_stack = var -# define SETUP_VAR_STACK(n) _SETUP_VAR_STACK(__gc_var_stack__, n, GC_variable_stack) -# define SETUP_VAR_STACK_REMEMBERED(n) SETUP_VAR_STACK(n) -# define SETUP_VAR_STACK_PRE_REMEMBERED(n) _SETUP_VAR_STACK(__gc_var_stack__, n, __gc_pre_var_stack__[0]) -# define SETUP_PRE_VAR_STACK(n) _SETUP_VAR_STACK(__gc_pre_var_stack__, n, GC_variable_stack) -# define VAR_STACK_PUSH(p, var) __gc_var_stack__[p+2] = &(var) -# define VAR_STACK_PUSH_ARRAY(p, var, n) __gc_var_stack__[p+2] = 0; \ - __gc_var_stack__[p+3] = &(var); \ - __gc_var_stack__[p+4] = (void *)(n) -# define PRE_VAR_STACK_PUSH(p, var) __gc_pre_var_stack__[p+2] = &(var) -# define SET_VAR_STACK() /* empty */ -# define WITH_VAR_STACK(x) x -# define REMEMBER_VAR_STACK() /* empty */ -# define WITH_REMEMBERED_STACK(x) x -# define READY_TO_RETURN GC_variable_stack = (void **)__gc_var_stack__[0] -# define READY_TO_PRE_RETURN READY_TO_RETURN -# endif - -# define CONSTRUCTOR_ARGS(x) () -# define CONSTRUCTOR_INIT(x) /* empty */ -# define ASSELF sElF-> -# define SELF__ sElF -# define INIT_NULLED_OUT = NULLED_OUT -# define INIT_NULLED_ARRAY(x) = x -# define INA_comma , -#else -# define SETUP_VAR_STACK(n) /* empty */ -# define SETUP_VAR_STACK_REMEMBERED(n) /* empty */ -# define SETUP_VAR_STACK_PRE_REMEMBERED(n) /* empty */ -# define SETUP_PRE_VAR_STACK(n) /* empty */ -# define VAR_STACK_PUSH(p, var) /* empty */ -# define VAR_STACK_PUSH_ARRAY(p, var, n) /* empty */ -# define PRE_VAR_STACK_PUSH(p, var) /* empty */ -# define SET_VAR_STACK() /* empty */ -# define WITH_VAR_STACK(x) x -# define REMEMBER_VAR_STACK() /* empty */ -# define WITH_REMEMBERED_STACK(x) x -# define READY_TO_RETURN /* empty */ -# define READY_TO_PRE_RETURN /* empty */ -# define CONSTRUCTOR_ARGS(x) x -# define CONSTRUCTOR_INIT(x) x -# define ASSELF /* empty */ -# define SELF__ this -# define INIT_NULLED_OUT /* empty */ -# define INIT_NULLED_ARRAY(x) /* empty */ -# define INA_comma /* empty */ -#endif - -#ifdef __cplusplus -}; -#endif - -#endif diff --git a/src/racket/utils/xctocc b/src/racket/utils/xctocc deleted file mode 100755 index 4a83097ddb..0000000000 --- a/src/racket/utils/xctocc +++ /dev/null @@ -1,3109 +0,0 @@ -#!/usr/local/bin/perl - -# Copyright (c) 1995 Matthew Flatt - -# This file reads C++ class descriptsions from files ending in ".xc". -# It produces a C++ file suitable for linking with libscheme plus -# objscheme.cc. - -# See xctocc.dvi for information about using this program. - -# No one should write code like this. It's horrible. It's immoral. -# -# Still, it works well enough for now. - -############################################################ - -# Overall file parsing - -$key_include = '@INCLUDE '; -$key_boolean = '@BOOLEAN '; -$key_classbase = '@CLASSBASE '; -$key_interface = '@INTERFACE '; -$key_implements = '@IMPLEMENTS '; -$key_classid = '@CLASSID '; -$key_global = '@GLOBAL '; -$key_header = '@HEADER '; -$key_end = '@END '; -$key_stop = '@STOP '; -$key_creator = '@CREATOR '; -$key_creatorx = '@CREATORX '; -$key_macro = '@MACRO '; -$key_var = '@VAR '; -$key_set = '@SET '; -$key_define = '@DEFINE '; -$key_ifdefine = '@IFDEFINE '; -$key_ivar = '@IVAR '; -$key_constant = '@CONSTANT '; -$key_suffix = '@CLASSSUFFIX '; -$key_test = '@TEST '; -$key_setmark = '@SETMARK '; -$key_idfield = '@IDFIELD '; -$key_startsymbols = '@BEGINSYMBOLS '; -$key_endsymbols = '@ENDSYMBOLS '; -$key_sym = '@SYM '; -$key_argnames = '@ARGNAMES '; - -sub ResetObjParams -{ - @functions = (); - @funcnames = (); - @vars = (); - @ivars = (); - @creators = (); - $iargnames = 'BYPOS'; - @distinct_creators = (); - @constants = (); - %justoneok = (); - %justonemin = (); - %justonemax = (); - $globalname = ''; - $classid = ''; - $global = 0; - $implementor = ""; - $interfacestring = ""; - $implements = ""; -} - -&ResetObjParams(); - -sub ReadFile { - @openfiles = (); - $stop = 0; - $linenum = 0; - $filepos = 0; - $testfile = 0; - $classsuffix = ''; - $idfield = ''; - $bool = 'boolean'; - $cursymset = ''; - %macros = (); - %sets = (); - %marks = (); - @syms = (); - $symsetkind = ""; - $symsetomit = ""; - $marks{'V'} = 'V'; - $marks{'H'} = 'H'; - $marks{'v'} = 'v'; - $marks{'m'} = 'm'; - $marks{'M'} = 'M'; - $ifzero = 0; - - open(SOUT, ">${file}.rkt"); - - while(!$stop) - { - $_ = ; - $linenum += 1; - $filepos += length($_); - if ($_ eq undef) { - if ($#openfiles >= 0) { - close(IN); - $oldin = pop(@openfiles); - $p = index($oldin, ":"); - $linenum = substr($oldin, 0, $p); - $oldin = substr($oldin, $p + 1); - $p = index($oldin, ":"); - $filepos = substr($oldin, 0, $p); - $thisfile = substr($oldin, $p + 1); - open(IN, "$thisfile"); - if ($filepos > 0) { - seek(IN, $filepos, 0); - } else { - seek(IN, 0, 2); - } - } else { - $stop = 1; - } - } elsif ($ifzero) { - if (/^\#endif/) { - $ifzero -= 1; - } elsif (/^\#if/) { - $ifzero += 1; - } - } elsif (/^\@/) { - chop; - $_ = $_ . " "; - if (&StartsWithKey($_, $key_include)) { - $_ = &SkipKey($_, $key_include); - $incfile = &Wash($_); - $oldin = $linenum . ":" . $filepos . ":" . $thisfile; - $thisfile =~ /^((.*\/)|)([^\/]*)$/; - $incpath = $1; - if (!open(IN2, "$incpath$incfile")) { - print STDERR "Couldn't open \"${incfile}\"\n"; - } else { - $thisfile = "$incpath$incfile"; - $linenum = 0; - $filepos = 0; - push(@openfiles, $oldin); - close(IN); - open(IN, "<&IN2"); - } - } elsif (&StartsWithKey($_, $key_boolean)) { - $bool = &Wash(&SkipKey($_, $key_boolean)); - } elsif (&StartsWithKey($_, $key_test)) { - $testfile = 1; - } elsif (&StartsWithKey($_, $key_classbase)) { - &ResetObjParams(); - $_ = &Wash(&SkipKey($_, $key_classbase)); - $pos = index($_, ' '); - $base = substr($_, 0, $pos); - ($base,$mkbase) = split(/=/, $base, 2); - if ($mkbase eq '') { - $mkbase = $base; - } - $classstring = substr($_, $pos); - $base = &Wash($base); - $mkbase = &Wash($mkbase); - ($classstring,$classflags) = split(/\//, $classstring, 2); - ($classstring,$parentstring) = &SplitColon($classstring); - $classstring = '"' . &Unquote(&Wash($classstring)) - . &Unquote($classsuffix) . '"'; - $parentstring = &Wash($parentstring); - if ($parentstring ne '') { - $parentstring = '"' . &Unquote($parentstring) - . &Unquote($classsuffix) . '"'; - } - $classflags = &Wash($classflags); - $oldclass = $base; - $oldclassmk = $mkbase; - $newclass = 'os_' . $base; - } elsif (&StartsWithKey($_, $key_interface)) { - $_ = &Wash(&SkipKey($_, $key_interface)); - $interfacestring =$_; - } elsif (&StartsWithKey($_, $key_implements)) { - $_ = &Wash(&SkipKey($_, $key_implements)); - $implements =$_; - } elsif (&StartsWithKey($_, $key_global)) { - &ResetObjParams(); - $global = 1; - $globalname = &Wash(&SkipKey($_, $key_global)); - } elsif (&StartsWithKey($_, $key_idfield)) { - $idfield = &Wash(&SkipKey($_, $key_idfield)); - } elsif (&StartsWithKey($_, $key_classid)) { - $classid = &Wash(&SkipKey($_, $key_classid)); - } elsif (&StartsWithKey($_, $key_header)) { - &PrintHeader(); - } elsif (&StartsWithKey($_, $key_end)) { - &DoPrintClass(); - } elsif (&StartsWithKey($_, $key_stop)) { - $stop = 1; - } elsif (&StartsWithKey($_, $key_creator)) { - $creator = &SkipKey($_, $key_creator); - @creators = (@creators, $creator); - @distinct_creators = (@distinct_creators, $creator); - } elsif (&StartsWithKey($_, $key_creatorx)) { - $creator = &SkipKey($_, $key_creatorx); - @creators = (@creators, $creator); - } elsif (&StartsWithKey($_, $key_argnames)) { - $iargnames = &SkipKey($_, $key_argnames); - $iargnames = &Wash($iargnames); - } elsif (&StartsWithKey($_, $key_macro)) { - $s = &Wash(&SkipKey($_, $key_macro)); - $eqpos = index($s, '='); - $parenpos = index($s, '['); - if ($parenpos >= $[ && $parenpos < $eqpos) { - $macro = substr($s, 0, $parenpos); - } else { - $macro = substr($s, 0, $eqpos); - } - $macro = &Wash($macro); - $macros{$macro} = $s; - } elsif (&StartsWithKey($_, $key_var)) { - @vars = (@vars, &Wash(substr($_, 4))); - } elsif (&StartsWithKey($_, $key_set)) { - ($var, $val) = split(/=/, &SkipKey($_, $key_set)); - $var = &Wash($var); - $val = &Wash($val); - $sets{$var} = $val; - } elsif (&StartsWithKey($_, $key_define)) { - ($var, $val) = split(/=/, &SkipKey($_, $key_define)); - $var = &Wash($var); - $val = &Wash($val); - &DefineVar($var, $val); - } elsif (&StartsWithKey($_, $key_ifdefine)) { - ($var, $val) = split(/=/, &SkipKey($_, $key_ifdefine), 2); - $var = &Wash($var); - ($test, $val1, $val2) = &SplitColon($val); - if ($sets{&Wash($test)} > 0) { - $val = $val1; - } else { - $val = $val2; - } - $val = &Wash($val); - &DefineVar($var, $val); - } elsif (&StartsWithKey($_, $key_ivar)) { - @ivars = (@ivars, &Wash(&SkipKey($_, $key_ivar))); - } elsif (&StartsWithKey($_, $key_constant)) { - @constants = (@constants, &Wash(&SkipKey($_, $key_constant))); - } elsif (&StartsWithKey($_, $key_suffix)) { - $classsuffix = &Wash(&SkipKey($_, $key_suffix)); - } elsif (&StartsWithKey($_, $key_setmark)) { - ($mark, $val) = split(/=/, &SkipKey($_, $key_setmark), 2); - $mark = &Wash($mark); - $marks{$mark} = &Wash($val); - } elsif (&StartsWithKey($_, $key_startsymbols)) { - ($name, $kind, $omit) = split(/>/, &SkipKey($_, $key_startsymbols), 3); - $name = &Wash($name); - @syms = (); - $cursymset = $name; - $symsetkind = $kind; - $symsetomit = $omit; - } elsif (&StartsWithKey($_, $key_sym)) { - ($name, $val) = split(/:/, &SkipKey($_, $key_sym), 2); - $name = &Wash($name); - $val = &Wash($val); - @syms = (@syms, "$name,$val"); - } elsif (&StartsWithKey($_, $key_endsymbols)) { - &PrintSymSet($cursymset, $symsetkind, $symsetomit, @syms); - } elsif (substr($_, 1, 1) ne ' ') { - print STDERR - "syntax error at line $linenum of \"$thisfile\".\n" - } else { - $function = &Wash(substr($_, 1)); - $mark = substr($function, 0, 1); - if ($mark ne '"') { - $mark = $marks{$mark}; - substr($function, 0, 1) = $mark; - } - @functions = ($function, @functions); - &ReadFields($function); - @funcnames = ($func, @funcnames); - } - } elsif (/^\#if 0/) { - $ifzero = 1; - } else { - &IgnoreLine($_); - } - } - - close(OUT); - - # Finish up the file - while() { &IgnoreLine($_); } - - &PrintFooter(); -} - -sub StartsWithKey -{ - return (index($_[0], $_[1]) == $[); -} - -sub SkipKey -{ - return substr($_[0], length($_[1])); -} - -sub Wash -{ - $_[0] =~ /^ *(.*[^ ]) *$/; - return $1; -} - -sub SplitColon -{ - local($s) = @_; - local($balance, @ans, $a, $c); - - $balance = 0; - $a = ''; - @ans = (); - while ($s ne '') { - $c = substr($s, 0, 1); - if (!$balance && $c eq ':') { - @ans = (@ans, $a); - $a = ''; - } else { - $a = $a . $c; - } - - if ($c eq '"') { - $balance = !$balance; - } - $s = substr($s, 1); - } - @ans = (@ans, $a) if ($a ne ''); - - return @ans; -} - -sub ReadFields { - - ($s) = @_; - - $virtual = $virtualonly = $hidden = $delegate = $externalmethod = $phantom = 0; - - $mark = substr($s, 0, 1); - if ($mark ne '"') { - substr($s, 0, 1) = ''; - } - - if ($mark eq 'p') { - $phantom = 1; - } elsif ($mark eq 'V') { - $virtual = $virtualonly = 1; - } elsif ($mark eq 'v') { - $virtual = 1; - } elsif ($mark eq 'H') { - $virtual = $virtualonly = $hidden = 1; - } elsif ($mark eq 'd') { - $virtual = 1; - } elsif ($mark eq 'm') { - $externalmethod = 1; - } elsif ($mark eq 'M') { - $externalmethod = 1; - $virtual = 1; - } - - ($s, $casename) = split(/<>/, $s); - if ($casename eq "") { - ($s, $onlyif) = split(/##/, $s); - } else { - ($casename, $onlyif) = split(/##/, $casename); - } - - $casename = &Wash($casename); - - ($fname, $s, $methodpostmacros, $gluepostmacros, $exception, $vexception, $implementor) - = &SplitColon($s); - - $s = &Wash($s); - - $p = index($s, ' '); - $returntype = substr($s, 0, $p); - $s = substr($s, $p + 1); - - $p = index($s, '('); - $func = substr($s, 0, $p); - $s = substr($s, $p + 1); - - $p = rindex($s, ')'); - $s = substr($s, 0, $p); - - @defvals = (); - @bundles = (); - @unbundles = (); - @typechecks = (); - @typeids = (); - @schemes = (); - @schemeparams = (); - @spideytypes = (); - @pushables = (); - @paramtypes = split(/,/, $s); - $numschemes = 0; - foreach $paramtype (@paramtypes) { - ($paramtype, $bundle, $unbundle, $typecheck, $typeid, $spideytype, $pushable) - = split('/', $paramtype); - - ($paramtype, $defval) = split(/=/, $paramtype); - $paramtype = &Wash($paramtype); - if (substr($paramtype, 0, 1) eq '-') { - $paramtype = substr($paramtype, 1); - $scheme = 0; - } else { - $scheme = 1; - } - $defval = &Wash($defval); - $bundle = &Wash($bundle); - $unbundle = &Wash($unbundle); - $typecheck = &Wash($typecheck); - $typeid = &Wash($typeid); - $spideytype = &Wash($spideytype); - $pushable = &Wash($pushable); - - @defvals = (@defvals, $defval); - @bundles = (@bundles, $bundle); - @unbundles = (@unbundles, $unbundle); - @typechecks = (@typechecks, $typecheck); - @typeids = (@typeids, $typeid); - @spideytypes = (@spideytypes, $spideytype); - @pushables = (@pushables, $pushable); - @schemes = (@schemes, $scheme); - if ($scheme) { - @schemeparams = (@schemeparams, $paramtype); - $numschemes += 1; - } - } - - ($returntype, $returnbundle, $returnunbundle, $returnspideytype, $returnpushable) = split('/', $returntype); - - $func = &Wash($func); - $fname = &Wash($fname); - $returntype = &Wash($returntype); - $returnbundle = &Wash($returnbundle); - $returnunbundle = &Wash($returnunbundle); - $returnpushable = &Wash($returnpushable); - - ($methpre, $methprecall, $methpostcall, $methpost) - = split('/', $methodpostmacros); - ($gluepre, $glueprecall, $gluepostcall, $gluepost, $gluepostschemebind) - = split('/', $gluepostmacros); - - $methpre = &Wash($methpre); - $methprecall = &Wash($methprecall); - $methpost = &Wash($methpost); - $methpostcall = &Wash($methpostcall); - - $gluepre = &Wash($gluepre); - $glueprecall = &Wash($glueprecall); - $gluepost = &Wash($gluepost); - $gluepostcall = &Wash($gluepostcall); - $gluepostschemebind = &Wash($gluepostschemebind); - - if ($virtualonly && ($vexception ne '')) { - $exception = &Wash($vexception); - } else { - $exception = &Wash($exception); - } - if ($exception eq '') { - $exception = 'SUPER'; - } - - if ($classstring eq '') { - $method = $fname; - } else { - if ($interfacestring eq '') { - $sourcestring = $classstring; - } else { - $sourcestring = substr($interfacestring, 0, length($interfacestring) - 1) . '<%>"'; - } - $method = '"' . substr($fname, 1, length($fname) - 2) . " in " - . substr($sourcestring, 1, length($sourcestring) - 2) . '"'; - } -} - -sub ReadIvarFields -{ - local($s) = @_; - - $readonly = 0; - - ($s, $onlyif) = split(/##/, $s); - - if (substr($s, 0, 1) eq 'r') { - $readonly = 1; - } - - substr($s, 0, 1) = '' if $readonly; - - ($iname, $itype) = &SplitColon($s); - ($itype, $ivarname) = split(/ /, &Wash($itype)); - - $iname = &Wash($iname); - $getname = substr($iname, 1); - substr($getname, -1) = ''; - $setname = "\"set-" . $getname . "\""; - $getname = "\"get-" . $getname . "\""; - - $ivartype = &Wash($itype); - $ivarname = &Wash($ivarname); - - $method = 'et-' . substr($iname, 1, length($iname) - 2) - . " in " . substr($classstring, 1, length($classstring) - 2) . '"'; - - $longsetname = '"s' . $method; - $longgetname = '"g' . $method; - $method = $longsetname; -} - -sub ReadConstFields -{ - local($s) = @_; - - ($s, $onlyif) = split(/##/, $s); - - ($const, $ctype) = &SplitColon($s); - ($ctype, $cname) = split(/ /, &Wash($ctype)); - - $const = &Wash($const); - $ctype = &Wash($ctype); - $cname = &Wash($cname); -} - -sub DefineReplace -{ - local($val) = @_; - - while ($val =~ /<([^>]*)>/ ) { - $subval = $sets{$1}; - $val =~ s/<[^>]*>/$subval/; - } - - return $val; -} - -sub DefineVar -{ - local($var, $val) = @_; - - $val = &DefineReplace($val); - &PrintDefine("#define $var $val\n"); -} - -sub Unquote -{ - return substr($_[0], 1, length($_[0]) - 2); -} - -sub Sprintfify -{ - $_[0] =~ s/%/%%/g; -} - -sub ApplyMacro -{ - local($name, $var, $var2) = @_; - - if (($name eq '') || ($name eq undef)) { - return ""; - } - - local($pos, @args, @argnames, $arg); - $pos = index($name, '['); - if ($pos >= $[) { - $arg = substr($name, $pos + 1); - $name = substr($name, 0, $pos); - $pos = index($arg, ']'); - $arg = substr($arg, 0, $pos); - @args = split(/\./, $arg); - } else { - @args = (); - } - - $macro = $macros{$name}; - - if ($macro eq undef) { - print STDERR "Unknown macro $name in $func.\n"; - return ""; - } - - $pos = index($macro, '='); - - $m = substr($macro, $pos + 1); - $macro = substr($macro, 0, $pos); - $pos = index($macro, '['); - if ($pos >= $[) { - $arg = substr($macro, $pos + 1); - $pos = index($arg, ']'); - $arg = substr($arg, 0, $pos); - @argnames = split(/\./, $arg); - } else { - @argnames = (); - } - - $m =~ s/{x}/$var/g; - $m =~ s/{s}/$var2/g; - - if ($#argnames != $#args) { - print STDERR "Bad parameter (" - . ($#args + 1) - . " for " - . ($#argnames + 1) - . ") count to macro $name in $func.\n"; - return ""; - } - - foreach $name (@argnames) { - $arg = shift(@args); - $name = &Wash($name); - $arg = &Wash($arg); - $m =~ s/<${name}>/$arg/g; - } - - $m = &Wash($m); - - while (substr($m, 0, 2) eq '$$') { - if (substr($m, 2, 1) eq '>') { - $m = &DefineReplace(substr($m, 3)); - } else { - $m = &ApplyMacro(substr($m, 2), "", ""); - } - } - - return $m; -} - -sub ApplyMacros -{ - local($macrolist, $var, $var2) = @_; - - @macros = split(/\|/, $macrolist); - $str = ''; - foreach $macro (@macros) { - $str = $str . &ApplyMacro(&Wash($macro), $var, $var2); - } - - return $str; -} - - -sub Desymbol -{ - local($t, $e) = @_; - - $e = substr($t, -1); - if ($e eq '*') { - substr($t, -1) = ''; - return &Desymbol($t) . "P"; - } - if ($e eq '&') { - substr($t, -1) = ''; - return &Desymbol($t) . "A"; - } - if ($e eq '?') { - substr($t, -1) = ''; - return &Desymbol($t) . "Q"; - } - if ($e eq '!') { - substr($t, -1) = ''; - return &Desymbol($t) . "PT"; - } - if ($e eq '^') { - substr($t, -1) = ''; - return &Desymbol($t) . "NP"; - } - if ($e eq '%') { - substr($t, -1) = ''; - return &Desymbol($t) . "AD"; - } - if ($e eq ']') { - $badflag = 1; - return "XXX"; - } - - return $t; -} - -############################################################ - -$cc_suffix = "cc"; - -if ($ARGV[0] eq '-cxx') { - $cc_suffix = "cxx"; - shift(@ARGV); -} - -$file = $infile = $ARGV[0]; - -if ($file =~ s/.xc$//) { -} else { - print STDERR "Bad extension \"$infile\".\n"; - exit 1; -} - -if (!open(IN, "$file.xc")) { - print STDERR "Couldn't open \"${file}.xc\"\n"; - exit 1; -} - -if (!open(OUT, ">${file}.${cc_suffix}")) { - print STDERR "Couldn't write \"${file}.${cc_suffix}\"\n"; - exit 1; -} - -if (!open(HEADER, ">${file}.h")) { - print STDERR "Couldn't write \"${file}.h\"\n"; - exit 1; -} - -$setup_d_start = "#ifndef WXS_SETUP_ONLY\n"; -$setup_d_end = "#endif\n"; - -print HEADER $setup_d_start; - -select(OUT); - -$base = ''; - -$dummyfields = " \"initialization\" : x create"; -$scheme_args = "int n, Scheme_Object *p[]"; -$global_scheme_args = "int n, Scheme_Object *p[]"; - -$file =~ /([^\/]*)$/; -$filenopath = $1; - -print "/* DO NOT EDIT THIS FILE. */\n"; -print "/* This file was generated by xctocc from \"${filenopath}.xc\". */\n\n"; - -$thisfile = "$file.xc"; -&ReadFile(); - -print HEADER $setup_d_end; - -close(IN); -close(OUT); -close(HEADER); - -sub IgnoreLine -{ - print $_[0]; -} - -sub PrintHeader -{ - print "#include \"wxscheme.h\"\n"; - print "#include \"${filenopath}.h\"\n"; - print "\n"; - - print "#ifdef MZ_PRECISE_GC\n"; - print "START_XFORM_SKIP;\n"; - print "#endif\n"; -} - -sub PrintFooter -{ - print "#ifdef MZ_PRECISE_GC\n"; - print "END_XFORM_SKIP;\n"; - print "#endif\n"; -} - -sub PrintDefine -{ - print $_[0]; -} - -sub DoPrintClass -{ - - if (!$global) { - $globalname = ""; - - print "class ${newclass} : public ${oldclassmk} {\n"; - print " public:\n"; - foreach $var (@vars) { - print " $var\n"; - } - - print "\n"; - - # Print creation prototypes: - if ($#distinct_creators >= 0) { - $did_one_creator = 0; - foreach $creator (@distinct_creators) { - &ReadFields($dummyfields . $creator); - if ($did_one_creator) { - printf "#ifndef MZ_PRECISE_GC\n"; - } - print " ${newclass} CONSTRUCTOR_ARGS(("; - &PrintParams(1); - print "));\n"; - if ($did_one_creator) { - printf "#endif\n"; - } - $did_one_creator = 1; - } - } - - # destruction - print " ~${newclass}();\n"; - } else { - $newclass = ""; - - select(HEADER); - } - - # Print method prototypes - if (!$global) { - $pos = 0; - foreach $function (@functions) { - if (!&Overridden($function, $pos)) { - &ReadFields($function); - if ($virtual) { - &OIStart; - print " " . &NormalType($returntype) - . " ${globalname}${func}"; - if ($externalmethod) { - print "_method"; - } - print "("; - &PrintParams(1); - print ");\n"; - &OIEnd; - } - } - $pos += 1; - } - } - - if (!$global) { - print "#ifdef MZ_PRECISE_GC\n"; - print " void gcMark();\n"; - print " void gcFixup();\n"; - print "#endif\n"; - - print "};\n\n"; - - print "#ifdef MZ_PRECISE_GC\n"; - print "void ${newclass}::gcMark() {\n"; - print " ${oldclassmk}::gcMark();\n"; - foreach $var (@vars) { - if ($var =~ /(.*[*])(.*);/) { - print " gcMARK_TYPED($1, $2);\n"; - } - } - print "}\n"; - - print "void ${newclass}::gcFixup() {\n"; - print " ${oldclassmk}::gcFixup();\n"; - foreach $var (@vars) { - if ($var =~ /(.*[*])(.*);/) { - print " gcFIXUP_TYPED($1, $2);\n"; - } - } - print "}\n"; - print "#endif\n\n"; - - # End of class definition - } else { - select(OUT); - } - - if ($global) { - $POFFSET = "0"; - } else { - $POFFSET = "POFFSET"; - } - - # Print class and interface decls: - if (!$global) { - print "static Scheme_Object *${newclass}_class;\n"; - if ($interfacestring ne '') { - print "static Scheme_Object *${newclass}_interface;\n"; - } - print "\n"; - } - - if (!$global) { - #Do creation methods - if ($#distinct_creators >= 0) { - $did_one_creator = 0; - foreach $creator (@distinct_creators) { - &ReadFields($dummyfields . $creator); - if ($did_one_creator) { - printf "#ifndef MZ_PRECISE_GC\n"; - } - &OIStart; - print "${newclass}::${newclass} CONSTRUCTOR_ARGS(("; - &PrintParams(0); - print "))\n"; - print "CONSTRUCTOR_INIT(: ${oldclassmk}("; - &PrintArgs(1); - print "))\n"; - print "{\n"; - print "}\n"; - &OIEnd; - if ($did_one_creator) { - printf "#endif\n"; - } - print "\n"; - $did_one_creator = 1; - } - } - - # destruction - print "${newclass}::~${newclass}()\n{\n "; - print " objscheme_destroy(this, (Scheme_Object *) __gc_external);\n}\n\n"; - } - - #Do regular methods - @funcs = (); - $pos = 0; - foreach $function (@functions) { - if (!&Overridden($function, $pos)) { - &PrintMethod($function); - @l = grep($_ =~ /^$func$/, @funcs); - if ($#l < $[) { - @funcs = (@funcs, $func); - } - } - $pos += 1; - } - - ##Regular glue code - - foreach $func (@funcs) { - &PrintFunction($func); - } - - foreach $ivar (@ivars) { - &ReadIvarFields($ivar); - &OIStart; - print "static Scheme_Object *objscheme_${oldclass}_Get${ivarname}("; - print $scheme_args; - print ")\n{\n "; - print "Scheme_Class_Object *cobj INIT_NULLED_OUT;\n "; - print &NormalType($ivartype, 1) . " v"; - print ";\n"; - print " REMEMBER_VAR_STACK();\n\n"; - print " p[0] = objscheme_unwrap(p[0], ${newclass}_class);\n"; - print " objscheme_check_valid(${newclass}_class, $longgetname, n, p);\n"; - print " if (n > POFFSET) WITH_REMEMBERED_STACK(scheme_wrong_count_m($longgetname, POFFSET, POFFSET, n, p, 1));\n"; - print " cobj = (Scheme_Class_Object *)p[0];\n"; - print " if (cobj->primflag)\n"; - print " v = "; - &PrintIndirect($ivartype); - print "(($newclass *)cobj->primdata)->${oldclass}::${ivarname}"; - print ";\n else\n v = "; - &PrintIndirect($ivartype); - print "(($oldclass *)cobj->primdata)->${ivarname}"; - - print ";\n\n return "; - &PrintBundleVar("v", $ivartype, "WITH_REMEMBERED_STACK", '', 1); - print ";\n}\n"; - - if (!$readonly) { - print "\nstatic Scheme_Object *objscheme_${oldclass}_Set${ivarname}("; - print $scheme_args; - print ")\n{\n "; - print "Scheme_Class_Object *cobj = (Scheme_Class_Object *)objscheme_unwrap(p[0], ${newclass}_class);\n "; - print &NormalType($ivartype, 1) . " v"; - print ";\n"; - print " SETUP_VAR_STACK(1);\n VAR_STACK_PUSH(0, cobj);\n\n"; - print " WITH_VAR_STACK(objscheme_check_valid(${newclass}_class, $longsetname, n, p));\n"; - print " if (n != (POFFSET+1)) WITH_VAR_STACK(scheme_wrong_count_m($longsetname, POFFSET+1, POFFSET+1, n, p, 1));\n\n"; - print " v = "; - &PrintUnbundleVar("p[POFFSET]", $ivartype); - print ";\n "; - if (substr($ivartype, -1) eq '%' || substr($ivartype, -1) eq '&') { - print "memcpy("; - print "&(($oldclass *)cobj->primdata)->${ivarname}"; - print ", v, sizeof(*v));\n"; - } else { - print "(($oldclass *)cobj->primdata)->${ivarname}"; - print " = v;\n\n"; - } - print " READY_TO_RETURN;\n return scheme_void;\n}\n"; - } - &OIEnd; - print "\n"; - } - - ## General glue code - - if (!$global) { - # Init function - if ($#creators >= 0) { - @savefunctions = @functions; - @savefuncnames = @funcnames; - @functions = (); - @funcnames = (); - foreach $creator (@creators) { - $function = $dummyfields . $creator; - @functions = (@functions, $function); - @funcnames = (@funcnames, "create"); - } - &PrintFunction("create", 1); - @functions = @savefunctions; - @funcnames = @savefuncnames; - } - - # Destroy function - if (0) { - print "static Scheme_Object *objscheme_destroy_${newclass}("; - print $scheme_args; - print ")\n{\n"; - print " Scheme_Class_Object *cobj = (Scheme_Class_Object *)p[0];\n"; - print " if (n) scheme_signal_error(\""; - print "destroy: method takes no arguments"; - print "\");\n"; - print " if (cobj->primflag > 1) return scheme_void;\n"; - print " if (cobj->primflag) {\n"; - print " cobj->primflag = 2;\n\n"; - print " delete (${newclass} *)(cobj->primdata);\n"; - print " } else\n"; - print " delete (${oldclass} *)(cobj->primdata);\n"; - print "\n"; - print " cobj->primflag = -1;\n\n"; - print " return scheme_void;\n}\n\n"; - } - } - - # Setup function - if (!$global) { - $proto = "void objscheme_setup_${oldclass}(Scheme_Env *env)"; - print HEADER $setup_d_end; - print HEADER "$proto;\n"; - print HEADER $setup_d_start; - print "$proto\n{\n"; - - # Count methods to be installed: - @funcs = (); - $nmethod = 0; # count - foreach $function (@functions) { - &ReadFields($function); - if (!$phantom) { - @l = grep($_ =~ /^$func$/, @funcs); - if ($#l < $[) { - @funcs = (@funcs, $func); - $nmethod += 1; - } - } - } - foreach $ivar (@ivars) { - &ReadIvarFields($ivar); - $nmethod += 1; - if (!$readonly) { - $nmethod += 1; - } - } - - # Create class: - print " SETUP_VAR_STACK(1);\n"; - print " VAR_STACK_PUSH(0, env);\n\n"; - print " wxREGGLOB(${newclass}_class);\n"; - if ($interfacestring ne '') { - print " wxREGGLOB(${newclass}_interface);\n"; - } - print "\n"; - - print " ${newclass}_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "; - print "${classstring}, "; - if ($parentstring ne '') { - print "${parentstring}"; - } else { - print "NULL"; - } - print ", "; - if ($#creators >= 0) { - print "(Scheme_Method_Prim *)${newclass}_ConstructScheme"; - } else { - print "NULL"; - } - print ", ${nmethod}))"; - print ";\n\n"; - - if ($interfacestring ne '') { - $sym = &Unquote($classstring); - print SOUT " (define-private-class $sym "; - $sym = &Unquote($interfacestring); - print SOUT "$sym<%> "; - } else { - $sym = &Unquote($classstring); - print SOUT " (define-class $sym "; - } - if ($parentstring ne '') { - $sym = &Unquote($parentstring); - print SOUT "$sym"; - } else { - print SOUT "#f"; - } - print SOUT " ($implements)"; - if ($iargnames ne 'BYPOS') { - print SOUT " ($iargnames)"; - } else { - print SOUT " #f"; - } - - @funcs = (); - foreach $function (@functions) { - &ReadFields($function); - @l = grep($_ =~ /^$func$/, @funcs); - if ($#l < $[) { - $sym = &Unquote($fname); - print SOUT "\n $sym"; - - @funcs = (@funcs, $func); - if (!$delegate && !$phantom) { - &OIStart; - print " WITH_VAR_STACK("; - if ($justoneok{$func}) { - print "scheme_add_method_w_arity"; - } else { - print "scheme_add_method"; - } - print "(${newclass}_class, "; - $cleanfunc = $func; - $cleanfunc = &OperatorClean($cleanfunc); - print "${fname} \" method\", (Scheme_Method_Prim *)${newclass}${cleanfunc}"; - if ($justoneok{$func}) { - print ", "; - print $justonemin{$func}; - print ", "; - print $justonemax{$func}; - } - print "));\n"; - &OIEnd; - } - } - } - - print "\n"; - - foreach $ivar (@ivars) { - &ReadIvarFields($ivar); - &OIStart; - print " WITH_VAR_STACK(scheme_add_method_w_arity(${newclass}_class,"; - print "${getname} \" method\", (Scheme_Method_Prim *)objscheme_${oldclass}_Get${ivarname}, 0, 0));\n"; - - $sym = &Unquote($getname); - print SOUT "\n $sym"; - - if (!$readonly) { - print " WITH_VAR_STACK(scheme_add_method_w_arity(${newclass}_class,"; - print "${setname} \" method\", (Scheme_Method_Prim *)objscheme_${oldclass}_Set${ivarname}, 1, 1));\n"; - - $sym = &Unquote($setname); - print SOUT "\n $sym"; - } - &OIEnd; - } - - print "\n"; - print SOUT ")\n"; - - print " WITH_VAR_STACK(scheme_made_class(${newclass}_class));\n\n"; - if ($interfacestring ne '') { - print " ${newclass}_interface = WITH_VAR_STACK("; - print "scheme_class_to_interface(${newclass}_class, ${interfacestring} \"<%>\"));\n\n"; - print " WITH_VAR_STACK("; - print "objscheme_add_global_interface(${newclass}_interface, ${interfacestring} \"<%>\", env));\n"; - } - - if ($idfield ne '' && $classid ne '') { - print " WITH_VAR_STACK(objscheme_install_bundler("; - print "(Objscheme_Bundler)objscheme_bundle_"; - print "${oldclass}, ${classid}));\n"; - } - - print "\n"; - } else { - $proto = "void objscheme_setup_${globalname}(Scheme_Env *env)"; - print HEADER $setup_d_end; - print HEADER "$proto;\n"; - print HEADER $setup_d_start; - print "$proto\n{\n"; - - print " Scheme_Object *functmp INIT_NULLED_OUT;\n"; - print " SETUP_VAR_STACK(1);\n"; - print " VAR_STACK_PUSH(0, env);\n"; - - @funcs = (); - foreach $function (@functions) { - &ReadFields($function); - - @l = grep($_ =~ /^$func$/, @funcs); - if ($#l < $[) { - $sym = &Unquote($fname); - print SOUT " (define-function $sym)\n"; - - @funcs = (@funcs, $func); - &OIStart; - print " functmp = WITH_VAR_STACK("; - if ($justoneok{$func}) { - print "scheme_make_prim_w_arity"; - } else { - print "scheme_make_prim"; - } - print "((Scheme_Prim *)${globalname}${func}"; - if ($justoneok{$func}) { - print ", ${fname}, "; - print $justonemin{$func}; - print ", "; - print $justonemax{$func}; - } - print "));\n"; - print " WITH_VAR_STACK(scheme_install_xc_global(${fname}, functmp, env));\n"; - &OIEnd; - } - } - } - - if ($#constants >= 0) { - print " Scheme_Object *xcconsttmp INIT_NULLED_OUT;\n"; - } - foreach $constant (@constants) { - &ReadConstFields($constant); - &OIStart; - print " xcconsttmp = "; - &PrintBundleVar($cname, $ctype, 'WITH_VAR_STACK'); - print ";\n"; - print " WITH_VAR_STACK(scheme_install_xc_global(${const}, xcconsttmp, env));\n"; - &OIEnd; - - $sym = &Unquote($const); - print SOUT " (define-constant $sym)\n"; - } - - print " READY_TO_RETURN;\n"; - print "}\n\n"; - - if (!$global) { - $proto="int objscheme_istype_${oldclass}" - . "(Scheme_Object *obj, const char *stop, int nullOK)"; - print HEADER "$proto;\n"; - print "$proto\n"; - print "{\n"; - print " REMEMBER_VAR_STACK();\n"; - print " if (nullOK && XC_SCHEME_NULLP(obj)) return 1;\n"; - print " obj = objscheme_unwrap(obj, ${newclass}_class);\n"; - print " if (objscheme_is_a(obj, ${newclass}_class))\n"; - print " return 1;\n"; - print " else {\n"; - print " if (!stop)\n"; - print " return 0;\n"; - $cs = &Unquote($classstring, 1); - print " WITH_REMEMBERED_STACK(scheme_wrong_type(stop, nullOK ? \"$cs object or \" XC_NULL_STR: \"$cs object\", -1, 0, &obj));\n"; - print " return 0;\n"; - print " }\n"; - print "}\n\n"; - - # Bundle function - $proto="Scheme_Object *objscheme_bundle_${oldclass}" - . "(class ${oldclass} *realobj)"; - print HEADER "$proto;\n"; - print "$proto\n"; - print "{\n Scheme_Class_Object *obj INIT_NULLED_OUT;\n Scheme_Object *sobj INIT_NULLED_OUT;\n\n"; - print " if (!realobj) return XC_SCHEME_NULL;\n\n"; - print " if (realobj->__gc_external)\n"; - print " return (Scheme_Object *)realobj->__gc_external;\n"; - print "\n SETUP_VAR_STACK(2);\n VAR_STACK_PUSH(0, obj);\n VAR_STACK_PUSH(1, realobj);\n\n"; - if ($idfield ne '') { - print " if ("; - if ($classid ne '') { - print "(realobj->${idfield} != ${classid}) && "; - } - print "(sobj = WITH_VAR_STACK(objscheme_bundle_by_type(realobj, "; - print "realobj->${idfield}))))\n"; - print " { READY_TO_RETURN; return sobj; }\n"; - } - print " obj = (Scheme_Class_Object *)"; - print "WITH_VAR_STACK(scheme_make_uninited_object(${newclass}_class));\n\n"; - print " obj->primdata = realobj;\n"; - if ($classflags ne "nofnl") { - print " WITH_VAR_STACK(objscheme_register_primpointer(obj, &obj->primdata));\n"; - } - print " obj->primflag = 0;\n\n"; - print " realobj->__gc_external = (void *)obj;\n"; - # print " objscheme_note_creation((Scheme_Object *)obj);\n"; - print " READY_TO_RETURN;\n"; - print " return (Scheme_Object *)obj;\n}\n\n"; - - # Unbundle function - $proto = "class ${oldclass} *objscheme_unbundle_${oldclass}" - . "(Scheme_Object *obj, const char *where, int nullOK)"; - print HEADER "$proto;\n"; - print "$proto\n"; - print "{\n"; - print " if (nullOK && XC_SCHEME_NULLP(obj)) return NULL;\n\n"; - print " REMEMBER_VAR_STACK();\n\n"; - print " obj = objscheme_unwrap(obj, ${newclass}_class);\n"; - print " (void)objscheme_istype_${oldclass}(obj, where, nullOK);\n"; - - print " Scheme_Class_Object *o = "; - print "(Scheme_Class_Object *)obj;\n"; - - print " WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));\n"; - print " if (o->primflag)\n"; - print " return (${newclass} *)o->primdata;\n"; - print " else\n"; - print " return (${oldclass} *)o->primdata;\n"; - print "}\n\n"; - } -} - -sub CalcNumRequired -{ - local($forscheme) = @_; - - $paramnum = 0; - @defvs = @defvals; - @scms = @schemes; - foreach $paramtype (@paramtypes) { - $defval = shift(@defvs); - $scheme = shift(@scms); - if (($defval ne '') && ($defval ne '.')) { - return $paramnum; - } - if (!$forscheme || $scheme) { - $paramnum += 1; - } - } - return $paramnum; -} - -sub CalcNumPossible -{ - local($forscheme) = @_; - local($offset); - - $offset = 0; - if ($forscheme) { - foreach $scheme (@schemes) { - $offset += 1 if (!$scheme); - } - } - - return $#paramtypes + 1 - $offset; -} - -sub PrintFailureHandling -{ - local($callback) = @_; - - if (($exception eq 'SUPER') && !$virtualonly) { - print "READY_TO_RETURN; "; - print "return " if ($returntype ne 'void'); - if ($callback) { - print "obj->"; - } - if (!$externalmethod) { - print "ASSELF ${oldclass}::"; - } - print "${func}("; - if ($externalmethod) { - printf("SELF__, "); - } - &PrintArgs(1); - print ");"; - } elsif ($exception ne '' && $exception ne 'SUPER') { - print &ApplyMacros($exception); - } else { - print "{ READY_TO_RETURN; return; }"; - } -} - -sub PrintMethod -{ - ($s) = @_; - - &ReadFields($s); - - $save_onlyif = $onlyif; - - if ($global || !$virtual || $phantom) { - return; - } - - &OIStart; - - # Define Class function - # - $methodfuncname = "${newclass}::${func}"; - - # Prototype for implementation - print "static Scheme_Object *"; - print $newclass; - print $func; - print "(int n, Scheme_Object *p[]);\n\n"; - - print &NormalType($returntype) . " ${methodfuncname}"; - if ($externalmethod) { - print "_method"; - } - print "("; - - &PrintParams(0); - $pcount = $paramnum; - - print ")\n"; - print "{\n"; - - if ($hidden) { - print "}\n\n"; - return; - } - - $returnptr = 0; - if ((($methodpost eq "") || ($methodpost eq undef)) - && (($methodpost ne "") || ($methodpost eq undef)) - && (&SomeParamNeedsDeref() == 0)) { - # No need to push return value - } else { - if ($returntype ne 'void') { - if ($returnpushable =~ /push/) { - if ($returnpushable eq "push") { - $returnptr = 1; - } - } elsif (ParamIsPointer($returntype)) { - $returnptr = 1; - } - } - } - - # Local variables - print " Scheme_Object *p[POFFSET+${numschemes}] INIT_NULLED_ARRAY({ "; - $i = $numschemes; - while ($i > 0) { - print "NULLED_OUT INA_comma "; - $i -= 1; - } - print "NULLED_OUT });\n"; - $varstacksize = 5; - print " Scheme_Object *v"; - if ($returnptr) { - printf " INIT_NULLED_OUT"; - $varstacksize += 1; - } - print ";\n"; - print " Scheme_Object *method INIT_NULLED_OUT;\n"; - print "#ifdef MZ_PRECISE_GC\n"; - print " ${newclass} *sElF = this;\n"; - print "#endif\n"; - print " static void *mcache = 0;\n"; - &PrintSboxTmp(); - print "\n"; - - # Count pushable arguments - @scms = @schemes; - @pbls = @pushables; - foreach $paramtype (@paramtypes) { - $scheme = shift(@scms); - $pushable = shift(@pbls); - - if ($scheme) { - if ($pushable =~ /push/) { - if ($pushable eq "push") { - $varstacksize += 1; - } - } elsif (&ParamIsPointer($paramtype)) { - $varstacksize += 1; - } - } - } - - print " SETUP_VAR_STACK($varstacksize);\n"; - print " VAR_STACK_PUSH(0, method);\n"; - print " VAR_STACK_PUSH(1, sElF);\n"; - print " VAR_STACK_PUSH_ARRAY(2, p, POFFSET+$numschemes);\n"; - $varstackpos = 5; - if ($returnptr) { - print " VAR_STACK_PUSH($varstackpos, v);\n"; - $varstackpos += 1; - } - - # Push arguments - $paramnum = 0; - $offset = 0; - @scms = @schemes; - @pbls = @pushables; - foreach $paramtype (@paramtypes) { - $scheme = shift(@scms); - $pushable = shift(@pbls); - - if ($scheme) { - $pushit = 0; - if ($pushable =~ /push/) { - if ($pushable eq "push") { - $pushit = 1; - } - } elsif (&ParamIsPointer($paramtype)) { - $pushit = 1; - } - - if ($pushit) { - $var = "x" . ($paramnum + $offset); - print " VAR_STACK_PUSH($varstackpos, $var);\n"; - $varstackpos += 1; - } - $paramnum += 1; - } else { - $offset += 1; - } - } - print " SET_VAR_STACK();\n"; - print "\n"; - - print " method = objscheme_find_method((Scheme_Object *) ASSELF __gc_external, "; - print "${newclass}_class, "; - print $fname; - print ", &mcache);\n"; - # print " if (method && !OBJSCHEME_PRIM_METHOD(method)) {\n"; - # print " COPY_JMPBUF(savebuf, scheme_error_buf);\n"; - # print " sj = scheme_setjmp(scheme_error_buf);\n"; - # print " if (sj) {\n"; - # print " COPY_JMPBUF(scheme_error_buf, savebuf);\n"; - # print " scheme_clear_escape();\n"; - # print " }\n"; else if (sj) - # print " } else {\n"; - - print " if (!method || OBJSCHEME_PRIM_METHOD(method, "; - print $newclass; - print $func; - print ")) {\n"; - print " SET_VAR_STACK();\n "; - - &PrintFailureHandling(); - - print "\n } else {\n"; - - print " " . &ApplyMacros($methpre) . "\n"; - - # Setup param array: - $paramnum = 0; - $offset = 0; - @bunds = @bundles; - @scms = @schemes; - foreach $paramtype (@paramtypes) { - $bundle = shift(@bunds); - $scheme = shift(@scms); - - if ($scheme) { - print " p[POFFSET+${paramnum}] = "; - $var = "x" . ($paramnum + $offset); - - &PrintBundleVar($var, $paramtype, 'WITH_VAR_STACK', $bundle); - - print ";\n"; - - $paramnum += 1; - } else { - $offset += 1; - } - } - - print " " . &ApplyMacros($methprecall) . "\n"; - - print " p[0] = (Scheme_Object *) ASSELF __gc_external;\n"; - - print "\n v = WITH_VAR_STACK(scheme_apply("; - print "method, "; - print "POFFSET+${numschemes}, p));\n"; - - print " " . &ApplyMacros($methpostcall) . "\n"; - - &PrintUnbundledEffects(); - - print " " . &ApplyMacros($methpost) . "\n"; - - # print " COPY_JMPBUF(scheme_error_buf, savebuf);\n\n"; - - if ($returntype ne 'void') { - print " {\n"; - print " " . &NormalType($returntype) . " resval;\n"; - print " resval = "; - &PrintUnbundleVar("v", $returntype, $returnunbundle, 1, &GetMethod(1) . "\", extracting return value\""); - print ";\n"; - print " READY_TO_RETURN;\n"; - print " return resval;\n }\n"; - } else { - print " READY_TO_RETURN;\n"; - } - print " }\n}\n"; - - $onlyif = $save_onlyif; - &OIEnd; - print "\n"; -} - -sub PrintFunction -{ - ($thefunc, $iscreator) = @_; - - # Define Scheme callback - # - - $numfuncs = 0; - $thisfuncs = (); - $fp = 0; - foreach $func (@funcnames) { - if ($thefunc eq $func) { - $function = $functions[$fp]; - &ReadFields($function); - if ($numfuncs > 0) { - $thefunction = $function; - @argtypes = @schemeparams; - @argtypeids = @typeids; - $numposs = &CalcNumRequired(1); - $found = 1; - $argpos = 0; - $foundpos = 0; - $foundlen = $numfuncs; - while ($found && ($argpos < $numposs)) { - $found = 0; - $checkid = ($argtypeids[$argpos] ne ''); - foreach $pos (0..($foundlen - 1)) { - &ReadFields($thisfuncs[$pos + $foundpos]); - $numposs2 = &CalcNumRequired(1); - if ($numposs2 > $argpos - && (($checkid && - ($typeids[$argpos] eq $argtypeids[$argpos])) - || ($schemeparams[$argpos] - eq $argtypes[$argpos]))) { - if ($found) { - $foundlen += 1; - } else { - $foundpos = $pos + $foundpos; - $foundlen = 1; - $found = 1; - } - } - } - $argpos += 1; - } - if (!$found) { - $foundlen = 0; - } elsif ($argpos >= $numposs) { - &ReadFields($thisfuncs[$foundpos]); - $numposs2 = &CalcNumRequired(1); - if ($numposs2 == $numposs) { - $foundlen = -1; - $thisfuncs[$foundpos] = $thefunction; - } - } - if ($foundlen >= 0) { - splice(@thisfuncs, $foundpos+$foundlen, 0, $thefunction); - $numfuncs += 1; - } - } else { - $numfuncs = 1; - $thisfuncs[0] = $function; - } - } - $fp += 1; - } - - &ReadFields($thisfuncs[0]); - - if ($delegate) { - return; # Superclass will dispatch for us - } - - if ($phantom) { - return; # No such method, really - } - - if ($numfuncs == 1) { - &OIStart; - } - - # print "#pragma argsused\n"; - - $pre_var_stack = ""; - - if ($iscreator) { - print "static Scheme_Object *${newclass}_ConstructScheme(${scheme_args})"; - print "\n{\n"; - - print " SETUP_PRE_VAR_STACK(1);\n"; - print " PRE_VAR_STACK_PUSH(0, p);\n"; - - $pre_var_stack = "PRE_"; - print " ${newclass} *realobj INIT_NULLED_OUT;\n"; - print " REMEMBER_VAR_STACK();\n"; - $returnptr = 0; - } else { - print "static Scheme_Object *"; - $func2 = $func; - $func2 = &OperatorClean($func2); - print "${globalname}${newclass}${func2}"; - print "("; - if (!$global) { - print "${scheme_args}"; - } else { - print "${global_scheme_args}"; - } - - print ")\n{\n"; - - print " WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)\n"; - - if ($numfuncs > 1) { - print " SETUP_PRE_VAR_STACK(1);\n"; - print " PRE_VAR_STACK_PUSH(0, p);\n"; - - $pre_var_stack = "PRE_"; - } - print " REMEMBER_VAR_STACK();\n"; - - # We only need to push if something's going - # to happen after the function/method call. - $returnptr = 0; - if (($numfuncs == 1) - && (($gluepostcall eq "") || ($gluepostcall eq undef)) - && (($gluepost ne "") || ($gluepost eq undef)) - && (&SomeParamNeedsDeref() == 0)) { - # No need to push return value - } else { - if ($returntype ne 'void') { - if ($returnpushable =~ /push/) { - if ($returnpushable eq "push") { - $returnptr = 1; - } - } elsif (ParamIsPointer($returntype)) { - $returnptr = 1; - } - } - } - - if ($returntype ne 'void') { - print " " . &NormalType($returntype, 1) . " r"; - if ($returnptr) { - print " INIT_NULLED_OUT"; - } - print ";\n"; - } - - if (!$global) { - print " p[0] = objscheme_unwrap(p[0], ${newclass}_class);\n"; - print " objscheme_check_valid(${newclass}_class, $method, n, p);\n"; - } - } - - if (!$iscreator) { - $justoneok{$func} = 1; - } - - if ($numfuncs == 1) { - if (!$iscreator) { - $justonemin{$func} = &CalcNumRequired(1); - $justonemax{$func} = &CalcNumPossible(1); - } - &PrintSpecificFunction("", $iscreator, !$iscreator, "", $pre_var_stack, $returnptr); - print " READY_TO_RETURN;\n"; - } else { - print " "; - - if (!$iscreator) { - $justonemin{$func} = 1000; - $justonemax{$func} = 0; - } - - foreach $pos (0..($numfuncs-2)) { - &ReadFields($thisfuncs[$pos + 1]); - @schemeparams2 = @schemeparams; - @typeids2 = @typeids; - &ReadFields($thisfuncs[$pos]); - - if (!$iscreator) { - $how_many_args_this_case = &CalcNumRequired(1); - if ($how_many_args_this_case < $justonemin{$func}) { - $justonemin{$func} = $how_many_args_this_case; - } - $how_many_args_this_case = &CalcNumPossible(1); - if ($how_many_args_this_case > $justonemax{$func}) { - $justonemax{$func} = $how_many_args_this_case; - } - } - - print "if ("; - - # Figure out how many things we'll check - $pos = 0; - while ($schemeparams[$pos] eq $schemeparams2[$pos] - || (($typeids[$pos] ne '') - && ($typeids[$pos] eq $typeids2[$pos]))) { - if ($schemeparams[$pos] eq undef) { - print STDERR "error: duplicate function ${newclass}::$func\n"; - exit(-1); - } - $pos += 1; - } - $checkcount = $pos; - $pos += 1; - print "(n >= ($POFFSET+$pos))"; - - # Check them: - $pos = 0; - @checks = @typechecks; - @scms = @schemes; - while ($pos < $checkcount) { - $scheme = 0; - while (!$scheme) { - $check = shift(@checks); - $scheme = shift(@scms); - } - print " && "; - &PrintTypecheck("p[$POFFSET+${pos}]", $schemeparams[$pos], $check, 0); - $pos += 1; - } - print " && "; - $scheme = 0; - while (!$scheme) { - $check = shift(@checks); - $scheme = shift(@scms); - } - &PrintTypecheck("p[$POFFSET+${pos}]", $schemeparams[$pos], $check, 0); - - print ") {\n"; - if ($casename eq "") { - print STDERR "Warning: unnamed ${newclass}::$func case\n"; - $casename = ""; - } else { - $casename = " ($casename case)"; - } - &PrintSpecificFunction(" ", $iscreator, 0, $casename, $pre_var_stack, $returnptr); - print " READY_TO_" . $pre_var_stack . "RETURN;\n"; - print " } else "; - } - - &ReadFields($thisfuncs[$numfuncs - 1]); - - if (!$iscreator) { - $how_many_args_this_case = &CalcNumRequired(1); - if ($how_many_args_this_case < $justonemin{$func}) { - $justonemin{$func} = $how_many_args_this_case; - } - $how_many_args_this_case = &CalcNumPossible(1); - if ($how_many_args_this_case > $justonemax{$func}) { - $justonemax{$func} = $how_many_args_this_case; - } - } - - if ($numfuncs > 1) { - if ($casename eq "") { - print STDERR "Warning: unnamed ${newclass}::$func case\n"; - $casename = ""; - } else { - $casename = " ($casename case)"; - } - } else { - $casename = ""; - } - - print " {\n"; - &PrintSpecificFunction(" ", $iscreator, 0, $casename, $pre_var_stack, $returnptr); - print " READY_TO_" . $pre_var_stack . "RETURN;\n"; - print " }"; - print "\n\n"; - } - - if ($iscreator) { - print " ((Scheme_Class_Object *)p[0])->primdata = realobj;\n"; - print " ((Scheme_Class_Object *)p[0])->primflag = 1;\n"; - if ($classflags ne "nofnl") { - print " WITH_REMEMBERED_STACK(objscheme_register_primpointer(p[0], &((Scheme_Class_Object *)p[0])"; - print "->primdata));\n"; - } - if ($gluepostschemebind ne undef) { - print " " . &ApplyMacros($gluepostschemebind) . "\n"; - } - print " return scheme_void;\n"; - print "}\n"; - } else { - print " return "; - - if ($returntype eq 'void') { - print "scheme_void"; - } else { - &PrintBundleVar("r", $returntype, "WITH_REMEMBERED_STACK", $returnbundle, 1); - } - print ";\n}\n"; - } - - if ($numfuncs == 1) { - &OIEnd; - } - - print "\n"; -} - -sub PrintCallRealMethod -{ - local($prefix, $ret_val, $direct) = @_; - - if ($global) { - print "$prefix "; - print $ret_val if ($returntype ne 'void'); - print "WITH_VAR_STACK(${func}("; - &PrintArgs($direct); - print "));\n\n"; - } else { - print "$prefix "; - if ($virtual && !$externalmethod) { - print "if (((Scheme_Class_Object *)p[0])->primflag)\n"; - print "$prefix "; - print $ret_val if ($returntype ne 'void'); - &PrintIndirect($returntype) if (!$direct); - if ($virtualonly) { - if ($exception ne "SUPER") { - $rets = &ApplyMacros($exception); - if ((substr($rets, -1) eq ';') && (substr($rets, 0, 6) eq 'return')) { - print substr($rets, 6); - } else { - print STDERR "error: cannot use exception for value: $rets\n"; - exit(-1); - } - print "\n"; - } else { - print "{}\n"; - } - } else { - print "WITH_VAR_STACK((($newclass *)((Scheme_Class_Object *)p[0])->primdata)->"; - if ($implementor ne "") { - print $implementor; - } else { - print $oldclass; - } - print "::"; - print "${func}("; - &PrintArgs($direct); - print "));\n"; - } - print "$prefix else\n"; - print "$prefix "; - } - print $ret_val if ($returntype ne 'void'); - &PrintIndirect($returntype) if (!$direct); - print "WITH_VAR_STACK("; - if (!$externalmethod) { - print "(($oldclass *)((Scheme_Class_Object *)p[0])->primdata)"; - print "->"; - } - print "${func}("; - if ($externalmethod) { - print "(($oldclass *)((Scheme_Class_Object *)p[0])->primdata)"; - print ", " if ($#paramtypes >= 0); - } - &PrintArgs($direct); - print "));\n"; - print "\n"; - } -} - -sub PrintSpecificFunction -{ - local($prefix, $iscreator, $just_one, $casename, $pre_var_stack, $returnptr) = @_; - - return if ($hidden); - - &OIStart; - - $req = &CalcNumRequired(1); - $aname = &Unquote($method); - - &PrintLocals($prefix); - &PrintSboxTmp(); - - # Count pushable pointers: - if ($global) { - $pointercount = 1; - } else { - if ($iscreator) { - $pointercount = 2; - } else { - $pointercount = 1; - } - } - if ($returnptr) { - $pointercount += 1; - } - @pbls = @pushables; - foreach $paramtype (@paramtypes) { - $pt = $paramtype; - $pushable = shift(@pbls); - if ($pushable =~ /push/) { - if ($pushable eq "push") { - $pointercount += 1; - } - } elsif (&ParamIsPointer($pt)) { - if (!(&NeedsDeref($pt))) { - $pointercount += 1; - } - } - } - print "\n$prefix SETUP_VAR_STACK_${pre_var_stack}REMEMBERED($pointercount);\n"; - print "$prefix VAR_STACK_PUSH(0, p);\n"; - if (!$global) { - if ($iscreator) { - print "$prefix VAR_STACK_PUSH(1, realobj);\n"; - } - } - if ($returnptr) { - print "$prefix VAR_STACK_PUSH(1, r);\n"; - } - # Push each pounter: - $paramnum = 0; - if ($global) { - $pointercount = 1; - } else { - if ($iscreator) { - $pointercount = 2; - } else { - $pointercount = 1; - } - } - if ($returnptr) { - $pointercount += 1; - } - - @pbls = @pushables; - foreach $paramtype (@paramtypes) { - $pt = $paramtype; - $pushable = shift(@pbls); - if ($pushable =~ /push/) { - if ($pushable eq "push") { - print "$prefix VAR_STACK_PUSH($pointercount, x$paramnum);\n"; - $pointercount += 1; - } - } elsif (&ParamIsPointer($pt)) { - if (!(&NeedsDeref($pt))) { - print "$prefix VAR_STACK_PUSH($pointercount, x$paramnum);\n"; - $pointercount += 1; - } - } - $paramnum += 1; - } - - print "\n"; - print "$prefix " . &ApplyMacros($gluepre) . "\n"; - - if (!$just_one) { - $possible = &CalcNumPossible(1); - print "$prefix if ("; - if ($req == $possible) { - print "n != ($POFFSET+$req)"; - $minimumok = $possible; - } else { - if ($req) { - $req_arg = $req; - print "(n < ($POFFSET+$req_arg)) || "; - $minimumok = $req_arg; - } else { - $minimumok = "$POFFSET"; - } - print "(n > ($POFFSET+$possible))"; - } - print ") \n"; - - print "$prefix WITH_VAR_STACK(scheme_wrong_count_m("; - print "\"${aname}${casename}\""; - - print ", $POFFSET+${minimumok}, $POFFSET+${possible}, n, p, "; - if ($global) { - print "0"; - } else { - print "1"; - } - print "));\n"; - } - - &PrintUnbundles($prefix, "\"${aname}${casename}\""); - print "\n"; - print "$prefix " . &ApplyMacros($glueprecall) . "\n"; - - if ($iscreator) { - print "$prefix realobj = WITH_VAR_STACK(new ${newclass} CONSTRUCTOR_ARGS(("; - &PrintArgs(); - print ")));\n"; - print "#ifdef MZ_PRECISE_GC\n"; - print "$prefix WITH_VAR_STACK(realobj->gcInit_${oldclassmk}("; - &PrintArgs(); - print "));\n"; - print "#endif\n"; - print "$prefix realobj->__gc_external = (void *)p[0];\n"; - # print "$prefix objscheme_note_creation(p[0]);\n"; - } else { - &PrintCallRealMethod($prefix, "r = ", $vonlyval); - } - - print "$prefix " . &ApplyMacros($gluepostcall) . "\n"; - - &PrintBundledEffects($prefix); - - print "$prefix " . &ApplyMacros($gluepost) . "\n"; - - if (($onlyif ne '') && ($returntype ne 'void')) { - print "#else\n"; - print " scheme_signal_error("; - print "\"%s: provided arglist unsupported on this platform\""; - print ", \"${aname}${casename}\");\n"; -# print "${prefix}r = "; -# if ($exception ne '' && $exception ne 'SUPER') { -# print &ApplyMacros($exception); -# } else { -# print "0"; -# } -# print ";\n"; - } - - &OIEnd; -} - -sub PrintIndirect -{ - local($type) = @_; - - if ((substr($type, -1) eq '%') || (substr($type, -1) eq '&')) { - print "&"; - } -} - -sub PrintBundleObject -{ - local($var, $paramtype, $wvs, $nullOK) = @_; - - $nullOK = '0' if ($nullOK eq ''); - - print "$wvs(objscheme_bundle_${paramtype}($var))"; - print HEADER "extern Scheme_Object *objscheme_bundle_${paramtype}"; - print HEADER "(class ${paramtype} *);\n"; -} - -sub PrintBundleVar -{ - local($var, $paramtype, $wvs, $bundle, $outgoing) = @_; - - if (($bundle ne undef) && ($bundle ne '')) { - print &ApplyMacros($bundle, $var); - } elsif (substr($paramtype, 0, 7) eq 'unknown') { - print "$wvs(objscheme_bundle_generic((void *)$var))"; - } elsif (substr($paramtype, -1) eq '*') { - substr($paramtype, -1) = ''; - print "(sbox_tmp = "; - &PrintBundleVar("(*$var)", $paramtype, $wvs); - print ", $wvs(objscheme_box(sbox_tmp)))"; - } elsif (substr($paramtype, -1) eq '?') { - substr($paramtype, -1) = ''; - print "(($var) ? "; - print "(sbox_tmp = "; - &PrintBundleVar("(*$var)", $paramtype, $wvs); - print ", $wvs(objscheme_box(sbox_tmp)))"; - print " : XC_SCHEME_NULL)"; - } elsif (substr($paramtype, -1) eq '&') { - substr($paramtype, -1) = ''; - $var = "&$var" unless $outgoing; - &PrintBundleVar("$var", $paramtype, $wvs); - } elsif (substr($paramtype, -1) eq '+') { - substr($paramtype, -1) = ''; - print "(sbox_tmp = "; - &PrintBundleVar($var, $paramtype, $wvs); - print ", $wvs(objscheme_box(sbox_tmp)))"; - } elsif ($paramtype eq 'bool') { - print "($var ? scheme_true : scheme_false)"; - } elsif ($paramtype eq 'char' || $paramtype eq 'mzchar') { - print "scheme_make_char($var)"; - } elsif ($paramtype eq 'uchar') { - print "scheme_make_char((char)$var)"; - } elsif ($paramtype eq 'int' - || $paramtype eq 'nnint' - || $paramtype eq 'unsigned' - || (substr($paramtype,0,4) eq 'rint')) { - print "scheme_make_integer($var)"; - } elsif ($paramtype eq 'short') { - print "scheme_make_integer($var)"; - } elsif ($paramtype eq 'byte' || $paramtype eq 'ubyte') { - print "scheme_make_integer($var)"; - } elsif ($paramtype eq 'long' - || $paramtype eq 'nnlong' - || (substr($paramtype, 0, 4) eq 'nnls') - || $paramtype eq 'Long') { - print "scheme_make_integer($var)"; - } elsif ($paramtype eq 'ExactLong') { - print "$wvs(scheme_make_integer_value($var))"; - } elsif (($paramtype eq 'double') - || ($paramtype eq 'nndouble') - || ($paramtype eq 'Double') - || (substr($paramtype,0,7) eq 'rdouble')) { - print "$wvs(scheme_make_double($var))"; - } elsif (substr($paramtype,0,4) eq 'nnfs') { - $paramtype =~ /nnfs\[(.*)\]/; - $symname = $1; - print "$wvs(objscheme_bundle_nonnegative_symbol_double($var, \"$symname\"))"; - } elsif (($paramtype eq 'string') || ($paramtype eq 'cstring') - || ($paramtype eq 'nstring') || ($paramtype eq 'ncstring')) { - print "$wvs(objscheme_bundle_string((char *)$var))"; - } elsif (($paramtype eq 'bstring') || ($paramtype eq 'cbstring') - || ($paramtype eq 'nbstring') || ($paramtype eq 'ncbstring') - || ($paramtype eq 'wbstring')) { - print "$wvs(objscheme_bundle_bstring((char *)$var))"; - } elsif (($paramtype eq 'mzstring') || ($paramtype eq 'mzxstring') || ($paramtype eq 'cmzstring') - || ($paramtype eq 'nmzstring') || ($paramtype eq 'ncmzstring') - || ($paramtype eq 'wmzstring')) { - print "$wvs(objscheme_bundle_mzstring((mzchar *)$var))"; - } elsif (($paramtype eq 'pstring') || ($paramtype eq 'cpstring') - || ($paramtype eq 'npstring') || ($paramtype eq 'ncpstring')) { - print "$wvs(objscheme_bundle_pstring((char *)$var))"; - } elsif (($paramtype eq 'pathname') - || ($paramtype eq 'cpathname') - || ($paramtype eq 'npathname') - || ($paramtype eq 'ncpathname') - || ($paramtype eq 'wpathname') - || ($paramtype eq 'wnpathname') - || ($paramtype eq 'epathname') - || ($paramtype eq 'nepathname') - || ($paramtype eq 'xpathname') - || ($paramtype eq 'nxpathname')) { - print "$wvs(objscheme_bundle_pathname((char *)$var))"; - } elsif (substr($paramtype, -1) eq '!') { - substr($paramtype, -1) = ''; - &PrintBundleObject($var, $paramtype, $wvs); - } elsif (substr($paramtype, -1) eq '^') { - substr($paramtype, -1) = ''; - &PrintBundleObject($var, $paramtype, $wvs, 1); - } elsif (substr($paramtype, -1) eq '%') { - substr($paramtype, -1) = ''; - $var = "&$var" unless $outgoing; - &PrintBundleObject($var, $paramtype, $wvs); - } elsif (substr($paramtype, 0, 3) eq 'SYM') { - $paramtype =~ /SYMZ?\[(.*)\]/; - $symtype = $1; - print "$wvs(bundle_symset_${symtype}($var))"; - } else { - print STDERR "Unknown type ${paramtype} in $func [for bundle].\n"; - } -} - -sub ParamIsPointer -{ - local($paramtype) = @_; - - if (substr($paramtype, 0, 7) eq 'unknown') { - return 1; - } elsif (substr($paramtype, -1) eq '*') { - return 1; - } elsif (substr($paramtype, -1) eq '?') { - return 1; - } elsif (substr($paramtype, -1) eq '&') { - return 1; - } elsif (substr($paramtype, -1) eq '+') { - return 1; - } elsif ($paramtype eq 'bool') { - return 0; - } elsif ($paramtype eq 'char' || $paramtype eq 'mzchar') { - return 0; - } elsif ($paramtype eq 'uchar') { - return 0; - } elsif ($paramtype eq 'int' - || $paramtype eq 'nnint' - || $paramtype eq 'unsigned' - || (substr($paramtype,0,4) eq 'rint')) { - return 0; - } elsif ($paramtype eq 'short') { - return 0; - } elsif ($paramtype eq 'byte' || $paramtype eq 'ubyte') { - return 0; - } elsif ($paramtype eq 'long' - || $paramtype eq 'nnlong' - || (substr($paramtype, 0, 4) eq 'nnls') - || $paramtype eq 'Long') { - return 0; - } elsif ($paramtype eq 'ExactLong') { - return 0; - } elsif (($paramtype eq 'double') - || ($paramtype eq 'nndouble') - || ($paramtype eq 'Double') - || (substr($paramtype,0,7) eq 'rdouble')) { - return 0; - } elsif (substr($paramtype,0,4) eq 'nnfs') { - return 0; - } elsif (($paramtype eq 'string') || ($paramtype eq 'cstring') - || ($paramtype eq 'nstring') || ($paramtype eq 'ncstring')) { - return 1; - } elsif (($paramtype eq 'bstring') || ($paramtype eq 'cbstring') - || ($paramtype eq 'nbstring') || ($paramtype eq 'ncbstring') - || ($paramtype eq 'wbstring')) { - return 1; - } elsif (($paramtype eq 'pstring') || ($paramtype eq 'cpstring') - || ($paramtype eq 'npstring') || ($paramtype eq 'ncpstring')) { - return 1; - } elsif (($paramtype eq 'mzstring') || ($paramtype eq 'mzxstring') || ($paramtype eq 'cmzstring') - || ($paramtype eq 'nmzstring') || ($paramtype eq 'ncmzstring') - || ($paramtype eq 'wmzstring')) { - return 1; - } elsif (($paramtype eq 'pathname') - || ($paramtype eq 'cpathname') - || ($paramtype eq 'npathname') - || ($paramtype eq 'ncpathname') - || ($paramtype eq 'wpathname') - || ($paramtype eq 'wnpathname') - || ($paramtype eq 'epathname') - || ($paramtype eq 'nepathname') - || ($paramtype eq 'xpathname') - || ($paramtype eq 'nxpathname')) { - return 1; - } elsif (substr($paramtype, -1) eq '!') { - return 1; - } elsif (substr($paramtype, -1) eq '^') { - return 1; - } elsif (substr($paramtype, -1) eq '%') { - return 1; - } elsif (substr($paramtype, 0, 3) eq 'SYM') { - return 0; - } else { - print STDERR "Unknown type ${paramtype} in $func [for ParamIsPointer].\n"; - return 1; - } -} - -sub PrintUnbundleObject -{ - local($var, $paramtype, $nullOK, $mname) = @_; - local($stop); - - $nullOK = '0' if ($nullOK eq ''); - - if (($mname eq '') || ($mname eq undef)) { - $stop = &GetMethod(1); - } else { - $stop = $mname; - } - - print "WITH_VAR_STACK(objscheme_unbundle_${paramtype}($var, $stop, $nullOK))"; - print HEADER "extern class ${paramtype} *"; - print HEADER "objscheme_unbundle_${paramtype}" . - "(Scheme_Object *, const char *, int);\n"; -} - -sub PrintUnbundleVar -{ - local($var, $paramtype, $unbundle, $outgoing, $mname) = @_; - local($stop, $pos); - - if (($mname eq "") || ($mname eq undef)) { - $stop = &GetMethod(1); - } else { - $stop = $mname; - } - - if (($unbundle ne undef) && ($unbundle ne '')) { - if ($var =~ /([0-9]+)/) { - $pos = $1; - } - print &ApplyMacros($unbundle, $var, $pos); - } elsif (substr($paramtype, 0, 7) eq 'unknown') { - print "("; - print substr($paramtype, 8); - print ")WITH_VAR_STACK(objscheme_unbundle_generic($var, $stop))"; - } elsif (substr($paramtype, -1) eq '*' || substr($paramtype, -1) eq '+') { - substr($paramtype, -1) = ''; - print "(sbox_tmp = WITH_VAR_STACK(objscheme_unbox($var, $stop)), "; - &PrintUnbundleVar("sbox_tmp", $paramtype, "", "", &Unboxing($stop)); - print ")"; - } elsif (substr($paramtype, -1) eq '&') { - substr($paramtype, -1) = ''; - print "*" if ($outgoing); - &PrintUnbundleVar("$var", $paramtype, "", "", $stop); - } elsif (substr($paramtype, -1) eq '?') { - substr($paramtype, -1) = ''; - print "(sbox_tmp = WITH_VAR_STACK(objscheme_nullable_unbox($var, $stop)), "; - &PrintUnbundleVar("sbox_tmp", $paramtype, "", "", &Unboxing($stop)); - print ")"; - } elsif ($paramtype eq 'bool') { - print "WITH_VAR_STACK(objscheme_unbundle_bool(${var}, $stop))"; - } elsif ($paramtype eq 'char' || $paramtype eq 'mzchar') { - print "WITH_VAR_STACK(objscheme_unbundle_char(${var}, $stop))"; - } elsif ($paramtype eq 'uchar') { - print "((unsigned char)WITH_VAR_STACK(objscheme_unbundle_char(${var}, $stop)))"; - } elsif (($paramtype eq 'int') || ($paramtype eq 'unsigned') - || ($paramtype eq 'short') || ($paramtype eq 'long') - || ($paramtype eq 'Long')) { - print "WITH_VAR_STACK(objscheme_unbundle_integer($var, $stop))"; - } elsif ($paramtype eq 'ubyte') { - print "WITH_VAR_STACK(objscheme_unbundle_integer_in($var, 0, 255, $stop))"; - } elsif (substr($paramtype,0,4) eq 'rint') { - $paramtype =~ /rint\[([^|]*)\|(.*)\]/; - print "WITH_VAR_STACK(objscheme_unbundle_integer_in($var, $1, $2, $stop))"; - } elsif ($paramtype eq 'ExactLong') { - print "WITH_VAR_STACK(objscheme_unbundle_ExactLong($var, $stop))"; - } elsif (($paramtype eq 'nnint') || ($paramtype eq 'nnlong')) { - print "WITH_VAR_STACK(objscheme_unbundle_nonnegative_integer($var, $stop))"; - } elsif (substr($paramtype,0,4) eq 'nnls') { - $paramtype =~ /nnls\[(.*)\]/; - $symname = $1; - print "WITH_VAR_STACK(objscheme_unbundle_nonnegative_symbol_integer($var, \"$symname\", $stop))"; - } elsif (($paramtype eq 'double') - || ($paramtype eq 'Double')) { - print "WITH_VAR_STACK(objscheme_unbundle_double($var, $stop))"; - } elsif (($paramtype eq 'nndouble')) { - print "WITH_VAR_STACK(objscheme_unbundle_nonnegative_double($var, $stop))"; - } elsif (substr($paramtype,0,7) eq 'rdouble') { - $paramtype =~ /rdouble\[([^|]*)\|(.*)\]/; - print "WITH_VAR_STACK(objscheme_unbundle_double_in($var, $1, $2, $stop))"; - } elsif (substr($paramtype,0,4) eq 'nnfs') { - $paramtype =~ /nnfs\[(.*)\]/; - $symname = $1; - print "WITH_VAR_STACK(objscheme_unbundle_nonnegative_symbol_double($var, \"$symname\", $stop))"; - } elsif ($paramtype eq 'string' || $paramtype eq 'cstring') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_string(${var}, $stop))"; - } elsif ($paramtype eq 'nstring' || $paramtype eq 'ncstring') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_string($var, $stop))"; - } elsif ($paramtype eq 'bstring' || $paramtype eq 'cbstring') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_bstring(${var}, $stop))"; - } elsif ($paramtype eq 'wbstring') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_mutable_bstring(${var}, $stop))"; - } elsif ($paramtype eq 'nbstring' || $paramtype eq 'ncbstring') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_bstring($var, $stop))"; - } elsif ($paramtype eq 'pstring' || $paramtype eq 'cpstring') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_pstring(${var}, $stop))"; - } elsif ($paramtype eq 'npstring' || $paramtype eq 'ncpstring') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_pstring($var, $stop))"; - } elsif ($paramtype eq 'mzstring' || $paramtype eq 'cmzstring') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_mzstring(${var}, $stop))"; - } elsif ($paramtype eq 'mzxstring') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_mzxstring(${var}, $stop))"; - } elsif ($paramtype eq 'wmzstring') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_mutable_mzstring(${var}, $stop))"; - } elsif ($paramtype eq 'nmzstring' || $paramtype eq 'ncmzstring') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_mzstring($var, $stop))"; - } elsif ($paramtype eq 'pathname' || $paramtype eq 'cpathname') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_pathname(${var}, $stop))"; - } elsif ($paramtype eq 'npathname' || $paramtype eq 'ncpathname') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_pathname(${var}, $stop))"; - } elsif ($paramtype eq 'wpathname') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_write_pathname(${var}, $stop))"; - } elsif ($paramtype eq 'wnpathname') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_write_pathname(${var}, $stop))"; - } elsif ($paramtype eq 'epathname' || $paramtype eq 'cepathname') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_epathname(${var}, $stop))"; - } elsif ($paramtype eq 'nepathname' || $paramtype eq 'ncepathname') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_epathname(${var}, $stop))"; - } elsif ($paramtype eq 'xpathname' || $paramtype eq 'cxpathname') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_xpathname(${var}, $stop))"; - } elsif ($paramtype eq 'nxpathname' || $paramtype eq 'ncxpathname') { - print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_xpathname(${var}, $stop))"; - } elsif (substr($paramtype, -1) eq '!') { - substr($paramtype, -1) = ''; - &PrintUnbundleObject($var, $paramtype, 0, $mname); - } elsif (substr($paramtype, -1) eq '^') { - substr($paramtype, -1) = ''; - &PrintUnbundleObject($var, $paramtype, 1, $mname); - } elsif (substr($paramtype, -1) eq '%') { - substr($paramtype, -1) = ''; - print "*" if ($outgoing); - &PrintUnbundleObject("$var", $paramtype, 0, $mname); - } elsif (substr($paramtype, 0, 4) eq 'SYMZ') { - $paramtype =~ /SYMZ\[(.*)\]/; - $symtype = $1; - print "WITH_VAR_STACK(unbundle_symset_${symtype}($var, NULL))"; - } elsif (substr($paramtype, 0, 3) eq 'SYM') { - $paramtype =~ /SYM\[(.*)\]/; - $symtype = $1; - print "WITH_VAR_STACK(unbundle_symset_${symtype}($var, $stop))"; - } else { - print STDERR "Unknown type ${paramtype} in $func [for unbundle].\n"; - } -} - -sub NormalType { - local($paramtype, $islocal) = @_; - - if (substr($paramtype, -1) eq '*' || substr($paramtype, -1) eq '?') { - substr($paramtype, -1) = ''; - $paramtype = &NormalType($paramtype) . '*'; - } elsif (substr($paramtype, 0, 7) eq 'unknown') { - return substr($paramtype, 8); - } elsif (substr($paramtype, -1) eq '!') { - substr($paramtype, -1) = '*'; - $paramtype = "class " . $paramtype; - } elsif (substr($paramtype, -1) eq '^') { - substr($paramtype, -1) = '*'; - $paramtype = "class " . $paramtype; - } elsif (substr($paramtype, -1) eq '%') { - if ($islocal) { - substr($paramtype, -1) = '*'; - } else { - substr($paramtype, -1) = '&'; - } - $paramtype = "class " . $paramtype; - } elsif (substr($paramtype, -1) eq '+') { - substr($paramtype, -1) = ''; - $paramtype = &NormalType($paramtype); - if ($islocal) { - $paramtype = $paramtype . '*'; - } else { - $paramtype = $paramtype . '&'; - } - } elsif (substr($paramtype, -2) eq '[]') { - substr($paramtype, -2) = '*'; - } elsif ($islocal && (substr($paramtype, -1) eq '&')) { - substr($paramtype, -1) = ''; - $paramtype = &NormalType($paramtype) . '*'; - } elsif ($paramtype eq 'uchar') { - $paramtype = 'unsigned char'; - } elsif (substr($paramtype,0,4) eq 'rint') { - $paramtype = 'int'; - } elsif ($paramtype eq 'bool') { - $paramtype = $bool; - } elsif ($paramtype eq 'Long') { - $paramtype = 'long'; - } elsif ($paramtype eq 'ExactLong') { - $paramtype = 'ExactLong'; - } elsif ($paramtype eq 'Double') { - $paramtype = 'double'; - } elsif (substr($paramtype,0,7) eq 'rdouble') { - $paramtype = 'double'; - } elsif (substr($paramtype, 0, 4) eq 'nnls') { - $paramtype = 'long'; - } elsif (substr($paramtype, 0, 4) eq 'nnfs') { - $paramtype = 'double'; - } elsif (substr($paramtype, 0, 3) eq 'SYM') { - $paramtype = 'int'; - } - - return $paramtype; -} - -sub PrintParams { - - ($dodefval, $prefix, $pointify) = @_; - - if ($prefix eq '') { - $prefix = 'x'; - } - - $paramnum = 0; - @defvs = @defvals; - foreach $paramtype (@paramtypes) { - $defval = shift(@defvs); - - print ", " if ($paramnum > 0); - - print &NormalType($paramtype, $pointify) . " ${prefix}${paramnum}"; - if ($dodefval && ($defval ne '') && ($defval ne '.')) { - print " = ${defval}"; - } - $paramnum += 1; - } -} - -sub PrintArgs -{ - local($direct) = @_; - - $paramnum = 0; - foreach $paramtype (@paramtypes) { - print ", " if ($paramnum > 0); - print "*" if (($direct != 1) && &CallByRef($paramtype)); - print "x${paramnum}"; - $paramnum += 1; - } -} - -sub PrintLocals -{ - local($prefix) = @_; - - $paramnum = 0; - @pbls = @pushables; - foreach $paramtype (@paramtypes) { - $pt = $paramtype; - $pushable = shift(@pbls); - - if (&NeedsDeref($pt)) { - $temp = $pt; - substr($temp, -1) = ''; - print "$prefix " . &NormalType($temp) . " _x${paramnum};\n"; - $deref = 1; - } else { - $deref = 0; - } - print "$prefix " . &NormalType($pt, 1) . " x${paramnum}"; - if ($deref) { - print " = &_x${paramnum}"; - } else { - if ($pushable =~ /push/) { - if ($pushable eq "push") { - print " INIT_NULLED_OUT"; - } - } elsif (ParamIsPointer($pt)) { - print " INIT_NULLED_OUT"; - } - } - print ";\n"; - $paramnum += 1; - } -} - -sub PrintUnbundles -{ - local($prefix, $mname) = @_; - - $paramnum = 0; - @defvs = @defvals; - @unbunds = @unbundles; - @scms = @schemes; - $offset = 0; - foreach $paramtype (@paramtypes) { - $defval = shift(@defvs); - $unbundle = shift(@unbunds); - $scheme = shift(@scms); - - if ($scheme || ($unbundle ne '')) { - print "$prefix "; - if (($defval ne '') && ($defval ne '.')) { - print "if (n > ($POFFSET+" . ($paramnum - $offset) . ")) {\n$prefix "; - } - $svar = "p[$POFFSET+" . ($paramnum - $offset) . "]"; - $xvar = "x${paramnum}"; - if (&NeedsDeref($paramtype)) { - if (&CanBeNull($paramtype)) { - print "if (XC_SCHEME_NULLP($svar))\n"; - print "$prefix $xvar = NULL;"; - print "\n$prefix else\n"; - } - print "$prefix *"; - } - print "$xvar = "; - &PrintUnbundleVar($svar, $paramtype, $unbundle, "", $mname); - print ";\n"; - if (($defval ne '') && ($defval ne '.')) { - print "$prefix } else\n$prefix "; - print "x${paramnum} = "; - print "${defval}"; - print ";\n"; - } - } - - if (!$scheme) { - $offset += 1; - } - $paramnum += 1; - } -} - -sub PrintBundledEffects -{ - local($prefix) = @_; - - $paramnum = 0; - $offset = 0; - foreach $paramtype (@paramtypes) { - if ($schemes[$paramnum]) { - if (&NeedsDeref($paramtype)) { - $pos = $paramnum - $offset; - print "$prefix if (n > ($POFFSET+$pos)"; - print " && !XC_SCHEME_NULLP(p[$POFFSET+$pos])" if &CanBeNull($paramtype); - print ")\n$prefix { Scheme_Object *sbv_ = "; - substr($paramtype, -1) = ''; - &PrintBundleVar("_x${paramnum}", $paramtype, 'WITH_VAR_STACK', $bundle); - print "; WITH_VAR_STACK(objscheme_set_box(p[$POFFSET+$pos], sbv_)); } \n"; - } - } else { - $offset += 1; - } - $paramnum += 1; - } -} - -sub PrintUnbundledEffects -{ - local($prefix) = @_; - - $paramnum = 0; - $offset = 0; - foreach $paramtype (@paramtypes) { - if ($schemes[$paramnum]) { - if (&NeedsDeref($paramtype)) { - # substr($paramtype, -1) = ''; - print "$prefix "; - if (!&CallByRef($paramtype)) { - print "if (x${paramnum}) *"; - } - print "x${paramnum} = "; - $svar = "p[$POFFSET+". ($paramnum - $offset) . "]"; - &PrintUnbundleVar($svar, $paramtype, undef, undef, &GetMethod(1) . "\", extracting return value via box\""); - print ";\n"; - } - } else { - $offset += 1; - } - $paramnum += 1; - } -} - -sub PrintSboxTmp -{ - $paramnum = 0; - foreach $paramtype (@paramtypes) { - if ($schemes[$paramnum]) { - if (&NeedsDeref($paramtype)) { - print " Scheme_Object *sbox_tmp;\n"; - return; - } - } - $paramnum += 1; - } -} - -sub SomeParamNeedsDeref -{ - $paramnum = 0; - foreach $paramtype (@paramtypes) { - if ($schemes[$paramnum]) { - if (&NeedsDeref($paramtype)) { - return 1; - } - } - $paramnum += 1; - } - - return 0; -} - -sub PrintTypecheckObj -{ - local($var, $paramtype, $stop, $nullOK) = @_; - - $nullOK = '0' if ($nullOK eq ''); - $stop = &GetMethod($stop); - - print "WITH_REMEMBERED_STACK(objscheme_istype_${paramtype}($var, $stop, $nullOK))"; - print HEADER "extern int objscheme_istype_${paramtype}"; - print HEADER "(Scheme_Object *, const char *, int);\n"; -} - -sub PrintTypecheck -{ - local($var, $paramtype, $check, $stop) = @_; - - $stop = &GetMethod($stop); - - if (substr($paramtype, 0, 7) eq 'unknown') { - print "WITH_REMEMBERED_STACK(objscheme_istype_generic($var, $stop))"; - } elsif (($check ne undef) && ($check ne '')) { - print &ApplyMacros($check, $var, $stop); - } elsif (substr($paramtype, -1) eq '*') { - print "(WITH_REMEMBERED_STACK(objscheme_istype_box($var, $stop)) && "; - substr($paramtype, -1) = ''; - &PrintTypecheck("objscheme_unbox($var, $stop)", $paramtype, '', &Unboxing($stop)); - print ")"; - } elsif (substr($paramtype, -1) eq '+') { - print "(WITH_REMEMBERED_STACK(objscheme_istype_box($var, $stop)) && "; - substr($paramtype, -1) = ''; - &PrintTypecheck("WITH_REMEMBERED_STACK(objscheme_unbox($var, $stop))", $paramtype, '', &Unboxing($stop)); - print ")"; - } elsif (substr($paramtype, -1) eq '?') { - print "(XC_SCHEME_NULLP($var) || (WITH_REMEMBERED_STACK(objscheme_istype_box($var, $stop)) && "; - substr($paramtype, -1) = ''; - &PrintTypecheck("WITH_REMEMBERED_STACK(objscheme_nullable_unbox($var, $stop))", $paramtype, '', &Unboxing($stop)); - print "))"; - } elsif (substr($paramtype, -1) eq '&') { - substr($paramtype, -1) = ''; - &PrintTypecheck($var, $paramtype); - } elsif ($paramtype eq 'bool') { - print "WITH_REMEMBERED_STACK(objscheme_istype_bool($var, $stop))"; - } elsif ($paramtype eq 'char' || $paramtype eq 'mzchar' || $paramtype eq 'uchar') { - print "WITH_REMEMBERED_STACK(objscheme_istype_char($var, $stop))"; - } elsif (($paramtype eq 'int') || ($paramtype eq 'unsigned') - || ($paramtype eq 'nnint') || ($paramtype eq 'nnlong') - || ($paramtype eq 'byte') || ($paramtype eq 'ubyte') - || ($paramtype eq 'short') || ($paramtype eq 'long') - || ($paramtype eq 'double') || ($paramtype eq 'nndouble') - || (substr($paramtype,0,4) eq 'rint') - || (substr($paramtype,0,7) eq 'rdouble')) { - print "WITH_REMEMBERED_STACK(objscheme_istype_number($var, $stop))"; - } elsif (substr($paramtype,0,4) eq 'nnls') { - $paramtype =~ /nnls\[(.*)\]/; - $symname = $1; - print "WITH_REMEMBERED_STACK(objscheme_istype_nonnegative_symbol_integer($var, \"$symname\", $stop))"; - } elsif (substr($paramtype,0,4) eq 'nnfs') { - $paramtype =~ /nnfs\[(.*)\]/; - $symname = $1; - print "WITH_REMEMBERED_STACK(objscheme_istype_nonnegative_symbol_double($var, \"$symname\", $stop))"; - } elsif (($paramtype eq 'ExactLong')) { - print "WITH_REMEMBERED_STACK(objscheme_istype_ExactLong($var, $stop))"; - } elsif (($paramtype eq 'Long')) { - print "WITH_REMEMBERED_STACK(objscheme_istype_integer($var, $stop))"; - } elsif (($paramtype eq 'Double')) { - print "WITH_REMEMBERED_STACK(objscheme_istype_double($var, $stop))"; - } elsif ($paramtype eq 'string' || $paramtype eq 'cstring') { - print "WITH_REMEMBERED_STACK(objscheme_istype_string($var, $stop))"; - } elsif ($paramtype eq 'nstring' || $paramtype eq 'ncstring') { - print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_string($var, $stop)))"; - } elsif ($paramtype eq 'bstring' || $paramtype eq 'cbstring' - || $paramtype eq 'wbstring') { - print "WITH_REMEMBERED_STACK(objscheme_istype_bstring($var, $stop))"; - } elsif ($paramtype eq 'nbstring' || $paramtype eq 'ncbstring') { - print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_bstring($var, $stop)))"; - } elsif ($paramtype eq 'pstring' || $paramtype eq 'cpstring') { - print "WITH_REMEMBERED_STACK(objscheme_istype_pstring($var, $stop))"; - } elsif ($paramtype eq 'npstring' || $paramtype eq 'ncpstring') { - print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_pstring($var, $stop)))"; - } elsif ($paramtype eq 'mzstring' || $paramtype eq 'mzxstring' || $paramtype eq 'cmzstring' - || $paramtype eq 'wmzstring') { - print "WITH_REMEMBERED_STACK(objscheme_istype_mzstring($var, $stop))"; - } elsif ($paramtype eq 'nmzstring' || $paramtype eq 'ncmzstring') { - print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_mzstring($var, $stop)))"; - } elsif ($paramtype eq 'pathname' || $paramtype eq 'cpathname') { - print "WITH_REMEMBERED_STACK(objscheme_istype_pathname($var, $stop))"; - } elsif ($paramtype eq 'npathname' || $paramtype eq 'ncpathname') { - print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_pathname($var, $stop)))"; - } elsif ($paramtype eq 'epathname' || $paramtype eq 'cepathname') { - print "WITH_REMEMBERED_STACK(objscheme_istype_epathname($var, $stop))"; - } elsif ($paramtype eq 'nepathname' || $paramtype eq 'ncepathname') { - print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_epathname($var, $stop)))"; - } elsif ($paramtype eq 'xpathname' || $paramtype eq 'cxpathname') { - print "WITH_REMEMBERED_STACK(objscheme_istype_xpathname($var, $stop))"; - } elsif ($paramtype eq 'nxpathname' || $paramtype eq 'ncxpathname') { - print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_xpathname($var, $stop)))"; - } elsif (substr($paramtype, -1) eq '!') { - substr($paramtype, -1) = ''; - &PrintTypecheckObj($var, $paramtype, $stop); - } elsif (substr($paramtype, -1) eq '^') { - substr($paramtype, -1) = ''; - &PrintTypecheckObj($var, $paramtype, $stop, 1); - } elsif (substr($paramtype, -1) eq '%') { - substr($paramtype, -1) = ''; - &PrintTypecheckObj("$var", $paramtype, $stop); - } elsif (substr($paramtype, 0, 3) eq 'SYM') { - $paramtype =~ /SYMZ?\[(.*)\]/; - $symtype = $1; - print "WITH_REMEMBERED_STACK(istype_symset_${symtype}($var, $stop))"; - } else { - print STDERR "Unknown type ${paramtype} in $func [for typecheck].\n"; - } -} - -sub NeedsDeref -{ - local($paramtype) = @_; - - return ((substr($paramtype,0,7) ne 'unknown') - && ((substr($paramtype, -1) eq '*') - || (substr($paramtype, -1) eq '+') - || (substr($paramtype, -1) eq '?'))) -} - -sub CanBeNull -{ - return (substr($_[0], -1) eq '?'); -} - -sub CallByRef -{ - local($paramtype) = @_; - - return ((substr($paramtype, -1) eq '&') - || (substr($paramtype, -1) eq '+') - || (substr($paramtype, -1) eq '%')); -} - -sub GetMethod -{ - local ($stop) = @_; - - if ($stop > 0) { - return $method; - } else { - return "NULL"; - } -} - -sub Overridden -{ - local($function, $pos) = @_; - - &ReadFields($function); - $thefunc = $func; - @theparamtypes = @paramtypes; - $thepos = $pos; - $fp = 0; - foreach $func (@funcnames) { - if ($fp >= $thepos) { - return 0; - } - if ($thefunc eq $func) { - &ReadFields($functions[$fp]); - if ($#paramtypes == $#theparamtypes) { - $same = 1; - foreach $pos (0 .. $#paramtypes) { - if ($paramtypes[$pos] ne $theparamtypes[$pos]) { - $same = 0; - } - } - if ($same) { - return 1; - } - } - } - $fp += 1; - } - - return 0; -} - -sub Unboxing -{ - local($stop) = @_; - - if ($stop) { - return "$stop\", extracting boxed argument\""; - } else { - return $stop; - } -} - -sub OperatorClean -{ - if (index($_[0], "operator") == $[) { - $_[0] =~ s//GT/g; - $_[0] =~ s/\*/STAR/g; - $_[0] =~ s/\-/MINUS/g; - $_[0] =~ s/\+/PLUS/g; - $_[0] =~ s/\&/AND/g; - $_[0] =~ s/\|/OR/g; - $_[0] =~ s/\!/BANG/g; - $_[0] =~ s/\:/COLON/g; - $_[0] =~ s/\@/AT/g; - $_[0] =~ s/\=/EQUAL/g; - $_[0] =~ s/\$/DOLLAR/g; - $_[0] =~ s/\%/MOD/g; - $_[0] =~ s/\#/NUMBER/g; - $_[0] =~ s/\~/TILDE/g; - $_[0] =~ s/\//SLASH/g; - } - - return $_[0]; -} - -sub OIStart -{ - if ($onlyif ne '') { - print "#if $onlyif\n"; - } -} - -sub OIEnd -{ - if ($onlyif ne '') { - print "#endif\n"; - } -} - -sub PrintSymSet -{ - local ($name, $kind, $omit, @syms) = @_; - local ($multi, $vv, $lname, $char); - - if ($kind =~ /ONE/) { - $multi = 0; - $lname = ""; - } else { - $multi = 1; - $lname = " list"; - } - if ($kind =~ /CHAR/) { - $char = 1; - } else { - $char = 0; - } - - if ($#syms < 0) { - if (!($omit =~ /PRED/)) { - print "MAYBE_UNUSED static int istype_symset_${name}(Scheme_Object *v, const char *where) {\n"; - print " if SCHEME_NULLP(v) return 1;\n"; - print " if (where) scheme_wrong_type(where, \"$name symbol${lname}\", -1, 0, &v);\n"; - print " return 0;\n"; - print "}\n\n"; - } - if (!($omit =~ /UNBUNDLE/)) { - print "MAYBE_UNUSED static int unbundle_symset_${name}(Scheme_Object *v, const char *where) {\n"; - print " istype_symset_${name}(v, where);\n"; - print " return 0;\n"; - print "}\n"; - } - if (!($omit =~ /BUNDLE/)) { - print "MAYBE_UNUSED static Scheme_Object *bundle_symset_${name}(int) {\n"; - print " return scheme_null;\n"; - print "}\n\n"; - } - return; - } - - foreach $sym (@syms) { - ($n, $v) = split(/,/, $sym); - print "static Scheme_Object *${name}_${v}_sym = NULL;\n"; - } - print "\n"; - - print "static void init_symset_${name}(void) {\n"; - print " REMEMBER_VAR_STACK();\n"; - foreach $sym (@syms) { - ($n, $v) = split(/,/, $sym); - print " wxREGGLOB(${name}_${v}_sym);\n"; - print " ${name}_${v}_sym = WITH_REMEMBERED_STACK(scheme_intern_symbol($n));\n"; - } - print "}\n\n"; - - foreach $mode ("unbundle", "istype") { - if ($mode eq 'unbundle') { - $dothisone = !($omit =~ /UNBUNDLE/); - } else { - $dothisone = !($omit =~ /PRED/); - } - - if ($dothisone) { - print "MAYBE_UNUSED static int ${mode}_symset_${name}(Scheme_Object *v, const char *where) {\n"; - print " SETUP_VAR_STACK(1);\n"; - print " VAR_STACK_PUSH(0, v);\n"; - print " if (!${name}_${v}_sym) WITH_VAR_STACK(init_symset_${name}());\n"; - if ($multi) { - $vv = "i"; - print " Scheme_Object *i INIT_NULLED_OUT, *l = v;\n"; - if ($mode eq 'unbundle') { - print " long result = 0;\n"; - } else { - print " long result = 1;\n"; - } - print " while (SCHEME_PAIRP(l)) {\n"; - print " i = SCHEME_CAR(l);\n"; - if ($mode eq 'unbundle') { - $donepre = "result = result | "; - } else { - $donepre = ""; - } - $donepost = ""; - } else { - $vv = "v"; - $donepre = "READY_TO_RETURN; return "; - $donepost = ""; - } - print " if (0) { }\n"; - if ($char) { - print " else if (SCHEME_CHARP(v)) { READY_TO_RETURN; return "; - if ($mode eq 'unbundle') { - print "SCHEME_CHAR_VAL(v)"; - } else { - print "1"; - } - print "; }\n"; - } - foreach $sym (@syms) { - ($n, $v) = split(/,/, $sym); - if ($mode eq 'unbundle') { - $result = $v; - } else { - if ($multi) { - $result = ""; - } else { - $result = "1"; - } - } - print " else if (${vv} == ${name}_${v}_sym) { $donepre$result$donepost; }\n"; - } - if ($multi) { - print " else { break; } \n"; - print " l = SCHEME_CDR(l);\n"; - print " }\n"; - print " if (SCHEME_NULLP(l)) { READY_TO_RETURN; return result; }\n"; - } - print " if (where) WITH_VAR_STACK(scheme_wrong_type(where, \"$name symbol${lname}\", -1, 0, &v));\n"; - print " READY_TO_RETURN;\n"; - print " return 0;\n"; - print "}\n\n"; - } - } - - if (!($omit =~ /BUNDLE/)) { - print "MAYBE_UNUSED static Scheme_Object *bundle_symset_${name}(int v) {\n"; - if ($multi) { - print " REMEMBER_VAR_STACK();\n"; - } - print " if (!${name}_${v}_sym) init_symset_${name}();\n"; - if ($multi) { - print " Scheme_Object *l = scheme_null;\n"; - foreach $sym (@syms) { - ($n, $v) = split(/,/, $sym); - print " if (v & $v) l = WITH_REMEMBERED_STACK(scheme_make_pair(${name}_${v}_sym, l));\n"; - } - print " return l;\n"; - } else { - print " switch (v) {\n"; - foreach $sym (@syms) { - ($n, $v) = split(/,/, $sym); - print " case $v: return ${name}_${v}_sym;\n"; - } - if ($char) { - print " default: return scheme_make_char_or_nul(v);\n"; - } else { - print " default: return NULL;\n"; - } - print " }\n"; - } - print "}\n\n"; - } -}