From 284ef4f0487928ce77cfbbf734a66fe3af274394 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Sat, 4 Jul 2009 15:23:11 +1200
Subject: [PATCH 01/77] 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 ;
+
<PRIVATE
SYMBOL: c-library
SYMBOL: library-is-c++
@@ -34,14 +42,6 @@ SYMBOL: c-strings
CHAR: a swap length CHAR: a + [a,b]
[ 1string ] map ;
-: 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 ;
-
: factor-function ( function types effect -- word quot effect )
annotate-effect [ c-library get ] 3dip
[ [ factorize-type ] map ] dip
From 577420b7ddeeffd7c84f65f6a5c30d27ba7d8b38 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Sun, 5 Jul 2009 17:28:13 +1200
Subject: [PATCH 02/77] 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 ;
-
<PRIVATE
SYMBOL: c-library
SYMBOL: library-is-c++
@@ -48,6 +41,18 @@ SYMBOL: c-strings
types-effect>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 <effect>
+ [
+ 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 -- )
+<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? [
+ [ <TYPE> 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 <jedahu@gmail.com>
Date: Sun, 5 Jul 2009 21:02:19 +1200
Subject: [PATCH 03/77] 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 <jedahu@gmail.com>
Date: Sun, 5 Jul 2009 21:03:36 +1200
Subject: [PATCH 04/77] 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 <jedahu@gmail.com>
Date: Sun, 5 Jul 2009 21:05:17 +1200
Subject: [PATCH 05/77] 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 <effect>
From 9cf0c5e33bf96f38d00c369faef7d10b7b788d70 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Mon, 6 Jul 2009 11:08:47 +1200
Subject: [PATCH 06/77] 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 <jedahu@gmail.com>
Date: Mon, 6 Jul 2009 11:26:17 +1200
Subject: [PATCH 07/77] 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 <effect> ;
-
-
: 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 <effect> ;
From 7ecadf0a6813526628f0d50498c9f2b5ef5155de Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Mon, 6 Jul 2009 11:28:41 +1200
Subject: [PATCH 08/77] 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 ] <effect> 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 ] <effect> 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 <jedahu@gmail.com>
Date: Mon, 6 Jul 2009 11:34:42 +1200
Subject: [PATCH 09/77] 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
-<PRIVATE
SYMBOL: c-library
SYMBOL: library-is-c++
SYMBOL: compiler-args
SYMBOL: c-strings
-: function-types-effect ( -- function types effect )
- scan scan swap ")" parse-tokens
- [ "(" subseq? not ] filter swap parse-arglist ;
-
+<PRIVATE
: arg-list ( types -- params )
CHAR: a swap length CHAR: a + [a,b]
[ 1string ] map ;
-: 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 ;
-
-:: marshalled-function ( function types effect -- word quot effect )
- function types effect annotate-effect factor-function
- [ in>> ]
- [ out>> types [ pointer-to-primitive? ] filter append ]
- bi <effect>
- [
- 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 ] <effect> 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 ] <effect> 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 <effect>
+ [
+ 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 <jedahu@gmail.com>
Date: Mon, 6 Jul 2009 11:55:53 +1200
Subject: [PATCH 10/77] 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 <jedahu@gmail.com>
Date: Tue, 7 Jul 2009 15:49:39 +1200
Subject: [PATCH 11/77] 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 <jedahu@gmail.com>
Date: Tue, 7 Jul 2009 16:04:41 +1200
Subject: [PATCH 12/77] 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 -- )
<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 )
+ [ <TYPE> 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? [
- [ <TYPE> 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 <jedahu@gmail.com>
Date: Tue, 7 Jul 2009 19:41:59 +1200
Subject: [PATCH 13/77] 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 <jedahu@gmail.com>
Date: Tue, 7 Jul 2009 19:43:30 +1200
Subject: [PATCH 14/77] 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 <jedahu@gmail.com>
Date: Tue, 7 Jul 2009 19:44:34 +1200
Subject: [PATCH 15/77] 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 <jedahu@gmail.com>
Date: Tue, 7 Jul 2009 20:51:31 +1200
Subject: [PATCH 16/77] 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 <jedahu@gmail.com>
Date: Tue, 7 Jul 2009 21:11:57 +1200
Subject: [PATCH 17/77] 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 <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 09:29:41 +1200
Subject: [PATCH 18/77] 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 <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 09:30:58 +1200
Subject: [PATCH 19/77] 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 <effect>
[
- 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 <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 09:31:27 +1200
Subject: [PATCH 20/77] 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 <effect>
From 787b5d618a7192da0a7bf852f1eaa831acfd0d72 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 09:33:04 +1200
Subject: [PATCH 21/77] 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 <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 09:33:29 +1200
Subject: [PATCH 22/77] 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 <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 09:39:15 +1200
Subject: [PATCH 23/77] 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 <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 09:39:39 +1200
Subject: [PATCH 24/77] 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 <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 11:30:45 +1200
Subject: [PATCH 25/77] 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 <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 14:00:48 +1200
Subject: [PATCH 26/77] 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 -- )
<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 <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 15:17:00 +1200
Subject: [PATCH 27/77] 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 <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 16:42:25 +1200
Subject: [PATCH 28/77] 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 <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 17:33:21 +1200
Subject: [PATCH 29/77] 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 <jedahu@gmail.com>
Date: Wed, 8 Jul 2009 17:35:17 +1200
Subject: [PATCH 30/77] 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 <jedahu@gmail.com>
Date: Thu, 9 Jul 2009 10:33:54 +1200
Subject: [PATCH 31/77] 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 <jedahu@gmail.com>
Date: Thu, 9 Jul 2009 10:34:41 +1200
Subject: [PATCH 32/77] 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 <jedahu@gmail.com>
Date: Thu, 9 Jul 2009 10:35:18 +1200
Subject: [PATCH 33/77] 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 <effect> 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 <jedahu@gmail.com>
Date: Thu, 9 Jul 2009 10:35:49 +1200
Subject: [PATCH 34/77] 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 <jedahu@gmail.com>
Date: Thu, 9 Jul 2009 10:36:21 +1200
Subject: [PATCH 35/77] 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 <jedahu@gmail.com>
Date: Thu, 9 Jul 2009 10:36:53 +1200
Subject: [PATCH 36/77] 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 ] [ <sundial> <wedge> 150 >>degrees >>wedge hours ] unit-test
+
+{ 2 0 } [ change_time ] must-infer-as
+[ 150.0 ] [ 5 <sundial> <wedge> 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test
From e0c0399d248bc8ee29c92c8d022c6c0cdb27c9b8 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Fri, 10 Jul 2009 12:45:27 +1200
Subject: [PATCH 37/77] 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 b03b76996615a3e984e57b13d523f3901ba4cde1 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Sat, 11 Jul 2009 19:23:21 +1200
Subject: [PATCH 38/77] alien.inline: renamed compiler-args to linker-args
---
basis/alien/inline/inline.factor | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor
index 1df77d6600..1b1820779c 100644
--- a/basis/alien/inline/inline.factor
+++ b/basis/alien/inline/inline.factor
@@ -12,11 +12,11 @@ IN: alien.inline
<PRIVATE
SYMBOL: c-library
SYMBOL: library-is-c++
-SYMBOL: compiler-args
+SYMBOL: linker-args
SYMBOL: c-strings
: cleanup-variables ( -- )
- { c-library library-is-c++ compiler-args c-strings }
+ { c-library library-is-c++ linker-args c-strings }
[ off ] each ;
: function-types-effect ( -- function types effect )
@@ -56,7 +56,7 @@ SYMBOL: c-strings
: compile-library ( -- )
library-is-c++ get [ C++ ] [ C ] if
- compiler-args get
+ linker-args get
c-strings get "\n" join
c-library get compile-to-library ;
@@ -67,7 +67,7 @@ PRIVATE>
: define-c-library ( name -- )
c-library-name c-library set
V{ } clone c-strings set
- V{ } clone compiler-args set ;
+ V{ } clone linker-args set ;
: compile-c-library ( -- )
compile-library? [ compile-library ] when
@@ -87,10 +87,10 @@ PRIVATE>
] dip append-function-body c-strings get push ;
: c-link-to ( str -- )
- "-l" prepend compiler-args get push ;
+ "-l" prepend linker-args get push ;
: c-use-framework ( str -- )
- "-framework" swap compiler-args get '[ _ push ] bi@ ;
+ "-framework" swap linker-args get '[ _ push ] bi@ ;
: c-link-to/use-framework ( str -- )
os macosx? [ c-use-framework ] [ c-link-to ] if ;
From eb72ba84f613ae5e5d3be6d018e33fdf3832558f Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Sat, 11 Jul 2009 19:23:49 +1200
Subject: [PATCH 39/77] alien.inline.compiler: fixed library-path and made
other words private
---
basis/alien/inline/compiler/compiler.factor | 25 ++++++++++++---------
1 file changed, 14 insertions(+), 11 deletions(-)
diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor
index d7d2d6fc43..4abc78ff67 100644
--- a/basis/alien/inline/compiler/compiler.factor
+++ b/basis/alien/inline/compiler/compiler.factor
@@ -22,14 +22,8 @@ SYMBOL: C++
{ [ dup windows? ] [ drop ".dll" ] }
} cond ;
-: library-path ( str -- str' )
- '[ "lib" % _ % library-suffix % ] "" make temp-file ;
-
-: src-suffix ( lang -- str )
- {
- { C [ ".c" ] }
- { C++ [ ".cpp" ] }
- } case ;
+: library-path ( str -- path )
+ '[ "lib" % _ % library-suffix % ] "" make inline-library-file ;
HOOK: compiler os ( lang -- str )
@@ -59,8 +53,16 @@ M: macosx link-descr
{ "-g" "-prebind" "-dynamiclib" "-o" }
cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ;
-: link-command ( in out lang -- descr )
- compiler-descr link-descr append prepend prepend ;
+<PRIVATE
+: src-suffix ( lang -- str )
+ {
+ { C [ ".c" ] }
+ { C++ [ ".cpp" ] }
+ } case ;
+
+: link-command ( args in out lang -- descr )
+ [ 2array ] dip compiler-descr link-descr
+ append prepend prepend ;
:: compile-to-object ( lang contents name -- )
name ".o" append temp-file
@@ -71,8 +73,9 @@ M: macosx link-descr
:: link-object ( lang args name -- )
args name [ library-path ]
- [ ".o" append temp-file ] bi 2array
+ [ ".o" append temp-file ] bi
lang link-command try-process ;
+PRIVATE>
:: compile-to-library ( lang args contents name -- )
lang contents name compile-to-object
From f2380aab7fc0f86fb0ee0f90ffd36d9ba71e76a3 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Sat, 11 Jul 2009 19:24:09 +1200
Subject: [PATCH 40/77] alien.inline.compiler: documentation
---
.../inline/compiler/compiler-docs.factor | 77 +++++++++++++++++++
1 file changed, 77 insertions(+)
create mode 100644 basis/alien/inline/compiler/compiler-docs.factor
diff --git a/basis/alien/inline/compiler/compiler-docs.factor b/basis/alien/inline/compiler/compiler-docs.factor
new file mode 100644
index 0000000000..28e2538e1f
--- /dev/null
+++ b/basis/alien/inline/compiler/compiler-docs.factor
@@ -0,0 +1,77 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings words.symbol sequences ;
+IN: alien.inline.compiler
+
+HELP: C
+{ $var-description "A symbol representing C source." } ;
+
+HELP: C++
+{ $var-description "A symbol representing C++ source." } ;
+
+HELP: compile-to-library
+{ $values
+ { "lang" symbol } { "args" sequence } { "contents" string } { "name" string }
+}
+{ $description "Compiles and links " { $snippet "contents" } " into a shared library called " { $snippet "libname.suffix" }
+ "in " { $snippet "resource:alien-inline-libs" } ". " { $snippet "suffix" } " is OS specific. "
+ { $snippet "args" } " is a sequence of arguments for the linking stage." }
+{ $notes
+ { $list
+ "C and C++ are the only supported languages."
+ { "Source and object files are placed in " { $snippet "resource:temp" } "." } }
+} ;
+
+HELP: compiler
+{ $values
+ { "lang" symbol }
+ { "str" string }
+}
+{ $description "Returns a compiler name based on OS and source language." }
+{ $see-also compiler-descr } ;
+
+HELP: compiler-descr
+{ $values
+ { "lang" symbol }
+ { "descr" "a process description" }
+}
+{ $description "Returns a compiler process description based on OS and source language." }
+{ $see-also compiler } ;
+
+HELP: inline-library-file
+{ $values
+ { "name" string }
+ { "path" "a pathname string" }
+}
+{ $description "Appends " { $snippet "name" } " to the " { $link inline-libs-directory } "." } ;
+
+HELP: inline-libs-directory
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "The directory where libraries created using " { $snippet "alien.inline" } " are stored." } ;
+
+HELP: library-path
+{ $values
+ { "str" string }
+ { "path" "a pathname string" }
+}
+{ $description "Converts " { $snippet "name" } " into a full path to the corresponding inline library." } ;
+
+HELP: library-suffix
+{ $values
+ { "str" string }
+}
+{ $description "The appropriate shared library suffix for the current OS." } ;
+
+HELP: link-descr
+{ $values
+ { "descr" sequence }
+}
+{ $description "Returns part of a process description. OS dependent." } ;
+
+ARTICLE: "alien.inline.compiler" "Inline C compiler"
+{ $vocab-link "alien.inline.compiler" }
+;
+
+ABOUT: "alien.inline.compiler"
From 11183fa5db30cab51c96dc3fbd152265d0d81702 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Sat, 11 Jul 2009 20:50:27 +1200
Subject: [PATCH 41/77] 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 ] <effect> c-function-string ;
+ [ dup arg-list ] <effect> 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 d2077b1670ae61d4cd66996a3b238ec708b9cc15 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Sat, 11 Jul 2009 20:51:34 +1200
Subject: [PATCH 42/77] alien.inline.compiler: changed windows compiler options
---
basis/alien/inline/compiler/compiler.factor | 13 +++++++++++--
1 file changed, 11 insertions(+), 2 deletions(-)
diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor
index 4abc78ff67..bc098ee26b 100644
--- a/basis/alien/inline/compiler/compiler.factor
+++ b/basis/alien/inline/compiler/compiler.factor
@@ -27,24 +27,32 @@ SYMBOL: C++
HOOK: compiler os ( lang -- str )
-M: word compiler ( lang -- str )
+M: word compiler
{
{ C [ "gcc" ] }
{ C++ [ "g++" ] }
} case ;
-M: openbsd compiler ( lang -- str )
+M: openbsd compiler
{
{ C [ "gcc" ] }
{ C++ [ "eg++" ] }
} case ;
+M: windows compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "gcc" ] }
+ } case ;
+
HOOK: compiler-descr os ( lang -- descr )
M: word compiler-descr compiler 1array ;
M: macosx compiler-descr
call-next-method cpu x86.64?
[ { "-arch" "x86_64" } append ] when ;
+M: windows compiler-descr
+ call-next-method { "-x" "c++" } append ;
HOOK: link-descr os ( -- descr )
@@ -52,6 +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" } ;
<PRIVATE
: src-suffix ( lang -- str )
From 2aec1d697c00eda6f0136a8788144a8eae5849b9 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Sat, 11 Jul 2009 20:53:50 +1200
Subject: [PATCH 43/77] 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" } ;
<PRIVATE
: src-suffix ( lang -- str )
From fe4aaad4171af47b18180d4f4e57896b7a4869a7 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Sat, 11 Jul 2009 20:53:50 +1200
Subject: [PATCH 44/77] 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" } ;
<PRIVATE
: src-suffix ( lang -- str )
From 687d5418388199fa27e83e9a426299ef84e9e2a8 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Mon, 13 Jul 2009 10:26:41 +1200
Subject: [PATCH 45/77] 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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 10:20:13 +1200
Subject: [PATCH 46/77] 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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 10:21:32 +1200
Subject: [PATCH 47/77] 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 <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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 10:24:31 +1200
Subject: [PATCH 48/77] alien.marshall: use marshall-primitive instead of
marshall-<primitive> 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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 10:25:34 +1200
Subject: [PATCH 49/77] 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 ;
+<PRIVATE
: (marshall-TYPE*) ( n/seq -- alien )
[ <TYPE> 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 ;
+<PRIVATE
+: (marshall-TYPE**) ( seq -- alien )
+ [ marshall-TYPE* ] void*-array{ } map-as malloc-underlying ;
+PRIVATE>
: 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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 10:26:26 +1200
Subject: [PATCH 50/77] 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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 10:26:45 +1200
Subject: [PATCH 51/77] 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-<prim>*" } " and " { $snippet "unmarshall-<prim>*-free" }
+" for all values of " { $snippet "<prim>" } " 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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 20:50:20 +1200
Subject: [PATCH 52/77] 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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 20:50:52 +1200
Subject: [PATCH 53/77] 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
+<PRIVATE
: define-struct-accessor ( class name quot -- )
[ "accessors" create create-method dup make-inline ] dip define ;
@@ -31,6 +32,7 @@ IN: alien.marshall.structs
[ name>> '[ _ malloc-object >>underlying ] append ]
[ name>> 1array ]
} cleave { } swap <effect> define-declared ;
+PRIVATE>
:: define-struct-tuple ( name -- )
name create-in :> class
From 010af379bb67280e70887882c4a7bcf55d5593b3 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 20:51:32 +1200
Subject: [PATCH 54/77] 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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 22:32:08 +1200
Subject: [PATCH 55/77] 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
+<PRIVATE
: $binding-note ( x -- )
drop
{ "This word requires that certain variables are correctly bound. "
"Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ;
+PRIVATE>
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
+<PRIVATE
: $memory-note ( arg -- )
drop "This word returns a pointer to unmanaged memory."
print-element ;
@@ -15,19 +16,7 @@ IN: alien.marshall
: $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 ;
+PRIVATE>
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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 22:33:23 +1200
Subject: [PATCH 56/77] 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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 22:36:45 +1200
Subject: [PATCH 57/77] 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 <effect>
@@ -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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 22:36:59 +1200
Subject: [PATCH 58/77] 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: <stdio.h>"
+ "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 <jedahu@gmail.com>
Date: Tue, 14 Jul 2009 22:39:27 +1200
Subject: [PATCH 59/77] 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 <jedahu@gmail.com>
Date: Wed, 15 Jul 2009 16:40:00 +1200
Subject: [PATCH 60/77] 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 <jedahu@gmail.com>
Date: Wed, 15 Jul 2009 16:40:41 +1200
Subject: [PATCH 61/77] 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 <jedahu@gmail.com>
Date: Wed, 15 Jul 2009 16:41:06 +1200
Subject: [PATCH 62/77] 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 <jedahu@gmail.com>
Date: Wed, 15 Jul 2009 16:41:40 +1200
Subject: [PATCH 63/77] 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 <jedahu@gmail.com>
Date: Wed, 15 Jul 2009 16:42:00 +1200
Subject: [PATCH 64/77] 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 <jedahu@gmail.com>
Date: Wed, 15 Jul 2009 16:42:45 +1200
Subject: [PATCH 65/77] 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 <jedahu@gmail.com>
Date: Wed, 15 Jul 2009 16:43:19 +1200
Subject: [PATCH 66/77] 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 <effect>
[
[
From 67c7df2653ca81a8b91bbd48f24dfe99f30e0495 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Wed, 15 Jul 2009 16:43:42 +1200
Subject: [PATCH 67/77] 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: <stdlib.h>
+C-INCLUDE: <string.h>
+
+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 <sundial> <wedge> 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 <jedahu@gmail.com>
Date: Wed, 15 Jul 2009 16:51:44 +1200
Subject: [PATCH 68/77] 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 ;
From 267d8d2a8599cee25be84a7337bd136acd7e22d6 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Thu, 16 Jul 2009 17:23:22 +1200
Subject: [PATCH 69/77] alien.marshall.syntax: use alien.inline.syntax vocab
---
extra/alien/marshall/syntax/syntax-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/alien/marshall/syntax/syntax-docs.factor b/extra/alien/marshall/syntax/syntax-docs.factor
index 6b7d6bfa35..c432ec2ad5 100644
--- a/extra/alien/marshall/syntax/syntax-docs.factor
+++ b/extra/alien/marshall/syntax/syntax-docs.factor
@@ -2,7 +2,7 @@
! 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 ;
+alien.marshall.structs strings sequences alien.inline.syntax ;
IN: alien.marshall.syntax
HELP: CM-FUNCTION:
From ee3e84a1f867850ceb7ad907e951d65a55263e29 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Thu, 16 Jul 2009 00:34:50 -0500
Subject: [PATCH 70/77] define-partial-eval framework in propagation pass makes
it easy to add transforms; moving some transforms from stack checker to
propagation, making them stronger
---
.../known-words/known-words.factor | 71 +------
.../tree/propagation/propagation-tests.factor | 25 ++-
.../tree/propagation/transforms/authors.txt | 2 +
.../propagation/transforms/transforms.factor | 195 ++++++++++++++++++
.../transforms/transforms.factor | 94 ---------
5 files changed, 223 insertions(+), 164 deletions(-)
create mode 100644 basis/compiler/tree/propagation/transforms/authors.txt
create mode 100644 basis/compiler/tree/propagation/transforms/transforms.factor
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index aec61608f1..f5ea64bc0a 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -14,7 +14,8 @@ compiler.tree.propagation.nodes
compiler.tree.propagation.slots
compiler.tree.propagation.simple
compiler.tree.propagation.constraints
-compiler.tree.propagation.call-effect ;
+compiler.tree.propagation.call-effect
+compiler.tree.propagation.transforms ;
IN: compiler.tree.propagation.known-words
\ fixnum
@@ -227,39 +228,6 @@ generic-comparison-ops [
] "outputs" set-word-prop
] assoc-each
-: rem-custom-inlining ( #call -- quot/f )
- second value-info literal>> dup integer?
- [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
-
-{
- mod-integer-integer
- mod-integer-fixnum
- mod-fixnum-integer
- fixnum-mod
-} [
- [
- in-d>> dup first value-info interval>> [0,inf] interval-subset?
- [ rem-custom-inlining ] [ drop f ] if
- ] "custom-inlining" set-word-prop
-] each
-
-\ rem [
- in-d>> rem-custom-inlining
-] "custom-inlining" set-word-prop
-
-{
- bitand-integer-integer
- bitand-integer-fixnum
- bitand-fixnum-integer
-} [
- [
- in-d>> second value-info >literal< [
- 0 most-positive-fixnum between?
- [ [ >fixnum ] bi@ fixnum-bitand ] f ?
- ] when
- ] "custom-inlining" set-word-prop
-] each
-
{ numerator denominator }
[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
@@ -314,15 +282,6 @@ generic-comparison-ops [
"outputs" set-word-prop
] each
-! Generate more efficient code for common idiom
-\ clone [
- in-d>> first value-info literal>> {
- { V{ } [ [ drop { } 0 vector boa ] ] }
- { H{ } [ [ drop 0 <hashtable> ] ] }
- [ drop f ]
- } case
-] "custom-inlining" set-word-prop
-
\ slot [
dup literal?>>
[ literal>> swap value-info-slot ] [ 2drop object-info ] if
@@ -346,29 +305,3 @@ generic-comparison-ops [
bi
] [ 2drop object-info ] if
] "outputs" set-word-prop
-
-\ instance? [
- in-d>> second value-info literal>> dup class?
- [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if
-] "custom-inlining" set-word-prop
-
-\ equal? [
- ! If first input has a known type and second input is an
- ! object, we convert this to [ swap equal? ].
- in-d>> first2 value-info class>> object class= [
- value-info class>> \ equal? specific-method
- [ swap equal? ] f ?
- ] [ drop f ] if
-] "custom-inlining" set-word-prop
-
-: inline-new ( class -- quot/f )
- dup tuple-class? [
- dup inlined-dependency depends-on
- [ all-slots [ initial>> literalize ] map ]
- [ tuple-layout '[ _ <tuple-boa> ] ]
- bi append [ drop ] prepend >quotation
- ] [ drop f ] if ;
-
-\ new [
- in-d>> first value-info literal>> inline-new
-] "custom-inlining" set-word-prop
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 108afad296..0a5dbab883 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
specialized-arrays.double system sorting math.libm
-math.intervals quotations ;
+math.intervals quotations effects ;
IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] unit-test
@@ -717,3 +717,26 @@ M: number whatever drop foo ;
: that-thing ( -- class ) foo ;
[ f ] [ [ that-thing new ] { new } inlined? ] unit-test
+
+GENERIC: whatever2 ( x -- y )
+M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ;
+M: f whatever2 ;
+
+[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
+[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
+
+[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
+[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test
+
+[ t ] [ [ { 1 2 3 } memq? ] { memq? } inlined? ] unit-test
+[ f ] [ [ { 1 2 3 } swap memq? ] { memq? } inlined? ] unit-test
+
+[ t ] [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test
+[ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test
+
+[ f ] [ [ instance? ] { instance? } inlined? ] unit-test
+[ f ] [ [ 5 instance? ] { instance? } inlined? ] unit-test
+[ t ] [ [ array instance? ] { instance? } inlined? ] unit-test
+
+[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
+[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
diff --git a/basis/compiler/tree/propagation/transforms/authors.txt b/basis/compiler/tree/propagation/transforms/authors.txt
new file mode 100644
index 0000000000..a44f8d7f8d
--- /dev/null
+++ b/basis/compiler/tree/propagation/transforms/authors.txt
@@ -0,0 +1,2 @@
+Slava Pestov
+Daniel Ehrenberg
diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
new file mode 100644
index 0000000000..1441897b07
--- /dev/null
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -0,0 +1,195 @@
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences words fry generic accessors classes.tuple
+classes classes.algebra definitions stack-checker.state quotations
+classes.tuple.private math math.partial-dispatch math.private
+math.intervals layouts math.order vectors hashtables
+combinators effects generalizations assocs sets
+combinators.short-circuit sequences.private locals
+stack-checker
+compiler.tree.propagation.info ;
+IN: compiler.tree.propagation.transforms
+
+\ equal? [
+ ! If first input has a known type and second input is an
+ ! object, we convert this to [ swap equal? ].
+ in-d>> first2 value-info class>> object class= [
+ value-info class>> \ equal? specific-method
+ [ swap equal? ] f ?
+ ] [ drop f ] if
+] "custom-inlining" set-word-prop
+
+: rem-custom-inlining ( #call -- quot/f )
+ second value-info literal>> dup integer?
+ [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
+
+{
+ mod-integer-integer
+ mod-integer-fixnum
+ mod-fixnum-integer
+ fixnum-mod
+} [
+ [
+ in-d>> dup first value-info interval>> [0,inf] interval-subset?
+ [ rem-custom-inlining ] [ drop f ] if
+ ] "custom-inlining" set-word-prop
+] each
+
+\ rem [
+ in-d>> rem-custom-inlining
+] "custom-inlining" set-word-prop
+
+{
+ bitand-integer-integer
+ bitand-integer-fixnum
+ bitand-fixnum-integer
+} [
+ [
+ in-d>> second value-info >literal< [
+ 0 most-positive-fixnum between?
+ [ [ >fixnum ] bi@ fixnum-bitand ] f ?
+ ] when
+ ] "custom-inlining" set-word-prop
+] each
+
+! Generate more efficient code for common idiom
+\ clone [
+ in-d>> first value-info literal>> {
+ { V{ } [ [ drop { } 0 vector boa ] ] }
+ { H{ } [ [ drop 0 <hashtable> ] ] }
+ [ drop f ]
+ } case
+] "custom-inlining" set-word-prop
+
+: prepare-partial-eval ( #call n -- value-infos ? )
+
+ERROR: bad-partial-eval quot word ;
+
+: check-effect ( quot word -- )
+ 2dup [ infer ] [ stack-effect ] bi* effect<=
+ [ 2drop ] [ bad-partial-eval ] if ;
+
+: values ( #call n -- infos )
+ [ in-d>> ] dip tail* [ value-info ] map ;
+
+:: define-partial-eval ( word quot n -- )
+ word [
+ n values
+ dup [ literal?>> ] all? [
+ [ literal>> ] map
+ n firstn
+ quot call dup [
+ [ n ndrop ] prepose
+ dup word check-effect
+ ] when
+ ] [ drop f ] if
+ ] "custom-inlining" set-word-prop ;
+
+: inline-new ( class -- quot/f )
+ dup tuple-class? [
+ dup inlined-dependency depends-on
+ [ all-slots [ initial>> literalize ] map ]
+ [ tuple-layout '[ _ <tuple-boa> ] ]
+ bi append >quotation
+ ] [ drop f ] if ;
+
+\ new [ inline-new ] 1 define-partial-eval
+
+\ instance? [
+ dup class?
+ [ "predicate" word-prop ] [ drop f ] if
+] 1 define-partial-eval
+
+! Shuffling
+: nths-quot ( indices -- quot )
+ [ [ '[ _ swap nth ] ] map ] [ length ] bi
+ '[ _ cleave _ narray ] ;
+
+\ shuffle [
+ shuffle-mapping nths-quot
+] 1 define-partial-eval
+
+! Index search
+\ index [
+ dup sequence? [
+ dup length 4 >= [
+ dup length zip >hashtable '[ _ at ]
+ ] [ drop f ] if
+ ] [ drop f ] if
+] 1 define-partial-eval
+
+: memq-quot ( seq -- newquot )
+ [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
+ [ drop f ] suffix [ cond ] curry ;
+
+\ memq? [
+ dup sequence? [ memq-quot ] [ drop f ] if
+] 1 define-partial-eval
+
+! Membership testing
+: member-quot ( seq -- newquot )
+ dup length 4 <= [
+ [ drop f ] swap
+ [ literalize [ t ] ] { } map>assoc linear-case-quot
+ ] [
+ unique [ key? ] curry
+ ] if ;
+
+\ member? [
+ dup sequence? [ member-quot ] [ drop f ] if
+] 1 define-partial-eval
+
+! Fast at for integer maps
+CONSTANT: lookup-table-at-max 256
+
+: lookup-table-at? ( assoc -- ? )
+ #! Can we use a fast byte array test here?
+ {
+ [ assoc-size 4 > ]
+ [ values [ ] all? ]
+ [ keys [ integer? ] all? ]
+ [ keys [ 0 lookup-table-at-max between? ] all? ]
+ } 1&& ;
+
+: lookup-table-seq ( assoc -- table )
+ [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
+
+: lookup-table-quot ( seq -- newquot )
+ lookup-table-seq
+ '[
+ _ over integer? [
+ 2dup bounds-check? [
+ nth-unsafe dup >boolean
+ ] [ 2drop f f ] if
+ ] [ 2drop f f ] if
+ ] ;
+
+: fast-lookup-table-at? ( assoc -- ? )
+ values {
+ [ [ integer? ] all? ]
+ [ [ 0 254 between? ] all? ]
+ } 1&& ;
+
+: fast-lookup-table-seq ( assoc -- table )
+ lookup-table-seq [ 255 or ] B{ } map-as ;
+
+: fast-lookup-table-quot ( seq -- newquot )
+ fast-lookup-table-seq
+ '[
+ _ over integer? [
+ 2dup bounds-check? [
+ nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
+ ] [ 2drop f f ] if
+ ] [ 2drop f f ] if
+ ] ;
+
+: at-quot ( assoc -- quot )
+ dup lookup-table-at? [
+ dup fast-lookup-table-at? [
+ fast-lookup-table-quot
+ ] [
+ lookup-table-quot
+ ] if
+ ] [ drop f ] if ;
+
+\ at* [ at-quot ] 1 define-partial-eval
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index 9d1ab1332a..056eda8b61 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -107,97 +107,3 @@ IN: stack-checker.transforms
] 1 define-transform
\ boa t "no-compile" set-word-prop
-
-! Fast at for integer maps
-CONSTANT: lookup-table-at-max 256
-
-: lookup-table-at? ( assoc -- ? )
- #! Can we use a fast byte array test here?
- {
- [ assoc-size 4 > ]
- [ values [ ] all? ]
- [ keys [ integer? ] all? ]
- [ keys [ 0 lookup-table-at-max between? ] all? ]
- } 1&& ;
-
-: lookup-table-seq ( assoc -- table )
- [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
-
-: lookup-table-quot ( seq -- newquot )
- lookup-table-seq
- '[
- _ over integer? [
- 2dup bounds-check? [
- nth-unsafe dup >boolean
- ] [ 2drop f f ] if
- ] [ 2drop f f ] if
- ] ;
-
-: fast-lookup-table-at? ( assoc -- ? )
- values {
- [ [ integer? ] all? ]
- [ [ 0 254 between? ] all? ]
- } 1&& ;
-
-: fast-lookup-table-seq ( assoc -- table )
- lookup-table-seq [ 255 or ] B{ } map-as ;
-
-: fast-lookup-table-quot ( seq -- newquot )
- fast-lookup-table-seq
- '[
- _ over integer? [
- 2dup bounds-check? [
- nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
- ] [ 2drop f f ] if
- ] [ 2drop f f ] if
- ] ;
-
-: at-quot ( assoc -- quot )
- dup lookup-table-at? [
- dup fast-lookup-table-at? [
- fast-lookup-table-quot
- ] [
- lookup-table-quot
- ] if
- ] [ drop f ] if ;
-
-\ at* [ at-quot ] 1 define-transform
-
-! Membership testing
-: member-quot ( seq -- newquot )
- dup length 4 <= [
- [ drop f ] swap
- [ literalize [ t ] ] { } map>assoc linear-case-quot
- ] [
- unique [ key? ] curry
- ] if ;
-
-\ member? [
- dup sequence? [ member-quot ] [ drop f ] if
-] 1 define-transform
-
-: memq-quot ( seq -- newquot )
- [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
- [ drop f ] suffix [ cond ] curry ;
-
-\ memq? [
- dup sequence? [ memq-quot ] [ drop f ] if
-] 1 define-transform
-
-! Index search
-\ index [
- dup sequence? [
- dup length 4 >= [
- dup length zip >hashtable '[ _ at ]
- ] [ drop f ] if
- ] [ drop f ] if
-] 1 define-transform
-
-! Shuffling
-: nths-quot ( indices -- quot )
- [ [ '[ _ swap nth ] ] map ] [ length ] bi
- '[ _ cleave _ narray ] ;
-
-\ shuffle [
- shuffle-mapping nths-quot
-] 1 define-transform
From 062e33f8fbbf45aa49413ff9b1d5a5ca1b9db933 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Thu, 16 Jul 2009 00:43:54 -0500
Subject: [PATCH 71/77] fixing stupid bug in propagation
---
.../tree/propagation/transforms/transforms.factor | 8 ++------
1 file changed, 2 insertions(+), 6 deletions(-)
diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
index 1441897b07..60f1db5093 100644
--- a/basis/compiler/tree/propagation/transforms/transforms.factor
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -61,20 +61,16 @@ IN: compiler.tree.propagation.transforms
} case
] "custom-inlining" set-word-prop
-: prepare-partial-eval ( #call n -- value-infos ? )
-
ERROR: bad-partial-eval quot word ;
: check-effect ( quot word -- )
2dup [ infer ] [ stack-effect ] bi* effect<=
[ 2drop ] [ bad-partial-eval ] if ;
-: values ( #call n -- infos )
- [ in-d>> ] dip tail* [ value-info ] map ;
-
:: define-partial-eval ( word quot n -- )
word [
- n values
+ in-d>> n tail*
+ [ value-info ] map
dup [ literal?>> ] all? [
[ literal>> ] map
n firstn
From 9f926ab88cd2388d7e7a3b9c55bac9cd4e628a39 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Thu, 16 Jul 2009 02:17:58 -0500
Subject: [PATCH 72/77] compiler.cfg.block-joining: join basic blocks connected
by a single edge to improve effectiveness of local optimizations
---
.../cfg/block-joining/block-joining.factor | 44 +++++++++++++++++++
.../cfg/instructions/instructions.factor | 22 ++++++++++
basis/compiler/cfg/optimizer/optimizer.factor | 3 ++
basis/compiler/cfg/tco/tco.factor | 3 +-
basis/compiler/utilities/utilities.factor | 4 +-
5 files changed, 73 insertions(+), 3 deletions(-)
create mode 100644 basis/compiler/cfg/block-joining/block-joining.factor
diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor
new file mode 100644
index 0000000000..39d9a64c41
--- /dev/null
+++ b/basis/compiler/cfg/block-joining/block-joining.factor
@@ -0,0 +1,44 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel sequences math
+compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.utilities ;
+IN: compiler.cfg.block-joining
+
+! Joining blocks that are not calls and are connected by a single CFG edge.
+! Predecessors must be recomputed after this. Also this pass does not
+! update ##phi nodes and should therefore only run before stack analysis.
+
+: kill-vreg-block? ( bb -- ? )
+ instructions>> {
+ [ length 2 >= ]
+ [ penultimate kill-vreg-insn? ]
+ } 1&& ;
+
+: predecessor ( bb -- pred )
+ predecessors>> first ; inline
+
+: join-block? ( bb -- ? )
+ {
+ [ kill-vreg-block? not ]
+ [ predecessors>> length 1 = ]
+ [ predecessor kill-vreg-block? not ]
+ [ predecessor successors>> length 1 = ]
+ [ [ predecessor ] keep back-edge? not ]
+ } 1&& ;
+
+: join-instructions ( bb pred -- )
+ [ instructions>> ] bi@ dup pop* push-all ;
+
+: update-successors ( bb pred -- )
+ [ successors>> ] dip (>>successors) ;
+
+: join-block ( bb pred -- )
+ [ join-instructions ] [ update-successors ] 2bi ;
+
+: join-blocks ( cfg -- cfg' )
+ dup post-order [
+ dup join-block?
+ [ dup predecessor join-block ] [ drop ] if
+ ] each
+ cfg-changed ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 910cb1992b..2f2668df8b 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -223,3 +223,25 @@ INSN: _reload dst class n ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ;
+! Instructions that poison the stack state
+UNION: poison-insn
+ ##jump
+ ##return
+ ##callback-return
+ ##fixnum-mul-tail
+ ##fixnum-add-tail
+ ##fixnum-sub-tail ;
+
+! Instructions that kill all live vregs
+UNION: kill-vreg-insn
+ poison-insn
+ ##stack-frame
+ ##call
+ ##prologue
+ ##epilogue
+ ##fixnum-mul
+ ##fixnum-add
+ ##fixnum-sub
+ ##alien-invoke
+ ##alien-indirect
+ ##alien-callback ;
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index e16fb734e1..1af0fcbc53 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -6,6 +6,7 @@ compiler.cfg.predecessors
compiler.cfg.useless-conditionals
compiler.cfg.stack-analysis
compiler.cfg.branch-splitting
+compiler.cfg.block-joining
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.dce
@@ -31,6 +32,8 @@ SYMBOL: check-optimizer?
delete-useless-conditionals
compute-predecessors
split-branches
+ join-blocks
+ compute-predecessors
stack-analysis
compute-liveness
alias-analysis
diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor
index 5fa2e1b042..8be9c15b04 100644
--- a/basis/compiler/cfg/tco/tco.factor
+++ b/basis/compiler/cfg/tco/tco.factor
@@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel math
namespaces sequences fry combinators
+compiler.utilities
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
@@ -19,8 +20,6 @@ IN: compiler.cfg.tco
[ second ##return? ]
} 1&& ;
-: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
-
: tail-call? ( bb -- ? )
{
[ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ]
diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor
index ac276b6e41..c21be39adb 100644
--- a/basis/compiler/utilities/utilities.factor
+++ b/basis/compiler/utilities/utilities.factor
@@ -27,4 +27,6 @@ SYMBOL: yield-hook
yield-hook [ [ ] ] initialize
: alist-max ( alist -- pair )
- [ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
\ No newline at end of file
+ [ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
+
+: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
From 884e41dd9c0d18c794a3e61a2a4da36ca59a734e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Thu, 16 Jul 2009 02:42:01 -0500
Subject: [PATCH 73/77] compiler.cfg.linear-scan.live-intervals: remove bogus
assertion
---
.../linear-scan/live-intervals/live-intervals.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index bf7e8bc042..d2fa661136 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -122,10 +122,10 @@ M: ##copy-float compute-live-intervals*
dup ranges>> [ first from>> ] [ last to>> ] bi
[ >>start ] [ >>end ] bi* drop ;
-: check-start/end ( live-interval -- )
- [ [ start>> ] [ uses>> first ] bi assert= ]
- [ [ end>> ] [ uses>> last ] bi assert= ]
- bi ;
+ERROR: bad-live-interval live-interval ;
+
+: check-start ( live-interval -- )
+ dup start>> -1 = [ bad-live-interval ] [ drop ] if ;
: finish-live-intervals ( live-intervals -- )
! Since live intervals are computed in a backward order, we have
@@ -135,7 +135,7 @@ M: ##copy-float compute-live-intervals*
[ ranges>> reverse-here ]
[ uses>> reverse-here ]
[ compute-start/end ]
- [ check-start/end ]
+ [ check-start ]
} cleave
] each ;
From 7596b3288c82e99fcc485664843abd327d8382c7 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Thu, 16 Jul 2009 19:55:08 +1200
Subject: [PATCH 74/77] alien.marshall.syntax-tests: use alien.inline.syntax
vocab
---
extra/alien/marshall/syntax/syntax-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/alien/marshall/syntax/syntax-tests.factor b/extra/alien/marshall/syntax/syntax-tests.factor
index 6ea6488167..3945924a57 100644
--- a/extra/alien/marshall/syntax/syntax-tests.factor
+++ b/extra/alien/marshall/syntax/syntax-tests.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.inline alien.marshall.syntax destructors
+USING: alien.inline.syntax alien.marshall.syntax destructors
tools.test accessors kernel ;
IN: alien.marshall.syntax.tests
From 5ae07b3168fa4f010a14dd15d800bed5501c59fb Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Thu, 16 Jul 2009 19:57:47 +1200
Subject: [PATCH 75/77] help lint fixes
---
extra/alien/inline/syntax/syntax-docs.factor | 4 ++--
extra/alien/marshall/syntax/syntax-docs.factor | 2 +-
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/alien/inline/syntax/syntax-docs.factor b/extra/alien/inline/syntax/syntax-docs.factor
index 2453d98cf6..0fc5a5140b 100644
--- a/extra/alien/inline/syntax/syntax-docs.factor
+++ b/extra/alien/inline/syntax/syntax-docs.factor
@@ -18,7 +18,7 @@ HELP: C-FUNCTION:
{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
{ $examples
{ $example
- "USING: alien.inline prettyprint ;"
+ "USING: alien.inline.syntax prettyprint ;"
"IN: cmath.ffi"
""
"C-LIBRARY: cmathlib"
@@ -44,7 +44,7 @@ HELP: C-LIBRARY:
{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
{ $examples
{ $example
- "USING: alien.inline ;"
+ "USING: alien.inline.syntax ;"
"IN: rectangle.ffi"
""
"C-LIBRARY: rectlib"
diff --git a/extra/alien/marshall/syntax/syntax-docs.factor b/extra/alien/marshall/syntax/syntax-docs.factor
index c432ec2ad5..864ae92c29 100644
--- a/extra/alien/marshall/syntax/syntax-docs.factor
+++ b/extra/alien/marshall/syntax/syntax-docs.factor
@@ -12,7 +12,7 @@ HELP: CM-FUNCTION:
}
{ $examples
{ $example
- "USING: alien.inline alien.marshall.syntax prettyprint ;"
+ "USING: alien.inline.syntax alien.marshall.syntax prettyprint ;"
"IN: example"
""
"C-LIBRARY: exlib"
From 8c892380fe658a24524f4ec8fb7e9372c37eebcd Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Thu, 16 Jul 2009 20:22:41 +1200
Subject: [PATCH 76/77] alien.marshall.syntax: fixed CM-FUNCTION: example
---
extra/alien/marshall/syntax/syntax-docs.factor | 6 ++----
1 file changed, 2 insertions(+), 4 deletions(-)
diff --git a/extra/alien/marshall/syntax/syntax-docs.factor b/extra/alien/marshall/syntax/syntax-docs.factor
index 864ae92c29..401934e736 100644
--- a/extra/alien/marshall/syntax/syntax-docs.factor
+++ b/extra/alien/marshall/syntax/syntax-docs.factor
@@ -28,10 +28,8 @@ HELP: CM-FUNCTION:
""
";C-LIBRARY"
""
- "8 5 0 0 sum_diff .s"
- "\"sum 13, diff 3\""
- "13"
- "3"
+ "8 5 0 0 sum_diff . . ."
+ "3\n13\n\"sum 13, diff 3\""
}
}
{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ;
From 4931ab0d5fa05c0a35f5be016d73a6d93c0f5683 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Thu, 16 Jul 2009 03:30:11 -0500
Subject: [PATCH 77/77] benchmark: run each benchmark 5 times and take the best
time
---
extra/benchmark/benchmark.factor | 8 ++++++--
1 file changed, 6 insertions(+), 2 deletions(-)
diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor
index ca71e22e9f..23809f2744 100755
--- a/extra/benchmark/benchmark.factor
+++ b/extra/benchmark/benchmark.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time vocabs.hierarchy
arrays assocs io.styles io help.markup prettyprint sequences
-continuations debugger math namespaces memory ;
+continuations debugger math namespaces memory fry ;
IN: benchmark
<PRIVATE
@@ -12,9 +12,12 @@ SYMBOL: errors
PRIVATE>
+: (run-benchmark) ( vocab -- time )
+ [ 5 ] dip '[ gc [ _ run ] benchmark ] replicate infimum ;
+
: run-benchmark ( vocab -- )
[ "=== " write print flush ] [
- [ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ]
+ [ [ require ] [ (run-benchmark) ] [ ] tri timings ]
[ swap errors ]
recover get set-at
] bi ;
@@ -24,6 +27,7 @@ PRIVATE>
V{ } clone timings set
V{ } clone errors set
"benchmark" child-vocab-names
+ [ find-vocab-root ] filter
[ run-benchmark ] each
timings get
errors get