From 284ef4f0487928ce77cfbbf734a66fe3af274394 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sat, 4 Jul 2009 15:23:11 +1200 Subject: [PATCH 01/63] Made factorize-type and cify-type public --- basis/alien/inline/inline.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 7ae530a0a0..cbe8ce8841 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -7,6 +7,14 @@ math.order math.ranges multiline namespaces sequences splitting strings system vocabs.loader vocabs.parser words ; IN: alien.inline +: factorize-type ( str -- str' ) + "const-" ?head drop + "unsigned-" ?head [ "u" prepend ] when + "long-" ?head [ "long" prepend ] when ; + +: cify-type ( str -- str' ) + { { CHAR: ~ CHAR: space } } substitute ; + Date: Sun, 5 Jul 2009 17:28:13 +1200 Subject: [PATCH 02/63] Added alien.marshall and modified alien.inline accordingly --- basis/alien/inline/inline.factor | 41 +++-- basis/alien/inline/types/authors.txt | 1 + basis/alien/inline/types/types.factor | 32 ++++ basis/alien/marshall/authors.txt | 1 + basis/alien/marshall/marshall.factor | 179 ++++++++++++++++++++ basis/alien/marshall/private/authors.txt | 1 + basis/alien/marshall/private/private.factor | 44 +++++ 7 files changed, 287 insertions(+), 12 deletions(-) create mode 100644 basis/alien/inline/types/authors.txt create mode 100644 basis/alien/inline/types/types.factor create mode 100644 basis/alien/marshall/authors.txt create mode 100644 basis/alien/marshall/marshall.factor create mode 100644 basis/alien/marshall/private/authors.txt create mode 100644 basis/alien/marshall/private/private.factor diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index cbe8ce8841..6f5c2a720d 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -1,20 +1,13 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.inline.compiler alien.libraries -alien.parser arrays assocs effects fry generalizations grouping -io.files io.files.info io.files.temp kernel lexer math -math.order math.ranges multiline namespaces sequences splitting +USING: accessors alien.inline.compiler alien.inline.types +alien.libraries alien.marshall alien.parser arrays assocs +combinators effects fry generalizations grouping io.files +io.files.info io.files.temp kernel lexer locals math math.order +math.ranges multiline namespaces quotations sequences splitting strings system vocabs.loader vocabs.parser words ; IN: alien.inline -: factorize-type ( str -- str' ) - "const-" ?head drop - "unsigned-" ?head [ "u" prepend ] when - "long-" ?head [ "long" prepend ] when ; - -: cify-type ( str -- str' ) - { { CHAR: ~ CHAR: space } } substitute ; - params-return factorize-type -roll concat make-function ; +:: marshalled-function ( function types effect -- word quot effect ) + function types effect factor-function + [ in>> ] + [ out>> types [ pointer-to-primitive? ] filter append ] + bi + [ + types [ marshaller ] map \ spread rot + types length \ nkeep + types [ out-arg-unmarshaller ] map \ spread + 7 narray >quotation + ] dip ; + : prototype-string ( function types effect -- str ) [ [ cify-type ] map ] dip types-effect>params-return cify-type -rot @@ -95,6 +100,14 @@ PRIVATE> [ in>> ] keep [ factor-function define-declared ] 3keep out>> prototype-string' ; +: define-c-marshalled ( function types effect -- prototype ) + [ marshalled-function define-declared ] 3keep + prototype-string ; + +: define-c-marshalled' ( function effect -- prototype ) + [ in>> ] keep [ marshalled-function define-declared ] 3keep + out>> prototype-string' ; + : define-c-link ( str -- ) "-l" prepend compiler-args get push ; @@ -123,4 +136,8 @@ SYNTAX: C-FUNCTION: function-types-effect define-c-function append-function-body c-strings get push ; +SYNTAX: C-MARSHALLED: + function-types-effect define-c-marshalled + append-function-body c-strings get push ; + SYNTAX: ;C-LIBRARY compile-c-library ; diff --git a/basis/alien/inline/types/authors.txt b/basis/alien/inline/types/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/basis/alien/inline/types/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/basis/alien/inline/types/types.factor b/basis/alien/inline/types/types.factor new file mode 100644 index 0000000000..6321c38b0a --- /dev/null +++ b/basis/alien/inline/types/types.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types assocs combinators.short-circuit fry +kernel memoize sequences splitting ; +IN: alien.inline.types + +: factorize-type ( str -- str' ) + "const-" ?head drop + "unsigned-" ?head [ "u" prepend ] when + "long-" ?head [ "long" prepend ] when ; + +: cify-type ( str -- str' ) + { { CHAR: ~ CHAR: space } } substitute ; + +: const-type? ( str -- ? ) + "const-" head? ; + +MEMO: resolved-primitives ( -- seq ) + primitive-types [ resolve-typedef ] map ; + +: primitive-type? ( type -- ? ) + factorize-type resolve-typedef [ resolved-primitives ] dip + '[ _ = ] any? ; + +: pointer? ( type -- ? ) + [ "*" tail? ] [ "&" tail? ] bi or ; + +: type-sans-pointer ( type -- type' ) + [ '[ _ = ] "*&" swap any? ] trim-tail ; + +: pointer-to-primitive? ( type -- ? ) + { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ; diff --git a/basis/alien/marshall/authors.txt b/basis/alien/marshall/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/basis/alien/marshall/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor new file mode 100644 index 0000000000..8ee7fc8f06 --- /dev/null +++ b/basis/alien/marshall/marshall.factor @@ -0,0 +1,179 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.c-types alien.inline.types +alien.marshall.private +alien.strings byte-arrays classes combinators +combinators.short-circuit destructors fry +io.encodings.utf8 kernel sequences +specialized-arrays.alien +specialized-arrays.bool specialized-arrays.char +specialized-arrays.double specialized-arrays.float +specialized-arrays.int specialized-arrays.long +specialized-arrays.longlong specialized-arrays.ulonglong +specialized-arrays.short specialized-arrays.uchar +specialized-arrays.uint specialized-arrays.ulong +specialized-arrays.ushort strings unix.utilities +vocabs.parser words ; +IN: alien.marshall + +<< primitive-types [ "void*" = not ] filter +[ define-primitive-marshallers ] each >> + +TUPLE: alien-wrapper { underlying alien } ; + +GENERIC: dynamic-cast ( alien-wrapper -- alien-wrapper' ) + +M: alien-wrapper dynamic-cast ; + +: marshall-pointer ( obj -- alien ) + { + { [ dup alien? ] [ ] } + { [ dup not ] [ ] } + { [ dup byte-array? ] [ malloc-byte-array ] } + { [ dup alien-wrapper? ] [ underlying>> ] } + } cond ; + +: marshall-void* ( obj -- alien ) + marshall-pointer ; + +: marshall-void** ( obj -- alien ) + [ marshall-void* ] map >void*-array malloc-underlying ; + +: marshall-char*-or-string ( n/string -- alien ) + dup string? + [ utf8 string>alien malloc-byte-array ] + [ marshall-char* ] if ; + +: marshall-char**-or-strings ( seq -- alien ) + dup first string? + [ utf8 strings>alien malloc-byte-array ] + [ marshall-char** ] if ; + +: primitive-marshaller ( type -- quot/f ) + { + { "bool" [ [ marshall-bool ] ] } + { "char" [ [ marshall-char ] ] } + { "uchar" [ [ marshall-uchar ] ] } + { "short" [ [ marshall-short ] ] } + { "ushort" [ [ marshall-ushort ] ] } + { "int" [ [ marshall-int ] ] } + { "uint" [ [ marshall-uint ] ] } + { "long" [ [ marshall-long ] ] } + { "ulong" [ [ marshall-ulong ] ] } + { "float" [ [ marshall-float ] ] } + { "double" [ [ marshall-double ] ] } + { "bool*" [ [ marshall-bool* ] ] } + { "char*" [ [ marshall-char*-or-string ] ] } + { "uchar*" [ [ marshall-uchar* ] ] } + { "short*" [ [ marshall-short* ] ] } + { "ushort*" [ [ marshall-ushort* ] ] } + { "int*" [ [ marshall-int* ] ] } + { "uint*" [ [ marshall-uint* ] ] } + { "long*" [ [ marshall-long* ] ] } + { "ulong*" [ [ marshall-ulong* ] ] } + { "float*" [ [ marshall-float* ] ] } + { "double*" [ [ marshall-double* ] ] } + { "bool&" [ [ marshall-bool* ] ] } + { "char&" [ [ marshall-char* ] ] } + { "uchar&" [ [ marshall-uchar* ] ] } + { "short&" [ [ marshall-short* ] ] } + { "ushort&" [ [ marshall-ushort* ] ] } + { "int&" [ [ marshall-int* ] ] } + { "uint&" [ [ marshall-uint* ] ] } + { "long&" [ [ marshall-long* ] ] } + { "ulong&" [ [ marshall-ulong* ] ] } + { "float&" [ [ marshall-float* ] ] } + { "double&" [ [ marshall-double* ] ] } + { "void*" [ [ marshall-void* ] ] } + { "bool**" [ [ marshall-bool** ] ] } + { "char**" [ [ marshall-char**-or-strings ] ] } + { "uchar**" [ [ marshall-uchar** ] ] } + { "short**" [ [ marshall-short** ] ] } + { "ushort**" [ [ marshall-ushort** ] ] } + { "int**" [ [ marshall-int** ] ] } + { "uint**" [ [ marshall-uint** ] ] } + { "long**" [ [ marshall-long** ] ] } + { "ulong**" [ [ marshall-ulong** ] ] } + { "float**" [ [ marshall-float** ] ] } + { "double**" [ [ marshall-double** ] ] } + { "void**" [ [ marshall-void** ] ] } + [ drop f ] + } case ; + +: marshall-struct ( obj -- byte-array ) ; + +: marshaller ( type -- quot ) + factorize-type dup primitive-marshaller [ nip ] [ + pointer? + [ [ marshall-pointer ] ] + [ [ marshall-struct ] ] if + ] if* ; + + +: unmarshall-char*-to-string ( alien -- string ) + utf8 alien>string ; + +: unmarshall-bool ( n -- ? ) + 0 = not ; + +: primitive-unmarshaller ( type -- quot/f ) + { + { "bool" [ [ unmarshall-bool ] ] } + { "char" [ [ ] ] } + { "uchar" [ [ ] ] } + { "short" [ [ ] ] } + { "ushort" [ [ ] ] } + { "int" [ [ ] ] } + { "uint" [ [ ] ] } + { "long" [ [ ] ] } + { "ulong" [ [ ] ] } + { "float" [ [ ] ] } + { "double" [ [ ] ] } + { "bool*" [ [ *bool ] ] } + { "char*" [ [ unmarshall-char*-to-string ] ] } + { "uchar*" [ [ *uchar ] ] } + { "short*" [ [ *short ] ] } + { "ushort*" [ [ *ushort ] ] } + { "int*" [ [ *int ] ] } + { "uint*" [ [ *uint ] ] } + { "long*" [ [ *long ] ] } + { "ulong*" [ [ *ulong ] ] } + { "float*" [ [ *float ] ] } + { "double*" [ [ *double ] ] } + { "bool&" [ [ *bool ] ] } + { "char&" [ [ *char ] ] } + { "uchar&" [ [ *uchar ] ] } + { "short&" [ [ *short ] ] } + { "ushort&" [ [ *ushort ] ] } + { "int&" [ [ *int ] ] } + { "uint&" [ [ *uint ] ] } + { "long&" [ [ *long ] ] } + { "ulong&" [ [ *ulong ] ] } + { "float&" [ [ *float ] ] } + { "double&" [ [ *double ] ] } + [ drop f ] + } case ; + + +: unmarshall-struct ( byte-array -- byte-array' ) ; + +: pointer-unmarshaller ( type -- quot ) + type-sans-pointer current-vocab lookup [ + dup superclasses [ alien-wrapper = ] any? [ + '[ _ new >>underlying dynamic-cast ] + ] [ drop [ ] ] if + ] [ [ ] ] if* ; + +: unmarshaller ( type -- quot ) + factorize-type dup primitive-unmarshaller [ nip ] [ + dup pointer? + [ '[ _ pointer-unmarshaller ] ] + [ drop [ unmarshall-struct ] ] if + ] if* ; + +: out-arg-unmarshaller ( type -- quot ) + dup { + [ const-type? not ] + [ factorize-type pointer-to-primitive? ] + } 1&& + [ primitive-unmarshaller ] [ drop [ drop ] ] if ; diff --git a/basis/alien/marshall/private/authors.txt b/basis/alien/marshall/private/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/basis/alien/marshall/private/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/basis/alien/marshall/private/private.factor b/basis/alien/marshall/private/private.factor new file mode 100644 index 0000000000..71852abe36 --- /dev/null +++ b/basis/alien/marshall/private/private.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.c-types alien.inline arrays +combinators fry functors kernel lexer libc macros math +sequences specialized-arrays.alien ; +IN: alien.marshall.private + +: bool>arg ( ? -- 1/0/obj ) + { + { t [ 1 ] } + { f [ 0 ] } + [ ] + } case ; + +MACRO: marshall-x* ( num-quot seq-quot -- alien ) + '[ bool>arg dup number? _ _ if ] ; + +: malloc-underlying ( obj -- alien ) + underlying>> malloc-byte-array ; + +FUNCTOR: define-primitive-marshallers ( TYPE -- ) + IS <${TYPE}> +>TYPE-array IS >${TYPE}-array +marshall-TYPE DEFINES marshall-${TYPE} +marshall-TYPE* DEFINES marshall-${TYPE}* +marshall-TYPE** DEFINES marshall-${TYPE}** +WHERE +: marshall-TYPE ( n -- byte-array ) + dup c-ptr? [ bool>arg ] unless ; +: marshall-TYPE* ( n/seq -- alien ) + dup c-ptr? [ + [ malloc-byte-array ] + [ >TYPE-array malloc-underlying ] + marshall-x* &free + ] unless ; +: marshall-TYPE** ( seq -- alien ) + dup c-ptr? [ + [ >TYPE-array malloc-underlying ] + map >void*-array malloc-underlying &free + ] unless ; +;FUNCTOR + +SYNTAX: PRIMITIVE-MARSHALLERS: +";" parse-tokens [ define-primitive-marshallers ] each ; From 519277a0a0b16a8a5fa3532a6ac589f1304cb697 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sun, 5 Jul 2009 21:02:19 +1200 Subject: [PATCH 03/63] Fixed cify-types bug --- basis/alien/inline/types/types.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/inline/types/types.factor b/basis/alien/inline/types/types.factor index 6321c38b0a..6610630329 100644 --- a/basis/alien/inline/types/types.factor +++ b/basis/alien/inline/types/types.factor @@ -10,7 +10,7 @@ IN: alien.inline.types "long-" ?head [ "long" prepend ] when ; : cify-type ( str -- str' ) - { { CHAR: ~ CHAR: space } } substitute ; + { { CHAR: - CHAR: space } } substitute ; : const-type? ( str -- ? ) "const-" head? ; From c32d7c5c97c2e2a7d8558e7a6593b37def18385f Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sun, 5 Jul 2009 21:03:36 +1200 Subject: [PATCH 04/63] Fixed bug where primitive-type? could not handle "Class*" types --- basis/alien/inline/types/types.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/basis/alien/inline/types/types.factor b/basis/alien/inline/types/types.factor index 6610630329..4eaade0875 100644 --- a/basis/alien/inline/types/types.factor +++ b/basis/alien/inline/types/types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types assocs combinators.short-circuit fry -kernel memoize sequences splitting ; +USING: alien.c-types assocs combinators.short-circuit +continuations fry kernel memoize sequences splitting ; IN: alien.inline.types : factorize-type ( str -- str' ) @@ -19,8 +19,10 @@ MEMO: resolved-primitives ( -- seq ) primitive-types [ resolve-typedef ] map ; : primitive-type? ( type -- ? ) - factorize-type resolve-typedef [ resolved-primitives ] dip - '[ _ = ] any? ; + [ + factorize-type resolve-typedef [ resolved-primitives ] dip + '[ _ = ] any? + ] [ 2drop f ] recover ; : pointer? ( type -- ? ) [ "*" tail? ] [ "&" tail? ] bi or ; From 64aef112b58b11da13653d00290858ca1d733d9c Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sun, 5 Jul 2009 21:05:17 +1200 Subject: [PATCH 05/63] alien.inline: stopped annotate-effect affecting prototype strings --- basis/alien/inline/inline.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 6f5c2a720d..06aef50aed 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -42,7 +42,7 @@ SYMBOL: c-strings concat make-function ; :: marshalled-function ( function types effect -- word quot effect ) - function types effect factor-function + function types effect annotate-effect factor-function [ in>> ] [ out>> types [ pointer-to-primitive? ] filter append ] bi From 9cf0c5e33bf96f38d00c369faef7d10b7b788d70 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Mon, 6 Jul 2009 11:08:47 +1200 Subject: [PATCH 06/63] alien.inline: made define-c-marshalled standalone --- basis/alien/inline/inline.factor | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 7751d5fbf1..9cb9027e70 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -102,13 +102,15 @@ PRIVATE> out>> prototype-string' append-function-body c-strings get push ; -: define-c-marshalled ( function types effect -- prototype ) +: define-c-marshalled ( function types effect -- ) [ marshalled-function define-declared ] 3keep - prototype-string ; + prototype-string + append-function-body c-strings get push ; -: define-c-marshalled' ( function effect -- prototype ) +: define-c-marshalled' ( function effect -- ) [ in>> ] keep [ marshalled-function define-declared ] 3keep - out>> prototype-string' ; + out>> prototype-string' + append-function-body c-strings get push ; : define-c-link ( str -- ) "-l" prepend compiler-args get push ; @@ -138,7 +140,6 @@ SYNTAX: C-FUNCTION: function-types-effect define-c-function ; SYNTAX: C-MARSHALLED: - function-types-effect define-c-marshalled - append-function-body c-strings get push ; + function-types-effect define-c-marshalled ; SYNTAX: ;C-LIBRARY compile-c-library ; From ae4b284006a6a8acfea69536f97fb5763af0a981 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Mon, 6 Jul 2009 11:26:17 +1200 Subject: [PATCH 07/63] Moved two words from alien.inline to alien.inline.types --- basis/alien/inline/inline.factor | 13 ------------- basis/alien/inline/types/types.factor | 12 ++++++++++++ 2 files changed, 12 insertions(+), 13 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 9cb9027e70..8337c44649 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -14,23 +14,10 @@ SYMBOL: library-is-c++ SYMBOL: compiler-args SYMBOL: c-strings -: annotate-effect ( types effect -- types effect' ) - [ in>> ] [ out>> ] bi [ - zip - [ over pointer-to-primitive? [ ">" prepend ] when ] - assoc-map unzip - ] dip ; - - : function-types-effect ( -- function types effect ) scan scan swap ")" parse-tokens [ "(" subseq? not ] filter swap parse-arglist ; -: types-effect>params-return ( types effect -- params return ) - [ in>> zip ] - [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ] - 2bi ; - : arg-list ( types -- params ) CHAR: a swap length CHAR: a + [a,b] [ 1string ] map ; diff --git a/basis/alien/inline/types/types.factor b/basis/alien/inline/types/types.factor index 4eaade0875..37b58a0b59 100644 --- a/basis/alien/inline/types/types.factor +++ b/basis/alien/inline/types/types.factor @@ -32,3 +32,15 @@ MEMO: resolved-primitives ( -- seq ) : pointer-to-primitive? ( type -- ? ) { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ; + +: types-effect>params-return ( types effect -- params return ) + [ in>> zip ] + [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ] + 2bi ; + +: annotate-effect ( types effect -- types effect' ) + [ in>> ] [ out>> ] bi [ + zip + [ over pointer-to-primitive? [ ">" prepend ] when ] + assoc-map unzip + ] dip ; From 7ecadf0a6813526628f0d50498c9f2b5ef5155de Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Mon, 6 Jul 2009 11:28:41 +1200 Subject: [PATCH 08/63] alien.inline: renamed and refactored prototype-string --- basis/alien/inline/inline.factor | 30 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 8337c44649..9669387040 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -40,19 +40,20 @@ SYMBOL: c-strings 7 narray >quotation ] dip ; -: prototype-string ( function types effect -- str ) +: append-function-body ( prototype-str -- str ) + " {\n" append parse-here append "\n}\n" append ; + +: c-function-string ( function types effect -- str ) [ [ cify-type ] map ] dip types-effect>params-return cify-type -rot [ " " join ] map ", " join "(" prepend ")" append 3array " " join - library-is-c++ get [ "extern \"C\" " prepend ] when ; - -: prototype-string' ( function types return -- str ) - [ dup arg-list ] prototype-string ; - -: append-function-body ( prototype-str -- str ) - " {\n" append parse-here append "\n}\n" append ; + library-is-c++ get [ "extern \"C\" " prepend ] when + append-function-body ; +: c-function-string' ( function types return -- str ) + [ dup arg-list ] c-function-string + append-function-body ; : library-path ( -- str ) "lib" c-library get library-suffix @@ -81,23 +82,20 @@ PRIVATE> c-library get library-path "cdecl" add-library ; : define-c-function ( function types effect -- ) - [ factor-function define-declared ] 3keep prototype-string - append-function-body c-strings get push ; + [ factor-function define-declared ] 3keep + c-function-string c-strings get push ; : define-c-function' ( function effect -- ) [ in>> ] keep [ factor-function define-declared ] 3keep - out>> prototype-string' - append-function-body c-strings get push ; + out>> c-function-string' c-strings get push ; : define-c-marshalled ( function types effect -- ) [ marshalled-function define-declared ] 3keep - prototype-string - append-function-body c-strings get push ; + c-function-string c-strings get push ; : define-c-marshalled' ( function effect -- ) [ in>> ] keep [ marshalled-function define-declared ] 3keep - out>> prototype-string' - append-function-body c-strings get push ; + out>> c-function-string' c-strings get push ; : define-c-link ( str -- ) "-l" prepend compiler-args get push ; From 511ae71763838b863ba372b001e1c2f55bb99c2b Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Mon, 6 Jul 2009 11:34:42 +1200 Subject: [PATCH 09/63] alien.inline: moved marshalling syntax to alien.marshall.syntax * made appropriate words in alien.inline public --- basis/alien/inline/inline.factor | 69 ++++++++--------------- basis/alien/inline/types/types.factor | 5 +- basis/alien/marshall/syntax/authors.txt | 1 + basis/alien/marshall/syntax/syntax.factor | 29 ++++++++++ 4 files changed, 56 insertions(+), 48 deletions(-) create mode 100644 basis/alien/marshall/syntax/authors.txt create mode 100644 basis/alien/marshall/syntax/syntax.factor diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 9669387040..a7f7492e7b 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -8,53 +8,19 @@ math.ranges multiline namespaces quotations sequences splitting strings system vocabs.loader vocabs.parser words ; IN: alien.inline -params-return factorize-type -roll - concat make-function ; - -:: marshalled-function ( function types effect -- word quot effect ) - function types effect annotate-effect factor-function - [ in>> ] - [ out>> types [ pointer-to-primitive? ] filter append ] - bi - [ - types [ marshaller ] map \ spread rot - types length \ nkeep - types [ out-arg-unmarshaller ] map \ spread - 7 narray >quotation - ] dip ; - : append-function-body ( prototype-str -- str ) " {\n" append parse-here append "\n}\n" append ; -: c-function-string ( function types effect -- str ) - [ [ cify-type ] map ] dip - types-effect>params-return cify-type -rot - [ " " join ] map ", " join - "(" prepend ")" append 3array " " join - library-is-c++ get [ "extern \"C\" " prepend ] when - append-function-body ; - -: c-function-string' ( function types return -- str ) - [ dup arg-list ] c-function-string - append-function-body ; - : library-path ( -- str ) "lib" c-library get library-suffix 3array concat temp-file ; @@ -72,6 +38,28 @@ SYMBOL: c-strings c-library get compile-to-library ; PRIVATE> +: function-types-effect ( -- function types effect ) + scan scan swap ")" parse-tokens + [ "(" subseq? not ] filter swap parse-arglist ; + +: c-function-string ( function types effect -- str ) + [ [ cify-type ] map ] dip + types-effect>params-return cify-type -rot + [ " " join ] map ", " join + "(" prepend ")" append 3array " " join + library-is-c++ get [ "extern \"C\" " prepend ] when + append-function-body ; + +: c-function-string' ( function types return -- str ) + [ dup arg-list ] c-function-string + append-function-body ; + +: factor-function ( function types effect -- word quot effect ) + annotate-effect [ c-library get ] 3dip + [ [ factorize-type ] map ] dip + types-effect>params-return factorize-type -roll + concat make-function ; + : define-c-library ( name -- ) c-library set V{ } clone c-strings set @@ -89,14 +77,6 @@ PRIVATE> [ in>> ] keep [ factor-function define-declared ] 3keep out>> c-function-string' c-strings get push ; -: define-c-marshalled ( function types effect -- ) - [ marshalled-function define-declared ] 3keep - c-function-string c-strings get push ; - -: define-c-marshalled' ( function effect -- ) - [ in>> ] keep [ marshalled-function define-declared ] 3keep - out>> c-function-string' c-strings get push ; - : define-c-link ( str -- ) "-l" prepend compiler-args get push ; @@ -124,7 +104,4 @@ SYNTAX: C-INCLUDE: scan define-c-include ; SYNTAX: C-FUNCTION: function-types-effect define-c-function ; -SYNTAX: C-MARSHALLED: - function-types-effect define-c-marshalled ; - SYNTAX: ;C-LIBRARY compile-c-library ; diff --git a/basis/alien/inline/types/types.factor b/basis/alien/inline/types/types.factor index 37b58a0b59..acc62a81a2 100644 --- a/basis/alien/inline/types/types.factor +++ b/basis/alien/inline/types/types.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types assocs combinators.short-circuit -continuations fry kernel memoize sequences splitting ; +USING: accessors alien.c-types assocs combinators.short-circuit +continuations effects fry kernel math memoize sequences +splitting ; IN: alien.inline.types : factorize-type ( str -- str' ) diff --git a/basis/alien/marshall/syntax/authors.txt b/basis/alien/marshall/syntax/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/basis/alien/marshall/syntax/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/basis/alien/marshall/syntax/syntax.factor b/basis/alien/marshall/syntax/syntax.factor new file mode 100644 index 0000000000..b1fa8a922a --- /dev/null +++ b/basis/alien/marshall/syntax/syntax.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.inline alien.inline.types alien.marshall +combinators effects generalizations kernel locals namespaces +quotations sequences words ; +IN: alien.marshall.syntax + +:: marshalled-function ( function types effect -- word quot effect ) + function types effect annotate-effect factor-function + [ in>> ] + [ out>> types [ pointer-to-primitive? ] filter append ] + bi + [ + types [ marshaller ] map \ spread rot + types length \ nkeep + types [ out-arg-unmarshaller ] map \ spread + 7 narray >quotation + ] dip ; + +: define-c-marshalled ( function types effect -- ) + [ marshalled-function define-declared ] 3keep + c-function-string c-strings get push ; + +: define-c-marshalled' ( function effect -- ) + [ in>> ] keep [ marshalled-function define-declared ] 3keep + out>> c-function-string' c-strings get push ; + +SYNTAX: C-MARSHALLED: + function-types-effect define-c-marshalled ; From 3b987a77a8238d3072cc023d32e3bdcae0b7010e Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Mon, 6 Jul 2009 11:55:53 +1200 Subject: [PATCH 10/63] alien.marshall.syntax: added MARSHALLED: word --- basis/alien/marshall/syntax/syntax.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/alien/marshall/syntax/syntax.factor b/basis/alien/marshall/syntax/syntax.factor index b1fa8a922a..935aec87f9 100644 --- a/basis/alien/marshall/syntax/syntax.factor +++ b/basis/alien/marshall/syntax/syntax.factor @@ -27,3 +27,6 @@ IN: alien.marshall.syntax SYNTAX: C-MARSHALLED: function-types-effect define-c-marshalled ; + +SYNTAX: MARSHALLED: + function-types-effect marshalled-function define-declared ; From dc9bcc8b7304020ffe6d0790742bcbabd795b9fb Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 7 Jul 2009 15:49:39 +1200 Subject: [PATCH 11/63] alien.structs: alien.syntax: struct wrapper and marshalling of fields --- basis/alien/structs/structs.factor | 43 +++++++++++++++++++++++++++--- basis/alien/syntax/syntax.factor | 3 ++- 2 files changed, 41 insertions(+), 5 deletions(-) diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index b618e7974b..6820c7afeb 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs generic hashtables kernel kernel.private -math namespaces parser sequences strings words libc fry -alien.c-types alien.structs.fields cpu.architecture math.order -quotations byte-arrays ; +USING: accessors alien.c-types alien.marshall +alien.structs.fields arrays assocs byte-arrays classes.tuple +combinators cpu.architecture destructors fry generalizations +generic hashtables kernel kernel.private libc locals math +math.order namespaces parser quotations sequences slots strings +words ; IN: alien.structs TUPLE: struct-type @@ -82,3 +84,36 @@ M: struct-type stack-size : offset-of ( field struct -- offset ) c-types get at fields>> [ name>> = ] with find nip offset>> ; + +TUPLE: struct-wrapper < alien-wrapper disposed ; + +M: struct-wrapper dispose* underlying>> free ; + +: define-struct-accessor ( class name quot -- ) + [ "accessors" create create-method dup make-inline ] dip define ; + +: define-struct-getter ( class name word type -- ) + [ ">>" append \ underlying>> ] 2dip + unmarshaller \ call 4array >quotation + define-struct-accessor ; + +: define-struct-setter ( class name word type -- ) + [ "(>>" prepend ")" append ] 2dip + marshaller [ underlying>> ] \ bi* roll 4array >quotation + define-struct-accessor ; + +: define-struct-accessors ( class name type reader writer -- ) + [ dup define-protocol-slot ] 3dip + [ drop swap define-struct-getter ] + [ nip swap define-struct-setter ] 5 nbi ; + +:: define-struct-tuple ( name -- ) + name create-in :> class + class struct-wrapper { } define-tuple-class + name c-type fields>> [ + class swap + { + [ name>> { { CHAR: space CHAR: - } } substitute ] + [ type>> ] [ reader>> ] [ writer>> ] + } cleave define-struct-accessors + ] each ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index d479e6d498..113581c949 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -22,7 +22,8 @@ SYNTAX: TYPEDEF: scan scan typedef ; SYNTAX: C-STRUCT: - scan current-vocab parse-definition define-struct ; + scan current-vocab parse-definition [ define-struct ] 3keep + 2drop define-struct-tuple ; SYNTAX: C-UNION: scan parse-definition define-union ; From f61b736f10eb5559518bec7e448b36ea6c959811 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 7 Jul 2009 16:04:41 +1200 Subject: [PATCH 12/63] alien.marshall(.private): free and non-free marshallers and struct marshalling --- basis/alien/marshall/marshall.factor | 109 +++++++++++++++++--- basis/alien/marshall/private/private.factor | 31 ++++-- 2 files changed, 117 insertions(+), 23 deletions(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 8ee7fc8f06..3c2cf2b80d 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -39,17 +39,80 @@ M: alien-wrapper dynamic-cast ; : marshall-void** ( obj -- alien ) [ marshall-void* ] map >void*-array malloc-underlying ; -: marshall-char*-or-string ( n/string -- alien ) - dup string? +: (marshall-char*-or-string) ( n/string -- alien ) + string? [ utf8 string>alien malloc-byte-array ] - [ marshall-char* ] if ; + [ (marshall-char*) ] if ; -: marshall-char**-or-strings ( seq -- alien ) - dup first string? +: marshall-char*-or-string ( n/string -- alien ) + [ (marshall-char*-or-string) ] ptr-pass-through ; + +: marshall-char*-or-string-free ( n/string -- alien ) + [ (marshall-char*-or-string) &free ] ptr-pass-through ; + +: (marshall-char**-or-strings) ( seq -- alien ) + first string? [ utf8 strings>alien malloc-byte-array ] - [ marshall-char** ] if ; + [ (marshall-char**) ] if ; + +: marshall-char**-or-string ( n/string -- alien ) + [ (marshall-char**-or-string) ] ptr-pass-through ; + +: marshall-char**-or-string-free ( n/string -- alien ) + [ (marshall-char**-or-string) &free ] ptr-pass-through ; : primitive-marshaller ( type -- quot/f ) + { + { "bool" [ [ marshall-bool ] ] } + { "char" [ [ marshall-char ] ] } + { "uchar" [ [ marshall-uchar ] ] } + { "short" [ [ marshall-short ] ] } + { "ushort" [ [ marshall-ushort ] ] } + { "int" [ [ marshall-int ] ] } + { "uint" [ [ marshall-uint ] ] } + { "long" [ [ marshall-long ] ] } + { "ulong" [ [ marshall-ulong ] ] } + { "float" [ [ marshall-float ] ] } + { "double" [ [ marshall-double ] ] } + { "bool*" [ [ marshall-bool*-free ] ] } + { "char*" [ [ marshall-char*-or-string-free ] ] } + { "uchar*" [ [ marshall-uchar*-free ] ] } + { "short*" [ [ marshall-short*-free ] ] } + { "ushort*" [ [ marshall-ushort*-free ] ] } + { "int*" [ [ marshall-int*-free ] ] } + { "uint*" [ [ marshall-uint*-free ] ] } + { "long*" [ [ marshall-long*-free ] ] } + { "ulong*" [ [ marshall-ulong*-free ] ] } + { "float*" [ [ marshall-float*-free ] ] } + { "double*" [ [ marshall-double*-free ] ] } + { "bool&" [ [ marshall-bool*-free ] ] } + { "char&" [ [ marshall-char*-free ] ] } + { "uchar&" [ [ marshall-uchar*-free ] ] } + { "short&" [ [ marshall-short*-free ] ] } + { "ushort&" [ [ marshall-ushort*-free ] ] } + { "int&" [ [ marshall-int*-free ] ] } + { "uint&" [ [ marshall-uint*-free ] ] } + { "long&" [ [ marshall-long*-free ] ] } + { "ulong&" [ [ marshall-ulong*-free ] ] } + { "float&" [ [ marshall-float*-free ] ] } + { "double&" [ [ marshall-double*-free ] ] } + { "void*" [ [ marshall-void* ] ] } + { "bool**" [ [ marshall-bool**-free ] ] } + { "char**" [ [ marshall-char**-or-strings-free ] ] } + { "uchar**" [ [ marshall-uchar**-free ] ] } + { "short**" [ [ marshall-short**-free ] ] } + { "ushort**" [ [ marshall-ushort**-free ] ] } + { "int**" [ [ marshall-int**-free ] ] } + { "uint**" [ [ marshall-uint**-free ] ] } + { "long**" [ [ marshall-long**-free ] ] } + { "ulong**" [ [ marshall-ulong**-free ] ] } + { "float**" [ [ marshall-float**-free ] ] } + { "double**" [ [ marshall-double**-free ] ] } + { "void**" [ [ marshall-void** ] ] } + [ drop f ] + } case ; + +: struct-primitive-marshaller ( type -- quot/f ) { { "bool" [ [ marshall-bool ] ] } { "char" [ [ marshall-char ] ] } @@ -100,13 +163,27 @@ M: alien-wrapper dynamic-cast ; [ drop f ] } case ; -: marshall-struct ( obj -- byte-array ) ; +: marshall-non-ptr ( obj -- byte-array/f ) + { + { [ dup byte-array? ] [ ] } + { [ dup alien-wrapper? ] + [ [ underlying>> ] [ class name>> heap-size ] bi + memory>byte-array ] } + } cond ; + : marshaller ( type -- quot ) factorize-type dup primitive-marshaller [ nip ] [ pointer? [ [ marshall-pointer ] ] - [ [ marshall-struct ] ] if + [ [ marshall-non-pointer ] ] if + ] if* ; + +: struct-field-marshaller ( type -- quot ) + factorize-type dup struct-primitive-marshaller [ nip ] [ + pointer? + [ [ marshall-pointer ] ] + [ [ marshall-non-pointer ] ] if ] if* ; @@ -155,20 +232,26 @@ M: alien-wrapper dynamic-cast ; } case ; -: unmarshall-struct ( byte-array -- byte-array' ) ; +: struct-unmarshaller ( type -- quot ) + current-vocab lookup [ + dup superclasses [ struct-wrapper? ] any? [ + [ class name>> heap-size ] keep + '[ 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 >>underlying dynamic-cast ] + dup superclasses [ alien-wrapper? ] any? [ + '[ _ new swap >>underlying dynamic-cast ] ] [ drop [ ] ] if ] [ [ ] ] if* ; : unmarshaller ( type -- quot ) factorize-type dup primitive-unmarshaller [ nip ] [ dup pointer? - [ '[ _ pointer-unmarshaller ] ] - [ drop [ unmarshall-struct ] ] if + [ pointer-unmarshaller ] + [ struct-unmarshaller ] if ] if* ; : out-arg-unmarshaller ( type -- quot ) diff --git a/basis/alien/marshall/private/private.factor b/basis/alien/marshall/private/private.factor index 71852abe36..afc685effb 100644 --- a/basis/alien/marshall/private/private.factor +++ b/basis/alien/marshall/private/private.factor @@ -15,6 +15,9 @@ IN: alien.marshall.private MACRO: marshall-x* ( num-quot seq-quot -- alien ) '[ bool>arg dup number? _ _ if ] ; +: ptr-pass-through ( obj quot -- alien ) + over c-ptr? [ drop ] [ call ] if ; + : malloc-underlying ( obj -- alien ) underlying>> malloc-byte-array ; @@ -22,22 +25,30 @@ FUNCTOR: define-primitive-marshallers ( TYPE -- ) IS <${TYPE}> >TYPE-array IS >${TYPE}-array marshall-TYPE DEFINES marshall-${TYPE} +(marshall-TYPE*) DEFINES (marshall-${TYPE}*) +(marshall-TYPE**) DEFINES (marshall-${TYPE}**) marshall-TYPE* DEFINES marshall-${TYPE}* marshall-TYPE** DEFINES marshall-${TYPE}** +marshall-TYPE*-free DEFINES marshall-${TYPE}*-free +marshall-TYPE**-free DEFINES marshall-${TYPE}**-free WHERE : marshall-TYPE ( n -- byte-array ) - dup c-ptr? [ bool>arg ] unless ; + [ bool>arg ] ptr-pass-through ; +: (marshall-TYPE*) ( n/seq -- alien ) + [ malloc-byte-array ] + [ >TYPE-array malloc-underlying ] + marshall-x* ; +: (marshall-TYPE**) ( seq -- alien ) + [ >TYPE-array malloc-underlying ] + map >void*-array malloc-underlying ; : marshall-TYPE* ( n/seq -- alien ) - dup c-ptr? [ - [ malloc-byte-array ] - [ >TYPE-array malloc-underlying ] - marshall-x* &free - ] unless ; + [ (marshall-TYPE*) ] ptr-pass-through ; : marshall-TYPE** ( seq -- alien ) - dup c-ptr? [ - [ >TYPE-array malloc-underlying ] - map >void*-array malloc-underlying &free - ] unless ; + [ (marshall-TYPE**) ] ptr-pass-through ; +: marshall-TYPE*-free ( n/seq -- alien ) + [ (marshall-TYPE*) &free ] ptr-pass-through ; +: marshall-TYPE**-free ( seq -- alien ) + [ (marshall-TYPE**) &free ] ptr-pass-through ; ;FUNCTOR SYNTAX: PRIMITIVE-MARSHALLERS: From 4917454b85346fc0fb58cf8239f0c774b9654673 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 7 Jul 2009 19:41:59 +1200 Subject: [PATCH 13/63] append inline to combinator --- basis/alien/marshall/private/private.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/marshall/private/private.factor b/basis/alien/marshall/private/private.factor index afc685effb..901d713009 100644 --- a/basis/alien/marshall/private/private.factor +++ b/basis/alien/marshall/private/private.factor @@ -16,7 +16,7 @@ MACRO: marshall-x* ( num-quot seq-quot -- alien ) '[ bool>arg dup number? _ _ if ] ; : ptr-pass-through ( obj quot -- alien ) - over c-ptr? [ drop ] [ call ] if ; + over c-ptr? [ drop ] [ call ] if ; inline : malloc-underlying ( obj -- alien ) underlying>> malloc-byte-array ; From 9128952867436817b293a70a5fd2208d6963afee Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 7 Jul 2009 19:43:30 +1200 Subject: [PATCH 14/63] alien.marshall: fixes --- basis/alien/marshall/marshall.factor | 36 +++++++++++++--------------- 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 3c2cf2b80d..4f6d125557 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -1,19 +1,17 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.inline.types -alien.marshall.private -alien.strings byte-arrays classes combinators -combinators.short-circuit destructors fry -io.encodings.utf8 kernel sequences -specialized-arrays.alien -specialized-arrays.bool specialized-arrays.char -specialized-arrays.double specialized-arrays.float -specialized-arrays.int specialized-arrays.long -specialized-arrays.longlong specialized-arrays.ulonglong +alien.marshall.private alien.strings byte-arrays classes +combinators combinators.short-circuit destructors fry +io.encodings.utf8 kernel libc sequences +specialized-arrays.alien specialized-arrays.bool +specialized-arrays.char specialized-arrays.double +specialized-arrays.float specialized-arrays.int +specialized-arrays.long specialized-arrays.longlong specialized-arrays.short specialized-arrays.uchar specialized-arrays.uint specialized-arrays.ulong -specialized-arrays.ushort strings unix.utilities -vocabs.parser words ; +specialized-arrays.ulonglong specialized-arrays.ushort strings +unix.utilities vocabs.parser words ; IN: alien.marshall << primitive-types [ "void*" = not ] filter @@ -40,7 +38,7 @@ M: alien-wrapper dynamic-cast ; [ marshall-void* ] map >void*-array malloc-underlying ; : (marshall-char*-or-string) ( n/string -- alien ) - string? + dup string? [ utf8 string>alien malloc-byte-array ] [ (marshall-char*) ] if ; @@ -51,15 +49,15 @@ M: alien-wrapper dynamic-cast ; [ (marshall-char*-or-string) &free ] ptr-pass-through ; : (marshall-char**-or-strings) ( seq -- alien ) - first string? + dup first string? [ utf8 strings>alien malloc-byte-array ] [ (marshall-char**) ] if ; -: marshall-char**-or-string ( n/string -- alien ) - [ (marshall-char**-or-string) ] ptr-pass-through ; +: marshall-char**-or-strings ( n/string -- alien ) + [ (marshall-char**-or-strings) ] ptr-pass-through ; -: marshall-char**-or-string-free ( n/string -- alien ) - [ (marshall-char**-or-string) &free ] ptr-pass-through ; +: marshall-char**-or-strings-free ( n/string -- alien ) + [ (marshall-char**-or-strings) &free ] ptr-pass-through ; : primitive-marshaller ( type -- quot/f ) { @@ -163,7 +161,7 @@ M: alien-wrapper dynamic-cast ; [ drop f ] } case ; -: marshall-non-ptr ( obj -- byte-array/f ) +: marshall-non-pointer ( obj -- byte-array/f ) { { [ dup byte-array? ] [ ] } { [ dup alien-wrapper? ] @@ -236,7 +234,7 @@ M: alien-wrapper dynamic-cast ; current-vocab lookup [ dup superclasses [ struct-wrapper? ] any? [ [ class name>> heap-size ] keep - '[ malloc-byte-array _ new swap >>underlying ] + '[ _ malloc-byte-array _ new swap >>underlying ] ] [ drop [ ] ] if ] [ [ ] ] if* ; From e046605473b602e1ac84781cc17e04407677c876 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 7 Jul 2009 19:44:34 +1200 Subject: [PATCH 15/63] moved struct wrapper code from alien.structs.structs to alien.marshall.structs --- basis/alien/marshall/marshall.factor | 2 + basis/alien/marshall/structs/authors.txt | 1 + basis/alien/marshall/structs/structs.factor | 37 ++++++++++++++++++ basis/alien/structs/structs.factor | 43 ++------------------- basis/alien/syntax/syntax.factor | 3 +- 5 files changed, 46 insertions(+), 40 deletions(-) create mode 100644 basis/alien/marshall/structs/authors.txt create mode 100644 basis/alien/marshall/structs/structs.factor diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 4f6d125557..098a0e9127 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -18,10 +18,12 @@ IN: alien.marshall [ define-primitive-marshallers ] each >> TUPLE: alien-wrapper { underlying alien } ; +TUPLE: struct-wrapper < alien-wrapper disposed ; GENERIC: dynamic-cast ( alien-wrapper -- alien-wrapper' ) M: alien-wrapper dynamic-cast ; +M: struct-wrapper dynamic-cast ; : marshall-pointer ( obj -- alien ) { diff --git a/basis/alien/marshall/structs/authors.txt b/basis/alien/marshall/structs/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/basis/alien/marshall/structs/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/basis/alien/marshall/structs/structs.factor b/basis/alien/marshall/structs/structs.factor new file mode 100644 index 0000000000..2fbe73563d --- /dev/null +++ b/basis/alien/marshall/structs/structs.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types alien.marshall arrays assocs +classes.tuple combinators destructors generalizations generic +kernel libc locals parser quotations sequences slots words ; +IN: alien.marshall.structs + +M: struct-wrapper dispose* underlying>> free ; + +: define-struct-accessor ( class name quot -- ) + [ "accessors" create create-method dup make-inline ] dip define ; + +: define-struct-getter ( class name word type -- ) + [ ">>" append \ underlying>> ] 2dip + unmarshaller \ call 4array >quotation + define-struct-accessor ; + +: define-struct-setter ( class name word type -- ) + [ "(>>" prepend ")" append ] 2dip + marshaller [ underlying>> ] \ bi* roll 4array >quotation + define-struct-accessor ; + +: define-struct-accessors ( class name type reader writer -- ) + [ dup define-protocol-slot ] 3dip + [ drop swap define-struct-getter ] + [ nip swap define-struct-setter ] 5 nbi ; + +:: define-struct-tuple ( name -- ) + name create-in :> class + class struct-wrapper { } define-tuple-class + name c-type fields>> [ + class swap + { + [ name>> { { CHAR: space CHAR: - } } substitute ] + [ type>> ] [ reader>> ] [ writer>> ] + } cleave define-struct-accessors + ] each ; diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 6820c7afeb..b618e7974b 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types alien.marshall -alien.structs.fields arrays assocs byte-arrays classes.tuple -combinators cpu.architecture destructors fry generalizations -generic hashtables kernel kernel.private libc locals math -math.order namespaces parser quotations sequences slots strings -words ; +USING: accessors arrays assocs generic hashtables kernel kernel.private +math namespaces parser sequences strings words libc fry +alien.c-types alien.structs.fields cpu.architecture math.order +quotations byte-arrays ; IN: alien.structs TUPLE: struct-type @@ -84,36 +82,3 @@ M: struct-type stack-size : offset-of ( field struct -- offset ) c-types get at fields>> [ name>> = ] with find nip offset>> ; - -TUPLE: struct-wrapper < alien-wrapper disposed ; - -M: struct-wrapper dispose* underlying>> free ; - -: define-struct-accessor ( class name quot -- ) - [ "accessors" create create-method dup make-inline ] dip define ; - -: define-struct-getter ( class name word type -- ) - [ ">>" append \ underlying>> ] 2dip - unmarshaller \ call 4array >quotation - define-struct-accessor ; - -: define-struct-setter ( class name word type -- ) - [ "(>>" prepend ")" append ] 2dip - marshaller [ underlying>> ] \ bi* roll 4array >quotation - define-struct-accessor ; - -: define-struct-accessors ( class name type reader writer -- ) - [ dup define-protocol-slot ] 3dip - [ drop swap define-struct-getter ] - [ nip swap define-struct-setter ] 5 nbi ; - -:: define-struct-tuple ( name -- ) - name create-in :> class - class struct-wrapper { } define-tuple-class - name c-type fields>> [ - class swap - { - [ name>> { { CHAR: space CHAR: - } } substitute ] - [ type>> ] [ reader>> ] [ writer>> ] - } cleave define-struct-accessors - ] each ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 113581c949..ba2cbd9e53 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -4,7 +4,8 @@ USING: accessors arrays alien alien.c-types alien.structs alien.arrays alien.strings kernel math namespaces parser sequences words quotations math.parser splitting grouping effects assocs combinators lexer strings.parser alien.parser -fry vocabs.parser words.constant alien.libraries ; +fry vocabs.parser words.constant alien.libraries +alien.marshall.structs ; IN: alien.syntax SYNTAX: DLL" lexer get skip-blank parse-string dlopen parsed ; From c478fa9f1b47f4486381bb32d9d63e3a1b83f935 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 7 Jul 2009 20:51:31 +1200 Subject: [PATCH 16/63] alien.inline: prepend vocab name to c-library name --- basis/alien/inline/compiler/compiler.factor | 12 +++++++++--- basis/alien/inline/inline-tests.factor | 9 ++++++--- basis/alien/inline/inline.factor | 10 +++------- 3 files changed, 18 insertions(+), 13 deletions(-) diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor index 2f5fd29aff..d9f87a9f3b 100644 --- a/basis/alien/inline/compiler/compiler.factor +++ b/basis/alien/inline/compiler/compiler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators fry generalizations io.encodings.ascii io.files io.files.temp io.launcher kernel -locals sequences system words ; +locals make sequences system vocabs.parser words ; IN: alien.inline.compiler SYMBOL: C @@ -15,6 +15,12 @@ SYMBOL: C++ { [ dup windows? ] [ drop ".dll" ] } } cond ; +: library-path ( str -- str' ) + '[ + "lib-" % current-vocab name>> % + "-" % _ % library-suffix % + ] "" make temp-file ; + : src-suffix ( lang -- str ) { { C [ ".c" ] } @@ -52,8 +58,8 @@ M: macosx link-descr try-process ; :: link-object ( lang args name -- ) - args name [ "lib" prepend library-suffix append ] - [ ".o" append ] bi [ temp-file ] bi@ 2array + args name [ library-path ] + [ ".o" append temp-file ] bi 2array lang link-command try-process ; :: compile-to-library ( lang args contents name -- ) diff --git a/basis/alien/inline/inline-tests.factor b/basis/alien/inline/inline-tests.factor index acd2d615cd..60e6b3b594 100644 --- a/basis/alien/inline/inline-tests.factor +++ b/basis/alien/inline/inline-tests.factor @@ -15,7 +15,8 @@ C-FUNCTION: const-int add ( int a, int b ) { 2 1 } [ add ] must-infer-as [ 5 ] [ 2 3 add ] unit-test -<< library-path dup exists? [ delete-file ] [ drop ] if >> +<< c-library get library-path dup exists? +[ delete-file ] [ drop ] if >> C-LIBRARY: cpplib @@ -34,7 +35,8 @@ C-FUNCTION: const-char* hello ( ) { 0 1 } [ hello ] must-infer-as [ "hello world" ] [ hello ] unit-test -<< library-path dup exists? [ delete-file ] [ drop ] if >> +<< c-library get library-path dup exists? +[ delete-file ] [ drop ] if >> C-LIBRARY: compile-error @@ -45,4 +47,5 @@ C-FUNCTION: char* breakme ( ) << [ compile-c-library ] must-fail >> -<< library-path dup exists? [ delete-file ] [ drop ] if >> +<< c-library get library-path dup exists? +[ delete-file ] [ drop ] if >> diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 007dee43c0..6390884dfb 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -5,7 +5,7 @@ alien.libraries alien.parser arrays assocs combinators effects fry generalizations grouping io.files io.files.info io.files.temp kernel lexer locals math math.order math.ranges multiline namespaces quotations sequences source-files splitting strings -system vocabs.loader vocabs.parser words ; +system vocabs.loader words ; IN: alien.inline SYMBOL: c-library @@ -21,12 +21,8 @@ SYMBOL: c-strings : append-function-body ( prototype-str -- str ) " {\n" append parse-here append "\n}\n" append ; -: library-path ( -- str ) - "lib" c-library get library-suffix - 3array concat temp-file ; - : compile-library? ( -- ? ) - library-path dup exists? [ + c-library get library-path dup exists? [ file get path>> [ file-info modified>> ] bi@ <=> +lt+ = ] [ drop t ] if ; @@ -67,7 +63,7 @@ PRIVATE> : compile-c-library ( -- ) compile-library? [ compile-library ] when - c-library get library-path "cdecl" add-library ; + c-library get dup library-path "cdecl" add-library ; : define-c-function ( function types effect -- ) [ factor-function define-declared ] 3keep From 5e822dd454b38c266ce64ab2e5ca91c0a1462191 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 7 Jul 2009 21:11:57 +1200 Subject: [PATCH 17/63] alien.inline: added DELETE-C-LIBRARY: word, mainly for tests --- basis/alien/inline/inline-tests.factor | 13 +++++-------- basis/alien/inline/inline.factor | 13 +++++++++---- 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/basis/alien/inline/inline-tests.factor b/basis/alien/inline/inline-tests.factor index 60e6b3b594..837f27ceb7 100644 --- a/basis/alien/inline/inline-tests.factor +++ b/basis/alien/inline/inline-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test alien.inline alien.inline.private io.files -io.directories kernel ; +USING: alien.inline alien.inline.private io.directories io.files +kernel namespaces tools.test ; IN: alien.inline.tests C-LIBRARY: const @@ -15,8 +15,7 @@ C-FUNCTION: const-int add ( int a, int b ) { 2 1 } [ add ] must-infer-as [ 5 ] [ 2 3 add ] unit-test -<< c-library get library-path dup exists? -[ delete-file ] [ drop ] if >> +DELETE-C-LIBRARY: const C-LIBRARY: cpplib @@ -35,8 +34,7 @@ C-FUNCTION: const-char* hello ( ) { 0 1 } [ hello ] must-infer-as [ "hello world" ] [ hello ] unit-test -<< c-library get library-path dup exists? -[ delete-file ] [ drop ] if >> +DELETE-C-LIBRARY: cpplib C-LIBRARY: compile-error @@ -47,5 +45,4 @@ C-FUNCTION: char* breakme ( ) << [ compile-c-library ] must-fail >> -<< c-library get library-path dup exists? -[ delete-file ] [ drop ] if >> +DELETE-C-LIBRARY: compile-error diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 6390884dfb..8043dad24d 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.inline.compiler alien.inline.types alien.libraries alien.parser arrays assocs combinators effects -fry generalizations grouping io.files io.files.info io.files.temp -kernel lexer locals math math.order math.ranges multiline -namespaces quotations sequences source-files splitting strings -system vocabs.loader words ; +fry generalizations grouping io.directories io.files +io.files.info io.files.temp kernel lexer locals math math.order +math.ranges multiline namespaces quotations sequences +source-files splitting strings system vocabs.loader words ; IN: alien.inline SYMBOL: c-library @@ -85,6 +85,9 @@ PRIVATE> : define-c-include ( str -- ) "#include " prepend c-strings get push ; +: delete-inline-library ( str -- ) + library-path dup exists? [ delete-file ] [ drop ] if ; + SYNTAX: C-LIBRARY: scan define-c-library ; SYNTAX: COMPILE-AS-C++ t library-is-c++ set ; @@ -101,3 +104,5 @@ SYNTAX: C-FUNCTION: function-types-effect define-c-function ; SYNTAX: ;C-LIBRARY compile-c-library ; + +SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ; From 09aea6d8e6ccbbb94c7b1ac6bdddc5f43e891a1e Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 09:29:41 +1200 Subject: [PATCH 18/63] alien.inline: allow compiling from non-file vocabs --- basis/alien/inline/inline.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 8043dad24d..f273bfb911 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -23,8 +23,10 @@ SYMBOL: c-strings : compile-library? ( -- ? ) c-library get library-path dup exists? [ - file get path>> - [ file-info modified>> ] bi@ <=> +lt+ = + file get [ + path>> + [ file-info modified>> ] bi@ <=> +lt+ = + ] [ drop t ] if* ] [ drop t ] if ; : compile-library ( -- ) From ca740fcb032932b6c8c5c7a34bce98787c717927 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 09:30:58 +1200 Subject: [PATCH 19/63] alien.marshall.syntax: fix: return value unmarshaller --- basis/alien/marshall/syntax/syntax.factor | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/basis/alien/marshall/syntax/syntax.factor b/basis/alien/marshall/syntax/syntax.factor index 935aec87f9..321ca59023 100644 --- a/basis/alien/marshall/syntax/syntax.factor +++ b/basis/alien/marshall/syntax/syntax.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.inline alien.inline.types alien.marshall -combinators effects generalizations kernel locals namespaces +combinators effects generalizations kernel locals make namespaces quotations sequences words ; IN: alien.marshall.syntax @@ -11,10 +11,14 @@ IN: alien.marshall.syntax [ out>> types [ pointer-to-primitive? ] filter append ] bi [ - types [ marshaller ] map \ spread rot - types length \ nkeep - types [ out-arg-unmarshaller ] map \ spread - 7 narray >quotation + [ + types [ marshaller ] map , \ spread , , + types length , \ nkeep , + types [ out-arg-unmarshaller ] map + effect out>> dup empty? + [ drop ] [ first unmarshaller prefix ] if + , \ spread , + ] [ ] make ] dip ; : define-c-marshalled ( function types effect -- ) From 0aa1a9a43ddfd1f27b3ca4c8ed6d00501e57c53d Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 09:31:27 +1200 Subject: [PATCH 20/63] alien.marshall.syntax: remove duplicate annotate-effect call --- basis/alien/marshall/syntax/syntax.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/marshall/syntax/syntax.factor b/basis/alien/marshall/syntax/syntax.factor index 321ca59023..ab794ed4a8 100644 --- a/basis/alien/marshall/syntax/syntax.factor +++ b/basis/alien/marshall/syntax/syntax.factor @@ -6,7 +6,7 @@ quotations sequences words ; IN: alien.marshall.syntax :: marshalled-function ( function types effect -- word quot effect ) - function types effect annotate-effect factor-function + function types effect factor-function [ in>> ] [ out>> types [ pointer-to-primitive? ] filter append ] bi From 787b5d618a7192da0a7bf852f1eaa831acfd0d72 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 09:33:04 +1200 Subject: [PATCH 21/63] alien.marshall: factorize-type before primitive-unmarshaller --- basis/alien/marshall/marshall.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 098a0e9127..ef96f86d98 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -259,4 +259,4 @@ M: struct-wrapper dynamic-cast ; [ const-type? not ] [ factorize-type pointer-to-primitive? ] } 1&& - [ primitive-unmarshaller ] [ drop [ drop ] ] if ; + [ factorize-type primitive-unmarshaller ] [ drop [ drop ] ] if ; From fec504197be4ca3625e4473b6197e1bd1ed0ae16 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 09:33:29 +1200 Subject: [PATCH 22/63] alien.marshall: add longlong and ulonglong marshallers --- basis/alien/marshall/marshall.factor | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index ef96f86d98..5619d9697b 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -72,6 +72,8 @@ M: struct-wrapper dynamic-cast ; { "uint" [ [ marshall-uint ] ] } { "long" [ [ marshall-long ] ] } { "ulong" [ [ marshall-ulong ] ] } + { "long" [ [ marshall-longlong ] ] } + { "ulong" [ [ marshall-ulonglong ] ] } { "float" [ [ marshall-float ] ] } { "double" [ [ marshall-double ] ] } { "bool*" [ [ marshall-bool*-free ] ] } @@ -83,6 +85,8 @@ M: struct-wrapper dynamic-cast ; { "uint*" [ [ marshall-uint*-free ] ] } { "long*" [ [ marshall-long*-free ] ] } { "ulong*" [ [ marshall-ulong*-free ] ] } + { "longlong*" [ [ marshall-longlong*-free ] ] } + { "ulonglong*" [ [ marshall-ulonglong*-free ] ] } { "float*" [ [ marshall-float*-free ] ] } { "double*" [ [ marshall-double*-free ] ] } { "bool&" [ [ marshall-bool*-free ] ] } @@ -94,6 +98,8 @@ M: struct-wrapper dynamic-cast ; { "uint&" [ [ marshall-uint*-free ] ] } { "long&" [ [ marshall-long*-free ] ] } { "ulong&" [ [ marshall-ulong*-free ] ] } + { "longlong&" [ [ marshall-longlong*-free ] ] } + { "ulonglong&" [ [ marshall-ulonglong*-free ] ] } { "float&" [ [ marshall-float*-free ] ] } { "double&" [ [ marshall-double*-free ] ] } { "void*" [ [ marshall-void* ] ] } @@ -106,6 +112,8 @@ M: struct-wrapper dynamic-cast ; { "uint**" [ [ marshall-uint**-free ] ] } { "long**" [ [ marshall-long**-free ] ] } { "ulong**" [ [ marshall-ulong**-free ] ] } + { "longlong**" [ [ marshall-longlong**-free ] ] } + { "ulonglong**" [ [ marshall-ulonglong**-free ] ] } { "float**" [ [ marshall-float**-free ] ] } { "double**" [ [ marshall-double**-free ] ] } { "void**" [ [ marshall-void** ] ] } @@ -123,6 +131,8 @@ M: struct-wrapper dynamic-cast ; { "uint" [ [ marshall-uint ] ] } { "long" [ [ marshall-long ] ] } { "ulong" [ [ marshall-ulong ] ] } + { "longlong" [ [ marshall-longlong ] ] } + { "ulonglong" [ [ marshall-ulonglong ] ] } { "float" [ [ marshall-float ] ] } { "double" [ [ marshall-double ] ] } { "bool*" [ [ marshall-bool* ] ] } @@ -134,6 +144,8 @@ M: struct-wrapper dynamic-cast ; { "uint*" [ [ marshall-uint* ] ] } { "long*" [ [ marshall-long* ] ] } { "ulong*" [ [ marshall-ulong* ] ] } + { "longlong*" [ [ marshall-longlong* ] ] } + { "ulonglong*" [ [ marshall-ulonglong* ] ] } { "float*" [ [ marshall-float* ] ] } { "double*" [ [ marshall-double* ] ] } { "bool&" [ [ marshall-bool* ] ] } @@ -145,6 +157,8 @@ M: struct-wrapper dynamic-cast ; { "uint&" [ [ marshall-uint* ] ] } { "long&" [ [ marshall-long* ] ] } { "ulong&" [ [ marshall-ulong* ] ] } + { "longlong&" [ [ marshall-longlong* ] ] } + { "ulonglong&" [ [ marshall-ulonglong* ] ] } { "float&" [ [ marshall-float* ] ] } { "double&" [ [ marshall-double* ] ] } { "void*" [ [ marshall-void* ] ] } @@ -157,6 +171,8 @@ M: struct-wrapper dynamic-cast ; { "uint**" [ [ marshall-uint** ] ] } { "long**" [ [ marshall-long** ] ] } { "ulong**" [ [ marshall-ulong** ] ] } + { "longlong**" [ [ marshall-longlong** ] ] } + { "ulonglong**" [ [ marshall-ulonglong** ] ] } { "float**" [ [ marshall-float** ] ] } { "double**" [ [ marshall-double** ] ] } { "void**" [ [ marshall-void** ] ] } @@ -204,6 +220,8 @@ M: struct-wrapper dynamic-cast ; { "uint" [ [ ] ] } { "long" [ [ ] ] } { "ulong" [ [ ] ] } + { "longlong" [ [ ] ] } + { "ulonglong" [ [ ] ] } { "float" [ [ ] ] } { "double" [ [ ] ] } { "bool*" [ [ *bool ] ] } @@ -215,6 +233,8 @@ M: struct-wrapper dynamic-cast ; { "uint*" [ [ *uint ] ] } { "long*" [ [ *long ] ] } { "ulong*" [ [ *ulong ] ] } + { "longlong*" [ [ *long ] ] } + { "ulonglong*" [ [ *ulong ] ] } { "float*" [ [ *float ] ] } { "double*" [ [ *double ] ] } { "bool&" [ [ *bool ] ] } @@ -226,6 +246,8 @@ M: struct-wrapper dynamic-cast ; { "uint&" [ [ *uint ] ] } { "long&" [ [ *long ] ] } { "ulong&" [ [ *ulong ] ] } + { "longlong&" [ [ *long ] ] } + { "ulonglong&" [ [ *ulong ] ] } { "float&" [ [ *float ] ] } { "double&" [ [ *double ] ] } [ drop f ] From 7c1ae71a3e5323cfea1312eb4c9124b1d5022de2 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 09:39:15 +1200 Subject: [PATCH 23/63] alien.marshall: formatting --- basis/alien/marshall/marshall.factor | 297 ++++++++++++++------------- 1 file changed, 149 insertions(+), 148 deletions(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 5619d9697b..66902f6c51 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -63,119 +63,119 @@ M: struct-wrapper dynamic-cast ; : primitive-marshaller ( type -- quot/f ) { - { "bool" [ [ marshall-bool ] ] } - { "char" [ [ marshall-char ] ] } - { "uchar" [ [ marshall-uchar ] ] } - { "short" [ [ marshall-short ] ] } - { "ushort" [ [ marshall-ushort ] ] } - { "int" [ [ marshall-int ] ] } - { "uint" [ [ marshall-uint ] ] } - { "long" [ [ marshall-long ] ] } - { "ulong" [ [ marshall-ulong ] ] } - { "long" [ [ marshall-longlong ] ] } - { "ulong" [ [ marshall-ulonglong ] ] } - { "float" [ [ marshall-float ] ] } - { "double" [ [ marshall-double ] ] } - { "bool*" [ [ marshall-bool*-free ] ] } - { "char*" [ [ marshall-char*-or-string-free ] ] } - { "uchar*" [ [ marshall-uchar*-free ] ] } - { "short*" [ [ marshall-short*-free ] ] } - { "ushort*" [ [ marshall-ushort*-free ] ] } - { "int*" [ [ marshall-int*-free ] ] } - { "uint*" [ [ marshall-uint*-free ] ] } - { "long*" [ [ marshall-long*-free ] ] } - { "ulong*" [ [ marshall-ulong*-free ] ] } - { "longlong*" [ [ marshall-longlong*-free ] ] } - { "ulonglong*" [ [ marshall-ulonglong*-free ] ] } - { "float*" [ [ marshall-float*-free ] ] } - { "double*" [ [ marshall-double*-free ] ] } - { "bool&" [ [ marshall-bool*-free ] ] } - { "char&" [ [ marshall-char*-free ] ] } - { "uchar&" [ [ marshall-uchar*-free ] ] } - { "short&" [ [ marshall-short*-free ] ] } - { "ushort&" [ [ marshall-ushort*-free ] ] } - { "int&" [ [ marshall-int*-free ] ] } - { "uint&" [ [ marshall-uint*-free ] ] } - { "long&" [ [ marshall-long*-free ] ] } - { "ulong&" [ [ marshall-ulong*-free ] ] } - { "longlong&" [ [ marshall-longlong*-free ] ] } - { "ulonglong&" [ [ marshall-ulonglong*-free ] ] } - { "float&" [ [ marshall-float*-free ] ] } - { "double&" [ [ marshall-double*-free ] ] } - { "void*" [ [ marshall-void* ] ] } - { "bool**" [ [ marshall-bool**-free ] ] } - { "char**" [ [ marshall-char**-or-strings-free ] ] } - { "uchar**" [ [ marshall-uchar**-free ] ] } - { "short**" [ [ marshall-short**-free ] ] } - { "ushort**" [ [ marshall-ushort**-free ] ] } - { "int**" [ [ marshall-int**-free ] ] } - { "uint**" [ [ marshall-uint**-free ] ] } - { "long**" [ [ marshall-long**-free ] ] } - { "ulong**" [ [ marshall-ulong**-free ] ] } - { "longlong**" [ [ marshall-longlong**-free ] ] } - { "ulonglong**" [ [ marshall-ulonglong**-free ] ] } - { "float**" [ [ marshall-float**-free ] ] } - { "double**" [ [ marshall-double**-free ] ] } - { "void**" [ [ marshall-void** ] ] } + { "bool" [ [ marshall-bool ] ] } + { "char" [ [ marshall-char ] ] } + { "uchar" [ [ marshall-uchar ] ] } + { "short" [ [ marshall-short ] ] } + { "ushort" [ [ marshall-ushort ] ] } + { "int" [ [ marshall-int ] ] } + { "uint" [ [ marshall-uint ] ] } + { "long" [ [ marshall-long ] ] } + { "ulong" [ [ marshall-ulong ] ] } + { "long" [ [ marshall-longlong ] ] } + { "ulong" [ [ marshall-ulonglong ] ] } + { "float" [ [ marshall-float ] ] } + { "double" [ [ marshall-double ] ] } + { "bool*" [ [ marshall-bool*-free ] ] } + { "char*" [ [ marshall-char*-or-string-free ] ] } + { "uchar*" [ [ marshall-uchar*-free ] ] } + { "short*" [ [ marshall-short*-free ] ] } + { "ushort*" [ [ marshall-ushort*-free ] ] } + { "int*" [ [ marshall-int*-free ] ] } + { "uint*" [ [ marshall-uint*-free ] ] } + { "long*" [ [ marshall-long*-free ] ] } + { "ulong*" [ [ marshall-ulong*-free ] ] } + { "longlong*" [ [ marshall-longlong*-free ] ] } + { "ulonglong*" [ [ marshall-ulonglong*-free ] ] } + { "float*" [ [ marshall-float*-free ] ] } + { "double*" [ [ marshall-double*-free ] ] } + { "bool&" [ [ marshall-bool*-free ] ] } + { "char&" [ [ marshall-char*-free ] ] } + { "uchar&" [ [ marshall-uchar*-free ] ] } + { "short&" [ [ marshall-short*-free ] ] } + { "ushort&" [ [ marshall-ushort*-free ] ] } + { "int&" [ [ marshall-int*-free ] ] } + { "uint&" [ [ marshall-uint*-free ] ] } + { "long&" [ [ marshall-long*-free ] ] } + { "ulong&" [ [ marshall-ulong*-free ] ] } + { "longlong&" [ [ marshall-longlong*-free ] ] } + { "ulonglong&" [ [ marshall-ulonglong*-free ] ] } + { "float&" [ [ marshall-float*-free ] ] } + { "double&" [ [ marshall-double*-free ] ] } + { "void*" [ [ marshall-void* ] ] } + { "bool**" [ [ marshall-bool**-free ] ] } + { "char**" [ [ marshall-char**-or-strings-free ] ] } + { "uchar**" [ [ marshall-uchar**-free ] ] } + { "short**" [ [ marshall-short**-free ] ] } + { "ushort**" [ [ marshall-ushort**-free ] ] } + { "int**" [ [ marshall-int**-free ] ] } + { "uint**" [ [ marshall-uint**-free ] ] } + { "long**" [ [ marshall-long**-free ] ] } + { "ulong**" [ [ marshall-ulong**-free ] ] } + { "longlong**" [ [ marshall-longlong**-free ] ] } + { "ulonglong**" [ [ marshall-ulonglong**-free ] ] } + { "float**" [ [ marshall-float**-free ] ] } + { "double**" [ [ marshall-double**-free ] ] } + { "void**" [ [ marshall-void** ] ] } [ drop f ] } case ; : struct-primitive-marshaller ( type -- quot/f ) { - { "bool" [ [ marshall-bool ] ] } - { "char" [ [ marshall-char ] ] } - { "uchar" [ [ marshall-uchar ] ] } - { "short" [ [ marshall-short ] ] } - { "ushort" [ [ marshall-ushort ] ] } - { "int" [ [ marshall-int ] ] } - { "uint" [ [ marshall-uint ] ] } - { "long" [ [ marshall-long ] ] } - { "ulong" [ [ marshall-ulong ] ] } - { "longlong" [ [ marshall-longlong ] ] } - { "ulonglong" [ [ marshall-ulonglong ] ] } - { "float" [ [ marshall-float ] ] } - { "double" [ [ marshall-double ] ] } - { "bool*" [ [ marshall-bool* ] ] } - { "char*" [ [ marshall-char*-or-string ] ] } - { "uchar*" [ [ marshall-uchar* ] ] } - { "short*" [ [ marshall-short* ] ] } - { "ushort*" [ [ marshall-ushort* ] ] } - { "int*" [ [ marshall-int* ] ] } - { "uint*" [ [ marshall-uint* ] ] } - { "long*" [ [ marshall-long* ] ] } - { "ulong*" [ [ marshall-ulong* ] ] } - { "longlong*" [ [ marshall-longlong* ] ] } - { "ulonglong*" [ [ marshall-ulonglong* ] ] } - { "float*" [ [ marshall-float* ] ] } - { "double*" [ [ marshall-double* ] ] } - { "bool&" [ [ marshall-bool* ] ] } - { "char&" [ [ marshall-char* ] ] } - { "uchar&" [ [ marshall-uchar* ] ] } - { "short&" [ [ marshall-short* ] ] } - { "ushort&" [ [ marshall-ushort* ] ] } - { "int&" [ [ marshall-int* ] ] } - { "uint&" [ [ marshall-uint* ] ] } - { "long&" [ [ marshall-long* ] ] } - { "ulong&" [ [ marshall-ulong* ] ] } - { "longlong&" [ [ marshall-longlong* ] ] } - { "ulonglong&" [ [ marshall-ulonglong* ] ] } - { "float&" [ [ marshall-float* ] ] } - { "double&" [ [ marshall-double* ] ] } - { "void*" [ [ marshall-void* ] ] } - { "bool**" [ [ marshall-bool** ] ] } - { "char**" [ [ marshall-char**-or-strings ] ] } - { "uchar**" [ [ marshall-uchar** ] ] } - { "short**" [ [ marshall-short** ] ] } - { "ushort**" [ [ marshall-ushort** ] ] } - { "int**" [ [ marshall-int** ] ] } - { "uint**" [ [ marshall-uint** ] ] } - { "long**" [ [ marshall-long** ] ] } - { "ulong**" [ [ marshall-ulong** ] ] } - { "longlong**" [ [ marshall-longlong** ] ] } - { "ulonglong**" [ [ marshall-ulonglong** ] ] } - { "float**" [ [ marshall-float** ] ] } - { "double**" [ [ marshall-double** ] ] } - { "void**" [ [ marshall-void** ] ] } + { "bool" [ [ marshall-bool ] ] } + { "char" [ [ marshall-char ] ] } + { "uchar" [ [ marshall-uchar ] ] } + { "short" [ [ marshall-short ] ] } + { "ushort" [ [ marshall-ushort ] ] } + { "int" [ [ marshall-int ] ] } + { "uint" [ [ marshall-uint ] ] } + { "long" [ [ marshall-long ] ] } + { "ulong" [ [ marshall-ulong ] ] } + { "longlong" [ [ marshall-longlong ] ] } + { "ulonglong" [ [ marshall-ulonglong ] ] } + { "float" [ [ marshall-float ] ] } + { "double" [ [ marshall-double ] ] } + { "bool*" [ [ marshall-bool* ] ] } + { "char*" [ [ marshall-char*-or-string ] ] } + { "uchar*" [ [ marshall-uchar* ] ] } + { "short*" [ [ marshall-short* ] ] } + { "ushort*" [ [ marshall-ushort* ] ] } + { "int*" [ [ marshall-int* ] ] } + { "uint*" [ [ marshall-uint* ] ] } + { "long*" [ [ marshall-long* ] ] } + { "ulong*" [ [ marshall-ulong* ] ] } + { "longlong*" [ [ marshall-longlong* ] ] } + { "ulonglong*" [ [ marshall-ulonglong* ] ] } + { "float*" [ [ marshall-float* ] ] } + { "double*" [ [ marshall-double* ] ] } + { "bool&" [ [ marshall-bool* ] ] } + { "char&" [ [ marshall-char* ] ] } + { "uchar&" [ [ marshall-uchar* ] ] } + { "short&" [ [ marshall-short* ] ] } + { "ushort&" [ [ marshall-ushort* ] ] } + { "int&" [ [ marshall-int* ] ] } + { "uint&" [ [ marshall-uint* ] ] } + { "long&" [ [ marshall-long* ] ] } + { "ulong&" [ [ marshall-ulong* ] ] } + { "longlong&" [ [ marshall-longlong* ] ] } + { "ulonglong&" [ [ marshall-ulonglong* ] ] } + { "float&" [ [ marshall-float* ] ] } + { "double&" [ [ marshall-double* ] ] } + { "void*" [ [ marshall-void* ] ] } + { "bool**" [ [ marshall-bool** ] ] } + { "char**" [ [ marshall-char**-or-strings ] ] } + { "uchar**" [ [ marshall-uchar** ] ] } + { "short**" [ [ marshall-short** ] ] } + { "ushort**" [ [ marshall-ushort** ] ] } + { "int**" [ [ marshall-int** ] ] } + { "uint**" [ [ marshall-uint** ] ] } + { "long**" [ [ marshall-long** ] ] } + { "ulong**" [ [ marshall-ulong** ] ] } + { "longlong**" [ [ marshall-longlong** ] ] } + { "ulonglong**" [ [ marshall-ulonglong** ] ] } + { "float**" [ [ marshall-float** ] ] } + { "double**" [ [ marshall-double** ] ] } + { "void**" [ [ marshall-void** ] ] } [ drop f ] } case ; @@ -211,45 +211,45 @@ M: struct-wrapper dynamic-cast ; : primitive-unmarshaller ( type -- quot/f ) { - { "bool" [ [ unmarshall-bool ] ] } - { "char" [ [ ] ] } - { "uchar" [ [ ] ] } - { "short" [ [ ] ] } - { "ushort" [ [ ] ] } - { "int" [ [ ] ] } - { "uint" [ [ ] ] } - { "long" [ [ ] ] } - { "ulong" [ [ ] ] } - { "longlong" [ [ ] ] } - { "ulonglong" [ [ ] ] } - { "float" [ [ ] ] } - { "double" [ [ ] ] } - { "bool*" [ [ *bool ] ] } - { "char*" [ [ unmarshall-char*-to-string ] ] } - { "uchar*" [ [ *uchar ] ] } - { "short*" [ [ *short ] ] } - { "ushort*" [ [ *ushort ] ] } - { "int*" [ [ *int ] ] } - { "uint*" [ [ *uint ] ] } - { "long*" [ [ *long ] ] } - { "ulong*" [ [ *ulong ] ] } - { "longlong*" [ [ *long ] ] } - { "ulonglong*" [ [ *ulong ] ] } - { "float*" [ [ *float ] ] } - { "double*" [ [ *double ] ] } - { "bool&" [ [ *bool ] ] } - { "char&" [ [ *char ] ] } - { "uchar&" [ [ *uchar ] ] } - { "short&" [ [ *short ] ] } - { "ushort&" [ [ *ushort ] ] } - { "int&" [ [ *int ] ] } - { "uint&" [ [ *uint ] ] } - { "long&" [ [ *long ] ] } - { "ulong&" [ [ *ulong ] ] } - { "longlong&" [ [ *long ] ] } - { "ulonglong&" [ [ *ulong ] ] } - { "float&" [ [ *float ] ] } - { "double&" [ [ *double ] ] } + { "bool" [ [ unmarshall-bool ] ] } + { "char" [ [ ] ] } + { "uchar" [ [ ] ] } + { "short" [ [ ] ] } + { "ushort" [ [ ] ] } + { "int" [ [ ] ] } + { "uint" [ [ ] ] } + { "long" [ [ ] ] } + { "ulong" [ [ ] ] } + { "longlong" [ [ ] ] } + { "ulonglong" [ [ ] ] } + { "float" [ [ ] ] } + { "double" [ [ ] ] } + { "bool*" [ [ *bool ] ] } + { "char*" [ [ unmarshall-char*-to-string ] ] } + { "uchar*" [ [ *uchar ] ] } + { "short*" [ [ *short ] ] } + { "ushort*" [ [ *ushort ] ] } + { "int*" [ [ *int ] ] } + { "uint*" [ [ *uint ] ] } + { "long*" [ [ *long ] ] } + { "ulong*" [ [ *ulong ] ] } + { "longlong*" [ [ *long ] ] } + { "ulonglong*" [ [ *ulong ] ] } + { "float*" [ [ *float ] ] } + { "double*" [ [ *double ] ] } + { "bool&" [ [ *bool ] ] } + { "char&" [ [ *char ] ] } + { "uchar&" [ [ *uchar ] ] } + { "short&" [ [ *short ] ] } + { "ushort&" [ [ *ushort ] ] } + { "int&" [ [ *int ] ] } + { "uint&" [ [ *uint ] ] } + { "long&" [ [ *long ] ] } + { "ulong&" [ [ *ulong ] ] } + { "longlong&" [ [ *long ] ] } + { "ulonglong&" [ [ *ulong ] ] } + { "float&" [ [ *float ] ] } + { "double&" [ [ *double ] ] } [ drop f ] } case ; @@ -281,4 +281,5 @@ M: struct-wrapper dynamic-cast ; [ const-type? not ] [ factorize-type pointer-to-primitive? ] } 1&& - [ factorize-type primitive-unmarshaller ] [ drop [ drop ] ] if ; + [ factorize-type primitive-unmarshaller ] + [ drop [ drop ] ] if ; From ed65e2ae4c386851cf365bb53ba4de9f1db676c7 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 09:39:39 +1200 Subject: [PATCH 24/63] alien.marshall.syntax: added tests --- .../alien/marshall/syntax/syntax-tests.factor | 28 +++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100644 basis/alien/marshall/syntax/syntax-tests.factor diff --git a/basis/alien/marshall/syntax/syntax-tests.factor b/basis/alien/marshall/syntax/syntax-tests.factor new file mode 100644 index 0000000000..f324d6b791 --- /dev/null +++ b/basis/alien/marshall/syntax/syntax-tests.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.inline alien.marshall.syntax destructors +tools.test ; +IN: alien.marshall.syntax.tests + +C-LIBRARY: test + +C-MARSHALLED: void outarg1 ( int* a ) + *a += 2; +; + +C-MARSHALLED: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b ) + unsigned long* x = (unsigned long*) malloc(sizeof(unsigned long)); + *b = 10 + *b; + *x = a + *b; + return x; +; + +;C-LIBRARY + +{ 1 1 } [ outarg1 ] must-infer-as +[ 3 ] [ [ 1 outarg1 ] with-destructors ] unit-test + +{ 2 2 } [ outarg2 ] must-infer-as +[ 18 15 ] [ [ 3 5 outarg2 ] with-destructors ] unit-test + +DELETE-C-LIBRARY: test From bc6e5de9116e62a8bcf51025be5d1726444237e0 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 11:30:45 +1200 Subject: [PATCH 25/63] alien.inline.types: replaced const-type? with const-pointer? and pointer-to-const? --- basis/alien/inline/types/types.factor | 9 ++++++--- basis/alien/marshall/marshall.factor | 2 +- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/basis/alien/inline/types/types.factor b/basis/alien/inline/types/types.factor index acc62a81a2..222eadf08e 100644 --- a/basis/alien/inline/types/types.factor +++ b/basis/alien/inline/types/types.factor @@ -8,13 +8,16 @@ IN: alien.inline.types : factorize-type ( str -- str' ) "const-" ?head drop "unsigned-" ?head [ "u" prepend ] when - "long-" ?head [ "long" prepend ] when ; + "long-" ?head [ "long" prepend ] when + "-const" ?tail drop ; : cify-type ( str -- str' ) { { CHAR: - CHAR: space } } substitute ; -: const-type? ( str -- ? ) - "const-" head? ; +: const-pointer? ( str -- ? ) + { [ "-const" tail? ] [ "&" tail? ] } 1|| ; + +: pointer-to-const? ( str -- ? ) "const-" head? ; MEMO: resolved-primitives ( -- seq ) primitive-types [ resolve-typedef ] map ; diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 66902f6c51..1aa7a4bff2 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -278,7 +278,7 @@ M: struct-wrapper dynamic-cast ; : out-arg-unmarshaller ( type -- quot ) dup { - [ const-type? not ] + [ pointer-to-const? not ] [ factorize-type pointer-to-primitive? ] } 1&& [ factorize-type primitive-unmarshaller ] From 60f847ea4c1f97feab94775a383078b80375cee7 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 14:00:48 +1200 Subject: [PATCH 26/63] alien.marshall.*: replace &free in marshallers with free in unmarshallers --- basis/alien/marshall/marshall.factor | 178 ++++++++---------- basis/alien/marshall/private/private.factor | 9 +- .../alien/marshall/syntax/syntax-tests.factor | 4 +- 3 files changed, 90 insertions(+), 101 deletions(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 1aa7a4bff2..5e52281f80 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -11,7 +11,7 @@ specialized-arrays.long specialized-arrays.longlong specialized-arrays.short specialized-arrays.uchar specialized-arrays.uint specialized-arrays.ulong specialized-arrays.ulonglong specialized-arrays.ushort strings -unix.utilities vocabs.parser words ; +unix.utilities vocabs.parser words libc.private ; IN: alien.marshall << primitive-types [ "void*" = not ] filter @@ -47,9 +47,6 @@ M: struct-wrapper dynamic-cast ; : marshall-char*-or-string ( n/string -- alien ) [ (marshall-char*-or-string) ] ptr-pass-through ; -: marshall-char*-or-string-free ( n/string -- alien ) - [ (marshall-char*-or-string) &free ] ptr-pass-through ; - : (marshall-char**-or-strings) ( seq -- alien ) dup first string? [ utf8 strings>alien malloc-byte-array ] @@ -58,9 +55,6 @@ M: struct-wrapper dynamic-cast ; : marshall-char**-or-strings ( n/string -- alien ) [ (marshall-char**-or-strings) ] ptr-pass-through ; -: marshall-char**-or-strings-free ( n/string -- alien ) - [ (marshall-char**-or-strings) &free ] ptr-pass-through ; - : primitive-marshaller ( type -- quot/f ) { { "bool" [ [ marshall-bool ] ] } @@ -76,65 +70,6 @@ M: struct-wrapper dynamic-cast ; { "ulong" [ [ marshall-ulonglong ] ] } { "float" [ [ marshall-float ] ] } { "double" [ [ marshall-double ] ] } - { "bool*" [ [ marshall-bool*-free ] ] } - { "char*" [ [ marshall-char*-or-string-free ] ] } - { "uchar*" [ [ marshall-uchar*-free ] ] } - { "short*" [ [ marshall-short*-free ] ] } - { "ushort*" [ [ marshall-ushort*-free ] ] } - { "int*" [ [ marshall-int*-free ] ] } - { "uint*" [ [ marshall-uint*-free ] ] } - { "long*" [ [ marshall-long*-free ] ] } - { "ulong*" [ [ marshall-ulong*-free ] ] } - { "longlong*" [ [ marshall-longlong*-free ] ] } - { "ulonglong*" [ [ marshall-ulonglong*-free ] ] } - { "float*" [ [ marshall-float*-free ] ] } - { "double*" [ [ marshall-double*-free ] ] } - { "bool&" [ [ marshall-bool*-free ] ] } - { "char&" [ [ marshall-char*-free ] ] } - { "uchar&" [ [ marshall-uchar*-free ] ] } - { "short&" [ [ marshall-short*-free ] ] } - { "ushort&" [ [ marshall-ushort*-free ] ] } - { "int&" [ [ marshall-int*-free ] ] } - { "uint&" [ [ marshall-uint*-free ] ] } - { "long&" [ [ marshall-long*-free ] ] } - { "ulong&" [ [ marshall-ulong*-free ] ] } - { "longlong&" [ [ marshall-longlong*-free ] ] } - { "ulonglong&" [ [ marshall-ulonglong*-free ] ] } - { "float&" [ [ marshall-float*-free ] ] } - { "double&" [ [ marshall-double*-free ] ] } - { "void*" [ [ marshall-void* ] ] } - { "bool**" [ [ marshall-bool**-free ] ] } - { "char**" [ [ marshall-char**-or-strings-free ] ] } - { "uchar**" [ [ marshall-uchar**-free ] ] } - { "short**" [ [ marshall-short**-free ] ] } - { "ushort**" [ [ marshall-ushort**-free ] ] } - { "int**" [ [ marshall-int**-free ] ] } - { "uint**" [ [ marshall-uint**-free ] ] } - { "long**" [ [ marshall-long**-free ] ] } - { "ulong**" [ [ marshall-ulong**-free ] ] } - { "longlong**" [ [ marshall-longlong**-free ] ] } - { "ulonglong**" [ [ marshall-ulonglong**-free ] ] } - { "float**" [ [ marshall-float**-free ] ] } - { "double**" [ [ marshall-double**-free ] ] } - { "void**" [ [ marshall-void** ] ] } - [ drop f ] - } case ; - -: struct-primitive-marshaller ( type -- quot/f ) - { - { "bool" [ [ marshall-bool ] ] } - { "char" [ [ marshall-char ] ] } - { "uchar" [ [ marshall-uchar ] ] } - { "short" [ [ marshall-short ] ] } - { "ushort" [ [ marshall-ushort ] ] } - { "int" [ [ marshall-int ] ] } - { "uint" [ [ marshall-uint ] ] } - { "long" [ [ marshall-long ] ] } - { "ulong" [ [ marshall-ulong ] ] } - { "longlong" [ [ marshall-longlong ] ] } - { "ulonglong" [ [ marshall-ulonglong ] ] } - { "float" [ [ marshall-float ] ] } - { "double" [ [ marshall-double ] ] } { "bool*" [ [ marshall-bool* ] ] } { "char*" [ [ marshall-char*-or-string ] ] } { "uchar*" [ [ marshall-uchar* ] ] } @@ -195,17 +130,13 @@ M: struct-wrapper dynamic-cast ; [ [ marshall-non-pointer ] ] if ] if* ; -: struct-field-marshaller ( type -- quot ) - factorize-type dup struct-primitive-marshaller [ nip ] [ - pointer? - [ [ marshall-pointer ] ] - [ [ marshall-non-pointer ] ] if - ] if* ; - : unmarshall-char*-to-string ( alien -- string ) utf8 alien>string ; +: unmarshall-char*-to-string-free ( alien -- string ) + [ unmarshall-char*-to-string ] keep add-malloc free ; + : unmarshall-bool ( n -- ? ) 0 = not ; @@ -224,32 +155,76 @@ M: struct-wrapper dynamic-cast ; { "ulonglong" [ [ ] ] } { "float" [ [ ] ] } { "double" [ [ ] ] } - { "bool*" [ [ *bool ] ] } + { "bool*" [ [ unmarshall-bool*-free ] ] } + { "char*" [ [ unmarshall-char*-to-string-free ] ] } + { "uchar*" [ [ unmarshall-uchar*-free ] ] } + { "short*" [ [ unmarshall-short*-free ] ] } + { "ushort*" [ [ unmarshall-ushort*-free ] ] } + { "int*" [ [ unmarshall-int*-free ] ] } + { "uint*" [ [ unmarshall-uint*-free ] ] } + { "long*" [ [ unmarshall-long*-free ] ] } + { "ulong*" [ [ unmarshall-ulong*-free ] ] } + { "longlong*" [ [ unmarshall-long*-free ] ] } + { "ulonglong*" [ [ unmarshall-ulong*-free ] ] } + { "float*" [ [ unmarshall-float*-free ] ] } + { "double*" [ [ unmarshall-double*-free ] ] } + { "bool&" [ [ unmarshall-bool*-free ] ] } + { "char&" [ [ unmarshall-char*-free ] ] } + { "uchar&" [ [ unmarshall-uchar*-free ] ] } + { "short&" [ [ unmarshall-short*-free ] ] } + { "ushort&" [ [ unmarshall-ushort*-free ] ] } + { "int&" [ [ unmarshall-int*-free ] ] } + { "uint&" [ [ unmarshall-uint*-free ] ] } + { "long&" [ [ unmarshall-long*-free ] ] } + { "ulong&" [ [ unmarshall-ulong*-free ] ] } + { "longlong&" [ [ unmarshall-longlong*-free ] ] } + { "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] } + { "float&" [ [ unmarshall-float*-free ] ] } + { "double&" [ [ unmarshall-double*-free ] ] } + [ drop f ] + } case ; + +: struct-primitive-unmarshaller ( type -- quot/f ) + { + { "bool" [ [ unmarshall-bool ] ] } + { "char" [ [ ] ] } + { "uchar" [ [ ] ] } + { "short" [ [ ] ] } + { "ushort" [ [ ] ] } + { "int" [ [ ] ] } + { "uint" [ [ ] ] } + { "long" [ [ ] ] } + { "ulong" [ [ ] ] } + { "longlong" [ [ ] ] } + { "ulonglong" [ [ ] ] } + { "float" [ [ ] ] } + { "double" [ [ ] ] } + { "bool*" [ [ unmarshall-bool* ] ] } { "char*" [ [ unmarshall-char*-to-string ] ] } - { "uchar*" [ [ *uchar ] ] } - { "short*" [ [ *short ] ] } - { "ushort*" [ [ *ushort ] ] } - { "int*" [ [ *int ] ] } - { "uint*" [ [ *uint ] ] } - { "long*" [ [ *long ] ] } - { "ulong*" [ [ *ulong ] ] } - { "longlong*" [ [ *long ] ] } - { "ulonglong*" [ [ *ulong ] ] } - { "float*" [ [ *float ] ] } - { "double*" [ [ *double ] ] } - { "bool&" [ [ *bool ] ] } - { "char&" [ [ *char ] ] } - { "uchar&" [ [ *uchar ] ] } - { "short&" [ [ *short ] ] } - { "ushort&" [ [ *ushort ] ] } - { "int&" [ [ *int ] ] } - { "uint&" [ [ *uint ] ] } - { "long&" [ [ *long ] ] } - { "ulong&" [ [ *ulong ] ] } - { "longlong&" [ [ *long ] ] } - { "ulonglong&" [ [ *ulong ] ] } - { "float&" [ [ *float ] ] } - { "double&" [ [ *double ] ] } + { "uchar*" [ [ unmarshall-uchar* ] ] } + { "short*" [ [ unmarshall-short* ] ] } + { "ushort*" [ [ unmarshall-ushort* ] ] } + { "int*" [ [ unmarshall-int* ] ] } + { "uint*" [ [ unmarshall-uint* ] ] } + { "long*" [ [ unmarshall-long* ] ] } + { "ulong*" [ [ unmarshall-ulong* ] ] } + { "longlong*" [ [ unmarshall-long* ] ] } + { "ulonglong*" [ [ unmarshall-ulong* ] ] } + { "float*" [ [ unmarshall-float* ] ] } + { "double*" [ [ unmarshall-double* ] ] } + { "bool&" [ [ unmarshall-bool* ] ] } + { "char&" [ [ unmarshall-char* ] ] } + { "uchar&" [ [ unmarshall-uchar* ] ] } + { "short&" [ [ unmarshall-short* ] ] } + { "ushort&" [ [ unmarshall-ushort* ] ] } + { "int&" [ [ unmarshall-int* ] ] } + { "uint&" [ [ unmarshall-uint* ] ] } + { "long&" [ [ unmarshall-long* ] ] } + { "ulong&" [ [ unmarshall-ulong* ] ] } + { "longlong&" [ [ unmarshall-longlong* ] ] } + { "ulonglong&" [ [ unmarshall-ulonglong* ] ] } + { "float&" [ [ unmarshall-float* ] ] } + { "double&" [ [ unmarshall-double* ] ] } [ drop f ] } case ; @@ -276,6 +251,13 @@ M: struct-wrapper dynamic-cast ; [ struct-unmarshaller ] if ] if* ; +: struct-field-unmarshaller ( type -- quot ) + factorize-type dup struct-primitive-unmarshaller [ nip ] [ + dup pointer? + [ pointer-unmarshaller ] + [ struct-unmarshaller ] if + ] if* ; + : out-arg-unmarshaller ( type -- quot ) dup { [ pointer-to-const? not ] diff --git a/basis/alien/marshall/private/private.factor b/basis/alien/marshall/private/private.factor index 901d713009..869f50705b 100644 --- a/basis/alien/marshall/private/private.factor +++ b/basis/alien/marshall/private/private.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.inline arrays combinators fry functors kernel lexer libc macros math -sequences specialized-arrays.alien ; +sequences specialized-arrays.alien libc.private ; IN: alien.marshall.private : bool>arg ( ? -- 1/0/obj ) @@ -23,6 +23,7 @@ MACRO: marshall-x* ( num-quot seq-quot -- alien ) FUNCTOR: define-primitive-marshallers ( TYPE -- ) IS <${TYPE}> +*TYPE IS *${TYPE} >TYPE-array IS >${TYPE}-array marshall-TYPE DEFINES marshall-${TYPE} (marshall-TYPE*) DEFINES (marshall-${TYPE}*) @@ -31,6 +32,8 @@ marshall-TYPE* DEFINES marshall-${TYPE}* marshall-TYPE** DEFINES marshall-${TYPE}** marshall-TYPE*-free DEFINES marshall-${TYPE}*-free marshall-TYPE**-free DEFINES marshall-${TYPE}**-free +unmarshall-TYPE* DEFINES unmarshall-${TYPE}* +unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free WHERE : marshall-TYPE ( n -- byte-array ) [ bool>arg ] ptr-pass-through ; @@ -49,6 +52,10 @@ WHERE [ (marshall-TYPE*) &free ] ptr-pass-through ; : marshall-TYPE**-free ( seq -- alien ) [ (marshall-TYPE**) &free ] ptr-pass-through ; +: unmarshall-TYPE* ( alien -- n ) + *TYPE ; inline +: unmarshall-TYPE*-free ( alien -- n ) + [ unmarshall-TYPE* ] keep add-malloc free ; ;FUNCTOR SYNTAX: PRIMITIVE-MARSHALLERS: diff --git a/basis/alien/marshall/syntax/syntax-tests.factor b/basis/alien/marshall/syntax/syntax-tests.factor index f324d6b791..7a96245d12 100644 --- a/basis/alien/marshall/syntax/syntax-tests.factor +++ b/basis/alien/marshall/syntax/syntax-tests.factor @@ -20,9 +20,9 @@ C-MARSHALLED: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b ) ;C-LIBRARY { 1 1 } [ outarg1 ] must-infer-as -[ 3 ] [ [ 1 outarg1 ] with-destructors ] unit-test +[ 3 ] [ 1 outarg1 ] unit-test { 2 2 } [ outarg2 ] must-infer-as -[ 18 15 ] [ [ 3 5 outarg2 ] with-destructors ] unit-test +[ 18 15 ] [ 3 5 outarg2 ] unit-test DELETE-C-LIBRARY: test From e2797b83bc123489bb08b87641d749c5bbe0a32a Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 15:17:00 +1200 Subject: [PATCH 27/63] alien.marshall.syntax.tests: delete library before compilation --- basis/alien/marshall/syntax/syntax-tests.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/alien/marshall/syntax/syntax-tests.factor b/basis/alien/marshall/syntax/syntax-tests.factor index 7a96245d12..23d9a7372a 100644 --- a/basis/alien/marshall/syntax/syntax-tests.factor +++ b/basis/alien/marshall/syntax/syntax-tests.factor @@ -4,6 +4,7 @@ USING: alien.inline alien.marshall.syntax destructors tools.test ; IN: alien.marshall.syntax.tests +DELETE-C-LIBRARY: test C-LIBRARY: test C-MARSHALLED: void outarg1 ( int* a ) @@ -24,5 +25,3 @@ C-MARSHALLED: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b ) { 2 2 } [ outarg2 ] must-infer-as [ 18 15 ] [ 3 5 outarg2 ] unit-test - -DELETE-C-LIBRARY: test From 25e034adb6fdda0a0d931343b320a3c2dbd744b1 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 16:42:25 +1200 Subject: [PATCH 28/63] alien.marshall: added struct-arrays to marshall-pointer --- basis/alien/marshall/marshall.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 5e52281f80..8c04c8b9f1 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -31,6 +31,7 @@ M: struct-wrapper dynamic-cast ; { [ dup not ] [ ] } { [ dup byte-array? ] [ malloc-byte-array ] } { [ dup alien-wrapper? ] [ underlying>> ] } + { [ dup struct-array? ] [ underlying>> ] } } cond ; : marshall-void* ( obj -- alien ) From eab6d79ac458ede74a0004fa4d7434a04d8cb0b0 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 17:33:21 +1200 Subject: [PATCH 29/63] alien.marshall.syntax: added M-STRUCTURE: --- basis/alien/marshall/structs/structs.factor | 6 +++++- basis/alien/marshall/syntax/syntax.factor | 4 ++++ basis/alien/syntax/syntax.factor | 6 ++---- 3 files changed, 11 insertions(+), 5 deletions(-) diff --git a/basis/alien/marshall/structs/structs.factor b/basis/alien/marshall/structs/structs.factor index 2fbe73563d..2ebade8f02 100644 --- a/basis/alien/marshall/structs/structs.factor +++ b/basis/alien/marshall/structs/structs.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.marshall arrays assocs classes.tuple combinators destructors generalizations generic -kernel libc locals parser quotations sequences slots words ; +kernel libc locals parser quotations sequences slots words +alien.structs ; IN: alien.marshall.structs M: struct-wrapper dispose* underlying>> free ; @@ -35,3 +36,6 @@ M: struct-wrapper dispose* underlying>> free ; [ type>> ] [ reader>> ] [ writer>> ] } cleave define-struct-accessors ] each ; + +: define-marshalled-struct ( name vocab fields -- ) + [ define-struct ] [ 2drop define-struct-tuple ] 3bi ; diff --git a/basis/alien/marshall/syntax/syntax.factor b/basis/alien/marshall/syntax/syntax.factor index ab794ed4a8..4453b1a405 100644 --- a/basis/alien/marshall/syntax/syntax.factor +++ b/basis/alien/marshall/syntax/syntax.factor @@ -34,3 +34,7 @@ SYNTAX: C-MARSHALLED: SYNTAX: MARSHALLED: function-types-effect marshalled-function define-declared ; + +SYNTAX: M-STRUCTURE: + scan current-vocab parse-definition + define-marshalled-struct ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index ba2cbd9e53..d479e6d498 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -4,8 +4,7 @@ USING: accessors arrays alien alien.c-types alien.structs alien.arrays alien.strings kernel math namespaces parser sequences words quotations math.parser splitting grouping effects assocs combinators lexer strings.parser alien.parser -fry vocabs.parser words.constant alien.libraries -alien.marshall.structs ; +fry vocabs.parser words.constant alien.libraries ; IN: alien.syntax SYNTAX: DLL" lexer get skip-blank parse-string dlopen parsed ; @@ -23,8 +22,7 @@ SYNTAX: TYPEDEF: scan scan typedef ; SYNTAX: C-STRUCT: - scan current-vocab parse-definition [ define-struct ] 3keep - 2drop define-struct-tuple ; + scan current-vocab parse-definition define-struct ; SYNTAX: C-UNION: scan parse-definition define-union ; From 3d5b9f16512b0403f2f08575e437905ea4ee91ef Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 8 Jul 2009 17:35:17 +1200 Subject: [PATCH 30/63] alien.marshall.syntax: changed naming scheme Prefixes: C- generates inline C code M- marshalls arguments and return values CM- does both --- basis/alien/marshall/syntax/syntax-tests.factor | 4 ++-- basis/alien/marshall/syntax/syntax.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/alien/marshall/syntax/syntax-tests.factor b/basis/alien/marshall/syntax/syntax-tests.factor index 23d9a7372a..5b0a28f0e6 100644 --- a/basis/alien/marshall/syntax/syntax-tests.factor +++ b/basis/alien/marshall/syntax/syntax-tests.factor @@ -7,11 +7,11 @@ IN: alien.marshall.syntax.tests DELETE-C-LIBRARY: test C-LIBRARY: test -C-MARSHALLED: void outarg1 ( int* a ) +CM-FUNCTION: void outarg1 ( int* a ) *a += 2; ; -C-MARSHALLED: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b ) +CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b ) unsigned long* x = (unsigned long*) malloc(sizeof(unsigned long)); *b = 10 + *b; *x = a + *b; diff --git a/basis/alien/marshall/syntax/syntax.factor b/basis/alien/marshall/syntax/syntax.factor index 4453b1a405..e764ed2307 100644 --- a/basis/alien/marshall/syntax/syntax.factor +++ b/basis/alien/marshall/syntax/syntax.factor @@ -29,10 +29,10 @@ IN: alien.marshall.syntax [ in>> ] keep [ marshalled-function define-declared ] 3keep out>> c-function-string' c-strings get push ; -SYNTAX: C-MARSHALLED: +SYNTAX: CM-FUNCTION: function-types-effect define-c-marshalled ; -SYNTAX: MARSHALLED: +SYNTAX: M-FUNCTION: function-types-effect marshalled-function define-declared ; SYNTAX: M-STRUCTURE: From cfc3372867d654fa80b5b651ab7ff28d6d126b88 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Thu, 9 Jul 2009 10:33:54 +1200 Subject: [PATCH 31/63] alien.marshall.*: added missing vocabs --- basis/alien/marshall/marshall.factor | 2 +- basis/alien/marshall/structs/structs.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 8c04c8b9f1..2468539583 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -11,7 +11,7 @@ specialized-arrays.long specialized-arrays.longlong 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 ; +unix.utilities vocabs.parser words libc.private struct-arrays ; IN: alien.marshall << primitive-types [ "void*" = not ] filter diff --git a/basis/alien/marshall/structs/structs.factor b/basis/alien/marshall/structs/structs.factor index 2ebade8f02..ba3013ca5d 100644 --- a/basis/alien/marshall/structs/structs.factor +++ b/basis/alien/marshall/structs/structs.factor @@ -3,7 +3,7 @@ USING: accessors alien.c-types alien.marshall arrays assocs classes.tuple combinators destructors generalizations generic kernel libc locals parser quotations sequences slots words -alien.structs ; +alien.structs lexer vocabs.parser fry effects ; IN: alien.marshall.structs M: struct-wrapper dispose* underlying>> free ; From ac6c207de86a77fda084d82c170f5839d738a2c0 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Thu, 9 Jul 2009 10:34:41 +1200 Subject: [PATCH 32/63] alien.marshall.struct: struct getter fix --- basis/alien/marshall/structs/structs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/alien/marshall/structs/structs.factor b/basis/alien/marshall/structs/structs.factor index ba3013ca5d..75c36a3cb5 100644 --- a/basis/alien/marshall/structs/structs.factor +++ b/basis/alien/marshall/structs/structs.factor @@ -12,8 +12,8 @@ M: struct-wrapper dispose* underlying>> free ; [ "accessors" create create-method dup make-inline ] dip define ; : define-struct-getter ( class name word type -- ) - [ ">>" append \ underlying>> ] 2dip - unmarshaller \ call 4array >quotation + [ ">>" append \ underlying>> ] 2dip + struct-field-unmarshaller \ call 4array >quotation define-struct-accessor ; : define-struct-setter ( class name word type -- ) From c4aabe2fb4c29d0cf5d8d7814580045684e51ad6 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Thu, 9 Jul 2009 10:35:18 +1200 Subject: [PATCH 33/63] alien.marshall.structs: generate struct constructors --- basis/alien/marshall/structs/structs.factor | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/basis/alien/marshall/structs/structs.factor b/basis/alien/marshall/structs/structs.factor index 75c36a3cb5..b14d49762b 100644 --- a/basis/alien/marshall/structs/structs.factor +++ b/basis/alien/marshall/structs/structs.factor @@ -26,9 +26,18 @@ M: struct-wrapper dispose* underlying>> free ; [ drop swap define-struct-getter ] [ nip swap define-struct-setter ] 5 nbi ; +: define-struct-constructor ( class -- ) + { + [ name>> "<" prepend ">" append create-in ] + [ '[ _ new ] ] + [ name>> '[ _ malloc-object >>underlying ] append ] + [ name>> 1array ] + } cleave { } swap define-declared ; + :: define-struct-tuple ( name -- ) name create-in :> class class struct-wrapper { } define-tuple-class + class define-struct-constructor name c-type fields>> [ class swap { From e2c6b21bfbcb5318b3dc211233ea19453558238a Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Thu, 9 Jul 2009 10:35:49 +1200 Subject: [PATCH 34/63] alien.marshall.syntax: added CM-STRUCTURE: --- basis/alien/marshall/syntax/syntax.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/alien/marshall/syntax/syntax.factor b/basis/alien/marshall/syntax/syntax.factor index e764ed2307..c4011a2f77 100644 --- a/basis/alien/marshall/syntax/syntax.factor +++ b/basis/alien/marshall/syntax/syntax.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.inline alien.inline.types alien.marshall combinators effects generalizations kernel locals make namespaces -quotations sequences words ; +quotations sequences words alien.marshall.structs lexer parser +vocabs.parser ; IN: alien.marshall.syntax :: marshalled-function ( function types effect -- word quot effect ) @@ -38,3 +39,7 @@ SYNTAX: M-FUNCTION: SYNTAX: M-STRUCTURE: scan current-vocab parse-definition define-marshalled-struct ; + +SYNTAX: CM-STRUCTURE: + scan current-vocab parse-definition + [ define-marshalled-struct ] [ define-c-struct ] 3bi ; From 426d173b7ce44a5c04516c7920d0cb358c7f0276 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Thu, 9 Jul 2009 10:36:21 +1200 Subject: [PATCH 35/63] alien.marshall: unmarshaller fixes --- basis/alien/marshall/marshall.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 2468539583..2ddd30b9f9 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -230,17 +230,19 @@ M: struct-wrapper dynamic-cast ; } case ; +: ?malloc-byte-array ( c-type -- alien ) + dup alien? [ malloc-byte-array ] unless ; + : struct-unmarshaller ( type -- quot ) current-vocab lookup [ - dup superclasses [ struct-wrapper? ] any? [ - [ class name>> heap-size ] keep - '[ _ malloc-byte-array _ new swap >>underlying ] + 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? [ + dup superclasses [ \ alien-wrapper = ] any? [ '[ _ new swap >>underlying dynamic-cast ] ] [ drop [ ] ] if ] [ [ ] ] if* ; From d49b637efdccf367ff60854eba8837e633147912 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Thu, 9 Jul 2009 10:36:53 +1200 Subject: [PATCH 36/63] alien.marshall.syntax-tests: added struct tests --- .../alien/marshall/syntax/syntax-tests.factor | 23 ++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/basis/alien/marshall/syntax/syntax-tests.factor b/basis/alien/marshall/syntax/syntax-tests.factor index 5b0a28f0e6..fe62e6d334 100644 --- a/basis/alien/marshall/syntax/syntax-tests.factor +++ b/basis/alien/marshall/syntax/syntax-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. USING: alien.inline alien.marshall.syntax destructors -tools.test ; +tools.test accessors kernel ; IN: alien.marshall.syntax.tests DELETE-C-LIBRARY: test @@ -18,6 +18,21 @@ CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b ) return x; ; +CM-STRUCTURE: wedge + { "double" "degrees" } ; + +CM-STRUCTURE: sundial + { "double" "radius" } + { "wedge" "wedge" } ; + +CM-FUNCTION: double hours ( sundial* d ) + return d->wedge.degrees / 30; +; + +CM-FUNCTION: void change_time ( double hours, sundial* d ) + d->wedge.degrees = hours * 30; +; + ;C-LIBRARY { 1 1 } [ outarg1 ] must-infer-as @@ -25,3 +40,9 @@ CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b ) { 2 2 } [ outarg2 ] must-infer-as [ 18 15 ] [ 3 5 outarg2 ] unit-test + +{ 1 1 } [ hours ] must-infer-as +[ 5.0 ] [ 150 >>degrees >>wedge hours ] unit-test + +{ 2 0 } [ change_time ] must-infer-as +[ 150.0 ] [ 5 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test From e0c0399d248bc8ee29c92c8d022c6c0cdb27c9b8 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Fri, 10 Jul 2009 12:45:27 +1200 Subject: [PATCH 37/63] alien.inline.compile: write library files to resource:alien-inline-libs --- basis/alien/inline/compiler/compiler.factor | 10 ++++++++-- basis/alien/inline/inline.factor | 2 +- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor index b1ccc2baab..991fdd7111 100644 --- a/basis/alien/inline/compiler/compiler.factor +++ b/basis/alien/inline/compiler/compiler.factor @@ -8,6 +8,12 @@ IN: alien.inline.compiler SYMBOL: C SYMBOL: C++ +: inline-libs-directory ( -- path ) + "resource:alien-inline-libs" dup make-directories ; + +: inline-library-file ( name -- path ) + inline-libs-directory prepend-path ; + : library-suffix ( -- str ) os { { [ dup macosx? ] [ drop ".dylib" ] } @@ -17,9 +23,9 @@ SYMBOL: C++ : library-path ( str -- str' ) '[ - "lib-" % current-vocab name>> % + "lib" % current-vocab name>> % "-" % _ % library-suffix % - ] "" make temp-file ; + ] "" make inline-library-file ; : src-suffix ( lang -- str ) { diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 641c6f4f4a..7a2713767c 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -60,7 +60,7 @@ PRIVATE> concat make-function ; : define-c-library ( name -- ) - c-library set + [ current-vocab name>> % "_" % % ] "" make c-library set V{ } clone c-strings set V{ } clone compiler-args set ; From 11183fa5db30cab51c96dc3fbd152265d0d81702 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sat, 11 Jul 2009 20:50:27 +1200 Subject: [PATCH 38/63] alien.inline.*: fixed merge breakage --- basis/alien/inline/inline.factor | 8 ++++---- basis/alien/marshall/syntax/syntax.factor | 23 ++++++++++++++--------- 2 files changed, 18 insertions(+), 13 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index d68f4fd32d..2514d30873 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -23,9 +23,6 @@ SYMBOL: c-strings CHAR: a swap length CHAR: a + [a,b] [ 1string ] map ; -: append-function-body ( prototype-str body -- str ) - [ swap % " {\n" % % "\n}\n" % ] "" make ; - : compile-library? ( -- ? ) c-library get library-path dup exists? [ file get [ @@ -44,6 +41,9 @@ SYMBOL: c-strings [ current-vocab name>> % "_" % % ] "" make ; PRIVATE> +: append-function-body ( prototype-str body -- str ) + [ swap % " {\n" % % "\n}\n" % ] "" make ; + : function-types-effect ( -- function types effect ) scan scan swap ")" parse-tokens [ "(" subseq? not ] filter swap parse-arglist ; @@ -56,7 +56,7 @@ PRIVATE> library-is-c++ get [ "extern \"C\" " prepend ] when ; : prototype-string' ( function types return -- str ) - [ dup arg-list ] c-function-string ; + [ dup arg-list ] prototype-string ; : factor-function ( function types effect -- word quot effect ) annotate-effect [ c-library get ] 3dip diff --git a/basis/alien/marshall/syntax/syntax.factor b/basis/alien/marshall/syntax/syntax.factor index c4011a2f77..822eb950e9 100644 --- a/basis/alien/marshall/syntax/syntax.factor +++ b/basis/alien/marshall/syntax/syntax.factor @@ -3,7 +3,7 @@ USING: accessors alien.inline alien.inline.types alien.marshall combinators effects generalizations kernel locals make namespaces quotations sequences words alien.marshall.structs lexer parser -vocabs.parser ; +vocabs.parser multiline ; IN: alien.marshall.syntax :: marshalled-function ( function types effect -- word quot effect ) @@ -22,16 +22,21 @@ IN: alien.marshall.syntax ] [ ] make ] dip ; -: define-c-marshalled ( function types effect -- ) - [ marshalled-function define-declared ] 3keep - c-function-string c-strings get push ; +: define-c-marshalled ( function types effect body -- ) + [ + [ marshalled-function define-declared ] + [ prototype-string ] 3bi + ] dip append-function-body c-strings get push ; -: define-c-marshalled' ( function effect -- ) - [ in>> ] keep [ marshalled-function define-declared ] 3keep - out>> c-function-string' c-strings get push ; +: define-c-marshalled' ( function effect body -- ) + [ + [ in>> ] keep + [ marshalled-function define-declared ] + [ out>> prototype-string' ] 3bi + ] dip append-function-body c-strings get push ; SYNTAX: CM-FUNCTION: - function-types-effect define-c-marshalled ; + function-types-effect parse-here define-c-marshalled ; SYNTAX: M-FUNCTION: function-types-effect marshalled-function define-declared ; @@ -42,4 +47,4 @@ SYNTAX: M-STRUCTURE: SYNTAX: CM-STRUCTURE: scan current-vocab parse-definition - [ define-marshalled-struct ] [ define-c-struct ] 3bi ; + [ define-marshalled-struct ] [ nip define-c-struct ] 3bi ; From 2aec1d697c00eda6f0136a8788144a8eae5849b9 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sat, 11 Jul 2009 20:53:50 +1200 Subject: [PATCH 39/63] alien.inline.compiler: added -mno-cygwin to linker on windows --- basis/alien/inline/compiler/compiler.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor index bc098ee26b..7ec70a356e 100644 --- a/basis/alien/inline/compiler/compiler.factor +++ b/basis/alien/inline/compiler/compiler.factor @@ -60,7 +60,7 @@ M: word link-descr { "-shared" "-o" } ; M: macosx link-descr { "-g" "-prebind" "-dynamiclib" "-o" } cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ; -M: windows link-descr { "-lstdc++" "-o" } ; +M: windows link-descr { "-lstdc++" "-mno-cygwin" "-o" } ; Date: Mon, 13 Jul 2009 10:26:41 +1200 Subject: [PATCH 40/63] alien.marshall: dynamic-cast: renamed to unmarshall-cast --- basis/alien/marshall/marshall.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 2ddd30b9f9..ef8ce56f60 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -20,10 +20,10 @@ IN: alien.marshall TUPLE: alien-wrapper { underlying alien } ; TUPLE: struct-wrapper < alien-wrapper disposed ; -GENERIC: dynamic-cast ( alien-wrapper -- alien-wrapper' ) +GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' ) -M: alien-wrapper dynamic-cast ; -M: struct-wrapper dynamic-cast ; +M: alien-wrapper unmarshall-cast ; +M: struct-wrapper unmarshall-cast ; : marshall-pointer ( obj -- alien ) { From c0714c6135c86a8d1f3407ed764c372ed70f8c74 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 10:20:13 +1200 Subject: [PATCH 41/63] alien.inline.types: factorize-type and pointer-to-const? accept strings with spaces --- basis/alien/inline/types/types.factor | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/basis/alien/inline/types/types.factor b/basis/alien/inline/types/types.factor index 222eadf08e..bf0a7936ba 100644 --- a/basis/alien/inline/types/types.factor +++ b/basis/alien/inline/types/types.factor @@ -5,19 +5,21 @@ continuations effects fry kernel math memoize sequences splitting ; IN: alien.inline.types -: factorize-type ( str -- str' ) - "const-" ?head drop - "unsigned-" ?head [ "u" prepend ] when - "long-" ?head [ "long" prepend ] when - "-const" ?tail drop ; - : cify-type ( str -- str' ) { { CHAR: - CHAR: space } } substitute ; -: const-pointer? ( str -- ? ) - { [ "-const" tail? ] [ "&" tail? ] } 1|| ; +: factorize-type ( str -- str' ) + cify-type + "const " ?head drop + "unsigned " ?head [ "u" prepend ] when + "long " ?head [ "long" prepend ] when + " const" ?tail drop ; -: pointer-to-const? ( str -- ? ) "const-" head? ; +: const-pointer? ( str -- ? ) + cify-type { [ " const" tail? ] [ "&" tail? ] } 1|| ; + +: pointer-to-const? ( str -- ? ) + cify-type "const " head? ; MEMO: resolved-primitives ( -- seq ) primitive-types [ resolve-typedef ] map ; From c5e30fee3ec3cb87a28f4374dcb6aabdaea913b7 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 10:21:32 +1200 Subject: [PATCH 42/63] alien.marshall: rewrote bool marshalling --- basis/alien/marshall/marshall.factor | 33 +++++++++++++++++++++++----- 1 file changed, 28 insertions(+), 5 deletions(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index ef8ce56f60..e863108190 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -14,8 +14,8 @@ specialized-arrays.ulonglong specialized-arrays.ushort strings unix.utilities vocabs.parser words libc.private struct-arrays ; IN: alien.marshall -<< primitive-types [ "void*" = not ] filter -[ define-primitive-marshallers ] each >> +<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ] +filter [ define-primitive-marshallers ] each >> TUPLE: alien-wrapper { underlying alien } ; TUPLE: struct-wrapper < alien-wrapper disposed ; @@ -56,6 +56,32 @@ M: struct-wrapper unmarshall-cast ; : marshall-char**-or-strings ( n/string -- alien ) [ (marshall-char**-or-strings) ] ptr-pass-through ; +: marshall-bool ( ? -- n ) + >boolean [ 1 ] [ 0 ] if ; + +: (marshall-bool*) ( ?/seq -- alien ) + [ marshall-bool malloc-byte-array ] + [ >bool-array malloc-underlying ] + marshall-x* ; + +: marshall-bool* ( ?/seq -- alien ) + [ (marshall-bool*) ] ptr-pass-through ; + +: (marshall-bool**) ( seq -- alien ) + [ marshall-bool* ] map >void*-array malloc-underlying ; + +: marshall-bool** ( seq -- alien ) + [ (marshall-bool**) ] ptr-pass-through ; + +: unmarshall-bool ( n -- ? ) + 0 = not ; + +: unmarshall-bool* ( alien -- ? ) + *bool unmarshall-bool ; + +: unmarshall-bool*-free ( alien -- ? ) + [ *bool unmarshall-bool ] keep add-malloc free ; + : primitive-marshaller ( type -- quot/f ) { { "bool" [ [ marshall-bool ] ] } @@ -138,9 +164,6 @@ M: struct-wrapper unmarshall-cast ; : unmarshall-char*-to-string-free ( alien -- string ) [ unmarshall-char*-to-string ] keep add-malloc free ; -: unmarshall-bool ( n -- ? ) - 0 = not ; - : primitive-unmarshaller ( type -- quot/f ) { { "bool" [ [ unmarshall-bool ] ] } From 1cca58d7813437347e2a7d2bdb7ef4193f142161 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 10:24:31 +1200 Subject: [PATCH 43/63] alien.marshall: use marshall-primitive instead of marshall- words --- basis/alien/marshall/marshall.factor | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index e863108190..422ed5695c 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -36,6 +36,8 @@ M: struct-wrapper unmarshall-cast ; : marshall-void* ( obj -- alien ) marshall-pointer ; +: marshall-primitive ( n -- n ) + [ bool>arg ] ptr-pass-through ; : marshall-void** ( obj -- alien ) [ marshall-void* ] map >void*-array malloc-underlying ; @@ -85,18 +87,18 @@ M: struct-wrapper unmarshall-cast ; : primitive-marshaller ( type -- quot/f ) { { "bool" [ [ marshall-bool ] ] } - { "char" [ [ marshall-char ] ] } - { "uchar" [ [ marshall-uchar ] ] } - { "short" [ [ marshall-short ] ] } - { "ushort" [ [ marshall-ushort ] ] } - { "int" [ [ marshall-int ] ] } - { "uint" [ [ marshall-uint ] ] } - { "long" [ [ marshall-long ] ] } - { "ulong" [ [ marshall-ulong ] ] } - { "long" [ [ marshall-longlong ] ] } - { "ulong" [ [ marshall-ulonglong ] ] } - { "float" [ [ marshall-float ] ] } - { "double" [ [ marshall-double ] ] } + { "char" [ [ marshall-primitive ] ] } + { "uchar" [ [ marshall-primitive ] ] } + { "short" [ [ marshall-primitive ] ] } + { "ushort" [ [ marshall-primitive ] ] } + { "int" [ [ marshall-primitive ] ] } + { "uint" [ [ marshall-primitive ] ] } + { "long" [ [ marshall-primitive ] ] } + { "ulong" [ [ marshall-primitive ] ] } + { "long" [ [ marshall-primitive ] ] } + { "ulong" [ [ marshall-primitive ] ] } + { "float" [ [ marshall-primitive ] ] } + { "double" [ [ marshall-primitive ] ] } { "bool*" [ [ marshall-bool* ] ] } { "char*" [ [ marshall-char*-or-string ] ] } { "uchar*" [ [ marshall-uchar* ] ] } From 702419c092835ac6796ac27d5a1f6053b0501211 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 10:25:34 +1200 Subject: [PATCH 44/63] alien.marshall.private: remove marshall-TYPE and make () words private --- basis/alien/marshall/private/private.factor | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/basis/alien/marshall/private/private.factor b/basis/alien/marshall/private/private.factor index 869f50705b..8eb3702135 100644 --- a/basis/alien/marshall/private/private.factor +++ b/basis/alien/marshall/private/private.factor @@ -35,23 +35,20 @@ marshall-TYPE**-free DEFINES marshall-${TYPE}**-free unmarshall-TYPE* DEFINES unmarshall-${TYPE}* unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free WHERE -: marshall-TYPE ( n -- byte-array ) - [ bool>arg ] ptr-pass-through ; + malloc-byte-array ] [ >TYPE-array malloc-underlying ] marshall-x* ; -: (marshall-TYPE**) ( seq -- alien ) - [ >TYPE-array malloc-underlying ] - map >void*-array malloc-underlying ; +PRIVATE> : marshall-TYPE* ( n/seq -- alien ) [ (marshall-TYPE*) ] ptr-pass-through ; + : marshall-TYPE** ( seq -- alien ) [ (marshall-TYPE**) ] ptr-pass-through ; -: marshall-TYPE*-free ( n/seq -- alien ) - [ (marshall-TYPE*) &free ] ptr-pass-through ; -: marshall-TYPE**-free ( seq -- alien ) - [ (marshall-TYPE**) &free ] ptr-pass-through ; : unmarshall-TYPE* ( alien -- n ) *TYPE ; inline : unmarshall-TYPE*-free ( alien -- n ) From fd23b4070f439fed8a58b84db5ec9b069d8f24d0 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 10:26:26 +1200 Subject: [PATCH 45/63] alien.marshall: marshalling word fixes --- basis/alien/marshall/marshall.factor | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 422ed5695c..c17a244e35 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -34,13 +34,13 @@ M: struct-wrapper unmarshall-cast ; { [ dup struct-array? ] [ underlying>> ] } } cond ; -: marshall-void* ( obj -- alien ) - marshall-pointer ; : marshall-primitive ( n -- n ) [ bool>arg ] ptr-pass-through ; -: marshall-void** ( obj -- alien ) - [ marshall-void* ] map >void*-array malloc-underlying ; +ALIAS: marshall-void* marshall-pointer + +: marshall-void** ( seq -- alien ) + [ marshall-void* ] void*-array{ } map-as malloc-underlying ; : (marshall-char*-or-string) ( n/string -- alien ) dup string? @@ -51,11 +51,10 @@ M: struct-wrapper unmarshall-cast ; [ (marshall-char*-or-string) ] ptr-pass-through ; : (marshall-char**-or-strings) ( seq -- alien ) - dup first string? - [ utf8 strings>alien malloc-byte-array ] - [ (marshall-char**) ] if ; + [ marshall-char*-or-string ] void*-array{ } map-as + malloc-underlying ; -: marshall-char**-or-strings ( n/string -- alien ) +: marshall-char**-or-strings ( seq -- alien ) [ (marshall-char**-or-strings) ] ptr-pass-through ; : marshall-bool ( ? -- n ) @@ -143,7 +142,7 @@ M: struct-wrapper unmarshall-cast ; [ drop f ] } case ; -: marshall-non-pointer ( obj -- byte-array/f ) +: marshall-non-pointer ( alien-wrapper/byte-array -- byte-array ) { { [ dup byte-array? ] [ ] } { [ dup alien-wrapper? ] @@ -268,7 +267,7 @@ M: struct-wrapper unmarshall-cast ; : pointer-unmarshaller ( type -- quot ) type-sans-pointer current-vocab lookup [ dup superclasses [ \ alien-wrapper = ] any? [ - '[ _ new swap >>underlying dynamic-cast ] + '[ _ new swap >>underlying unmarshall-cast ] ] [ drop [ ] ] if ] [ [ ] ] if* ; From f65adc1a6327e0e908cf6f2c82e98bc2a2489ee6 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 10:26:45 +1200 Subject: [PATCH 46/63] alien.marshall: added documentation --- basis/alien/marshall/marshall-docs.factor | 645 ++++++++++++++++++++++ 1 file changed, 645 insertions(+) create mode 100644 basis/alien/marshall/marshall-docs.factor diff --git a/basis/alien/marshall/marshall-docs.factor b/basis/alien/marshall/marshall-docs.factor new file mode 100644 index 0000000000..fd1b57579f --- /dev/null +++ b/basis/alien/marshall/marshall-docs.factor @@ -0,0 +1,645 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations sequences +strings alien alien.c-types math byte-arrays ; +IN: alien.marshall + +: $memory-note ( arg -- ) + drop "This word returns a pointer to unmanaged memory." + print-element ; + +: $c-ptr-note ( arg -- ) + drop "Does nothing if its argument is a non false c-ptr." + print-element ; + +: $see-article ( arg -- ) + drop { "See " { $vocab-link "alien.inline" } "." } + print-element ; + +: $marshall-descr* ( arg -- ) + dup + "When the argument is a sequence, returns a pointer to an array of" + print-element print-element + "otherwise returns a pointer to a single " + print-element print-element " value." print-element ; + +: $marshall-descr** ( arg -- ) + "Takes a one or two dimensional array of " + print-element print-element + " and returns a pointer to the equivalent C structure." + print-element ; + +HELP: ?malloc-byte-array +{ $values + { "c-type" c-type } + { "alien" alien } +} +{ $description "Does nothing if input is an alien, otherwise assumes it is a byte array and calls " + { $snippet "malloc-byte-array" } "." +} +{ $notes $memory-note } ; + +HELP: alien-wrapper +{ $var-description "For wrapping C pointers in a structure factor can dispatch on." } ; + +HELP: unmarshall-cast +{ $values + { "alien-wrapper" alien-wrapper } + { "alien-wrapper'" alien-wrapper } +} +{ $description "Called immediately after unmarshalling. Useful for automatically casting to subtypes." } ; + +HELP: marshall-bool +{ $values + { "?" "a generalized boolean" } + { "n" "0 or 1" } +} +{ $description "Marshalls objects to bool." } +{ $notes "Will treat " { $snippet "0" } " as " { $snippet "t" } "." } ; + +HELP: marshall-bool* +{ $values + { "?/seq" "t/f or sequence" } + { "alien" alien } +} +{ $description { $marshall-descr* "bool" } } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-bool** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description { $marshall-descr** "generalized booleans" } } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-primitive +{ $values + { "n" number } + { "n" number } +} +{ $description "Marshall numbers to C primitives." + $nl + "Factor marshalls numbers to primitives for FFI calls, so all " + "this word does is convert " { $snippet "t" } " to " { $snippet "1" } + ", " { $snippet "f" } " to " { $snippet "0" } ", and lets anything else " + "pass through untouched." +} ; + +HELP: marshall-char* +{ $values + { "n/seq" "number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-char** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-char**-or-strings +{ $values + { "seq" "a sequence of strings" } + { "alien" alien } +} +{ $description "Marshalls an array of strings or characters to an array of C strings." } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-char*-or-string +{ $values + { "n/string" "a number or string" } + { "alien" alien } +} +{ $description "Marshalls a string to a C string or a number to a pointer to " { $snippet "char" } "." } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-double* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-double** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-float* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-float** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-int* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-int** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-long* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-long** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-longlong* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-longlong** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-non-pointer +{ $values + { "alien-wrapper/byte-array" "an alien-wrapper or byte-array" } + { "byte-array" byte-array } +} +{ $description "Converts argument to a byte array." } +{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ; + +HELP: marshall-pointer +{ $values + { "obj" object } + { "alien" alien } +} +{ $description "Converts argument to a C pointer." } +{ $notes "Can marshall the following types: " { $snippet "alien, f, byte-array, alien-wrapper, struct-array" } "." } ; + +HELP: marshall-short* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-short** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-uchar* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-uchar** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-uint* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-uint** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-ulong* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-ulong** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-ulonglong* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-ulonglong** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-ushort* +{ $values + { "n/seq" "a number or sequence" } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-ushort** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description $see-article } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshall-void** +{ $values + { "seq" sequence } + { "alien" alien } +} +{ $description "Marshalls a sequence of objects to an array of pointers to void." } +{ $notes { $list $c-ptr-note $memory-note } } ; + +HELP: marshaller +{ $values + { "type" "a C type string" } + { "quot" quotation } +} +{ $description "Given a C type, returns a quotation that will marshall its argument to that type." } ; + +HELP: out-arg-unmarshaller +{ $values + { "type" "a C type string" } + { "quot" quotation } +} +{ $description "Like " { $link unmarshaller } " but returns an empty quotation " + "for all types except pointers to non-const primitives." +} ; + +HELP: pointer-unmarshaller +{ $values + { "type" " a C type string" } + { "quot" quotation } +} +{ $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper } + " named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which " + "wraps its argument in an instance of that subclass. In any other case it returns an empty quotation." +} +{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ; + +HELP: primitive-marshaller +{ $values + { "type" "a C type string" } + { "quot/f" "a quotation or f" } +} +{ $description "Returns a quotation to marshall objects to the argument type." } +{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ; + +HELP: primitive-unmarshaller +{ $values + { "type" "a C type string" } + { "quot/f" "a quotation or f" } +} +{ $description "Returns a quotation to unmarshall objects from the argument type." } +{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ; + +HELP: struct-field-unmarshaller +{ $values + { "type" "a C type string" } + { "quot" quotation } +} +{ $description "Like " { $link unmarshaller } " but returns a quotation that " + "does not call " { $snippet "free" } " on its argument." +} +{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ; + +HELP: struct-primitive-unmarshaller +{ $values + { "type" "a C type string" } + { "quot/f" "a quotation or f" } +} +{ $description "Like " { $link primitive-unmarshaller } " but returns a quotation that " + "does not call " { $snippet "free" } " on its argument." } +{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ; + +HELP: struct-unmarshaller +{ $values + { "type" "a C type string" } + { "quot" quotation } +} +{ $description "Returns a quotation which wraps its argument in the subclass of " + { $link struct-wrapper } " which matches the " { $snippet "type" } " arg." +} +{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ; + +HELP: struct-wrapper +{ $var-description "For wrapping C structs in a structure factor can dispatch on." } ; + +HELP: unmarshall-bool +{ $values + { "n" number } + { "?" "a boolean" } +} +{ $description "Unmarshalls a number to a boolean." } ; + +HELP: unmarshall-bool* +{ $values + { "alien" alien } + { "?" "a boolean" } +} +{ $description "Unmarshalls a C pointer to a boolean." } ; + +HELP: unmarshall-bool*-free +{ $values + { "alien" alien } + { "?" "a boolean" } +} +{ $description "Unmarshalls a C pointer to a boolean and frees the pointer." } ; + +HELP: unmarshall-char* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-char*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-char*-to-string +{ $values + { "alien" alien } + { "string" string } +} +{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string." } ; + +HELP: unmarshall-char*-to-string-free +{ $values + { "alien" alien } + { "string" string } +} +{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string and frees the pointer." } ; + +HELP: unmarshall-double* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-double*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-float* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-float*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-int* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-int*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-long* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-long*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-longlong* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-longlong*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-short* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-short*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-uchar* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-uchar*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-uint* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-uint*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-ulong* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-ulong*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-ulonglong* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-ulonglong*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-ushort* +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshall-ushort*-free +{ $values + { "alien" alien } + { "n" number } +} +{ $description $see-article } ; + +HELP: unmarshaller +{ $values + { "type" "a C type string" } + { "quot" quotation } +} +{ $description "Given a C type, returns a quotation that will unmarshall values of that type." } ; + +ARTICLE: "alien.marshall" "C marshalling" +{ $vocab-link "alien.marshall" } " provides alien wrappers and marshalling words for the " +"automatic marshalling and unmarshalling of C function arguments, return values, and output parameters." + +{ $subheading "Important words" } +"Wrap an alien:" { $subsection alien-wrapper } +"Wrap a struct:" { $subsection struct-wrapper } +"Get the marshaller for a C type:" { $subsection marshaller } +"Get the unmarshaller for a C type:" { $subsection marshaller } +"Get the unmarshaller for an output parameter:" { $subsection out-arg-unmarshaller } +"Get the unmarshaller for a struct field:" { $subsection struct-field-unmarshaller } +$nl +"Other marshalling and unmarshalling words in this vocabulary are not intended to be " +"invoked directly." +$nl +"Most marshalling words allow non false c-ptrs to pass through unchanged." + +{ $subheading "Primitive marshallers" } +{ $subsection marshall-primitive } "for marshalling primitive values." +{ $subsection marshall-int* } + "marshalls a number or sequence of numbers. If argument is a sequence, returns a pointer " + "to a C array, otherwise returns a pointer to a single value." +{ $subsection marshall-int** } +"marshalls a 1D or 2D array of numbers. Returns an array of pointers to arrays." + +{ $subheading "Primitive unmarshallers" } +{ $snippet "unmarshall-*" } " and " { $snippet "unmarshall-*-free" } +" for all values of " { $snippet "" } " in " { $link primitive-types } "." +{ $subsection unmarshall-int* } +"unmarshalls a pointer to primitive. Returns a number. " +"Assumes the pointer is not an array (if it is, only the first value is returned). " +"C functions that return arrays are not handled correctly by " { $snippet "alien.marshall" } +" and must be unmarshalled by hand." +{ $subsection unmarshall-int*-free } +"unmarshalls a pointer to primitive, and then frees the pointer." +$nl +"Primitive values require no unmarshalling. The factor FFI already does this." +; + +ABOUT: "alien.marshall" From 3b56dc8b1341c9170e6db5fee7ed5e3c25f3fe24 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 20:50:20 +1200 Subject: [PATCH 47/63] alien.marshall.structs: moved struct-wrapper dispose* method to alien.marshall --- basis/alien/marshall/marshall.factor | 2 ++ basis/alien/marshall/structs/structs.factor | 2 -- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index c17a244e35..3fbfb32047 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -25,6 +25,8 @@ GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' ) M: alien-wrapper unmarshall-cast ; M: struct-wrapper unmarshall-cast ; +M: struct-wrapper dispose* underlying>> free ; + : marshall-pointer ( obj -- alien ) { { [ dup alien? ] [ ] } diff --git a/basis/alien/marshall/structs/structs.factor b/basis/alien/marshall/structs/structs.factor index b14d49762b..c3509cf8d7 100644 --- a/basis/alien/marshall/structs/structs.factor +++ b/basis/alien/marshall/structs/structs.factor @@ -6,8 +6,6 @@ kernel libc locals parser quotations sequences slots words alien.structs lexer vocabs.parser fry effects ; IN: alien.marshall.structs -M: struct-wrapper dispose* underlying>> free ; - : define-struct-accessor ( class name quot -- ) [ "accessors" create create-method dup make-inline ] dip define ; From 92e38530a332c1f6a304bab41f9c02d47682b706 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 20:50:52 +1200 Subject: [PATCH 48/63] alien.marshall.structs: made some words private --- basis/alien/marshall/structs/structs.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/alien/marshall/structs/structs.factor b/basis/alien/marshall/structs/structs.factor index c3509cf8d7..54bcab45f2 100644 --- a/basis/alien/marshall/structs/structs.factor +++ b/basis/alien/marshall/structs/structs.factor @@ -6,6 +6,7 @@ kernel libc locals parser quotations sequences slots words alien.structs lexer vocabs.parser fry effects ; IN: alien.marshall.structs +> '[ _ malloc-object >>underlying ] append ] [ name>> 1array ] } cleave { } swap define-declared ; +PRIVATE> :: define-struct-tuple ( name -- ) name create-in :> class From 010af379bb67280e70887882c4a7bcf55d5593b3 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 20:51:32 +1200 Subject: [PATCH 49/63] alien.marshall.structs: added documentation --- .../marshall/structs/structs-docs.factor | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 basis/alien/marshall/structs/structs-docs.factor diff --git a/basis/alien/marshall/structs/structs-docs.factor b/basis/alien/marshall/structs/structs-docs.factor new file mode 100644 index 0000000000..0c5645810e --- /dev/null +++ b/basis/alien/marshall/structs/structs-docs.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: classes help.markup help.syntax kernel quotations words +alien.marshall.structs strings alien.structs alien.marshall ; +IN: alien.marshall.structs + +HELP: define-marshalled-struct +{ $values + { "name" string } { "vocab" "a vocabulary specifier" } { "fields" "an alist" } +} +{ $description "Calls " { $link define-struct } " and " { $link define-struct-tuple } "." } ; + +HELP: define-struct-tuple +{ $values + { "name" string } +} +{ $description "Defines a subclass of " { $link struct-wrapper } ", a constructor, " + "and accessor words." +} ; From 90b7ca501b0d66e22fb4cfbba8bfd79ced1887ef Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 22:32:08 +1200 Subject: [PATCH 50/63] alien.(inline,marshall): removed unused doc helper words and made the rest private --- basis/alien/inline/inline-docs.factor | 2 ++ basis/alien/marshall/marshall-docs.factor | 23 ++++++++--------------- 2 files changed, 10 insertions(+), 15 deletions(-) diff --git a/basis/alien/inline/inline-docs.factor b/basis/alien/inline/inline-docs.factor index 58eca558ea..7f4bd510f4 100644 --- a/basis/alien/inline/inline-docs.factor +++ b/basis/alien/inline/inline-docs.factor @@ -3,10 +3,12 @@ USING: help.markup help.syntax kernel strings effects quotations ; IN: alien.inline + HELP: ;C-LIBRARY { $syntax ";C-LIBRARY" } diff --git a/basis/alien/marshall/marshall-docs.factor b/basis/alien/marshall/marshall-docs.factor index fd1b57579f..6002b0c1c3 100644 --- a/basis/alien/marshall/marshall-docs.factor +++ b/basis/alien/marshall/marshall-docs.factor @@ -4,6 +4,7 @@ USING: help.markup help.syntax kernel quotations sequences strings alien alien.c-types math byte-arrays ; IN: alien.marshall + HELP: ?malloc-byte-array { $values @@ -62,7 +51,9 @@ HELP: marshall-bool* { "?/seq" "t/f or sequence" } { "alien" alien } } -{ $description { $marshall-descr* "bool" } } +{ $description "When the argument is a sequence, returns a pointer to an array of bool, " + "otherwise returns a pointer to a single bool value." +} { $notes { $list $c-ptr-note $memory-note } } ; HELP: marshall-bool** @@ -70,7 +61,9 @@ HELP: marshall-bool** { "seq" sequence } { "alien" alien } } -{ $description { $marshall-descr** "generalized booleans" } } +{ $description "Takes a one or two dimensional array of generalized booleans " + "and returns a pointer to the equivalent C structure." +} { $notes { $list $c-ptr-note $memory-note } } ; HELP: marshall-primitive From 586cf9547f87b5893c11137ddf5c863e4c2a70f8 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 22:33:23 +1200 Subject: [PATCH 51/63] alien.marshall: fixed char* unmarshalling bug --- basis/alien/marshall/marshall.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor index 3fbfb32047..e15cfee746 100644 --- a/basis/alien/marshall/marshall.factor +++ b/basis/alien/marshall/marshall.factor @@ -183,7 +183,7 @@ ALIAS: marshall-void* marshall-pointer { "float" [ [ ] ] } { "double" [ [ ] ] } { "bool*" [ [ unmarshall-bool*-free ] ] } - { "char*" [ [ unmarshall-char*-to-string-free ] ] } + { "char*" [ [ ] ] } { "uchar*" [ [ unmarshall-uchar*-free ] ] } { "short*" [ [ unmarshall-short*-free ] ] } { "ushort*" [ [ unmarshall-ushort*-free ] ] } @@ -196,7 +196,7 @@ ALIAS: marshall-void* marshall-pointer { "float*" [ [ unmarshall-float*-free ] ] } { "double*" [ [ unmarshall-double*-free ] ] } { "bool&" [ [ unmarshall-bool*-free ] ] } - { "char&" [ [ unmarshall-char*-free ] ] } + { "char&" [ [ ] ] } { "uchar&" [ [ unmarshall-uchar*-free ] ] } { "short&" [ [ unmarshall-short*-free ] ] } { "ushort&" [ [ unmarshall-ushort*-free ] ] } @@ -227,7 +227,7 @@ ALIAS: marshall-void* marshall-pointer { "float" [ [ ] ] } { "double" [ [ ] ] } { "bool*" [ [ unmarshall-bool* ] ] } - { "char*" [ [ unmarshall-char*-to-string ] ] } + { "char*" [ [ ] ] } { "uchar*" [ [ unmarshall-uchar* ] ] } { "short*" [ [ unmarshall-short* ] ] } { "ushort*" [ [ unmarshall-ushort* ] ] } From cddc5a31888fc63b777f823e7c2e66c660fb663c Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 22:36:45 +1200 Subject: [PATCH 52/63] alien.marshall.syntax: arg renaming --- basis/alien/marshall/syntax/syntax.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/alien/marshall/syntax/syntax.factor b/basis/alien/marshall/syntax/syntax.factor index 822eb950e9..783e822246 100644 --- a/basis/alien/marshall/syntax/syntax.factor +++ b/basis/alien/marshall/syntax/syntax.factor @@ -6,8 +6,8 @@ quotations sequences words alien.marshall.structs lexer parser vocabs.parser multiline ; IN: alien.marshall.syntax -:: marshalled-function ( function types effect -- word quot effect ) - function types effect factor-function +:: marshalled-function ( name types effect -- word quot effect ) + name types effect factor-function [ in>> ] [ out>> types [ pointer-to-primitive? ] filter append ] bi @@ -22,13 +22,13 @@ IN: alien.marshall.syntax ] [ ] make ] dip ; -: define-c-marshalled ( function types effect body -- ) +: define-c-marshalled ( name types effect body -- ) [ [ marshalled-function define-declared ] [ prototype-string ] 3bi ] dip append-function-body c-strings get push ; -: define-c-marshalled' ( function effect body -- ) +: define-c-marshalled' ( name effect body -- ) [ [ in>> ] keep [ marshalled-function define-declared ] From 48bd9aaacffa875e800d3fbd011c5bfc4a87b549 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 22:36:59 +1200 Subject: [PATCH 53/63] alien.marshall.syntax: added documentation --- .../alien/marshall/syntax/syntax-docs.factor | 85 +++++++++++++++++++ 1 file changed, 85 insertions(+) create mode 100644 basis/alien/marshall/syntax/syntax-docs.factor diff --git a/basis/alien/marshall/syntax/syntax-docs.factor b/basis/alien/marshall/syntax/syntax-docs.factor new file mode 100644 index 0000000000..6b7d6bfa35 --- /dev/null +++ b/basis/alien/marshall/syntax/syntax-docs.factor @@ -0,0 +1,85 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations words +alien.inline alien.syntax effects alien.marshall +alien.marshall.structs strings sequences ; +IN: alien.marshall.syntax + +HELP: CM-FUNCTION: +{ $syntax "CM-FUNCTION: return name args\n body\n;" } +{ $description "Like " { $link POSTPONE: C-FUNCTION: } " but with marshalling " + "of arguments and return values." +} +{ $examples + { $example + "USING: alien.inline alien.marshall.syntax prettyprint ;" + "IN: example" + "" + "C-LIBRARY: exlib" + "" + "C-INCLUDE: " + "CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )" + " *x = a + b;" + " *y = a - b;" + " char* s = (char*) malloc(sizeof(char) * 64);" + " sprintf(s, \"sum %i, diff %i\", *x, *y);" + " return s;" + ";" + "" + ";C-LIBRARY" + "" + "8 5 0 0 sum_diff .s" + "\"sum 13, diff 3\"" + "13" + "3" + } +} +{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ; + +HELP: CM-STRUCTURE: +{ $syntax "CM-STRUCTURE: name fields ... ;" } +{ $description "Like " { $link POSTPONE: C-STRUCTURE: } " but with marshalling of fields. " + "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words." +} +{ $see-also POSTPONE: C-STRUCTURE: POSTPONE: M-STRUCTURE: } ; + +HELP: M-FUNCTION: +{ $syntax "M-FUNCTION: return name args ;" } +{ $description "Like " { $link POSTPONE: FUNCTION: } " but with marshalling " + "of arguments and return values." +} +{ $see-also marshalled-function POSTPONE: C-FUNCTION: POSTPONE: CM-FUNCTION: } ; + +HELP: M-STRUCTURE: +{ $syntax "M-STRUCTURE: name fields ... ;" } +{ $description "Like " { $link POSTPONE: C-STRUCT: } " but with marshalling of fields. " + "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words." +} +{ $see-also define-marshalled-struct POSTPONE: C-STRUCTURE: POSTPONE: CM-STRUCTURE: } ; + +HELP: define-c-marshalled +{ $values + { "name" string } { "types" sequence } { "effect" effect } { "body" string } +} +{ $description "Defines a C function and a factor word which calls it with marshalling of " + "args and return values." +} +{ $see-also define-c-marshalled' } ; + +HELP: define-c-marshalled' +{ $values + { "name" string } { "effect" effect } { "body" string } +} +{ $description "Like " { $link define-c-marshalled } ". " + "The effect elements must be C type strings." +} ; + +HELP: marshalled-function +{ $values + { "name" string } { "types" sequence } { "effect" effect } + { "word" word } { "quot" quotation } { "effect" effect } +} +{ $description "Defines a word which calls the named C function. Arguments, " + "return value, and output parameters are marshalled and unmarshalled." +} ; + From 79dd644e57700f32c69561818b9c83e4e190847a Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 14 Jul 2009 22:39:27 +1200 Subject: [PATCH 54/63] moved alien.inline and alien.marshall to extra --- {basis => extra}/alien/inline/authors.txt | 0 {basis => extra}/alien/inline/compiler/authors.txt | 0 {basis => extra}/alien/inline/compiler/compiler-docs.factor | 0 {basis => extra}/alien/inline/compiler/compiler.factor | 0 {basis => extra}/alien/inline/inline-docs.factor | 0 {basis => extra}/alien/inline/inline-tests.factor | 0 {basis => extra}/alien/inline/inline.factor | 0 {basis => extra}/alien/inline/types/authors.txt | 0 {basis => extra}/alien/inline/types/types.factor | 0 {basis => extra}/alien/marshall/authors.txt | 0 {basis => extra}/alien/marshall/marshall-docs.factor | 0 {basis => extra}/alien/marshall/marshall.factor | 0 {basis => extra}/alien/marshall/private/authors.txt | 0 {basis => extra}/alien/marshall/private/private.factor | 0 {basis => extra}/alien/marshall/structs/authors.txt | 0 {basis => extra}/alien/marshall/structs/structs-docs.factor | 0 {basis => extra}/alien/marshall/structs/structs.factor | 0 {basis => extra}/alien/marshall/syntax/authors.txt | 0 {basis => extra}/alien/marshall/syntax/syntax-docs.factor | 0 {basis => extra}/alien/marshall/syntax/syntax-tests.factor | 0 {basis => extra}/alien/marshall/syntax/syntax.factor | 0 21 files changed, 0 insertions(+), 0 deletions(-) rename {basis => extra}/alien/inline/authors.txt (100%) rename {basis => extra}/alien/inline/compiler/authors.txt (100%) rename {basis => extra}/alien/inline/compiler/compiler-docs.factor (100%) rename {basis => extra}/alien/inline/compiler/compiler.factor (100%) rename {basis => extra}/alien/inline/inline-docs.factor (100%) rename {basis => extra}/alien/inline/inline-tests.factor (100%) rename {basis => extra}/alien/inline/inline.factor (100%) rename {basis => extra}/alien/inline/types/authors.txt (100%) rename {basis => extra}/alien/inline/types/types.factor (100%) rename {basis => extra}/alien/marshall/authors.txt (100%) rename {basis => extra}/alien/marshall/marshall-docs.factor (100%) rename {basis => extra}/alien/marshall/marshall.factor (100%) rename {basis => extra}/alien/marshall/private/authors.txt (100%) rename {basis => extra}/alien/marshall/private/private.factor (100%) rename {basis => extra}/alien/marshall/structs/authors.txt (100%) rename {basis => extra}/alien/marshall/structs/structs-docs.factor (100%) rename {basis => extra}/alien/marshall/structs/structs.factor (100%) rename {basis => extra}/alien/marshall/syntax/authors.txt (100%) rename {basis => extra}/alien/marshall/syntax/syntax-docs.factor (100%) rename {basis => extra}/alien/marshall/syntax/syntax-tests.factor (100%) rename {basis => extra}/alien/marshall/syntax/syntax.factor (100%) diff --git a/basis/alien/inline/authors.txt b/extra/alien/inline/authors.txt similarity index 100% rename from basis/alien/inline/authors.txt rename to extra/alien/inline/authors.txt diff --git a/basis/alien/inline/compiler/authors.txt b/extra/alien/inline/compiler/authors.txt similarity index 100% rename from basis/alien/inline/compiler/authors.txt rename to extra/alien/inline/compiler/authors.txt diff --git a/basis/alien/inline/compiler/compiler-docs.factor b/extra/alien/inline/compiler/compiler-docs.factor similarity index 100% rename from basis/alien/inline/compiler/compiler-docs.factor rename to extra/alien/inline/compiler/compiler-docs.factor diff --git a/basis/alien/inline/compiler/compiler.factor b/extra/alien/inline/compiler/compiler.factor similarity index 100% rename from basis/alien/inline/compiler/compiler.factor rename to extra/alien/inline/compiler/compiler.factor diff --git a/basis/alien/inline/inline-docs.factor b/extra/alien/inline/inline-docs.factor similarity index 100% rename from basis/alien/inline/inline-docs.factor rename to extra/alien/inline/inline-docs.factor diff --git a/basis/alien/inline/inline-tests.factor b/extra/alien/inline/inline-tests.factor similarity index 100% rename from basis/alien/inline/inline-tests.factor rename to extra/alien/inline/inline-tests.factor diff --git a/basis/alien/inline/inline.factor b/extra/alien/inline/inline.factor similarity index 100% rename from basis/alien/inline/inline.factor rename to extra/alien/inline/inline.factor diff --git a/basis/alien/inline/types/authors.txt b/extra/alien/inline/types/authors.txt similarity index 100% rename from basis/alien/inline/types/authors.txt rename to extra/alien/inline/types/authors.txt diff --git a/basis/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor similarity index 100% rename from basis/alien/inline/types/types.factor rename to extra/alien/inline/types/types.factor diff --git a/basis/alien/marshall/authors.txt b/extra/alien/marshall/authors.txt similarity index 100% rename from basis/alien/marshall/authors.txt rename to extra/alien/marshall/authors.txt diff --git a/basis/alien/marshall/marshall-docs.factor b/extra/alien/marshall/marshall-docs.factor similarity index 100% rename from basis/alien/marshall/marshall-docs.factor rename to extra/alien/marshall/marshall-docs.factor diff --git a/basis/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor similarity index 100% rename from basis/alien/marshall/marshall.factor rename to extra/alien/marshall/marshall.factor diff --git a/basis/alien/marshall/private/authors.txt b/extra/alien/marshall/private/authors.txt similarity index 100% rename from basis/alien/marshall/private/authors.txt rename to extra/alien/marshall/private/authors.txt diff --git a/basis/alien/marshall/private/private.factor b/extra/alien/marshall/private/private.factor similarity index 100% rename from basis/alien/marshall/private/private.factor rename to extra/alien/marshall/private/private.factor diff --git a/basis/alien/marshall/structs/authors.txt b/extra/alien/marshall/structs/authors.txt similarity index 100% rename from basis/alien/marshall/structs/authors.txt rename to extra/alien/marshall/structs/authors.txt diff --git a/basis/alien/marshall/structs/structs-docs.factor b/extra/alien/marshall/structs/structs-docs.factor similarity index 100% rename from basis/alien/marshall/structs/structs-docs.factor rename to extra/alien/marshall/structs/structs-docs.factor diff --git a/basis/alien/marshall/structs/structs.factor b/extra/alien/marshall/structs/structs.factor similarity index 100% rename from basis/alien/marshall/structs/structs.factor rename to extra/alien/marshall/structs/structs.factor diff --git a/basis/alien/marshall/syntax/authors.txt b/extra/alien/marshall/syntax/authors.txt similarity index 100% rename from basis/alien/marshall/syntax/authors.txt rename to extra/alien/marshall/syntax/authors.txt diff --git a/basis/alien/marshall/syntax/syntax-docs.factor b/extra/alien/marshall/syntax/syntax-docs.factor similarity index 100% rename from basis/alien/marshall/syntax/syntax-docs.factor rename to extra/alien/marshall/syntax/syntax-docs.factor diff --git a/basis/alien/marshall/syntax/syntax-tests.factor b/extra/alien/marshall/syntax/syntax-tests.factor similarity index 100% rename from basis/alien/marshall/syntax/syntax-tests.factor rename to extra/alien/marshall/syntax/syntax-tests.factor diff --git a/basis/alien/marshall/syntax/syntax.factor b/extra/alien/marshall/syntax/syntax.factor similarity index 100% rename from basis/alien/marshall/syntax/syntax.factor rename to extra/alien/marshall/syntax/syntax.factor From c1ccc6a2b0501984da3b918a8ab9b071b7673528 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 15 Jul 2009 16:40:00 +1200 Subject: [PATCH 55/63] alien.inline: added raw-c word --- extra/alien/inline/inline-docs.factor | 6 ++++-- extra/alien/inline/inline.factor | 6 ++++-- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/extra/alien/inline/inline-docs.factor b/extra/alien/inline/inline-docs.factor index 7f4bd510f4..260644e663 100644 --- a/extra/alien/inline/inline-docs.factor +++ b/extra/alien/inline/inline-docs.factor @@ -106,8 +106,6 @@ HELP: RAW-C: { $syntax "RAW-C:" "body" ";" } { $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ; -CONSTANT: foo "abc" - HELP: compile-c-library { $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". " "Also calls " { $snippet "add-library" } ". " @@ -206,6 +204,10 @@ HELP: with-c-library } { $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ; +HELP: raw-c +{ $values { "str" string } } +{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ; + ARTICLE: "alien.inline" "Inline C" { $vocab-link "alien.inline" } ; diff --git a/extra/alien/inline/inline.factor b/extra/alien/inline/inline.factor index 2514d30873..4582782c41 100644 --- a/extra/alien/inline/inline.factor +++ b/extra/alien/inline/inline.factor @@ -122,6 +122,9 @@ PRIVATE> [ [ define-c-library ] dip call compile-c-library ] [ cleanup-variables ] [ ] cleanup ; inline +: raw-c ( str -- ) + [ "\n" % % "\n" % ] "" make c-strings get push ; + SYNTAX: C-LIBRARY: scan define-c-library ; SYNTAX: COMPILE-AS-C++ t library-is-c++ set ; @@ -146,5 +149,4 @@ SYNTAX: ;C-LIBRARY compile-c-library ; SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ; -SYNTAX: RAW-C: - [ "\n" % parse-here % "\n" % c-strings get push ] "" make ; +SYNTAX: RAW-C: parse-here raw-c ; From 30698cc534164368d816e9a43d1115a7904418bf Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 15 Jul 2009 16:40:41 +1200 Subject: [PATCH 56/63] alien.marshall.types: robustifying --- extra/alien/inline/types/types.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor index bf0a7936ba..b90bde1850 100644 --- a/extra/alien/inline/types/types.factor +++ b/extra/alien/inline/types/types.factor @@ -31,12 +31,13 @@ MEMO: resolved-primitives ( -- seq ) ] [ 2drop f ] recover ; : pointer? ( type -- ? ) - [ "*" tail? ] [ "&" tail? ] bi or ; + factorize-type [ "*" tail? ] [ "&" tail? ] bi or ; : type-sans-pointer ( type -- type' ) - [ '[ _ = ] "*&" swap any? ] trim-tail ; + factorize-type [ '[ _ = ] "*&" swap any? ] trim-tail ; : pointer-to-primitive? ( type -- ? ) + factorize-type { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ; : types-effect>params-return ( types effect -- params return ) From e4fbb978a3aa6121903f19e3cc96e894565af060 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 15 Jul 2009 16:41:06 +1200 Subject: [PATCH 57/63] alien.marshall.types: added pointer-to-non-const-primitive? --- extra/alien/inline/types/types.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/extra/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor index b90bde1850..94b98d1eb5 100644 --- a/extra/alien/inline/types/types.factor +++ b/extra/alien/inline/types/types.factor @@ -40,6 +40,12 @@ MEMO: resolved-primitives ( -- seq ) factorize-type { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ; +: pointer-to-non-const-primitive? ( str -- ? ) + { + [ pointer-to-const? not ] + [ factorize-type pointer-to-primitive? ] + } 1&& ; + : types-effect>params-return ( types effect -- params return ) [ in>> zip ] [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ] From e3a12999939aa844ee4945f6024afa3a6f7c0212 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 15 Jul 2009 16:41:40 +1200 Subject: [PATCH 58/63] alien.marshall: added boolean as bool alias --- extra/alien/marshall/marshall.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index e15cfee746..290e186b36 100644 --- a/extra/alien/marshall/marshall.factor +++ b/extra/alien/marshall/marshall.factor @@ -88,6 +88,7 @@ ALIAS: marshall-void* marshall-pointer : primitive-marshaller ( type -- quot/f ) { { "bool" [ [ marshall-bool ] ] } + { "boolean" [ [ marshall-bool ] ] } { "char" [ [ marshall-primitive ] ] } { "uchar" [ [ marshall-primitive ] ] } { "short" [ [ marshall-primitive ] ] } @@ -101,6 +102,7 @@ ALIAS: marshall-void* marshall-pointer { "float" [ [ marshall-primitive ] ] } { "double" [ [ marshall-primitive ] ] } { "bool*" [ [ marshall-bool* ] ] } + { "boolean*" [ [ marshall-bool* ] ] } { "char*" [ [ marshall-char*-or-string ] ] } { "uchar*" [ [ marshall-uchar* ] ] } { "short*" [ [ marshall-short* ] ] } @@ -114,6 +116,7 @@ ALIAS: marshall-void* marshall-pointer { "float*" [ [ marshall-float* ] ] } { "double*" [ [ marshall-double* ] ] } { "bool&" [ [ marshall-bool* ] ] } + { "boolean&" [ [ marshall-bool* ] ] } { "char&" [ [ marshall-char* ] ] } { "uchar&" [ [ marshall-uchar* ] ] } { "short&" [ [ marshall-short* ] ] } @@ -128,6 +131,7 @@ ALIAS: marshall-void* marshall-pointer { "double&" [ [ marshall-double* ] ] } { "void*" [ [ marshall-void* ] ] } { "bool**" [ [ marshall-bool** ] ] } + { "boolean**" [ [ marshall-bool** ] ] } { "char**" [ [ marshall-char**-or-strings ] ] } { "uchar**" [ [ marshall-uchar** ] ] } { "short**" [ [ marshall-short** ] ] } @@ -170,6 +174,7 @@ ALIAS: marshall-void* marshall-pointer : primitive-unmarshaller ( type -- quot/f ) { { "bool" [ [ unmarshall-bool ] ] } + { "boolean" [ [ unmarshall-bool ] ] } { "char" [ [ ] ] } { "uchar" [ [ ] ] } { "short" [ [ ] ] } @@ -183,6 +188,7 @@ ALIAS: marshall-void* marshall-pointer { "float" [ [ ] ] } { "double" [ [ ] ] } { "bool*" [ [ unmarshall-bool*-free ] ] } + { "boolean*" [ [ unmarshall-bool*-free ] ] } { "char*" [ [ ] ] } { "uchar*" [ [ unmarshall-uchar*-free ] ] } { "short*" [ [ unmarshall-short*-free ] ] } @@ -196,6 +202,7 @@ ALIAS: marshall-void* marshall-pointer { "float*" [ [ unmarshall-float*-free ] ] } { "double*" [ [ unmarshall-double*-free ] ] } { "bool&" [ [ unmarshall-bool*-free ] ] } + { "boolean&" [ [ unmarshall-bool*-free ] ] } { "char&" [ [ ] ] } { "uchar&" [ [ unmarshall-uchar*-free ] ] } { "short&" [ [ unmarshall-short*-free ] ] } @@ -214,6 +221,7 @@ ALIAS: marshall-void* marshall-pointer : struct-primitive-unmarshaller ( type -- quot/f ) { { "bool" [ [ unmarshall-bool ] ] } + { "boolean" [ [ unmarshall-bool ] ] } { "char" [ [ ] ] } { "uchar" [ [ ] ] } { "short" [ [ ] ] } @@ -227,6 +235,7 @@ ALIAS: marshall-void* marshall-pointer { "float" [ [ ] ] } { "double" [ [ ] ] } { "bool*" [ [ unmarshall-bool* ] ] } + { "boolean*" [ [ unmarshall-bool* ] ] } { "char*" [ [ ] ] } { "uchar*" [ [ unmarshall-uchar* ] ] } { "short*" [ [ unmarshall-short* ] ] } @@ -240,6 +249,7 @@ ALIAS: marshall-void* marshall-pointer { "float*" [ [ unmarshall-float* ] ] } { "double*" [ [ unmarshall-double* ] ] } { "bool&" [ [ unmarshall-bool* ] ] } + { "boolean&" [ [ unmarshall-bool* ] ] } { "char&" [ [ unmarshall-char* ] ] } { "uchar&" [ [ unmarshall-uchar* ] ] } { "short&" [ [ unmarshall-short* ] ] } From 0c0ae68c5e37eba4bb04997934ec292a4debba7e Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 15 Jul 2009 16:42:00 +1200 Subject: [PATCH 59/63] alien.marshall: fixed out-arg-unmarshaller --- extra/alien/marshall/marshall.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index 290e186b36..85b157e4a0 100644 --- a/extra/alien/marshall/marshall.factor +++ b/extra/alien/marshall/marshall.factor @@ -298,9 +298,6 @@ ALIAS: marshall-void* marshall-pointer ] if* ; : out-arg-unmarshaller ( type -- quot ) - dup { - [ pointer-to-const? not ] - [ factorize-type pointer-to-primitive? ] - } 1&& + dup pointer-to-non-const-primitive? [ factorize-type primitive-unmarshaller ] [ drop [ drop ] ] if ; From 17e2c9f91cdc029f9e3afd9134b652f91814a6de Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 15 Jul 2009 16:42:45 +1200 Subject: [PATCH 60/63] alien.marshall.private: fix ptr-pass-through --- extra/alien/marshall/private/private.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/alien/marshall/private/private.factor b/extra/alien/marshall/private/private.factor index 8eb3702135..70b03e2bab 100644 --- a/extra/alien/marshall/private/private.factor +++ b/extra/alien/marshall/private/private.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.inline arrays combinators fry functors kernel lexer libc macros math -sequences specialized-arrays.alien libc.private ; +sequences specialized-arrays.alien libc.private +combinators.short-circuit ; IN: alien.marshall.private : bool>arg ( ? -- 1/0/obj ) @@ -16,7 +17,7 @@ MACRO: marshall-x* ( num-quot seq-quot -- alien ) '[ bool>arg dup number? _ _ if ] ; : ptr-pass-through ( obj quot -- alien ) - over c-ptr? [ drop ] [ call ] if ; inline + over { [ c-ptr? ] [ ] } 1&& [ drop ] [ call ] if ; inline : malloc-underlying ( obj -- alien ) underlying>> malloc-byte-array ; From eef0ef9068d4414469664590325aea20a351c08b Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 15 Jul 2009 16:43:19 +1200 Subject: [PATCH 61/63] alien.marshall.syntax: fix marshalled-function --- extra/alien/marshall/syntax/syntax.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/alien/marshall/syntax/syntax.factor b/extra/alien/marshall/syntax/syntax.factor index 783e822246..334343654c 100644 --- a/extra/alien/marshall/syntax/syntax.factor +++ b/extra/alien/marshall/syntax/syntax.factor @@ -9,7 +9,7 @@ IN: alien.marshall.syntax :: marshalled-function ( name types effect -- word quot effect ) name types effect factor-function [ in>> ] - [ out>> types [ pointer-to-primitive? ] filter append ] + [ out>> types [ pointer-to-non-const-primitive? ] filter append ] bi [ [ From 67c7df2653ca81a8b91bbd48f24dfe99f30e0495 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 15 Jul 2009 16:43:42 +1200 Subject: [PATCH 62/63] alien.marshall.syntax: add more tests --- .../alien/marshall/syntax/syntax-tests.factor | 30 ++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/extra/alien/marshall/syntax/syntax-tests.factor b/extra/alien/marshall/syntax/syntax-tests.factor index fe62e6d334..6ea6488167 100644 --- a/extra/alien/marshall/syntax/syntax-tests.factor +++ b/extra/alien/marshall/syntax/syntax-tests.factor @@ -7,12 +7,17 @@ IN: alien.marshall.syntax.tests DELETE-C-LIBRARY: test C-LIBRARY: test +C-INCLUDE: +C-INCLUDE: + +C-TYPEDEF: char bool + CM-FUNCTION: void outarg1 ( int* a ) *a += 2; ; CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b ) - unsigned long* x = (unsigned long*) malloc(sizeof(unsigned long)); + unsigned long* x = malloc(sizeof(unsigned long*)); *b = 10 + *b; *x = a + *b; return x; @@ -33,10 +38,26 @@ CM-FUNCTION: void change_time ( double hours, sundial* d ) d->wedge.degrees = hours * 30; ; +CM-FUNCTION: bool c_not ( bool p ) + return !p; +; + +CM-FUNCTION: char* upcase ( const-char* s ) + int len = strlen(s); + char* t = malloc(sizeof(char) * len); + int i; + for (i = 0; i < len; i++) + t[i] = toupper(s[i]); + t[i] = '\0'; + return t; +; + ;C-LIBRARY { 1 1 } [ outarg1 ] must-infer-as [ 3 ] [ 1 outarg1 ] unit-test +[ 3 ] [ t outarg1 ] unit-test +[ 2 ] [ f outarg1 ] unit-test { 2 2 } [ outarg2 ] must-infer-as [ 18 15 ] [ 3 5 outarg2 ] unit-test @@ -46,3 +67,10 @@ CM-FUNCTION: void change_time ( double hours, sundial* d ) { 2 0 } [ change_time ] must-infer-as [ 150.0 ] [ 5 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test + +{ 1 1 } [ c_not ] must-infer-as +[ f ] [ "x" c_not ] unit-test +[ f ] [ 0 c_not ] unit-test + +{ 1 1 } [ upcase ] must-infer-as +[ "ABC" ] [ "abc" upcase ] unit-test From 28dbb22aeea7cc0409bb61ce82e2c9dc41f81440 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 15 Jul 2009 16:51:44 +1200 Subject: [PATCH 63/63] split alien.inline syntax into alien.inline.syntax --- extra/alien/inline/inline-docs.factor | 102 ------------------ extra/alien/inline/inline.factor | 26 ----- extra/alien/inline/syntax/authors.txt | 1 + extra/alien/inline/syntax/syntax-docs.factor | 100 +++++++++++++++++ .../syntax-tests.factor} | 4 +- extra/alien/inline/syntax/syntax.factor | 31 ++++++ 6 files changed, 134 insertions(+), 130 deletions(-) create mode 100644 extra/alien/inline/syntax/authors.txt create mode 100644 extra/alien/inline/syntax/syntax-docs.factor rename extra/alien/inline/{inline-tests.factor => syntax/syntax-tests.factor} (93%) create mode 100644 extra/alien/inline/syntax/syntax.factor diff --git a/extra/alien/inline/inline-docs.factor b/extra/alien/inline/inline-docs.factor index 260644e663..2c0cd28745 100644 --- a/extra/alien/inline/inline-docs.factor +++ b/extra/alien/inline/inline-docs.factor @@ -10,102 +10,6 @@ IN: alien.inline "Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ; PRIVATE> -HELP: ;C-LIBRARY -{ $syntax ";C-LIBRARY" } -{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." } -{ $see-also POSTPONE: compile-c-library } ; - -HELP: C-FRAMEWORK: -{ $syntax "C-FRAMEWORK: name" } -{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." } -{ $see-also POSTPONE: c-use-framework } ; - -HELP: C-FUNCTION: -{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" } -{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." } -{ $examples - { $example - "USING: alien.inline prettyprint ;" - "IN: cmath.ffi" - "" - "C-LIBRARY: cmathlib" - "" - "C-FUNCTION: int add ( int a, int b )" - " return a + b;" - ";" - "" - ";C-LIBRARY" - "" - "1 2 add ." - "3" } -} -{ $see-also POSTPONE: define-c-function } ; - -HELP: C-INCLUDE: -{ $syntax "C-INCLUDE: name" } -{ $description "Appends an include line to the C library in scope." } -{ $see-also POSTPONE: c-include } ; - -HELP: C-LIBRARY: -{ $syntax "C-LIBRARY: name" } -{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." } -{ $examples - { $example - "USING: alien.inline ;" - "IN: rectangle.ffi" - "" - "C-LIBRARY: rectlib" - "" - "C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;" - "" - "C-FUNCTION: int area ( rectangle c )" - " return c.width * c.height;" - ";" - "" - ";C-LIBRARY" - "" } -} -{ $see-also POSTPONE: define-c-library } ; - -HELP: C-LINK/FRAMEWORK: -{ $syntax "C-LINK/FRAMEWORK: name" } -{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." } -{ $see-also POSTPONE: c-link-to/use-framework } ; - -HELP: C-LINK: -{ $syntax "C-LINK: name" } -{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." } -{ $see-also POSTPONE: c-link-to } ; - -HELP: C-STRUCTURE: -{ $syntax "C-STRUCTURE: name pairs ... ;" } -{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."} -{ $see-also POSTPONE: define-c-struct } ; - -HELP: C-TYPEDEF: -{ $syntax "C-TYPEDEF: old new" } -{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." } -{ $see-also POSTPONE: define-c-typedef } ; - -HELP: COMPILE-AS-C++ -{ $syntax "COMPILE-AS-C++" } -{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ; - -HELP: DELETE-C-LIBRARY: -{ $syntax "DELETE-C-LIBRARY: name" } -{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " } -{ $notes - { $list - { "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } - "This word is mainly useful for unit tests." - } -} -{ $see-also POSTPONE: delete-inline-library } ; - -HELP: RAW-C: -{ $syntax "RAW-C:" "body" ";" } -{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ; - HELP: compile-c-library { $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". " "Also calls " { $snippet "add-library" } ". " @@ -207,9 +111,3 @@ HELP: with-c-library HELP: raw-c { $values { "str" string } } { $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ; - -ARTICLE: "alien.inline" "Inline C" -{ $vocab-link "alien.inline" } -; - -ABOUT: "alien.inline" diff --git a/extra/alien/inline/inline.factor b/extra/alien/inline/inline.factor index 4582782c41..62c6102a86 100644 --- a/extra/alien/inline/inline.factor +++ b/extra/alien/inline/inline.factor @@ -124,29 +124,3 @@ PRIVATE> : raw-c ( str -- ) [ "\n" % % "\n" % ] "" make c-strings get push ; - -SYNTAX: C-LIBRARY: scan define-c-library ; - -SYNTAX: COMPILE-AS-C++ t library-is-c++ set ; - -SYNTAX: C-LINK: scan c-link-to ; - -SYNTAX: C-FRAMEWORK: scan c-use-framework ; - -SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ; - -SYNTAX: C-INCLUDE: scan c-include ; - -SYNTAX: C-FUNCTION: - function-types-effect parse-here define-c-function ; - -SYNTAX: C-TYPEDEF: scan scan define-c-typedef ; - -SYNTAX: C-STRUCTURE: - scan parse-definition define-c-struct ; - -SYNTAX: ;C-LIBRARY compile-c-library ; - -SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ; - -SYNTAX: RAW-C: parse-here raw-c ; diff --git a/extra/alien/inline/syntax/authors.txt b/extra/alien/inline/syntax/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/inline/syntax/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/inline/syntax/syntax-docs.factor b/extra/alien/inline/syntax/syntax-docs.factor new file mode 100644 index 0000000000..2453d98cf6 --- /dev/null +++ b/extra/alien/inline/syntax/syntax-docs.factor @@ -0,0 +1,100 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax alien.inline ; +IN: alien.inline.syntax + +HELP: ;C-LIBRARY +{ $syntax ";C-LIBRARY" } +{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." } +{ $see-also POSTPONE: compile-c-library } ; + +HELP: C-FRAMEWORK: +{ $syntax "C-FRAMEWORK: name" } +{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." } +{ $see-also POSTPONE: c-use-framework } ; + +HELP: C-FUNCTION: +{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" } +{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." } +{ $examples + { $example + "USING: alien.inline prettyprint ;" + "IN: cmath.ffi" + "" + "C-LIBRARY: cmathlib" + "" + "C-FUNCTION: int add ( int a, int b )" + " return a + b;" + ";" + "" + ";C-LIBRARY" + "" + "1 2 add ." + "3" } +} +{ $see-also POSTPONE: define-c-function } ; + +HELP: C-INCLUDE: +{ $syntax "C-INCLUDE: name" } +{ $description "Appends an include line to the C library in scope." } +{ $see-also POSTPONE: c-include } ; + +HELP: C-LIBRARY: +{ $syntax "C-LIBRARY: name" } +{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." } +{ $examples + { $example + "USING: alien.inline ;" + "IN: rectangle.ffi" + "" + "C-LIBRARY: rectlib" + "" + "C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;" + "" + "C-FUNCTION: int area ( rectangle c )" + " return c.width * c.height;" + ";" + "" + ";C-LIBRARY" + "" } +} +{ $see-also POSTPONE: define-c-library } ; + +HELP: C-LINK/FRAMEWORK: +{ $syntax "C-LINK/FRAMEWORK: name" } +{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." } +{ $see-also POSTPONE: c-link-to/use-framework } ; + +HELP: C-LINK: +{ $syntax "C-LINK: name" } +{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." } +{ $see-also POSTPONE: c-link-to } ; + +HELP: C-STRUCTURE: +{ $syntax "C-STRUCTURE: name pairs ... ;" } +{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."} +{ $see-also POSTPONE: define-c-struct } ; + +HELP: C-TYPEDEF: +{ $syntax "C-TYPEDEF: old new" } +{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." } +{ $see-also POSTPONE: define-c-typedef } ; + +HELP: COMPILE-AS-C++ +{ $syntax "COMPILE-AS-C++" } +{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ; + +HELP: DELETE-C-LIBRARY: +{ $syntax "DELETE-C-LIBRARY: name" } +{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " } +{ $notes + { $list + { "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } + "This word is mainly useful for unit tests." + } +} +{ $see-also POSTPONE: delete-inline-library } ; + +HELP: RAW-C: +{ $syntax "RAW-C:" "body" ";" } +{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ; diff --git a/extra/alien/inline/inline-tests.factor b/extra/alien/inline/syntax/syntax-tests.factor similarity index 93% rename from extra/alien/inline/inline-tests.factor rename to extra/alien/inline/syntax/syntax-tests.factor index 09b76a4bb5..e6a0b8b7d8 100644 --- a/extra/alien/inline/inline-tests.factor +++ b/extra/alien/inline/syntax/syntax-tests.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.inline alien.inline.private io.directories io.files +USING: alien.inline alien.inline.syntax io.directories io.files kernel namespaces tools.test alien.c-types alien.structs ; -IN: alien.inline.tests +IN: alien.inline.syntax.tests DELETE-C-LIBRARY: test C-LIBRARY: test diff --git a/extra/alien/inline/syntax/syntax.factor b/extra/alien/inline/syntax/syntax.factor new file mode 100644 index 0000000000..6cef56f9b2 --- /dev/null +++ b/extra/alien/inline/syntax/syntax.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.inline lexer multiline namespaces parser ; +IN: alien.inline.syntax + + +SYNTAX: C-LIBRARY: scan define-c-library ; + +SYNTAX: COMPILE-AS-C++ t library-is-c++ set ; + +SYNTAX: C-LINK: scan c-link-to ; + +SYNTAX: C-FRAMEWORK: scan c-use-framework ; + +SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ; + +SYNTAX: C-INCLUDE: scan c-include ; + +SYNTAX: C-FUNCTION: + function-types-effect parse-here define-c-function ; + +SYNTAX: C-TYPEDEF: scan scan define-c-typedef ; + +SYNTAX: C-STRUCTURE: + scan parse-definition define-c-struct ; + +SYNTAX: ;C-LIBRARY compile-c-library ; + +SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ; + +SYNTAX: RAW-C: parse-here raw-c ;