steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-08-26 14:07:33 -05:00
parent 4a9f885ac9 ddea2453a4
commit 2ae4f64d65
8 changed files with 161 additions and 164 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/combinators/smart/smart.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry generalizations kernel macros math.order USING: accessors fry generalizations kernel macros math.order
stack-checker math ; stack-checker math sequences ;
IN: combinators.smart IN: combinators.smart
MACRO: drop-outputs ( quot -- quot' ) MACRO: drop-outputs ( quot -- quot' )
@ -42,3 +42,9 @@ MACRO: append-outputs-as ( quot exemplar -- newquot )
MACRO: append-outputs ( quot -- seq ) MACRO: append-outputs ( quot -- seq )
'[ _ { } append-outputs-as ] ; '[ _ { } append-outputs-as ] ;
MACRO: preserving ( quot -- )
[ infer in>> length ] keep '[ _ ndup @ ] ;
MACRO: smart-if ( pred true false -- )
'[ _ preserving _ _ if ] ; inline

277
basis/compiler/tests/alien.factor
View File

@ -1,9 +1,10 @@
USING: alien alien.c-types alien.syntax compiler kernel namespaces USING: accessors alien alien.c-types alien.libraries
sequences stack-checker stack-checker.errors words arrays parser alien.syntax arrays classes.struct combinators
quotations continuations effects namespaces.private io compiler continuations effects io io.backend io.pathnames
io.streams.string memory system threads tools.test math accessors io.streams.string kernel math memory namespaces
combinators specialized-arrays.float alien.libraries io.pathnames namespaces.private parser quotations sequences
io.backend ; specialized-arrays.float stack-checker stack-checker.errors
system threads tools.test words specialized-arrays.char ;
IN: compiler.tests.alien 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 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
C-STRUCT: foo STRUCT: FOO { x int } { y int } ;
{ "int" "x" }
{ "int" "y" }
;
: make-foo ( x y -- foo ) : make-FOO ( x y -- FOO )
"foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ; 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 ; 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 [ 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 ; 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 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
[ 1 2 ffi_test_15 ] must-fail [ 1 2 ffi_test_15 ] must-fail
C-STRUCT: bar STRUCT: BAR { x long } { y long } { z long } ;
{ "long" "x" }
{ "long" "y" }
{ "long" "z" }
;
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 ] [
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 ] unit-test
C-STRUCT: tiny STRUCT: TINY { x int } ;
{ "int" "x" }
;
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 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
@ -132,12 +124,12 @@ unit-test
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- bar ) : ffi_test_19 ( x y z -- BAR )
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } "BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
alien-invoke gc ; alien-invoke gc ;
[ 11 6 -7 ] [ [ 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 ] unit-test
FUNCTION: double ffi_test_6 float x float y ; 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 [ 1111 f 123456789 ffi_test_22 ] must-fail
C-STRUCT: rect STRUCT: RECT
{ "float" "x" } { x float } { y float }
{ "float" "y" } { w float } { h float } ;
{ "float" "w" }
{ "float" "h" }
;
: <rect> ( x y w h -- rect ) : <RECT> ( x y w h -- rect )
"rect" <c-object> RECT <struct>
[ set-rect-h ] keep swap >>h
[ set-rect-w ] keep swap >>w
[ set-rect-y ] keep swap >>y
[ set-rect-x ] keep ; 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 [ 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 ] unit-test
! Test odd-size structs ! 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 ; 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 ; 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 ; 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 ; 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 ; 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 ; 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 ; 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 ; FUNCTION: double ffi_test_32 test-struct-8 x int y ;
[ 9.0 ] [ [ 9.0 ] [
"test-struct-8" <c-object> test-struct-8 <struct>
1.0 over set-test-struct-8-x 1.0 >>x
2.0 over set-test-struct-8-y 2.0 >>y
3 ffi_test_32 3 ffi_test_32
] unit-test ] 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 ; FUNCTION: double ffi_test_33 test-struct-9 x int y ;
[ 9.0 ] [ [ 9.0 ] [
"test-struct-9" <c-object> test-struct-9 <struct>
1.0 over set-test-struct-9-x 1.0 >>x
2.0 over set-test-struct-9-y 2.0 >>y
3 ffi_test_33 3 ffi_test_33
] unit-test ] 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 ; FUNCTION: double ffi_test_34 test-struct-10 x int y ;
[ 9.0 ] [ [ 9.0 ] [
"test-struct-10" <c-object> test-struct-10 <struct>
1.0 over set-test-struct-10-x 1.0 >>x
2 over set-test-struct-10-y 2 >>y
3 ffi_test_34 3 ffi_test_34
] unit-test ] 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 ; FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ 9.0 ] [ [ 9.0 ] [
"test-struct-11" <c-object> test-struct-11 <struct>
1 over set-test-struct-11-x 1 >>x
2 over set-test-struct-11-y 2 >>y
3 ffi_test_35 3 ffi_test_35
] unit-test ] unit-test
C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; STRUCT: test-struct-12 { a int } { x double } ;
: make-struct-12 ( x -- alien ) : make-struct-12 ( x -- alien )
"test-struct-12" <c-object> test-struct-12 <struct>
[ set-test-struct-12-x ] keep ; swap >>x ;
FUNCTION: double ffi_test_36 ( test-struct-12 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 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
C-STRUCT: test_struct_13 STRUCT: test_struct_13
{ "float" "x1" } { x1 float }
{ "float" "x2" } { x2 float }
{ "float" "x3" } { x3 float }
{ "float" "x4" } { x4 float }
{ "float" "x5" } { x5 float }
{ "float" "x6" } ; { x6 float } ;
: make-test-struct-13 ( -- alien ) : make-test-struct-13 ( -- alien )
"test_struct_13" <c-object> test_struct_13 <struct>
1.0 over set-test_struct_13-x1 1.0 >>x1
2.0 over set-test_struct_13-x2 2.0 >>x2
3.0 over set-test_struct_13-x3 3.0 >>x3
4.0 over set-test_struct_13-x4 4.0 >>x4
5.0 over set-test_struct_13-x5 5.0 >>x5
6.0 over set-test_struct_13-x6 ; 6.0 >>x6 ;
FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ; 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 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
! Joe Groff found this problem ! Joe Groff found this problem
C-STRUCT: double-rect STRUCT: double-rect
{ "double" "a" } { a double }
{ "double" "b" } { b double }
{ "double" "c" } { c double }
{ "double" "d" } ; { d double } ;
: <double-rect> ( a b c d -- foo ) : <double-rect> ( a b c d -- foo )
"double-rect" <c-object> double-rect <struct>
{ swap >>d
[ set-double-rect-d ] swap >>c
[ set-double-rect-c ] swap >>b
[ set-double-rect-b ] swap >>a ;
[ set-double-rect-a ]
[ ]
} cleave ;
: >double-rect< ( foo -- a b c d ) : >double-rect< ( foo -- a b c d )
{ {
[ double-rect-a ] [ a>> ]
[ double-rect-b ] [ b>> ]
[ double-rect-c ] [ c>> ]
[ double-rect-d ] [ d>> ]
} cleave ; } cleave ;
: double-rect-callback ( -- alien ) : 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 ]
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test [ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
C-STRUCT: test_struct_14 STRUCT: test_struct_14
{ "double" "x1" } { x1 double }
{ "double" "x2" } ; { x2 double } ;
FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ; FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
[ 1.0 2.0 ] [ [ 1.0 2.0 ] [
1.0 2.0 ffi_test_40 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
[ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
] unit-test ] unit-test
: callback-10 ( -- callback ) : callback-10 ( -- callback )
"test_struct_14" { "double" "double" } "cdecl" "test_struct_14" { "double" "double" } "cdecl"
[ [
"test_struct_14" <c-object> test_struct_14 <struct>
[ set-test_struct_14-x2 ] keep swap >>x2
[ set-test_struct_14-x1 ] keep swap >>x1
] alien-callback ; ] alien-callback ;
: callback-10-test ( x1 x2 callback -- result ) : 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 ] [
1.0 2.0 callback-10 callback-10-test 1.0 2.0 callback-10 callback-10-test
[ test_struct_14-x1 ] [ test_struct_14-x2 ] bi [ x1>> ] [ x2>> ] bi
] unit-test ] unit-test
FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ; FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
[ 1 2.0 ] [ [ 1 2.0 ] [
1 2.0 ffi_test_41 1 2.0 ffi_test_41
[ test-struct-12-a ] [ test-struct-12-x ] bi [ a>> ] [ x>> ] bi
] unit-test ] unit-test
: callback-11 ( -- callback ) : callback-11 ( -- callback )
"test-struct-12" { "int" "double" } "cdecl" "test-struct-12" { "int" "double" } "cdecl"
[ [
"test-struct-12" <c-object> test-struct-12 <struct>
[ set-test-struct-12-x ] keep swap >>x
[ set-test-struct-12-a ] keep swap >>a
] alien-callback ; ] alien-callback ;
: callback-11-test ( x1 x2 callback -- result ) : 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 ] [
1 2.0 callback-11 callback-11-test 1 2.0 callback-11 callback-11-test
[ test-struct-12-a ] [ test-struct-12-x ] bi [ a>> ] [ x>> ] bi
] unit-test ] unit-test
C-STRUCT: test_struct_15 STRUCT: test_struct_15
{ "float" "x" } { x float }
{ "float" "y" } ; { y float } ;
FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ; 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 ) : callback-12 ( -- callback )
"test_struct_15" { "float" "float" } "cdecl" "test_struct_15" { "float" "float" } "cdecl"
[ [
"test_struct_15" <c-object> test_struct_15 <struct>
[ set-test_struct_15-y ] keep swap >>y
[ set-test_struct_15-x ] keep swap >>x
] alien-callback ; ] alien-callback ;
: callback-12-test ( x1 x2 callback -- result ) : callback-12-test ( x1 x2 callback -- result )
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ; "test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [ [ 1.0 2.0 ] [
1.0 2.0 callback-12 callback-12-test 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
[ test_struct_15-x ] [ test_struct_15-y ] bi
] unit-test ] unit-test
C-STRUCT: test_struct_16 STRUCT: test_struct_16
{ "float" "x" } { x float }
{ "int" "a" } ; { a int } ;
FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ; 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 ) : callback-13 ( -- callback )
"test_struct_16" { "float" "int" } "cdecl" "test_struct_16" { "float" "int" } "cdecl"
[ [
"test_struct_16" <c-object> test_struct_16 <struct>
[ set-test_struct_16-a ] keep swap >>a
[ set-test_struct_16-x ] keep swap >>x
] alien-callback ; ] alien-callback ;
: callback-13-test ( x1 x2 callback -- result ) : 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 ] [
1.0 2 callback-13 callback-13-test 1.0 2 callback-13 callback-13-test
[ test_struct_16-x ] [ test_struct_16-a ] bi [ x>> ] [ a>> ] bi
] unit-test ] unit-test
FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline 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 ; : 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 ] unit-test
! Reported by jedahu ! Reported by jedahu
C-STRUCT: bool-field-test STRUCT: bool-field-test
{ "char*" "name" } { name char* }
{ "bool" "on" } { on bool }
{ "short" "parents" } ; { parents short } ;
FUNCTION: short ffi_test_48 ( bool-field-test x ) ; FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
[ 123 ] [ [ 123 ] [
"bool-field-test" <c-object> 123 over set-bool-field-test-parents bool-field-test <struct>
123 >>parents
ffi_test_48 ffi_test_48
] unit-test ] unit-test

6
basis/generalizations/generalizations.factor
View File

@ -15,7 +15,7 @@ IN: generalizations
MACRO: nsequence ( n seq -- ) MACRO: nsequence ( n seq -- )
[ [
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi [ drop iota <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep ] keep
'[ @ _ like ] ; '[ @ _ like ] ;
@ -27,7 +27,7 @@ MACRO: nsum ( n -- )
1 - [ + ] n*quot ; 1 - [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- ) MACRO: firstn-unsafe ( n -- )
[ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ; iota [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
MACRO: firstn ( n -- ) MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [ dup zero? [ drop [ drop ] ] [
@ -94,7 +94,7 @@ MACRO: mnswap ( m n -- )
1 + '[ _ -nrot ] swap '[ _ _ napply ] ; 1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
MACRO: nweave ( n -- ) MACRO: nweave ( n -- )
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep [ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ; '[ _ _ ncleave ] ;
MACRO: nbi-curry ( n -- ) MACRO: nbi-curry ( n -- )

5
basis/multiline/multiline-docs.factor
View File

@ -21,7 +21,7 @@ HELP: /*
HELP: HEREDOC: HELP: HEREDOC:
{ $syntax "HEREDOC: marker\n...text...\nmarker" } { $syntax "HEREDOC: marker\n...text...\nmarker" }
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } } { $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." } { $warning "Whitespace is significant." }
{ $examples { $examples
{ $example "USING: multiline prettyprint ;" { $example "USING: multiline prettyprint ;"
@ -37,7 +37,8 @@ HELP: HEREDOC:
HELP: DELIMITED: HELP: DELIMITED:
{ $syntax "DELIMITED: marker\n...text...\nmarker" } { $syntax "DELIMITED: marker\n...text...\nmarker" }
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } } { $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 { $examples
{ $example "USING: multiline prettyprint ;" { $example "USING: multiline prettyprint ;"
"DELIMITED: factor blows my mind" "DELIMITED: factor blows my mind"

4
core/classes/tuple/tuple.factor
View File

@ -35,7 +35,7 @@ M: tuple class layout-of 2 slot { word } declare ; inline
layout-of 3 slot { fixnum } declare ; inline layout-of 3 slot { fixnum } declare ; inline
: prepare-tuple>array ( tuple -- n tuple layout ) : 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 ) : copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ; [ array-nth ] curry map ;
@ -69,7 +69,7 @@ GENERIC: slots>tuple ( seq class -- tuple )
M: tuple-class slots>tuple ( seq class -- tuple ) M: tuple-class slots>tuple ( seq class -- tuple )
check-slots pad-slots check-slots pad-slots
tuple-layout <tuple> [ tuple-layout <tuple> [
[ tuple-size ] [ tuple-size iota ]
[ [ set-array-nth ] curry ] [ [ set-array-nth ] curry ]
bi 2each bi 2each
] keep ; ] keep ;

19
core/effects/effects.factor
View File

@ -6,25 +6,29 @@ IN: effects
TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ; 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 ) : <effect> ( in out -- effect )
dup { "*" } sequence= [ drop { } t ] [ f ] if dup { "*" } sequence= [ drop { } t ] [ f ] if
effect boa ; effect boa ;
: effect-height ( effect -- n ) : effect-height ( effect -- n )
[ out>> length ] [ in>> length ] bi - ; inline [ out>> effect-length ] [ in>> effect-length ] bi - ; inline
: effect<= ( effect1 effect2 -- ? ) : effect<= ( effect1 effect2 -- ? )
{ {
{ [ over terminated?>> ] [ t ] } { [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] } { [ dup terminated?>> ] [ f ] }
{ [ 2dup [ in>> length ] bi@ > ] [ f ] } { [ 2dup [ in>> effect-length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] } { [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ] [ t ]
} cond 2nip ; inline } cond 2nip ; inline
: effect= ( effect1 effect2 -- ? ) : effect= ( effect1 effect2 -- ? )
[ [ in>> length ] bi@ = ] [ [ in>> effect-length ] bi@ = ]
[ [ out>> length ] bi@ = ] [ [ out>> effect-length ] bi@ = ]
[ [ terminated?>> ] bi@ = ] [ [ terminated?>> ] bi@ = ]
2tri and and ; 2tri and and ;
@ -62,7 +66,7 @@ M: effect clone
stack-effect effect-height ; stack-effect effect-height ;
: split-shuffle ( stack shuffle -- stack1 stack2 ) : split-shuffle ( stack shuffle -- stack1 stack2 )
in>> length cut* ; in>> effect-length cut* ;
: shuffle-mapping ( effect -- mapping ) : shuffle-mapping ( effect -- mapping )
[ out>> ] [ in>> ] bi [ index ] curry map ; [ out>> ] [ in>> ] bi [ index ] curry map ;
@ -77,8 +81,9 @@ M: effect clone
over terminated?>> [ over terminated?>> [
drop drop
] [ ] [
[ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ] [ [ [ in>> effect-length ] [ out>> effect-length ] bi ] [ in>> effect-length ] bi* swap [-] + ]
[ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ] [ [ out>> effect-length ] [ [ in>> effect-length ] [ out>> effect-length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri [ nip terminated?>> ] 2tri
[ [ [ "obj" ] replicate ] bi@ ] dip
effect boa effect boa
] if ; inline ] if ; inline

2
core/sequences/sequences-tests.factor
View File

@ -293,4 +293,4 @@ USE: make
[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test [ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
[ t ] [ 0 array-capacity? ] unit-test [ t ] [ 0 array-capacity? ] unit-test
[ f ] [ -1 array-capacity? ] unit-test [ f ] [ -1 array-capacity? ] unit-test

4
core/sequences/sequences.factor
View File

@ -919,7 +919,7 @@ PRIVATE>
<PRIVATE <PRIVATE
: generic-flip ( matrix -- newmatrix ) : 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 [ [ nth-unsafe ] with { } map-as ] curry { } map-as ; inline
USE: arrays USE: arrays
@ -929,7 +929,7 @@ USE: arrays
: array-flip ( matrix -- newmatrix ) : array-flip ( matrix -- newmatrix )
{ array } declare { 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 ; [ [ { array } declare array-nth ] with { } map-as ] curry { } map-as ;
PRIVATE> PRIVATE>