suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

My first foray into the C side of things.

Browse Source 
svn: r18299
This commit is contained in:
Stevie Strickland 2010-02-23 14:55:24 +00:00
parent 88a6038705
commit 6583b0b77c
2 changed files with 33 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/scheme/private/class-internal.ss
View File

@ -2124,7 +2124,7 @@
;; --- Make the new object struct ---
(let*-values ([(prim-object-make prim-object? struct:prim-object)
(if make-struct:prim
(make-struct:prim c prop:object preparer dispatcher (get-properties interfaces))
(make-struct:prim c prop:object preparer dispatcher unwrap-object (get-properties interfaces))
(values #f #f #f))]
[(struct:object object-make object? object-field-ref object-field-set!)
(if make-struct:prim
@ -4189,7 +4189,7 @@
new-methods) ; list of methods
; The `make-struct:prim' function takes prop:object, a
; class, a preparer, a dispatcher function, and a property assoc list, and produces:
; class, a preparer, a dispatcher function, an unwrapper, and a property assoc list, and produces:
; * a struct constructor (must have prop:object)
; * a struct predicate
; * a struct type for derived classes (mustn't have prop:object)
@ -4198,6 +4198,8 @@
;
; The supplied dispatcher takes an object and a num and returns a method.
;
; The supplied unwrapper takes an object and returns the unwrapped version (or the original object).
;
; When a primitive class has a superclass, the struct:prim maker
; is responsible for ensuring that the returned struct items match
; the supertype predicate.

38
src/mzscheme/utils/xcglue.c
View File

@ -18,10 +18,10 @@
arguments v...
(primitive-class-prepare-struct-type! prim-class gen-property
gen-value preparer dispatcher 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.
gen-value preparer dispatcher unwrapper 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.
@ -30,6 +30,9 @@
method-specific value produced by the prepaper. It returns a
method procedure.
The unwrapper takes a possibly wrapped object and returns the
unwrapped version (or the object if not wrapped).
The extra-props argument is a list of property--value pairs.
(primitive-class-find-method prim-class sym) - gets the method
@ -96,6 +99,7 @@ static Scheme_Object *object_struct;
static Scheme_Object *object_property;
static Scheme_Object *dispatcher_property;
static Scheme_Object *preparer_property;
static Scheme_Object *unwrapper_property;
#ifdef MZ_PRECISE_GC
# include "../gc2/gc2.h"
@ -170,8 +174,9 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
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);
scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 5, argc, argv);
props = argv[5];
props = argv[6];
while (SCHEME_PAIRP(props)) {
name = SCHEME_CAR(props);
if (!SCHEME_PAIRP(name))
@ -181,8 +186,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
props = SCHEME_CDR(props);
}
if (!SCHEME_NULLP(props))
scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 5, argc, argv);
props = argv[5];
scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 6, argc, argv);
props = argv[6];
objscheme_something_prepared = 1;
@ -235,7 +240,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]),
scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]),
props));
scheme_make_pair(scheme_make_pair(unwrapper_property, argv[5]),
props)));
stype = scheme_make_struct_type(name,
base_stype,
@ -453,7 +459,18 @@ int objscheme_is_a(Scheme_Object *o, Scheme_Object *c)
Scheme_Object *objscheme_unwrap(Scheme_Object *o)
{
return o;
Scheme_Object *s[1], *unwrapper;
if (!o)
return NULL;
unwrapper = scheme_struct_type_property_ref(unwrapper_property, (Scheme_Object *)o);
if (!unwrapper)
return NULL;
s[0] = o;
return _scheme_apply(unwrapper, 1, s);
}
/***************************************************************************/
@ -523,6 +540,9 @@ void objscheme_init(Scheme_Env *env)
wxREGGLOB(dispatcher_property);
dispatcher_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-dispatcher"));
wxREGGLOB(unwrapper_property);
unwrapper_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-unwrapper"));
wxREGGLOB(object_struct);
object_struct = scheme_make_struct_type(scheme_intern_symbol("primitive-object"),
NULL, NULL,