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

Various fixes for call(

db4
Slava Pestov 2009-03-17 18:53:44 -05:00
parent 786475102d
commit 2ed97f5a24
5 changed files with 23 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/core-foundation/fsevents/fsevents.factor
View File

@ -167,7 +167,7 @@ SYMBOL: event-stream-callbacks
eventFlags numEvents <direct-int-array> eventFlags numEvents <direct-int-array>
eventIds numEvents <direct-longlong-array> eventIds numEvents <direct-longlong-array>
3array flip 3array flip
info event-stream-callbacks get at [ drop ] or call ; info event-stream-callbacks get at [ drop ] or call( changes -- ) ;
: master-event-source-callback ( -- alien ) : master-event-source-callback ( -- alien )
"void" "void"

14
basis/stack-checker/call-effect/call-effect.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.private effects fry USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations kernel kernel.private make sequences continuations quotations
stack-checker stack-checker.transforms ; stack-checker stack-checker.transforms ;
IN: stack-checker.call-effect IN: stack-checker.call-effect
@ -20,18 +20,22 @@ TUPLE: inline-cache value ;
: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline : cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline
SYMBOL: +failed+ SYMBOL: +unknown+
: cached-effect ( quot -- effect ) GENERIC: cached-effect ( quot -- effect )
M: object cached-effect drop +unknown+ ;
M: quotation cached-effect
dup cached-effect>> dup cached-effect>>
[ ] [ [ ] [
[ [ infer ] [ 2drop +failed+ ] recover dup ] keep [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
(>>cached-effect) (>>cached-effect)
] ?if ; ] ?if ;
: call-effect-unsafe? ( quot effect -- ? ) : call-effect-unsafe? ( quot effect -- ? )
[ cached-effect ] dip [ cached-effect ] dip
over +failed+ eq? over +unknown+ eq?
[ 2drop f ] [ effect<= ] if ; inline [ 2drop f ] [ effect<= ] if ; inline
: (call-effect-slow>quot) ( in out effect -- quot ) : (call-effect-slow>quot) ( in out effect -- quot )

4
basis/tools/deploy/shaker/shaker.factor
View File

@ -122,6 +122,7 @@ IN: tools.deploy.shaker
"inline" "inline"
"inlined-block" "inlined-block"
"input-classes" "input-classes"
"instances"
"interval" "interval"
"intrinsics" "intrinsics"
"lambda" "lambda"
@ -344,7 +345,8 @@ IN: tools.deploy.shaker
] 2each ; ] 2each ;
: compress-quotations ( -- ) : compress-quotations ( -- )
[ quotation? ] [ remain-compiled ] "quotations" compress ; [ quotation? ] [ remain-compiled ] "quotations" compress
[ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
: compress-strings ( -- ) : compress-strings ( -- )
[ string? ] [ ] "strings" compress ; [ string? ] [ ] "strings" compress ;

2
basis/tools/deploy/shaker/strip-call.factor
View File

@ -5,4 +5,6 @@ IN: tools.deploy.shaker.call
IN: call IN: call
USE: call.private USE: call.private
: call-effect ( word effect -- ) call-effect-unsafe ; inline
: execute-effect ( word effect -- ) execute-effect-unsafe ; inline : execute-effect ( word effect -- ) execute-effect-unsafe ; inline

8
core/combinators/combinators-tests.factor
View File

@ -27,6 +27,14 @@ IN: combinators.tests
[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test [ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test [ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
: compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ;
[ t ] [ \ compile-call(-test-1 optimized>> ] unit-test
[ 4 ] [ 1 3 [ + ] compile-call(-test-1 ] unit-test
[ 7 ] [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test
[ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test
[ 4 ] [ 1 3 [ { + } [ ] like call ] compile-call(-test-1 ] unit-test
! Compiled ! Compiled
: cond-test-1 ( obj -- str ) : cond-test-1 ( obj -- str )
{ {