Merge branch 'master' of git://factorcode.org/git/factor
commit
1dadc4efed
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -684,28 +684,30 @@ mingw? [
|
|||
: fastcall-struct-return-iii-indirect ( x y z ptr -- result )
|
||||
test-struct-11 { int int int } fastcall alien-indirect ;
|
||||
|
||||
: win32? ( -- ? ) os windows? cpu x86.32? and ;
|
||||
|
||||
[ 8 ] [
|
||||
3 4
|
||||
os windows? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
|
||||
win32? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
|
||||
fastcall-ii-indirect
|
||||
] unit-test
|
||||
|
||||
[ 13 ] [
|
||||
3 4 5
|
||||
os windows? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
|
||||
win32? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
|
||||
fastcall-iii-indirect
|
||||
] unit-test
|
||||
|
||||
mingw? [
|
||||
[ 13 ] [
|
||||
3 4.0 5
|
||||
os windows? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
|
||||
win32? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
|
||||
fastcall-ifi-indirect
|
||||
] unit-test
|
||||
|
||||
[ 19 ] [
|
||||
3 4.0 5 6
|
||||
os windows? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
|
||||
win32? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
|
||||
fastcall-ifii-indirect
|
||||
] unit-test
|
||||
] unless
|
||||
|
@ -713,14 +715,14 @@ mingw? [
|
|||
[ S{ test-struct-11 f 7 -1 } ]
|
||||
[
|
||||
3 4
|
||||
os windows? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
|
||||
win32? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
|
||||
fastcall-struct-return-ii-indirect
|
||||
] unit-test
|
||||
|
||||
[ S{ test-struct-11 f 7 -3 } ]
|
||||
[
|
||||
3 4 7
|
||||
os windows? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
|
||||
win32? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
|
||||
fastcall-struct-return-iii-indirect
|
||||
] unit-test
|
||||
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
IN: compiler.tests.redefine23
|
||||
USING: classes.struct specialized-arrays alien.c-types sequences
|
||||
compiler.units vocabs tools.test ;
|
||||
FROM: specialized-arrays.private => specialized-array-vocab ;
|
||||
|
||||
STRUCT: my-struct { x int } ;
|
||||
SPECIALIZED-ARRAY: my-struct
|
||||
|
@ -8,6 +9,6 @@ SPECIALIZED-ARRAY: my-struct
|
|||
|
||||
[ ] [
|
||||
[
|
||||
"specialized-arrays.instances.compiler.tests.redefine23" forget-vocab
|
||||
my-struct specialized-array-vocab forget-vocab
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1,2 +1,2 @@
|
|||
compiler
|
||||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1,2 +1,2 @@
|
|||
untested
|
||||
not loaded
|
||||
compiler
|
||||
|
|
|
@ -1,2 +1,2 @@
|
|||
untested
|
||||
not loaded
|
||||
compiler
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1,2 +1,2 @@
|
|||
untested
|
||||
not loaded
|
||||
compiler
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +0,0 @@
|
|||
untested
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1,2 @@
|
|||
web
|
||||
web services
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays effects fry vectors sequences assocs math math.order accessors kernel
|
||||
combinators quotations namespaces grouping locals stack-checker.state
|
||||
stack-checker.backend stack-checker.errors stack-checker.visitor
|
||||
stack-checker.values stack-checker.recursive-state ;
|
||||
FROM: sequences.private => dispatch ;
|
||||
IN: stack-checker.branches
|
||||
|
||||
: balanced? ( pairs -- ? )
|
||||
|
@ -43,10 +44,9 @@ SYMBOLS: +bottom+ +top+ ;
|
|||
: phi-outputs ( phi-in -- stack )
|
||||
flip [ unify-values ] map ;
|
||||
|
||||
SYMBOL: quotations
|
||||
SYMBOLS: combinator quotations ;
|
||||
|
||||
: simple-unbalanced-branches-error ( branches quots -- * )
|
||||
[ \ if ] 2dip swap
|
||||
: simple-unbalanced-branches-error ( word quots branches -- * )
|
||||
[ length [ (( ..a -- ..b )) ] replicate ]
|
||||
[ [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi
|
||||
unbalanced-branches-error ;
|
||||
|
@ -54,9 +54,10 @@ SYMBOL: quotations
|
|||
: unify-branches ( ins stacks -- in phi-in phi-out )
|
||||
zip [ 0 { } { } ] [
|
||||
[ keys supremum ] [ ] [ balanced? ] tri
|
||||
[ dupd phi-inputs dup phi-outputs ]
|
||||
[ quotations get simple-unbalanced-branches-error ]
|
||||
if
|
||||
[ dupd phi-inputs dup phi-outputs ] [
|
||||
[ combinator get quotations get ] dip
|
||||
simple-unbalanced-branches-error
|
||||
] if
|
||||
] if-empty ;
|
||||
|
||||
: branch-variable ( seq symbol -- seq )
|
||||
|
@ -125,13 +126,13 @@ M: curried curried/composed? drop t ;
|
|||
M: composed curried/composed? drop t ;
|
||||
M: declared-effect curried/composed? known>> curried/composed? ;
|
||||
|
||||
:: declare-if-effects ( -- )
|
||||
H{ } clone :> variables
|
||||
V{ } clone :> branches
|
||||
\ if (( ..a -- ..b )) variables branches 0 declare-effect-d
|
||||
\ if (( ..a -- ..b )) variables branches 1 declare-effect-d ;
|
||||
: declare-if-effects ( -- )
|
||||
H{ } clone V{ } clone
|
||||
[ [ \ if (( ..a -- ..b )) ] 2dip 0 declare-effect-d ]
|
||||
[ [ \ if (( ..a -- ..b )) ] 2dip 1 declare-effect-d ] 2bi ;
|
||||
|
||||
: infer-if ( -- )
|
||||
\ if combinator set
|
||||
2 literals-available? [
|
||||
(infer-if)
|
||||
] [
|
||||
|
@ -148,5 +149,6 @@ M: declared-effect curried/composed? known>> curried/composed? ;
|
|||
] if ;
|
||||
|
||||
: infer-dispatch ( -- )
|
||||
\ dispatch combinator set
|
||||
pop-literal nip infer-branches
|
||||
[ #dispatch, ] dip compute-phi-function ;
|
||||
|
|
|
@ -24,7 +24,7 @@ IN: stack-checker.row-polymorphism
|
|||
[ with-inner-d ] 2dip (effect-here) ; inline
|
||||
|
||||
: (diff-variable) ( diff variable vars -- diff' )
|
||||
[ at* nip ] [ '[ _ _ at - ] ] [ '[ _ _ set-at 0 ] ] 2tri if ;
|
||||
[ key? ] [ '[ _ _ at - ] ] [ '[ _ _ set-at 0 ] ] 2tri if ;
|
||||
|
||||
: (check-variable) ( actual-count declared-count variable vars -- diff ? )
|
||||
[ - ] 2dip dupd '[ _ _ (diff-variable) t ] [ dup 0 <= ] if ;
|
||||
|
@ -63,4 +63,3 @@ IN: stack-checker.row-polymorphism
|
|||
[ >>actual ] keep
|
||||
2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
|
||||
[ 2drop ] [ drop combinator-unbalanced-branches-error ] if ;
|
||||
|
||||
|
|
|
@ -252,6 +252,11 @@ DEFER: blah4
|
|||
! A typo
|
||||
{ 1 0 } [ { [ ] } dispatch ] must-infer-as
|
||||
|
||||
! Make sure the error is correct
|
||||
[
|
||||
[ { [ drop ] [ dup ] } dispatch ] infer
|
||||
] [ word>> \ dispatch eq? ] must-fail-with
|
||||
|
||||
DEFER: inline-recursive-2
|
||||
: inline-recursive-1 ( -- ) inline-recursive-2 ;
|
||||
: inline-recursive-2 ( -- ) inline-recursive-1 ;
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -2,11 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs combinators compiler.units
|
||||
continuations debugger effects fry generalizations io io.files
|
||||
io.styles kernel lexer locals macros math.parser namespaces parser
|
||||
vocabs.parser prettyprint quotations sequences source-files splitting
|
||||
stack-checker summary unicode.case vectors vocabs vocabs.loader
|
||||
vocabs.files words tools.errors source-files.errors io.streams.string
|
||||
make compiler.errors ;
|
||||
io.styles kernel lexer locals macros math.parser namespaces
|
||||
parser vocabs.parser prettyprint quotations sequences
|
||||
source-files splitting stack-checker summary unicode.case
|
||||
vectors vocabs vocabs.loader vocabs.files vocabs.metadata words
|
||||
tools.errors source-files.errors io.streams.string make
|
||||
compiler.errors ;
|
||||
IN: tools.test
|
||||
|
||||
TUPLE: test-failure < source-file-error continuation ;
|
||||
|
@ -126,7 +127,7 @@ SYMBOL: forget-tests?
|
|||
forget-tests? get
|
||||
[ [ [ forget-source ] each ] with-compilation-unit ] [ drop ] if ;
|
||||
|
||||
: run-vocab-tests ( vocab -- )
|
||||
: test-vocab ( vocab -- )
|
||||
vocab dup [
|
||||
dup source-loaded?>> [
|
||||
vocab-tests
|
||||
|
@ -136,6 +137,8 @@ SYMBOL: forget-tests?
|
|||
] [ drop ] if
|
||||
] [ drop ] if ;
|
||||
|
||||
: test-vocabs ( vocabs -- ) [ test-vocab ] each ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
TEST: unit-test
|
||||
|
@ -154,7 +157,6 @@ M: test-failure error. ( error -- )
|
|||
|
||||
: :test-failures ( -- ) test-failures get errors. ;
|
||||
|
||||
: test ( prefix -- )
|
||||
child-vocabs [ run-vocab-tests ] each ;
|
||||
: test ( prefix -- ) child-vocabs test-vocabs ;
|
||||
|
||||
: test-all ( -- ) "" test ;
|
||||
: test-all ( -- ) vocabs filter-don't-test test-vocabs ;
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -66,8 +66,8 @@ M: source-file-renderer filled-column drop 1 ;
|
|||
[ invoke-primary-operation ] >>action
|
||||
COLOR: dark-gray >>column-line-color
|
||||
6 >>gap
|
||||
5 >>min-rows
|
||||
5 >>max-rows
|
||||
4 >>min-rows
|
||||
4 >>max-rows
|
||||
60 >>min-cols
|
||||
60 >>max-cols
|
||||
t >>selection-required?
|
||||
|
@ -115,8 +115,8 @@ M: error-renderer column-alignment drop { 0 1 0 0 } ;
|
|||
[ invoke-primary-operation ] >>action
|
||||
COLOR: dark-gray >>column-line-color
|
||||
6 >>gap
|
||||
5 >>min-rows
|
||||
5 >>max-rows
|
||||
4 >>min-rows
|
||||
4 >>max-rows
|
||||
60 >>min-cols
|
||||
60 >>max-cols
|
||||
t >>selection-required?
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -97,9 +97,6 @@ MEMO: all-vocabs-recursive ( -- assoc )
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: filter-unportable ( seq -- seq' )
|
||||
[ vocab-name unportable? not ] filter ;
|
||||
|
||||
: collect-vocabs ( quot -- seq )
|
||||
[ all-vocabs-recursive no-roots no-prefixes ] dip
|
||||
gather natural-sort ; inline
|
||||
|
@ -109,7 +106,7 @@ PRIVATE>
|
|||
: (load) ( prefix -- failures )
|
||||
[ child-vocabs-recursive no-roots no-prefixes ]
|
||||
[ dup find-vocab-root [ >vocab-link prefix ] [ drop ] if ] bi
|
||||
filter-unportable
|
||||
filter-don't-load
|
||||
require-all ;
|
||||
|
||||
: load ( prefix -- )
|
||||
|
|
|
@ -103,12 +103,21 @@ ERROR: bad-platform name ;
|
|||
: supported-platform? ( platforms -- ? )
|
||||
[ t ] [ [ os swap class<= ] any? ] if-empty ;
|
||||
|
||||
: unportable? ( vocab -- ? )
|
||||
: don't-load? ( vocab -- ? )
|
||||
{
|
||||
[ vocab-tags "untested" swap member? ]
|
||||
[ vocab-tags "not loaded" swap member? ]
|
||||
[ vocab-platforms supported-platform? not ]
|
||||
} 1|| ;
|
||||
|
||||
: filter-don't-load ( vocabs -- vocabs' )
|
||||
[ vocab-name don't-load? not ] filter ;
|
||||
|
||||
: don't-test? ( vocab -- ? )
|
||||
vocab-tags "not tested" swap member? ;
|
||||
|
||||
: filter-don't-test ( vocabs -- vocabs' )
|
||||
[ don't-test? not ] filter ;
|
||||
|
||||
TUPLE: unsupported-platform vocab requires ;
|
||||
|
||||
: unsupported-platform ( vocab requires -- )
|
||||
|
|
|
@ -16,13 +16,22 @@ M: hash-set in? table>> key? ; inline
|
|||
M: hash-set adjoin table>> dupd set-at ; inline
|
||||
M: hash-set delete table>> delete-at ; inline
|
||||
M: hash-set members table>> keys ; inline
|
||||
M: hash-set set-like
|
||||
drop dup hash-set? [ members <hash-set> ] unless ;
|
||||
M: hash-set clone
|
||||
table>> clone hash-set boa ;
|
||||
M: hash-set set-like drop dup hash-set? [ members <hash-set> ] unless ;
|
||||
M: hash-set clone table>> clone hash-set boa ;
|
||||
|
||||
M: sequence fast-set <hash-set> ;
|
||||
M: f fast-set drop H{ } clone hash-set boa ;
|
||||
|
||||
M: sequence duplicates
|
||||
f fast-set [ [ in? ] [ adjoin ] 2bi ] curry filter ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (all-unique?) ( elt hash -- ? )
|
||||
2dup in? [ 2drop f ] [ adjoin t ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: sequence all-unique?
|
||||
dup length <hashtable> hash-set boa
|
||||
[ (all-unique?) ] curry all? ;
|
||||
|
|
|
@ -3,7 +3,9 @@ debugger.threads destructors generic.single io io.directories
|
|||
io.encodings.8-bit.latin1 io.encodings.ascii
|
||||
io.encodings.binary io.encodings.string io.files
|
||||
io.files.private io.files.temp io.files.unique kernel make math
|
||||
sequences specialized-arrays system threads tools.test ;
|
||||
sequences specialized-arrays system threads tools.test vocabs
|
||||
compiler.units ;
|
||||
FROM: specialized-arrays.private => specialized-array-vocab ;
|
||||
SPECIALIZED-ARRAY: int
|
||||
IN: io.files.tests
|
||||
|
||||
|
@ -119,6 +121,12 @@ CONSTANT: pt-array-1
|
|||
pt-array-1 rest-slice sequence=
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
pt specialized-array-vocab forget-vocab
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
! Writing strings to binary streams should fail
|
||||
[
|
||||
"test.txt" temp-file binary [
|
||||
|
|
|
@ -92,9 +92,6 @@ M: sequence set-like
|
|||
M: sequence members
|
||||
[ pruned ] keep like ;
|
||||
|
||||
M: sequence all-unique?
|
||||
dup pruned sequence= ;
|
||||
|
||||
: combine ( sets -- set )
|
||||
[ f ]
|
||||
[ [ [ members ] map concat ] [ first ] bi set-like ]
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not loaded
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,33 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs http.client json.reader kernel namespaces urls ;
|
||||
IN: bit.ly
|
||||
|
||||
SYMBOLS: login api-key ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: of ( assoc key -- value ) swap at ;
|
||||
|
||||
: make-request ( long-url -- request )
|
||||
"http://api.bit.ly/v3/shorten" >url
|
||||
login get "login" set-query-param
|
||||
api-key get "apiKey" set-query-param
|
||||
"json" "format" set-query-param
|
||||
swap "longUrl" set-query-param ;
|
||||
|
||||
ERROR: bad-response json status ;
|
||||
|
||||
: check-response ( json -- json )
|
||||
dup "status_code" of 200 = [
|
||||
dup "status_txt" of
|
||||
bad-response
|
||||
] unless ;
|
||||
|
||||
: parse-response ( response data -- short-url )
|
||||
nip json> check-response "data" of "url" of ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: shorten-url ( long-url -- short-url )
|
||||
make-request http-get parse-response ;
|
|
@ -0,0 +1 @@
|
|||
Wrapper for bit.ly URL shortening web service
|
|
@ -0,0 +1 @@
|
|||
web services
|
|
@ -1,6 +1,7 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors alien.c-types classes.struct classes.struct.vectored
|
||||
kernel sequences specialized-arrays tools.test ;
|
||||
kernel sequences specialized-arrays tools.test vocabs compiler.units ;
|
||||
FROM: specialized-arrays.private => specialized-array-vocab ;
|
||||
SPECIALIZED-ARRAYS: int ushort float ;
|
||||
IN: classes.struct.vectored.tests
|
||||
|
||||
|
@ -71,3 +72,9 @@ VECTORED-STRUCT: foo
|
|||
{ w ushort-array{ 15 25 35 45 } }
|
||||
} third vectored-element>
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
foo specialized-array-vocab forget-vocab
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not tested
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2010 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cuda kernel tools.test ;
|
||||
IN: cuda.tests
|
||||
|
||||
! [ ] [ [ 0 0 [ drop ] with-cuda-context ] with-cuda ] unit-test
|
||||
! [ ] [ 100 cuda-malloc cuda-free ] unit-test
|
|
@ -0,0 +1,77 @@
|
|||
! Copyright (C) 2010 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.data assocs classes.struct
|
||||
combinators continuations cuda.ffi fry io.backend kernel
|
||||
sequences ;
|
||||
IN: cuda
|
||||
|
||||
ERROR: throw-cuda-error n ;
|
||||
|
||||
: cuda-error ( n -- )
|
||||
{
|
||||
{ CUDA_SUCCESS [ ] }
|
||||
[ throw-cuda-error ]
|
||||
} case ;
|
||||
|
||||
: cuda-version ( -- n )
|
||||
int <c-object> [ cuDriverGetVersion cuda-error ] keep *int ;
|
||||
|
||||
: init-cuda ( -- )
|
||||
0 cuInit cuda-error ;
|
||||
|
||||
: with-cuda ( quot -- )
|
||||
init-cuda [ ] [ ] cleanup ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: #cuda-devices ( -- n )
|
||||
int <c-object> [ cuDeviceGetCount cuda-error ] keep *int ;
|
||||
|
||||
: n>cuda-device ( n -- device )
|
||||
[ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop *int ;
|
||||
|
||||
: enumerate-cuda-devices ( -- devices )
|
||||
#cuda-devices iota [ n>cuda-device ] map ;
|
||||
|
||||
: cuda-device>properties ( device -- properties )
|
||||
[ CUdevprop <c-object> ] dip
|
||||
[ cuDeviceGetProperties cuda-error ] 2keep drop
|
||||
CUdevprop memory>struct ;
|
||||
|
||||
: cuda-device-properties ( -- properties )
|
||||
enumerate-cuda-devices [ cuda-device>properties ] map ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: cuda-devices ( -- assoc )
|
||||
enumerate-cuda-devices [ dup cuda-device>properties ] { } map>assoc ;
|
||||
|
||||
: with-cuda-context ( flags device quot -- )
|
||||
[
|
||||
[ CUcontext <c-object> ] 2dip
|
||||
[ cuCtxCreate cuda-error ] 3keep 2drop *void*
|
||||
] dip
|
||||
[ '[ _ @ ] ]
|
||||
[ drop '[ _ cuCtxDestroy cuda-error ] ] 2bi
|
||||
[ ] cleanup ; inline
|
||||
|
||||
: with-cuda-module ( path quot -- )
|
||||
[
|
||||
normalize-path
|
||||
[ CUmodule <c-object> ] dip
|
||||
[ cuModuleLoad cuda-error ] 2keep drop *void*
|
||||
] dip
|
||||
[ '[ _ @ ] ]
|
||||
[ drop '[ _ cuModuleUnload cuda-error ] ] 2bi
|
||||
[ ] cleanup ; inline
|
||||
|
||||
: get-cuda-function ( module string -- function )
|
||||
[ CUfunction <c-object> ] 2dip
|
||||
[ cuModuleGetFunction cuda-error ] 3keep 2drop *void* ;
|
||||
|
||||
: cuda-malloc ( n -- ptr )
|
||||
[ CUdeviceptr <c-object> ] dip
|
||||
[ cuMemAlloc cuda-error ] 2keep drop *int ;
|
||||
|
||||
: cuda-free ( ptr -- )
|
||||
cuMemFree cuda-error ;
|
|
@ -307,12 +307,12 @@ FUNCTION: CUresult cuCtxPopCurrent ( CUcontext* pctx ) ;
|
|||
FUNCTION: CUresult cuCtxGetDevice ( CUdevice* device ) ;
|
||||
FUNCTION: CUresult cuCtxSynchronize ( ) ;
|
||||
|
||||
FUNCTION: CUresult cuModuleLoad ( CUmodule* module, char* fname ) ;
|
||||
FUNCTION: CUresult cuModuleLoad ( CUmodule* module, c-string fname ) ;
|
||||
FUNCTION: CUresult cuModuleLoadData ( CUmodule* module, void* image ) ;
|
||||
FUNCTION: CUresult cuModuleLoadDataEx ( CUmodule* module, void* image, uint numOptions, CUjit_option* options, void** optionValues ) ;
|
||||
FUNCTION: CUresult cuModuleLoadFatBinary ( CUmodule* module, void* fatCubin ) ;
|
||||
FUNCTION: CUresult cuModuleUnload ( CUmodule hmod ) ;
|
||||
FUNCTION: CUresult cuModuleGetFunction ( CUfunction* hfunc, CUmodule hmod, char* name ) ;
|
||||
FUNCTION: CUresult cuModuleGetFunction ( CUfunction* hfunc, CUmodule hmod, c-string name ) ;
|
||||
FUNCTION: CUresult cuModuleGetGlobal ( CUdeviceptr* dptr, uint* bytes, CUmodule hmod, char* name ) ;
|
||||
FUNCTION: CUresult cuModuleGetTexRef ( CUtexref* pTexRef, CUmodule hmod, char* name ) ;
|
||||
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
not tested
|
|
@ -0,0 +1 @@
|
|||
not tested
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not tested
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Matthew Willis.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.libraries alien.syntax system sequences combinators kernel alien.c-types ;
|
||||
USING: alien alien.libraries alien.syntax system sequences combinators kernel alien.c-types ;
|
||||
|
||||
IN: llvm.core
|
||||
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not tested
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Matthew Willis.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.libraries alien.syntax llvm.core ;
|
||||
USING: alien.c-types alien.libraries alien.syntax llvm.core ;
|
||||
IN: llvm.engine
|
||||
|
||||
<<
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not tested
|
||||
|
|
|
@ -45,7 +45,7 @@ TUPLE: function name alien return params ;
|
|||
] [ ] make swap function-effect [ define-declared ] with-compilation-unit ;
|
||||
|
||||
: install-module ( name -- )
|
||||
thejit get mps>> at [
|
||||
current-jit mps>> at [
|
||||
module>> functions [ install-function ] each
|
||||
] [ "no such module" throw ] if* ;
|
||||
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not tested
|
||||
|
|
|
@ -5,8 +5,6 @@ kernel llvm.core llvm.engine llvm.wrappers namespaces ;
|
|||
|
||||
IN: llvm.jit
|
||||
|
||||
SYMBOL: thejit
|
||||
|
||||
TUPLE: jit ee mps ;
|
||||
|
||||
: empty-engine ( -- engine )
|
||||
|
@ -15,8 +13,11 @@ TUPLE: jit ee mps ;
|
|||
: <jit> ( -- jit )
|
||||
jit new empty-engine >>ee H{ } clone >>mps ;
|
||||
|
||||
: current-jit ( -- jit )
|
||||
\ current-jit global [ drop <jit> ] cache ;
|
||||
|
||||
: (remove-functions) ( function -- )
|
||||
thejit get ee>> value>> over LLVMFreeMachineCodeForFunction
|
||||
current-jit ee>> value>> over LLVMFreeMachineCodeForFunction
|
||||
LLVMGetNextFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
|
||||
|
||||
: remove-functions ( module -- )
|
||||
|
@ -24,26 +25,24 @@ TUPLE: jit ee mps ;
|
|||
LLVMGetFirstFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
|
||||
|
||||
: remove-provider ( provider -- )
|
||||
thejit get ee>> value>> swap value>> f <void*> f <void*>
|
||||
current-jit ee>> value>> swap value>> f <void*> f <void*>
|
||||
[ LLVMRemoveModuleProvider drop ] 2keep *void* [ llvm-throw ] when*
|
||||
*void* module new swap >>value
|
||||
[ value>> remove-functions ] with-disposal ;
|
||||
|
||||
: remove-module ( name -- )
|
||||
dup thejit get mps>> at [
|
||||
dup current-jit mps>> at [
|
||||
remove-provider
|
||||
thejit get mps>> delete-at
|
||||
current-jit mps>> delete-at
|
||||
] [ drop ] if* ;
|
||||
|
||||
: add-module ( module name -- )
|
||||
[ <provider> ] dip [ remove-module ] keep
|
||||
thejit get ee>> value>> pick
|
||||
current-jit ee>> value>> pick
|
||||
[ [ value>> LLVMAddModuleProvider ] [ t >>disposed drop ] bi ] with-disposal
|
||||
thejit get mps>> set-at ;
|
||||
current-jit mps>> set-at ;
|
||||
|
||||
: function-pointer ( name -- alien )
|
||||
thejit get ee>> value>> dup
|
||||
current-jit ee>> value>> dup
|
||||
rot f <void*> [ LLVMFindFunction drop ] keep
|
||||
*void* LLVMGetPointerToGlobal ;
|
||||
|
||||
thejit [ <jit> ] initialize
|
||||
*void* LLVMGetPointerToGlobal ;
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not tested
|
||||
|
|
|
@ -1 +1 @@
|
|||
untested
|
||||
not tested
|
||||
|
|
|
@ -1,2 +1,2 @@
|
|||
bindings
|
||||
untested
|
||||
not tested
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue