From 2936f05ce004df8e601e1a8d3202eb3174ac7eca Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Aug 2009 04:38:59 -0500
Subject: [PATCH 01/15] add smart-if to combinators.smart
---
basis/combinators/smart/smart.factor | 8 +++++++-
1 file changed, 7 insertions(+), 1 deletion(-)
diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor
index 751a1f52e1..604d2cc8e4 100644
--- a/basis/combinators/smart/smart.factor
+++ b/basis/combinators/smart/smart.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry generalizations kernel macros math.order
-stack-checker math ;
+stack-checker math sequences ;
IN: combinators.smart
MACRO: drop-outputs ( quot -- quot' )
@@ -39,3 +39,9 @@ MACRO: append-outputs-as ( quot exemplar -- newquot )
MACRO: append-outputs ( quot -- seq )
'[ _ { } append-outputs-as ] ;
+
+MACRO: preserving ( quot -- )
+ [ infer in>> length ] keep '[ _ ndup @ ] ;
+
+MACRO: smart-if ( pred true false -- )
+ '[ _ preserving _ _ if ] ; inline
From 06d9e1d46da6fed433c1d4ff801831d5cf5040d3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Aug 2009 04:41:33 -0500
Subject: [PATCH 02/15] clarify docs
---
basis/multiline/multiline-docs.factor | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/basis/multiline/multiline-docs.factor b/basis/multiline/multiline-docs.factor
index fd91c440d7..3616c0976c 100644
--- a/basis/multiline/multiline-docs.factor
+++ b/basis/multiline/multiline-docs.factor
@@ -21,7 +21,7 @@ HELP: /*
HELP: HEREDOC:
{ $syntax "HEREDOC: marker\n...text...\nmarker" }
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
-{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: HEREDOC: } " until the end of the line containing the " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." }
+{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after " { $link POSTPONE: HEREDOC: } " until the end of the line containing " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." }
{ $warning "Whitespace is significant." }
{ $examples
{ $example "USING: multiline prettyprint ;"
@@ -37,7 +37,8 @@ HELP: HEREDOC:
HELP: DELIMITED:
{ $syntax "DELIMITED: marker\n...text...\nmarker" }
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
-{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: DELIMITED: } " until the end of the line containing the " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." }
+{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after " { $link POSTPONE: DELIMITED: } " until the end of the line containing " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." }
+{ $warning "Whitespace is significant on the " { $link POSTPONE: DELIMITED: } " line." }
{ $examples
{ $example "USING: multiline prettyprint ;"
"DELIMITED: factor blows my mind"
From 3313098936293a914b99840f16f56a0d6e1566f3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Aug 2009 08:21:45 -0500
Subject: [PATCH 03/15] use iota
---
core/classes/tuple/tuple.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 0a437a3d69..4609642765 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -69,7 +69,7 @@ GENERIC: slots>tuple ( seq class -- tuple )
M: tuple-class slots>tuple ( seq class -- tuple )
check-slots pad-slots
tuple-layout <tuple> [
- [ tuple-size ]
+ [ tuple-size iota ]
[ [ set-array-nth ] curry ]
bi 2each
] keep ;
From fadede137cb2eeeb5fb67c9592bcca63ce592013 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Aug 2009 08:27:28 -0500
Subject: [PATCH 04/15] use iota
---
core/classes/tuple/tuple.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 4609642765..5f24417c4b 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -35,7 +35,7 @@ M: tuple class layout-of 2 slot { word } declare ; inline
layout-of 3 slot { fixnum } declare ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
- check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
+ check-tuple [ tuple-size iota ] [ ] [ layout-of ] tri ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
From 346636ed3bb5455a6ff5d434b3c9f10b8e1903bf Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Aug 2009 09:53:13 -0500
Subject: [PATCH 05/15] use iota in generalizaions
---
basis/generalizations/generalizations.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
index e7b3ee8252..b2d6b06697 100644
--- a/basis/generalizations/generalizations.factor
+++ b/basis/generalizations/generalizations.factor
@@ -15,7 +15,7 @@ IN: generalizations
MACRO: nsequence ( n seq -- )
[
- [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
+ [ drop iota <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep
'[ @ _ like ] ;
@@ -27,7 +27,7 @@ MACRO: nsum ( n -- )
1 - [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- )
- [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
+ iota [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
@@ -94,7 +94,7 @@ MACRO: mnswap ( m n -- )
1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
MACRO: nweave ( n -- )
- [ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
+ [ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ;
MACRO: nbi-curry ( n -- )
From a6c7e9d9d427eb42657e4135aee2df6ef1358d85 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 22 Aug 2009 20:56:16 -0400
Subject: [PATCH 06/15] use iota in a couple of places
---
core/sequences/sequences-tests.factor | 2 +-
core/sequences/sequences.factor | 4 ++--
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index 2aa95b23ab..e36bfaf9d2 100644
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -293,4 +293,4 @@ USE: make
[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
[ t ] [ 0 array-capacity? ] unit-test
-[ f ] [ -1 array-capacity? ] unit-test
\ No newline at end of file
+[ f ] [ -1 array-capacity? ] unit-test
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 031d5f7b4a..177a157994 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -919,7 +919,7 @@ PRIVATE>
<PRIVATE
: generic-flip ( matrix -- newmatrix )
- [ dup first length [ length min ] reduce ] keep
+ [ dup first length [ length min ] reduce iota ] keep
[ [ nth-unsafe ] with { } map-as ] curry { } map-as ; inline
USE: arrays
@@ -929,7 +929,7 @@ USE: arrays
: array-flip ( matrix -- newmatrix )
{ array } declare
- [ dup first array-length [ array-length min ] reduce ] keep
+ [ dup first array-length [ array-length min ] reduce iota ] keep
[ [ { array } declare array-nth ] with { } map-as ] curry { } map-as ;
PRIVATE>
From 679a7c9b01b5a5760ce0514870a5db89eaea3309 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 22 Aug 2009 20:56:28 -0400
Subject: [PATCH 07/15] temporary fix for core/effects
---
core/effects/effects.factor | 19 ++++++++++++-------
1 file changed, 12 insertions(+), 7 deletions(-)
diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index cab1e531b7..5cbb0fe36e 100644
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -6,25 +6,29 @@ IN: effects
TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
+GENERIC: effect-length ( obj -- n )
+M: sequence effect-length length ;
+M: integer effect-length ;
+
: <effect> ( in out -- effect )
dup { "*" } sequence= [ drop { } t ] [ f ] if
effect boa ;
: effect-height ( effect -- n )
- [ out>> length ] [ in>> length ] bi - ; inline
+ [ out>> effect-length ] [ in>> effect-length ] bi - ; inline
: effect<= ( effect1 effect2 -- ? )
{
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
- { [ 2dup [ in>> length ] bi@ > ] [ f ] }
+ { [ 2dup [ in>> effect-length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ; inline
: effect= ( effect1 effect2 -- ? )
- [ [ in>> length ] bi@ = ]
- [ [ out>> length ] bi@ = ]
+ [ [ in>> effect-length ] bi@ = ]
+ [ [ out>> effect-length ] bi@ = ]
[ [ terminated?>> ] bi@ = ]
2tri and and ;
@@ -62,7 +66,7 @@ M: effect clone
stack-effect effect-height ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
- in>> length cut* ;
+ in>> effect-length cut* ;
: shuffle-mapping ( effect -- mapping )
[ out>> ] [ in>> ] bi [ index ] curry map ;
@@ -77,8 +81,9 @@ M: effect clone
over terminated?>> [
drop
] [
- [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
- [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
+ [ [ [ in>> effect-length ] [ out>> effect-length ] bi ] [ in>> effect-length ] bi* swap [-] + ]
+ [ [ out>> effect-length ] [ [ in>> effect-length ] [ out>> effect-length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri
+ [ [ [ "obj" ] replicate ] bi@ ] dip
effect boa
] if ; inline
From 87a6e9cb3170f5862ca898949f6b5cbf1adf101c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 22 Aug 2009 20:59:36 -0400
Subject: [PATCH 08/15] use iota in replicate
---
core/sequences/sequences.factor | 9 +++++----
1 file changed, 5 insertions(+), 4 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 177a157994..de2435c292 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -99,10 +99,10 @@ M: f like drop [ f ] when-empty ; inline
INSTANCE: f immutable-sequence
! Integers support the sequence protocol
-M: integer length ; inline
-M: integer nth-unsafe drop ; inline
+! M: integer length ; inline
+! M: integer nth-unsafe drop ; inline
-INSTANCE: integer immutable-sequence
+! INSTANCE: integer immutable-sequence
PRIVATE>
@@ -424,9 +424,10 @@ PRIVATE>
over map-as ; inline
: replicate ( seq quot -- newseq )
- [ drop ] prepose map ; inline
+ [ iota ] dip [ drop ] prepose map ; inline
: replicate-as ( seq quot exemplar -- newseq )
+ [ iota ] 2dip
[ [ drop ] prepose ] dip map-as ; inline
: change-each ( seq quot -- )
From 7b7f22fae2c20017e8d88f6dbaa91af89f086600 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 22 Aug 2009 20:59:56 -0400
Subject: [PATCH 09/15] Revert "use iota in replicate"
This reverts commit 88d1f0d78a55a2e86070509a33796ebf4afda9b8.
---
core/sequences/sequences.factor | 9 ++++-----
1 file changed, 4 insertions(+), 5 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index de2435c292..177a157994 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -99,10 +99,10 @@ M: f like drop [ f ] when-empty ; inline
INSTANCE: f immutable-sequence
! Integers support the sequence protocol
-! M: integer length ; inline
-! M: integer nth-unsafe drop ; inline
+M: integer length ; inline
+M: integer nth-unsafe drop ; inline
-! INSTANCE: integer immutable-sequence
+INSTANCE: integer immutable-sequence
PRIVATE>
@@ -424,10 +424,9 @@ PRIVATE>
over map-as ; inline
: replicate ( seq quot -- newseq )
- [ iota ] dip [ drop ] prepose map ; inline
+ [ drop ] prepose map ; inline
: replicate-as ( seq quot exemplar -- newseq )
- [ iota ] 2dip
[ [ drop ] prepose ] dip map-as ; inline
: change-each ( seq quot -- )
From 3dce2eda1972ed187fd9794c774843b3a37d70e2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 22 Aug 2009 21:00:18 -0400
Subject: [PATCH 10/15] use iota in replicate
---
core/sequences/sequences.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 177a157994..281290c3d2 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -424,9 +424,11 @@ PRIVATE>
over map-as ; inline
: replicate ( seq quot -- newseq )
+ [ iota ] dip
[ drop ] prepose map ; inline
: replicate-as ( seq quot exemplar -- newseq )
+ [ iota ] 2dip
[ [ drop ] prepose ] dip map-as ; inline
: change-each ( seq quot -- )
From bea1e3732efa3ea336042ead036190718ea74c0c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 23 Aug 2009 01:00:46 -0400
Subject: [PATCH 11/15] revert replicate change again...the world is not ready
---
core/sequences/sequences.factor | 2 --
1 file changed, 2 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 281290c3d2..177a157994 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -424,11 +424,9 @@ PRIVATE>
over map-as ; inline
: replicate ( seq quot -- newseq )
- [ iota ] dip
[ drop ] prepose map ; inline
: replicate-as ( seq quot exemplar -- newseq )
- [ iota ] 2dip
[ [ drop ] prepose ] dip map-as ; inline
: change-each ( seq quot -- )
From b756a37d7543591108e1ebedb366d3a16a531840 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 25 Aug 2009 11:59:33 -0400
Subject: [PATCH 12/15] use new structs wherever possible in compiler tests
---
basis/compiler/tests/alien.factor | 250 ++++++++++++++----------------
1 file changed, 118 insertions(+), 132 deletions(-)
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index e3c5dee917..3ecf873be5 100755
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -1,10 +1,12 @@
-USING: alien alien.c-types alien.syntax compiler kernel namespaces
-sequences stack-checker stack-checker.errors words arrays parser
-quotations continuations effects namespaces.private io
-io.streams.string memory system threads tools.test math accessors
-combinators specialized-arrays.float alien.libraries io.pathnames
-io.backend ;
+USING: accessors alien alien.c-types alien.libraries
+alien.syntax arrays classes.c-types classes.struct combinators
+compiler continuations effects io io.backend io.pathnames
+io.streams.string kernel math memory namespaces
+namespaces.private parser quotations sequences
+specialized-arrays.float stack-checker stack-checker.errors
+system threads tools.test words ;
IN: compiler.tests.alien
+FROM: classes.c-types => short ;
<<
: libfactor-ffi-tests-path ( -- string )
@@ -46,25 +48,22 @@ FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
-C-STRUCT: foo
- { "int" "x" }
- { "int" "y" }
-;
+STRUCT: FOO { x int } { y int } ;
-: make-foo ( x y -- foo )
- "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
+: make-FOO ( x y -- FOO )
+ FOO <struct> swap >>y swap >>x ;
-FUNCTION: int ffi_test_11 int a foo b int c ;
+FUNCTION: int ffi_test_11 int a FOO b int c ;
-[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
+[ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
-FUNCTION: foo ffi_test_14 int x int y ;
+FUNCTION: FOO ffi_test_14 int x int y ;
-[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
+[ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
FUNCTION: char* ffi_test_15 char* x char* y ;
@@ -72,25 +71,19 @@ FUNCTION: char* ffi_test_15 char* x char* y ;
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
[ 1 2 ffi_test_15 ] must-fail
-C-STRUCT: bar
- { "long" "x" }
- { "long" "y" }
- { "long" "z" }
-;
+STRUCT: BAR { x long } { y long } { z long } ;
-FUNCTION: bar ffi_test_16 long x long y long z ;
+FUNCTION: BAR ffi_test_16 long x long y long z ;
[ 11 6 -7 ] [
- 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
+ 11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
] unit-test
-C-STRUCT: tiny
- { "int" "x" }
-;
+STRUCT: TINY { x int } ;
-FUNCTION: tiny ffi_test_17 int x ;
+FUNCTION: TINY ffi_test_17 int x ;
-[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
+[ 11 ] [ 11 ffi_test_17 x>> ] unit-test
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
@@ -132,12 +125,12 @@ unit-test
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
-: ffi_test_19 ( x y z -- bar )
- "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
+: ffi_test_19 ( x y z -- BAR )
+ "BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
alien-invoke gc ;
[ 11 6 -7 ] [
- 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
+ 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
] unit-test
FUNCTION: double ffi_test_6 float x float y ;
@@ -189,23 +182,20 @@ FUNCTION: long ffi_test_22 long x longlong y longlong z ;
[ 1111 f 123456789 ffi_test_22 ] must-fail
-C-STRUCT: rect
- { "float" "x" }
- { "float" "y" }
- { "float" "w" }
- { "float" "h" }
-;
+STRUCT: RECT
+ { x single-float } { y single-float }
+ { w single-float } { h single-float } ;
-: <rect> ( x y w h -- rect )
- "rect" <c-object>
- [ set-rect-h ] keep
- [ set-rect-w ] keep
- [ set-rect-y ] keep
- [ set-rect-x ] keep ;
+: <RECT> ( x y w h -- rect )
+ RECT <struct>
+ swap >>h
+ swap >>w
+ swap >>y
+ swap >>x ;
-FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
+FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
-[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
+[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
@@ -260,55 +250,55 @@ FUNCTION: test-struct-7 ffi_test_30 ;
[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
-C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
+STRUCT: test-struct-8 { x float } { y float } ;
FUNCTION: double ffi_test_32 test-struct-8 x int y ;
[ 9.0 ] [
- "test-struct-8" <c-object>
- 1.0 over set-test-struct-8-x
- 2.0 over set-test-struct-8-y
+ test-struct-8 <struct>
+ 1.0 >>x
+ 2.0 >>y
3 ffi_test_32
] unit-test
-C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
+STRUCT: test-struct-9 { x single-float } { y single-float } ;
FUNCTION: double ffi_test_33 test-struct-9 x int y ;
[ 9.0 ] [
- "test-struct-9" <c-object>
- 1.0 over set-test-struct-9-x
- 2.0 over set-test-struct-9-y
+ test-struct-9 <struct>
+ 1.0 >>x
+ 2.0 >>y
3 ffi_test_33
] unit-test
-C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
+STRUCT: test-struct-10 { x single-float } { y int } ;
FUNCTION: double ffi_test_34 test-struct-10 x int y ;
[ 9.0 ] [
- "test-struct-10" <c-object>
- 1.0 over set-test-struct-10-x
- 2 over set-test-struct-10-y
+ test-struct-10 <struct>
+ 1.0 >>x
+ 2 >>y
3 ffi_test_34
] unit-test
-C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
+STRUCT: test-struct-11 { x int } { y int } ;
FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ 9.0 ] [
- "test-struct-11" <c-object>
- 1 over set-test-struct-11-x
- 2 over set-test-struct-11-y
+ test-struct-11 <struct>
+ 1 >>x
+ 2 >>y
3 ffi_test_35
] unit-test
-C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
+STRUCT: test-struct-12 { a int } { x float } ;
: make-struct-12 ( x -- alien )
- "test-struct-12" <c-object>
- [ set-test-struct-12-x ] keep ;
+ test-struct-12 <struct>
+ swap >>x ;
FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
@@ -408,50 +398,47 @@ FUNCTION: int ffi_test_37 ( void* func ) ;
[ 7 ] [ callback-9 ffi_test_37 ] unit-test
-C-STRUCT: test_struct_13
-{ "float" "x1" }
-{ "float" "x2" }
-{ "float" "x3" }
-{ "float" "x4" }
-{ "float" "x5" }
-{ "float" "x6" } ;
+STRUCT: test_struct_13
+{ x1 single-float }
+{ x2 single-float }
+{ x3 single-float }
+{ x4 single-float }
+{ x5 single-float }
+{ x6 single-float } ;
: make-test-struct-13 ( -- alien )
- "test_struct_13" <c-object>
- 1.0 over set-test_struct_13-x1
- 2.0 over set-test_struct_13-x2
- 3.0 over set-test_struct_13-x3
- 4.0 over set-test_struct_13-x4
- 5.0 over set-test_struct_13-x5
- 6.0 over set-test_struct_13-x6 ;
+ test_struct_13 <struct>
+ 1.0 >>x1
+ 2.0 >>x2
+ 3.0 >>x3
+ 4.0 >>x4
+ 5.0 >>x5
+ 6.0 >>x6 ;
FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
[ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
! Joe Groff found this problem
-C-STRUCT: double-rect
-{ "double" "a" }
-{ "double" "b" }
-{ "double" "c" }
-{ "double" "d" } ;
+STRUCT: double-rect
+{ a float }
+{ b float }
+{ c float }
+{ d float } ;
: <double-rect> ( a b c d -- foo )
- "double-rect" <c-object>
- {
- [ set-double-rect-d ]
- [ set-double-rect-c ]
- [ set-double-rect-b ]
- [ set-double-rect-a ]
- [ ]
- } cleave ;
+ double-rect <struct>
+ swap >>d
+ swap >>c
+ swap >>b
+ swap >>a ;
: >double-rect< ( foo -- a b c d )
{
- [ double-rect-a ]
- [ double-rect-b ]
- [ double-rect-c ]
- [ double-rect-d ]
+ [ a>> ]
+ [ b>> ]
+ [ c>> ]
+ [ d>> ]
} cleave ;
: double-rect-callback ( -- alien )
@@ -467,23 +454,22 @@ C-STRUCT: double-rect
[ 1.0 2.0 3.0 4.0 ]
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
-C-STRUCT: test_struct_14
-{ "double" "x1" }
-{ "double" "x2" } ;
+STRUCT: test_struct_14
+ { x1 float }
+ { x2 float } ;
FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
[ 1.0 2.0 ] [
- 1.0 2.0 ffi_test_40
- [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
+ 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
] unit-test
: callback-10 ( -- callback )
"test_struct_14" { "double" "double" } "cdecl"
[
- "test_struct_14" <c-object>
- [ set-test_struct_14-x2 ] keep
- [ set-test_struct_14-x1 ] keep
+ test_struct_14 <struct>
+ swap >>x2
+ swap >>x1
] alien-callback ;
: callback-10-test ( x1 x2 callback -- result )
@@ -491,22 +477,22 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
[ 1.0 2.0 ] [
1.0 2.0 callback-10 callback-10-test
- [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
+ [ x1>> ] [ x2>> ] bi
] unit-test
FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
[ 1 2.0 ] [
1 2.0 ffi_test_41
- [ test-struct-12-a ] [ test-struct-12-x ] bi
+ [ a>> ] [ x>> ] bi
] unit-test
: callback-11 ( -- callback )
"test-struct-12" { "int" "double" } "cdecl"
[
- "test-struct-12" <c-object>
- [ set-test-struct-12-x ] keep
- [ set-test-struct-12-a ] keep
+ test-struct-12 <struct>
+ swap >>x
+ swap >>a
] alien-callback ;
: callback-11-test ( x1 x2 callback -- result )
@@ -514,47 +500,46 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
[ 1 2.0 ] [
1 2.0 callback-11 callback-11-test
- [ test-struct-12-a ] [ test-struct-12-x ] bi
+ [ a>> ] [ x>> ] bi
] unit-test
-C-STRUCT: test_struct_15
-{ "float" "x" }
-{ "float" "y" } ;
+STRUCT: test_struct_15
+ { x single-float }
+ { y single-float } ;
FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
-[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ test_struct_15-x ] [ test_struct_15-y ] bi ] unit-test
+[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
: callback-12 ( -- callback )
"test_struct_15" { "float" "float" } "cdecl"
[
- "test_struct_15" <c-object>
- [ set-test_struct_15-y ] keep
- [ set-test_struct_15-x ] keep
+ test_struct_15 <struct>
+ swap >>y
+ swap >>x
] alien-callback ;
: callback-12-test ( x1 x2 callback -- result )
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
- 1.0 2.0 callback-12 callback-12-test
- [ test_struct_15-x ] [ test_struct_15-y ] bi
+ 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
] unit-test
-C-STRUCT: test_struct_16
-{ "float" "x" }
-{ "int" "a" } ;
+STRUCT: test_struct_16
+ { x single-float }
+ { a int } ;
FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
-[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ test_struct_16-x ] [ test_struct_16-a ] bi ] unit-test
+[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
: callback-13 ( -- callback )
"test_struct_16" { "float" "int" } "cdecl"
[
- "test_struct_16" <c-object>
- [ set-test_struct_16-a ] keep
- [ set-test_struct_16-x ] keep
+ test_struct_16 <struct>
+ swap >>a
+ swap >>x
] alien-callback ;
: callback-13-test ( x1 x2 callback -- result )
@@ -562,12 +547,12 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
[ 1.0 2 ] [
1.0 2 callback-13 callback-13-test
- [ test_struct_16-x ] [ test_struct_16-a ] bi
+ [ x>> ] [ a>> ] bi
] unit-test
FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
-[ 1.0 2.0 ] [ ffi_test_44 [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi ] unit-test
+[ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
@@ -589,14 +574,15 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
] unit-test
! Reported by jedahu
-C-STRUCT: bool-field-test
- { "char*" "name" }
- { "bool" "on" }
- { "short" "parents" } ;
+STRUCT: bool-field-test
+ { name pinned-c-ptr }
+ { on boolean }
+ { parents short } ;
FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
[ 123 ] [
- "bool-field-test" <c-object> 123 over set-bool-field-test-parents
+ bool-field-test <struct>
+ 123 >>parents
ffi_test_48
] unit-test
From 2c6ef83c13c13fae5e7b0d4bf7ccef62f8880609 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 25 Aug 2009 12:00:06 -0500
Subject: [PATCH 13/15] update compiler.tests.alien to joe's latest changes
---
basis/compiler/tests/alien.factor | 44 +++++++++++++++----------------
1 file changed, 22 insertions(+), 22 deletions(-)
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 3ecf873be5..b1780e33e1 100755
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -6,7 +6,7 @@ namespaces.private parser quotations sequences
specialized-arrays.float stack-checker stack-checker.errors
system threads tools.test words ;
IN: compiler.tests.alien
-FROM: classes.c-types => short ;
+FROM: classes.c-types => short float ;
<<
: libfactor-ffi-tests-path ( -- string )
@@ -183,8 +183,8 @@ FUNCTION: long ffi_test_22 long x longlong y longlong z ;
[ 1111 f 123456789 ffi_test_22 ] must-fail
STRUCT: RECT
- { x single-float } { y single-float }
- { w single-float } { h single-float } ;
+ { x float } { y float }
+ { w float } { h float } ;
: <RECT> ( x y w h -- rect )
RECT <struct>
@@ -250,7 +250,7 @@ FUNCTION: test-struct-7 ffi_test_30 ;
[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
-STRUCT: test-struct-8 { x float } { y float } ;
+STRUCT: test-struct-8 { x double } { y double } ;
FUNCTION: double ffi_test_32 test-struct-8 x int y ;
@@ -261,7 +261,7 @@ FUNCTION: double ffi_test_32 test-struct-8 x int y ;
3 ffi_test_32
] unit-test
-STRUCT: test-struct-9 { x single-float } { y single-float } ;
+STRUCT: test-struct-9 { x float } { y float } ;
FUNCTION: double ffi_test_33 test-struct-9 x int y ;
@@ -272,7 +272,7 @@ FUNCTION: double ffi_test_33 test-struct-9 x int y ;
3 ffi_test_33
] unit-test
-STRUCT: test-struct-10 { x single-float } { y int } ;
+STRUCT: test-struct-10 { x float } { y int } ;
FUNCTION: double ffi_test_34 test-struct-10 x int y ;
@@ -294,7 +294,7 @@ FUNCTION: double ffi_test_35 test-struct-11 x int y ;
3 ffi_test_35
] unit-test
-STRUCT: test-struct-12 { a int } { x float } ;
+STRUCT: test-struct-12 { a int } { x double } ;
: make-struct-12 ( x -- alien )
test-struct-12 <struct>
@@ -399,12 +399,12 @@ FUNCTION: int ffi_test_37 ( void* func ) ;
[ 7 ] [ callback-9 ffi_test_37 ] unit-test
STRUCT: test_struct_13
-{ x1 single-float }
-{ x2 single-float }
-{ x3 single-float }
-{ x4 single-float }
-{ x5 single-float }
-{ x6 single-float } ;
+{ x1 float }
+{ x2 float }
+{ x3 float }
+{ x4 float }
+{ x5 float }
+{ x6 float } ;
: make-test-struct-13 ( -- alien )
test_struct_13 <struct>
@@ -421,10 +421,10 @@ FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
! Joe Groff found this problem
STRUCT: double-rect
-{ a float }
-{ b float }
-{ c float }
-{ d float } ;
+{ a double }
+{ b double }
+{ c double }
+{ d double } ;
: <double-rect> ( a b c d -- foo )
double-rect <struct>
@@ -455,8 +455,8 @@ STRUCT: double-rect
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
STRUCT: test_struct_14
- { x1 float }
- { x2 float } ;
+ { x1 double }
+ { x2 double } ;
FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
@@ -504,8 +504,8 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
] unit-test
STRUCT: test_struct_15
- { x single-float }
- { y single-float } ;
+ { x float }
+ { y float } ;
FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
@@ -527,7 +527,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
] unit-test
STRUCT: test_struct_16
- { x single-float }
+ { x float }
{ a int } ;
FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
From 0ce57d056607faac566d0127f5962ae6cabd6fe4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 25 Aug 2009 16:31:58 -0500
Subject: [PATCH 14/15] update new structs again
---
basis/compiler/tests/alien.factor | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index b1780e33e1..a5aa91bdf7 100755
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -6,7 +6,6 @@ namespaces.private parser quotations sequences
specialized-arrays.float stack-checker stack-checker.errors
system threads tools.test words ;
IN: compiler.tests.alien
-FROM: classes.c-types => short float ;
<<
: libfactor-ffi-tests-path ( -- string )
@@ -575,8 +574,8 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
! Reported by jedahu
STRUCT: bool-field-test
- { name pinned-c-ptr }
- { on boolean }
+ { name char* }
+ { on bool }
{ parents short } ;
FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
From 1b77718625e974470c04fe155b9aebb96c5a98cc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 26 Aug 2009 11:01:39 -0500
Subject: [PATCH 15/15] use structs
---
basis/compiler/tests/alien.factor | 32 +++++++++++++++----------------
1 file changed, 16 insertions(+), 16 deletions(-)
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index a5aa91bdf7..1428ba1b66 100755
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -1,10 +1,10 @@
USING: accessors alien alien.c-types alien.libraries
-alien.syntax arrays classes.c-types classes.struct combinators
+alien.syntax arrays classes.struct combinators
compiler continuations effects io io.backend io.pathnames
io.streams.string kernel math memory namespaces
namespaces.private parser quotations sequences
specialized-arrays.float stack-checker stack-checker.errors
-system threads tools.test words ;
+system threads tools.test words specialized-arrays.char ;
IN: compiler.tests.alien
<<
@@ -207,47 +207,47 @@ FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
] unit-test
! Test odd-size structs
-C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
+STRUCT: test-struct-1 { x char[1] } ;
FUNCTION: test-struct-1 ffi_test_24 ;
-[ B{ 1 } ] [ ffi_test_24 ] unit-test
+[ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
-C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
+STRUCT: test-struct-2 { x char[2] } ;
FUNCTION: test-struct-2 ffi_test_25 ;
-[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
+[ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
-C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
+STRUCT: test-struct-3 { x char[3] } ;
FUNCTION: test-struct-3 ffi_test_26 ;
-[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
+[ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
-C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
+STRUCT: test-struct-4 { x char[4] } ;
FUNCTION: test-struct-4 ffi_test_27 ;
-[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
+[ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
-C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
+STRUCT: test-struct-5 { x char[5] } ;
FUNCTION: test-struct-5 ffi_test_28 ;
-[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
+[ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
-C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
+STRUCT: test-struct-6 { x char[6] } ;
FUNCTION: test-struct-6 ffi_test_29 ;
-[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
+[ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
-C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
+STRUCT: test-struct-7 { x char[7] } ;
FUNCTION: test-struct-7 ffi_test_30 ;
-[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
+[ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
STRUCT: test-struct-8 { x double } { y double } ;