specialized-arrays.short specialized-arrays.uchar
specialized-arrays.uint specialized-arrays.ulong
specialized-arrays.ulonglong specialized-arrays.ushort strings
-unix.utilities vocabs.parser words libc.private struct-arrays ;
+unix.utilities vocabs.parser words libc.private struct-arrays
+locals generalizations ;
IN: alien.marshall
<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
: ?malloc-byte-array ( c-type -- alien )
dup alien? [ malloc-byte-array ] unless ;
-: struct-unmarshaller ( type -- quot )
- current-vocab lookup [
- dup superclasses [ \ struct-wrapper = ] any? [
- '[ ?malloc-byte-array _ new swap >>underlying ]
- ] [ drop [ ] ] if
- ] [ [ ] ] if* ;
-
-: pointer-unmarshaller ( type -- quot )
- type-sans-pointer current-vocab lookup [
- dup superclasses [ \ alien-wrapper = ] any? [
- '[ _ new swap >>underlying unmarshall-cast ]
- ] [ drop [ ] ] if
- ] [ [ ] ] if* ;
+:: x-unmarshaller ( type type-quot wrapper-test def clean -- quot/f )
+ type type-quot call current-vocab lookup [
+ dup superclasses wrapper-test any?
+ [ def call ] [ drop clean call f ] if
+ ] [ clean call f ] if* ; inline
+
+: struct-unmarshaller ( type -- quot/f )
+ [ ] [ \ struct-wrapper = ]
+ [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
+ [ ]
+ x-unmarshaller ;
+
+: class-unmarshaller ( type -- quot/f )
+ [ type-sans-pointer ] [ \ alien-wrapper = ]
+ [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
+ [ ]
+ x-unmarshaller ;
+
+: template-class-unmarshaller ( type -- quot/f )
+ [ parse-c++-type [ name>> ] keep swap ] [ \ template-wrapper = ]
+ [ '[ _ _ new swap >>type swap >>underlying unmarshall-cast ] ]
+ [ drop ]
+ x-unmarshaller ;
+
+: non-primitive-unmarshaller ( type -- quot/f )
+ {
+ { [ dup template-class? ]
+ [ template-class-unmarshaller ] }
+ { [ dup pointer? ] [ class-unmarshaller ] }
+ [ struct-unmarshaller ]
+ } cond ;
: unmarshaller ( type -- quot )
- factorize-type dup primitive-unmarshaller [ nip ] [
- dup pointer?
- [ pointer-unmarshaller ]
- [ struct-unmarshaller ] if
- ] if* ;
+ factorize-type {
+ [ primitive-unmarshaller ]
+ [ non-primitive-unmarshaller ]
+ [ drop [ ] ]
+ } 1|| ;
: struct-field-unmarshaller ( type -- quot )
- factorize-type dup struct-primitive-unmarshaller [ nip ] [
- dup pointer?
- [ pointer-unmarshaller ]
- [ struct-unmarshaller ] if
- ] if* ;
+ factorize-type {
+ [ struct-primitive-unmarshaller ]
+ [ non-primitive-unmarshaller ]
+ [ drop [ ] ]
+ } 1|| ;
: out-arg-unmarshaller ( type -- quot )
dup pointer-to-non-const-primitive?