1 swap malloc-array ; inline
: malloc-byte-array ( byte-array -- alien )
- dup length dup malloc [ -rot memcpy ] keep ;
+ dup length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
- dup <byte-array> [ -rot memcpy ] keep ;
+ [ nip <byte-array> dup ] 2keep memcpy ;
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;
[ 120 ] [ "barx" heap-size ] unit-test
"help" vocab [
- "help" "help" lookup "help" set
+ "print-topic" "help" lookup "help" set
[ ] [ \ foox-x "help" get execute ] unit-test
[ ] [ \ set-foox-x "help" get execute ] unit-test
] when
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cocoa cocoa.messages cocoa.classes
cocoa.application sequences splitting core-foundation ;
"/" split1-last [ <NSString> ] bi@ ;
: save-panel ( path -- paths )
- <NSSavePanel> dup
- rot split-path -> runModalForDirectory:file: NSOKButton =
+ [ <NSSavePanel> dup ] dip
+ split-path -> runModalForDirectory:file: NSOKButton =
[ -> filename CF>string ] [ drop f ] if ;
assoc-union alien>objc-types set-global
: objc-struct-type ( i string -- ctype )
- 2dup CHAR: = -rot index-from swap subseq
+ [ CHAR: = ] 2keep index-from swap subseq
dup c-types get key? [
"Warning: no such C type: " write dup print
drop "void*"
dup 0 -> setReleasedWhenClosed: ;
: window-content-rect ( window -- rect )
- NSWindow over -> frame rot -> styleMask
+ [ NSWindow ] dip
+ [ -> frame ] [ -> styleMask ] bi
-> contentRectForFrameRect:styleMask: ;
math sequences namespaces make assocs init accessors
continuations combinators core-foundation
core-foundation.run-loop core-foundation.run-loop.thread
-io.encodings.utf8 destructors ;
+io.encodings.utf8 destructors locals arrays ;
IN: core-foundation.fsevents
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
"FSEventStreamContext" <c-object>
[ set-FSEventStreamContext-info ] keep ;
-: <FSEventStream> ( callback info paths latency flags -- event-stream )
- >r >r >r >r >r
+:: <FSEventStream> ( callback info paths latency flags -- event-stream )
f ! allocator
- r> ! callback
- r> make-FSEventStreamContext
- r> <CFStringArray> ! paths
+ callback
+ info make-FSEventStreamContext
+ paths <CFStringArray>
FSEventStreamEventIdSinceNow ! sinceWhen
- r> ! latency
- r> ! flags
+ latency
+ flags
FSEventStreamCreate ;
: kCFRunLoopCommonModes ( -- string )
: remove-event-source-callback ( id -- )
event-stream-callbacks get delete-at ;
-: >event-triple ( n eventPaths eventFlags eventIds -- triple )
- [
- >r >r >r dup dup
- r> void*-nth utf8 alien>string ,
- r> int-nth ,
- r> longlong-nth ,
- ] { } make ;
+:: >event-triple ( n eventPaths eventFlags eventIds -- triple )
+ n eventPaths void*-nth utf8 alien>string
+ n eventFlags int-nth
+ n eventIds longlong-nth
+ 3array ;
: master-event-source-callback ( -- alien )
"void"
: define-consult ( group class quot -- )
[ register-protocol ]
- [ rot group-words -rot [ consult-method ] 2curry each ]
+ [ [ group-words ] 2dip [ consult-method ] 2curry each ]
3bi ;
: CONSULT:
] [ keys ] if ;
: describe* ( obj mirror keys -- )
- rot summary.
- [
- drop
- ] [
+ [ summary. ] 2dip
+ [ drop ] [
dup enum? [ +sequence+ on ] when
standard-table-style [
swap [ -rot describe-row ] curry each-index
FD_SETSIZE 8 * <bit-array> >>write-fdset ;
: clear-nth ( n seq -- ? )
- [ nth ] [ f -rot set-nth ] 2bi ;
+ [ nth ] [ [ f ] 2dip set-nth ] 2bi ;
:: check-fd ( fd fdset mx quot -- )
fd munge fdset clear-nth [ fd mx quot call ] when ; inline
] call ;
M: unix (receive) ( datagram -- packet sockaddr )
- dup do-receive dup [ rot drop ] [
+ dup do-receive dup [ [ drop ] 2dip ] [
2drop [ +input+ wait-for-port ] [ (receive) ] bi
] if ;
M: complex absq >rect [ sq ] bi@ + ;
: 2>rect ( x y -- xr yr xi yi )
- [ [ real-part ] bi@ ] 2keep
- [ imaginary-part ] bi@ ; inline
+ [ [ real-part ] bi@ ]
+ [ [ imaginary-part ] bi@ ] 2bi ; inline
M: complex hashcode*
nip >rect [ hashcode ] bi@ bitxor ;
M: complex number=
2>rect number= [ number= ] [ 2drop f ] if ;
-: *re ( x y -- xr*yr xi*ri ) 2>rect * >r * r> ; inline
-: *im ( x y -- xi*yr xr*yi ) 2>rect >r * swap r> * ; inline
+: *re ( x y -- xr*yr xi*ri ) 2>rect [ * ] 2bi@ ; inline
+: *im ( x y -- xi*yr xr*yi ) 2>rect [ * swap ] dip * ; inline
-M: complex + 2>rect + >r + r> (rect>) ;
-M: complex - 2>rect - >r - r> (rect>) ;
-M: complex * 2dup *re - -rot *im + (rect>) ;
+M: complex + 2>rect [ + ] 2bi@ (rect>) ;
+M: complex - 2>rect [ - ] 2bi@ (rect>) ;
+M: complex * [ *re - ] [ *im + ] 2bi (rect>) ;
: complex/ ( x y -- r i m )
- dup absq >r 2dup *re + -rot *im - r> ; inline
+ [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline
-M: complex / complex/ tuck / >r / r> (rect>) ;
+M: complex / complex/ tuck [ / ] 2bi@ (rect>) ;
M: complex abs absq >float fsqrt ;
-M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ;
+M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ;
IN: syntax
: 0^ ( x -- z )
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
-PRIVATE>
-
-: ^ ( x y -- z )
- {
- { [ over zero? ] [ nip 0^ ] }
- { [ dup integer? ] [ integer^ ] }
- { [ 2dup real^? ] [ fpow ] }
- [ ^complex ]
- } cond ; inline
-
: (^mod) ( n x y -- z )
1 swap [
[ dupd * pick mod ] when [ sq over mod ] dip
swap [ /mod [ over * swapd - ] dip ] keep (gcd)
] if ;
+PRIVATE>
+
+: ^ ( x y -- z )
+ {
+ { [ over zero? ] [ nip 0^ ] }
+ { [ dup integer? ] [ integer^ ] }
+ { [ 2dup real^? ] [ fpow ] }
+ [ ^complex ]
+ } cond ; inline
+
: gcd ( x y -- a d )
[ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; foldable
GENERIC: cos ( x -- y ) foldable
M: complex cos
- >float-rect 2dup
- fcosh swap fcos * -rot
- fsinh swap fsin neg * rect> ;
+ >float-rect
+ [ [ fcos ] [ fcosh ] bi* * ]
+ [ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
M: real cos fcos ;
GENERIC: cosh ( x -- y ) foldable
M: complex cosh
- >float-rect 2dup
- fcos swap fcosh * -rot
- fsin swap fsinh * rect> ;
+ >float-rect
+ [ [ fcosh ] [ fcos ] bi* * ]
+ [ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
M: real cosh fcosh ;
GENERIC: sin ( x -- y ) foldable
M: complex sin
- >float-rect 2dup
- fcosh swap fsin * -rot
- fsinh swap fcos * rect> ;
+ >float-rect
+ [ [ fsin ] [ fcosh ] bi* * ]
+ [ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
M: real sin fsin ;
GENERIC: sinh ( x -- y ) foldable
M: complex sinh
- >float-rect 2dup
- fcos swap fsinh * -rot
- fsin swap fcosh * rect> ;
+ >float-rect
+ [ [ fsinh ] [ fcos ] bi* * ]
+ [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
M: real sinh fsinh ;
: twiddle 2dup > -1 1 ? ; inline
-: (a, dup roll + -rot ; inline
+: (a, dup [ + ] curry 2dip ; inline
-: ,b) dup neg rot + swap ; inline
+: ,b) dup [ - ] curry dip ; inline
: [a,b] ( a b -- range ) twiddle <range> ; inline
swap [ swapd set-at ] curry assoc-each ;
: assoc-union ( assoc1 assoc2 -- union )
- 2dup [ assoc-size ] bi@ + pick new-assoc
- [ rot update ] keep [ swap update ] keep ;
+ [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
+ [ dupd update ] bi@ ;
: assoc-combine ( seq -- union )
H{ } clone [ dupd update ] reduce ;
M: intersection-class update-class define-intersection-predicate ;
: define-intersection-class ( class participants -- )
- [ f f rot intersection-class define-class ]
+ [ [ f f ] dip intersection-class define-class ]
[ drop update-classes ]
2bi ;
3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? )
- rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ;
+ [ over ] dip
+ [ [ superclass ] dip = ]
+ [ [ "slots" word-prop ] dip = ] 2bi* and ;
: valid-superclass? ( class -- ? )
[ tuple-class? ] [ tuple eq? ] bi or ;
"( gensym )" f <word> ;
: define-temp ( quot -- word )
- gensym dup rot define ;
+ [ gensym dup ] dip define ;
: reveal ( word -- )
dup [ name>> ] [ vocabulary>> ] bi dup vocab-words