Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
2ae4f64d65
|
|
@ -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' )
|
||||
|
|
@ -42,3 +42,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
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
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.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 specialized-arrays.char ;
|
||||
IN: compiler.tests.alien
|
||||
|
||||
<<
|
||||
|
|
@ -46,25 +47,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 +70,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 +124,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 +181,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 float } { y float }
|
||||
{ w float } { h 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
|
||||
|
||||
|
|
@ -218,97 +207,97 @@ 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
|
||||
|
||||
C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
|
||||
STRUCT: test-struct-8 { x double } { y double } ;
|
||||
|
||||
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 float } { y 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 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 double } ;
|
||||
|
||||
: 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 +397,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 float }
|
||||
{ x2 float }
|
||||
{ x3 float }
|
||||
{ x4 float }
|
||||
{ x5 float }
|
||||
{ x6 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 double }
|
||||
{ b double }
|
||||
{ c double }
|
||||
{ d double } ;
|
||||
|
||||
: <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 +453,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 double }
|
||||
{ x2 double } ;
|
||||
|
||||
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 +476,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 +499,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 float }
|
||||
{ y 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 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 +546,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 +573,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 char* }
|
||||
{ on bool }
|
||||
{ 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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ f ] [ -1 array-capacity? ] unit-test
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
Loading…
Reference in New Issue